/[lmdze]/trunk/phylmd/Radlwsw/radlwsw.f
ViewVC logotype

Contents of /trunk/phylmd/Radlwsw/radlwsw.f

Parent Directory Parent Directory | Revision Log Revision Log

Revision 10 - (show annotations)
Fri Apr 18 14:45:53 2008 UTC (16 years ago) by guez
Original Path: trunk/libf/phylmd/radlwsw.f
File size: 202115 byte(s) 
Added NetCDF directory "/home/guez/include" in "g95.mk" and
"nag_tools.mk".

Added some "intent" attributes in "PVtheta", "advtrac", "caladvtrac",
"calfis", "diagedyn", "dissip", "vlspltqs", "aeropt", "ajsec",
"calltherm", "clmain", "cltrac", "cltracrn", "concvl", "conema3",
"conflx", "fisrtilp", "newmicro", "nuage", "diagcld1", "diagcld2",
"drag_noro", "lift_noro", "SUGWD", "physiq", "phytrac", "radlwsw", "thermcell".

Removed the case "ierr == 0" in "abort_gcm"; moved call to "histclo"
and messages for end of run from "abort_gcm" to "gcm"; replaced call
to "abort_gcm" in "leapfrog" by exit from outer loop.

In "calfis": removed argument "pp" and variable "unskap"; changed
"pksurcp" from scalar to rank 2; use "pressure_var"; rewrote
computation of "zplev", "zplay", "ztfi", "pcvgt" using "dyn_phy";
added computation of "pls".

Removed unused variable in "dynredem0".

In "exner_hyb": changed "dellta" from scalar to rank 1; replaced call
to "ssum" by call to "sum"; removed variables "xpn" and "xps";
replaced some loops by array expressions.

In "leapfrog": use "pressure_var"; deleted variables "p", "longcles".

Converted common blocks "YOECUMF", "YOEGWD" to modules.

Removed argument "pplay" in "cvltr", "diagetpq", "nflxtr".

Created module "raddimlw" from include file "raddimlw.h".

Corrected call to "new_unit" in "test_disvert".
1 !
2 ! $Header: /home/cvsroot/LMDZ4/libf/phylmd/radlwsw.F,v 1.4 2005/06/06 13:16:33 fairhead Exp $
3 !
4 SUBROUTINE radlwsw(dist, rmu0, fract,
5 . paprs, pplay,tsol,albedo, alblw, t,q,wo,
6 . cldfra, cldemi, cldtaupd,
7 . heat,heat0,cool,cool0,radsol,albpla,
8 . topsw,toplw,solsw,sollw,
9 . sollwdown,
10 . topsw0,toplw0,solsw0,sollw0,
11 . lwdn0, lwdn, lwup0, lwup,
12 . swdn0, swdn, swup0, swup,
13 . ok_ade, ok_aie,
14 . tau_ae, piz_ae, cg_ae,
15 . topswad, solswad,
16 . cldtaupi, topswai, solswai)
17 c
18 use dimphy
19 use clesphys
20 use YOMCST
21 use raddim, only: kflev, kdlon
22 use yoethf
23 IMPLICIT none
24 c======================================================================
25 c Auteur(s): Z.X. Li (LMD/CNRS) date: 19960719
26 c Objet: interface entre le modele et les rayonnements
27 c Arguments:
28 c dist-----input-R- distance astronomique terre-soleil
29 c rmu0-----input-R- cosinus de l'angle zenithal
30 c fract----input-R- duree d'ensoleillement normalisee
31 c co2_ppm--input-R- concentration du gaz carbonique (en ppm)
32 c solaire--input-R- constante solaire (W/m**2)
33 c paprs----input-R- pression a inter-couche (Pa)
34 c pplay----input-R- pression au milieu de couche (Pa)
35 c tsol-----input-R- temperature du sol (en K)
36 c albedo---input-R- albedo du sol (entre 0 et 1)
37 c t--------input-R- temperature (K)
38 c q--------input-R- vapeur d'eau (en kg/kg)
39 c wo-------input-R- contenu en ozone (en kg/kg) correction MPL 100505
40 c cldfra---input-R- fraction nuageuse (entre 0 et 1)
41 c cldtaupd---input-R- epaisseur optique des nuages dans le visible (present-day value)
42 c cldemi---input-R- emissivite des nuages dans l'IR (entre 0 et 1)
43 c ok_ade---input-L- apply the Aerosol Direct Effect or not?
44 c ok_aie---input-L- apply the Aerosol Indirect Effect or not?
45 c tau_ae, piz_ae, cg_ae-input-R- aerosol optical properties (calculated in aeropt.F)
46 c cldtaupi-input-R- epaisseur optique des nuages dans le visible
47 c calculated for pre-industrial (pi) aerosol concentrations, i.e. with smaller
48 c droplet concentration, thus larger droplets, thus generally cdltaupi cldtaupd
49 c it is needed for the diagnostics of the aerosol indirect radiative forcing
50 c
51 c heat-----output-R- echauffement atmospherique (visible) (K/jour)
52 c cool-----output-R- refroidissement dans l'IR (K/jour)
53 c radsol---output-R- bilan radiatif net au sol (W/m**2) (+ vers le bas)
54 c albpla---output-R- albedo planetaire (entre 0 et 1)
55 c topsw----output-R- flux solaire net au sommet de l'atm.
56 c toplw----output-R- ray. IR montant au sommet de l'atmosphere
57 c solsw----output-R- flux solaire net a la surface
58 c sollw----output-R- ray. IR montant a la surface
59 c solswad---output-R- ray. solaire net absorbe a la surface (aerosol dir)
60 c topswad---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol dir)
61 c solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind)
62 c topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind)
63 c
64 c ATTENTION: swai and swad have to be interpreted in the following manner:
65 c ---------
66 c ok_ade=F & ok_aie=F -both are zero
67 c ok_ade=T & ok_aie=F -aerosol direct forcing is F_{AD} = topsw-topswad
68 c indirect is zero
69 c ok_ade=F & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
70 c direct is zero
71 c ok_ade=T & ok_aie=T -aerosol indirect forcing is F_{AI} = topsw-topswai
72 c aerosol direct forcing is F_{AD} = topswai-topswad
73 c
74
75 c======================================================================
76 c
77 real rmu0(klon), fract(klon), dist
78 cIM real co2_ppm
79 cIM real solaire
80 c
81 real, intent(in):: paprs(klon,klev+1)
82 real, intent(in):: pplay(klon,klev)
83 real albedo(klon), alblw(klon), tsol(klon)
84 real t(klon,klev), q(klon,klev)
85 real, intent(in):: wo(klon,klev)
86 real cldfra(klon,klev), cldemi(klon,klev), cldtaupd(klon,klev)
87 real heat(klon,klev), cool(klon,klev)
88 real heat0(klon,klev), cool0(klon,klev)
89 real radsol(klon), topsw(klon), toplw(klon)
90 real solsw(klon), sollw(klon), albpla(klon)
91 real topsw0(klon), toplw0(klon), solsw0(klon), sollw0(klon)
92 real sollwdown(klon)
93 cIM output 3D
94 REAL*8 ZFSUP(KDLON,KFLEV+1)
95 REAL*8 ZFSDN(KDLON,KFLEV+1)
96 REAL*8 ZFSUP0(KDLON,KFLEV+1)
97 REAL*8 ZFSDN0(KDLON,KFLEV+1)
98 c
99 REAL*8 ZFLUP(KDLON,KFLEV+1)
100 REAL*8 ZFLDN(KDLON,KFLEV+1)
101 REAL*8 ZFLUP0(KDLON,KFLEV+1)
102 REAL*8 ZFLDN0(KDLON,KFLEV+1)
103 c
104 REAL*8 zx_alpha1, zx_alpha2
105 c
106 c
107 INTEGER k, kk, i, j, iof, nb_gr
108 EXTERNAL lw, sw
109 c
110 cIM ctes ds clesphys.h REAL*8 RCO2, RCH4, RN2O, RCFC11, RCFC12
111 REAL*8 PSCT
112 c
113 REAL*8 PALBD(kdlon,2), PALBP(kdlon,2)
114 REAL*8 PEMIS(kdlon), PDT0(kdlon), PVIEW(kdlon)
115 REAL*8 PPSOL(kdlon), PDP(kdlon,klev)
116 REAL*8 PTL(kdlon,kflev+1), PPMB(kdlon,kflev+1)
117 REAL*8 PTAVE(kdlon,kflev)
118 REAL*8 PWV(kdlon,kflev), PQS(kdlon,kflev), POZON(kdlon,kflev)
119 REAL*8 PAER(kdlon,kflev,5)
120 REAL*8 PCLDLD(kdlon,kflev)
121 REAL*8 PCLDLU(kdlon,kflev)
122 REAL*8 PCLDSW(kdlon,kflev)
123 REAL*8 PTAU(kdlon,2,kflev)
124 REAL*8 POMEGA(kdlon,2,kflev)
125 REAL*8 PCG(kdlon,2,kflev)
126 c
127 REAL*8 zfract(kdlon), zrmu0(kdlon), zdist
128 c
129 REAL*8 zheat(kdlon,kflev), zcool(kdlon,kflev)
130 REAL*8 zheat0(kdlon,kflev), zcool0(kdlon,kflev)
131 REAL*8 ztopsw(kdlon), ztoplw(kdlon)
132 REAL*8 zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon)
133 cIM
134 REAL*8 zsollwdown(kdlon)
135 c
136 REAL*8 ztopsw0(kdlon), ztoplw0(kdlon)
137 REAL*8 zsolsw0(kdlon), zsollw0(kdlon)
138 REAL*8 zznormcp
139 cIM output 3D : SWup, SWdn, LWup, LWdn
140 REAL swdn(klon,kflev+1),swdn0(klon,kflev+1)
141 REAL swup(klon,kflev+1),swup0(klon,kflev+1)
142 REAL lwdn(klon,kflev+1),lwdn0(klon,kflev+1)
143 REAL lwup(klon,kflev+1),lwup0(klon,kflev+1)
144 c-OB
145 cjq the following quantities are needed for the aerosol radiative forcings
146
147 real topswad(klon), solswad(klon) ! output: aerosol direct forcing at TOA and surface
148 real topswai(klon), solswai(klon) ! output: aerosol indirect forcing atTOA and surface
149 real tau_ae(klon,klev,2), piz_ae(klon,klev,2), cg_ae(klon,klev,2) ! aerosol optical properties (see aeropt.F)
150 real cldtaupi(klon,klev) ! cloud optical thickness for pre-industrial aerosol concentrations
151 ! (i.e., with a smaller droplet concentrationand thus larger droplet radii)
152 logical ok_ade, ok_aie ! switches whether to use aerosol direct (indirect) effects or not
153 real*8 tauae(kdlon,kflev,2) ! aer opt properties
154 real*8 pizae(kdlon,kflev,2)
155 real*8 cgae(kdlon,kflev,2)
156 REAL*8 PTAUA(kdlon,2,kflev) ! present-day value of cloud opt thickness (PTAU is pre-industrial value), local use
157 REAL*8 POMEGAA(kdlon,2,kflev) ! dito for single scatt albedo
158 REAL*8 ztopswad(kdlon), zsolswad(kdlon) ! Aerosol direct forcing at TOAand surface
159 REAL*8 ztopswai(kdlon), zsolswai(kdlon) ! dito, indirect
160 cjq-end
161 !rv
162 tauae(:,:,:)=0.
163 pizae(:,:,:)=0.
164 cgae(:,:,:)=0.
165 !rv
166
167 c
168 c-------------------------------------------
169 nb_gr = klon / kdlon
170 IF (nb_gr*kdlon .NE. klon) THEN
171 PRINT*, "kdlon mauvais:", klon, kdlon, nb_gr
172 stop 1
173 ENDIF
174 IF (kflev .NE. klev) THEN
175 PRINT*, "kflev differe de klev, kflev, klev"
176 stop 1
177 ENDIF
178 c-------------------------------------------
179 DO k = 1, klev
180 DO i = 1, klon
181 heat(i,k)=0.
182 cool(i,k)=0.
183 heat0(i,k)=0.
184 cool0(i,k)=0.
185 ENDDO
186 ENDDO
187 c
188 zdist = dist
189 c
190 cIM anciennes valeurs
191 c RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97
192 c
193 cIM : on met RCO2, RCH4, RN2O, RCFC11 et RCFC12 dans clesphys.h /lecture ds conf_phys.F90
194 c RCH4 = 1.65E-06* 16.043/28.97
195 c RN2O = 306.E-09* 44.013/28.97
196 c RCFC11 = 280.E-12* 137.3686/28.97
197 c RCFC12 = 484.E-12* 120.9140/28.97
198 cIM anciennes valeurs
199 c RCH4 = 1.72E-06* 16.043/28.97
200 c RN2O = 310.E-09* 44.013/28.97
201 c
202 c PRINT*,'IMradlwsw : solaire, co2= ', solaire, co2_ppm
203 PSCT = solaire/zdist/zdist
204 c
205 DO 99999 j = 1, nb_gr
206 iof = kdlon*(j-1)
207 c
208 DO i = 1, kdlon
209 zfract(i) = fract(iof+i)
210 zrmu0(i) = rmu0(iof+i)
211 PALBD(i,1) = albedo(iof+i)
212 ! PALBD(i,2) = albedo(iof+i)
213 PALBD(i,2) = alblw(iof+i)
214 PALBP(i,1) = albedo(iof+i)
215 ! PALBP(i,2) = albedo(iof+i)
216 PALBP(i,2) = alblw(iof+i)
217 cIM cf. JLD pour etre en accord avec ORCHIDEE il faut mettre PEMIS(i) = 0.96
218 PEMIS(i) = 1.0
219 PVIEW(i) = 1.66
220 PPSOL(i) = paprs(iof+i,1)
221 zx_alpha1 = (paprs(iof+i,1)-pplay(iof+i,2))
222 . / (pplay(iof+i,1)-pplay(iof+i,2))
223 zx_alpha2 = 1.0 - zx_alpha1
224 PTL(i,1) = t(iof+i,1) * zx_alpha1 + t(iof+i,2) * zx_alpha2
225 PTL(i,klev+1) = t(iof+i,klev)
226 PDT0(i) = tsol(iof+i) - PTL(i,1)
227 ENDDO
228 DO k = 2, kflev
229 DO i = 1, kdlon
230 PTL(i,k) = (t(iof+i,k)+t(iof+i,k-1))*0.5
231 ENDDO
232 ENDDO
233 DO k = 1, kflev
234 DO i = 1, kdlon
235 PDP(i,k) = paprs(iof+i,k)-paprs(iof+i,k+1)
236 PTAVE(i,k) = t(iof+i,k)
237 PWV(i,k) = MAX (q(iof+i,k), 1.0e-12)
238 PQS(i,k) = PWV(i,k)
239 c wo: cm.atm (epaisseur en cm dans la situation standard)
240 c POZON: kg/kg
241 IF (bug_ozone) then
242 POZON(i,k) = MAX(wo(iof+i,k),1.0e-12)*RG/46.6968
243 . /(paprs(iof+i,k)-paprs(iof+i,k+1))
244 . *(paprs(iof+i,1)/101325.0)
245 ELSE
246 c le calcul qui suit est maintenant fait dans ozonecm (MPL)
247 POZON(i,k) = wo(i,k)
248 ENDIF
249 PCLDLD(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
250 PCLDLU(i,k) = cldfra(iof+i,k)*cldemi(iof+i,k)
251 PCLDSW(i,k) = cldfra(iof+i,k)
252 PTAU(i,1,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! 1e-12 serait instable
253 PTAU(i,2,k) = MAX(cldtaupi(iof+i,k), 1.0e-05)! pour 32-bit machines
254 POMEGA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAU(i,1,k))
255 POMEGA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAU(i,2,k))
256 PCG(i,1,k) = 0.865
257 PCG(i,2,k) = 0.910
258 c-OB
259 cjq Introduced for aerosol indirect forcings.
260 cjq The following values use the cloud optical thickness calculated from
261 cjq present-day aerosol concentrations whereas the quantities without the
262 cjq "A" at the end are for pre-industial (natural-only) aerosol concentrations
263 cjq
264 PTAUA(i,1,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! 1e-12 serait instable
265 PTAUA(i,2,k) = MAX(cldtaupd(iof+i,k), 1.0e-05)! pour 32-bit machines
266 POMEGAA(i,1,k) = 0.9999 - 5.0e-04 * EXP(-0.5 * PTAUA(i,1,k))
267 POMEGAA(i,2,k) = 0.9988 - 2.5e-03 * EXP(-0.05 * PTAUA(i,2,k))
268 cjq-end
269 ENDDO
270 ENDDO
271 c
272 DO k = 1, kflev+1
273 DO i = 1, kdlon
274 PPMB(i,k) = paprs(iof+i,k)/100.0
275 ENDDO
276 ENDDO
277 c
278 DO kk = 1, 5
279 DO k = 1, kflev
280 DO i = 1, kdlon
281 PAER(i,k,kk) = 1.0E-15
282 ENDDO
283 ENDDO
284 ENDDO
285 c-OB
286 DO k = 1, kflev
287 DO i = 1, kdlon
288 tauae(i,k,1)=tau_ae(iof+i,k,1)
289 pizae(i,k,1)=piz_ae(iof+i,k,1)
290 cgae(i,k,1) =cg_ae(iof+i,k,1)
291 tauae(i,k,2)=tau_ae(iof+i,k,2)
292 pizae(i,k,2)=piz_ae(iof+i,k,2)
293 cgae(i,k,2) =cg_ae(iof+i,k,2)
294 ENDDO
295 ENDDO
296 c
297 c======================================================================
298 cIM ctes ds clesphys.h CALL LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
299 CALL LW(
300 . PPMB, PDP,
301 . PPSOL,PDT0,PEMIS,
302 . PTL, PTAVE, PWV, POZON, PAER,
303 . PCLDLD,PCLDLU,
304 . PVIEW,
305 . zcool, zcool0,
306 . ztoplw,zsollw,ztoplw0,zsollw0,
307 . zsollwdown,
308 . ZFLUP, ZFLDN, ZFLUP0,ZFLDN0)
309 cIM ctes ds clesphys.h CALL SW(PSCT, RCO2, zrmu0, zfract,
310 CALL SW(PSCT, zrmu0, zfract,
311 S PPMB, PDP,
312 S PPSOL, PALBD, PALBP,
313 S PTAVE, PWV, PQS, POZON, PAER,
314 S PCLDSW, PTAU, POMEGA, PCG,
315 S zheat, zheat0,
316 S zalbpla,ztopsw,zsolsw,ztopsw0,zsolsw0,
317 S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
318 S tauae, pizae, cgae, ! aerosol optical properties
319 s PTAUA, POMEGAA,
320 s ztopswad,zsolswad,ztopswai,zsolswai, ! diagnosed aerosol forcing
321 J ok_ade, ok_aie) ! apply aerosol effects or not?
322
323 c======================================================================
324 DO i = 1, kdlon
325 radsol(iof+i) = zsolsw(i) + zsollw(i)
326 topsw(iof+i) = ztopsw(i)
327 toplw(iof+i) = ztoplw(i)
328 solsw(iof+i) = zsolsw(i)
329 sollw(iof+i) = zsollw(i)
330 sollwdown(iof+i) = zsollwdown(i)
331 cIM
332 DO k = 1, kflev+1
333 lwdn0 ( iof+i,k) = ZFLDN0 ( i,k)
334 lwdn ( iof+i,k) = ZFLDN ( i,k)
335 lwup0 ( iof+i,k) = ZFLUP0 ( i,k)
336 lwup ( iof+i,k) = ZFLUP ( i,k)
337 ENDDO
338 c
339 topsw0(iof+i) = ztopsw0(i)
340 toplw0(iof+i) = ztoplw0(i)
341 solsw0(iof+i) = zsolsw0(i)
342 sollw0(iof+i) = zsollw0(i)
343 albpla(iof+i) = zalbpla(i)
344 cIM
345 DO k = 1, kflev+1
346 swdn0 ( iof+i,k) = ZFSDN0 ( i,k)
347 swdn ( iof+i,k) = ZFSDN ( i,k)
348 swup0 ( iof+i,k) = ZFSUP0 ( i,k)
349 swup ( iof+i,k) = ZFSUP ( i,k)
350 ENDDO !k=1, kflev+1
351 ENDDO
352 cjq-transform the aerosol forcings, if they have
353 cjq to be calculated
354 IF (ok_ade) THEN
355 DO i = 1, kdlon
356 topswad(iof+i) = ztopswad(i)
357 solswad(iof+i) = zsolswad(i)
358 ENDDO
359 ELSE
360 DO i = 1, kdlon
361 topswad(iof+i) = 0.0
362 solswad(iof+i) = 0.0
363 ENDDO
364 ENDIF
365 IF (ok_aie) THEN
366 DO i = 1, kdlon
367 topswai(iof+i) = ztopswai(i)
368 solswai(iof+i) = zsolswai(i)
369 ENDDO
370 ELSE
371 DO i = 1, kdlon
372 topswai(iof+i) = 0.0
373 solswai(iof+i) = 0.0
374 ENDDO
375 ENDIF
376 cjq-end
377 DO k = 1, kflev
378 c DO i = 1, kdlon
379 c heat(iof+i,k) = zheat(i,k)
380 c cool(iof+i,k) = zcool(i,k)
381 c heat0(iof+i,k) = zheat0(i,k)
382 c cool0(iof+i,k) = zcool0(i,k)
383 c ENDDO
384 DO i = 1, kdlon
385 C scale factor to take into account the difference between
386 C dry air and watter vapour scpecific heat capacity
387 zznormcp=1.0+RVTMP2*PWV(i,k)
388 heat(iof+i,k) = zheat(i,k)/zznormcp
389 cool(iof+i,k) = zcool(i,k)/zznormcp
390 heat0(iof+i,k) = zheat0(i,k)/zznormcp
391 cool0(iof+i,k) = zcool0(i,k)/zznormcp
392 ENDDO
393 ENDDO
394 c
395 99999 CONTINUE
396 RETURN
397 END
398 cIM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
399 SUBROUTINE SW(PSCT, PRMU0, PFRAC,
400 S PPMB, PDP,
401 S PPSOL, PALBD, PALBP,
402 S PTAVE, PWV, PQS, POZON, PAER,
403 S PCLDSW, PTAU, POMEGA, PCG,
404 S PHEAT, PHEAT0,
405 S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
406 S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
407 S tauae, pizae, cgae,
408 s PTAUA, POMEGAA,
409 S PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
410 J ok_ade, ok_aie )
411
412 use dimens_m
413 use dimphy
414 use clesphys
415 use YOMCST
416 use raddim
417 IMPLICIT none
418
419 C
420 C ------------------------------------------------------------------
421 C
422 C PURPOSE.
423 C --------
424 C
425 C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
426 C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
427 C
428 C METHOD.
429 C -------
430 C
431 C 1. COMPUTES ABSORBER AMOUNTS (SWU)
432 C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S)
433 C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S)
434 C
435 C REFERENCE.
436 C ----------
437 C
438 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
439 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
440 C
441 C AUTHOR.
442 C -------
443 C JEAN-JACQUES MORCRETTE *ECMWF*
444 C
445 C MODIFICATIONS.
446 C --------------
447 C ORIGINAL : 89-07-14
448 C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo
449 c 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER)
450 C ------------------------------------------------------------------
451 C
452 C* ARGUMENTS:
453 C
454 REAL*8 PSCT ! constante solaire (valeur conseillee: 1370)
455 cIM ctes ds clesphys.h REAL*8 RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
456 C
457 REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (PA)
458 REAL*8 PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA)
459 REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
460 C
461 REAL*8 PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE
462 REAL*8 PFRAC(KDLON) ! fraction de la journee
463 C
464 REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
465 REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG)
466 REAL*8 PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG)
467 REAL*8 POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG)
468 REAL*8 PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
469 C
470 REAL*8 PALBD(KDLON,2) ! albedo du sol (lumiere diffuse)
471 REAL*8 PALBP(KDLON,2) ! albedo du sol (lumiere parallele)
472 C
473 REAL*8 PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION
474 REAL*8 PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS
475 REAL*8 PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR
476 REAL*8 POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO
477 C
478 REAL*8 PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
479 REAL*8 PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
480 REAL*8 PALBPLA(KDLON) ! PLANETARY ALBEDO
481 REAL*8 PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A.
482 REAL*8 PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE
483 REAL*8 PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
484 REAL*8 PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
485 C
486 C* LOCAL VARIABLES:
487 C
488 REAL*8 ZOZ(KDLON,KFLEV)
489 REAL*8 ZAKI(KDLON,2)
490 REAL*8 ZCLD(KDLON,KFLEV)
491 REAL*8 ZCLEAR(KDLON)
492 REAL*8 ZDSIG(KDLON,KFLEV)
493 REAL*8 ZFACT(KDLON)
494 REAL*8 ZFD(KDLON,KFLEV+1)
495 REAL*8 ZFDOWN(KDLON,KFLEV+1)
496 REAL*8 ZFU(KDLON,KFLEV+1)
497 REAL*8 ZFUP(KDLON,KFLEV+1)
498 REAL*8 ZRMU(KDLON)
499 REAL*8 ZSEC(KDLON)
500 REAL*8 ZUD(KDLON,5,KFLEV+1)
501 REAL*8 ZCLDSW0(KDLON,KFLEV)
502 c
503 REAL*8 ZFSUP(KDLON,KFLEV+1)
504 REAL*8 ZFSDN(KDLON,KFLEV+1)
505 REAL*8 ZFSUP0(KDLON,KFLEV+1)
506 REAL*8 ZFSDN0(KDLON,KFLEV+1)
507 C
508 INTEGER inu, jl, jk, i, k, kpl1
509 c
510 INTEGER swpas ! Every swpas steps, sw is calculated
511 PARAMETER(swpas=1)
512 c
513 INTEGER itapsw
514 LOGICAL appel1er
515 DATA itapsw /0/
516 DATA appel1er /.TRUE./
517 cjq-Introduced for aerosol forcings
518 real*8 flag_aer
519 logical ok_ade, ok_aie ! use aerosol forcings or not?
520 real*8 tauae(kdlon,kflev,2) ! aerosol optical properties
521 real*8 pizae(kdlon,kflev,2) ! (see aeropt.F)
522 real*8 cgae(kdlon,kflev,2) ! -"-
523 REAL*8 PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value)
524 REAL*8 POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO
525 REAL*8 PTOPSWAD(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
526 REAL*8 PSOLSWAD(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
527 REAL*8 PTOPSWAI(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
528 REAL*8 PSOLSWAI(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
529 cjq - Fluxes including aerosol effects
530 REAL*8 ZFSUPAD(KDLON,KFLEV+1)
531 REAL*8 ZFSDNAD(KDLON,KFLEV+1)
532 REAL*8 ZFSUPAI(KDLON,KFLEV+1)
533 REAL*8 ZFSDNAI(KDLON,KFLEV+1)
534 logical initialized
535 SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
536 !rv
537 save flag_aer
538 data initialized/.false./
539 cjq-end
540 if(.not.initialized) then
541 flag_aer=0.
542 initialized=.TRUE.
543 endif
544 !rv
545
546 c
547 IF (appel1er) THEN
548 PRINT*, 'SW calling frequency : ', swpas
549 PRINT*, " In general, it should be 1"
550 appel1er = .FALSE.
551 ENDIF
552 C ------------------------------------------------------------------
553 IF (MOD(itapsw,swpas).EQ.0) THEN
554 c
555 DO JK = 1 , KFLEV
556 DO JL = 1, KDLON
557 ZCLDSW0(JL,JK) = 0.0
558 IF (bug_ozone) then
559 ZOZ(JL,JK) = POZON(JL,JK)*46.6968/RG
560 . *PDP(JL,JK)*(101325.0/PPSOL(JL))
561 ELSE
562 c Correction MPL 100505
563 ZOZ(JL,JK) = POZON(JL,JK)*RMD/RMO3*46.6968/RG*PDP(JL,JK)
564 ENDIF
565 ENDDO
566 ENDDO
567 C
568 C
569 c clear-sky:
570 cIM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
571 CALL SWU(PSCT,ZCLDSW0,PPMB,PPSOL,
572 S PRMU0,PFRAC,PTAVE,PWV,
573 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
574 INU = 1
575 CALL SW1S(INU,
576 S PAER, flag_aer, tauae, pizae, cgae,
577 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
578 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
579 S ZFD, ZFU)
580 INU = 2
581 CALL SW2S(INU,
582 S PAER, flag_aer, tauae, pizae, cgae,
583 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, ZCLDSW0,
584 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
585 S PWV, PQS,
586 S ZFDOWN, ZFUP)
587 DO JK = 1 , KFLEV+1
588 DO JL = 1, KDLON
589 ZFSUP0(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL)
590 ZFSDN0(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
591 ENDDO
592 ENDDO
593
594 flag_aer=0.0
595 CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
596 S PRMU0,PFRAC,PTAVE,PWV,
597 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
598 INU = 1
599 CALL SW1S(INU,
600 S PAER, flag_aer, tauae, pizae, cgae,
601 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
602 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
603 S ZFD, ZFU)
604 INU = 2
605 CALL SW2S(INU,
606 S PAER, flag_aer, tauae, pizae, cgae,
607 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
608 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
609 S PWV, PQS,
610 S ZFDOWN, ZFUP)
611
612 c cloudy-sky:
613
614 DO JK = 1 , KFLEV+1
615 DO JL = 1, KDLON
616 ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL)
617 ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
618 ENDDO
619 ENDDO
620
621 c
622 IF (ok_ade) THEN
623 c
624 c cloudy-sky + aerosol dir OB
625 flag_aer=1.0
626 CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
627 S PRMU0,PFRAC,PTAVE,PWV,
628 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
629 INU = 1
630 CALL SW1S(INU,
631 S PAER, flag_aer, tauae, pizae, cgae,
632 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
633 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
634 S ZFD, ZFU)
635 INU = 2
636 CALL SW2S(INU,
637 S PAER, flag_aer, tauae, pizae, cgae,
638 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
639 S ZDSIG, POMEGA, ZOZ, ZRMU, ZSEC, PTAU, ZUD,
640 S PWV, PQS,
641 S ZFDOWN, ZFUP)
642 DO JK = 1 , KFLEV+1
643 DO JL = 1, KDLON
644 ZFSUPAD(JL,JK) = ZFSUP(JL,JK)
645 ZFSDNAD(JL,JK) = ZFSDN(JL,JK)
646 ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL)
647 ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
648 ENDDO
649 ENDDO
650
651 ENDIF ! ok_ade
652
653 IF (ok_aie) THEN
654
655 cjq cloudy-sky + aerosol direct + aerosol indirect
656 flag_aer=1.0
657 CALL SWU(PSCT,PCLDSW,PPMB,PPSOL,
658 S PRMU0,PFRAC,PTAVE,PWV,
659 S ZAKI,ZCLD,ZCLEAR,ZDSIG,ZFACT,ZRMU,ZSEC,ZUD)
660 INU = 1
661 CALL SW1S(INU,
662 S PAER, flag_aer, tauae, pizae, cgae,
663 S PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
664 S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
665 S ZFD, ZFU)
666 INU = 2
667 CALL SW2S(INU,
668 S PAER, flag_aer, tauae, pizae, cgae,
669 S ZAKI, PALBD, PALBP, PCG, ZCLD, ZCLEAR, PCLDSW,
670 S ZDSIG, POMEGAA, ZOZ, ZRMU, ZSEC, PTAUA, ZUD,
671 S PWV, PQS,
672 S ZFDOWN, ZFUP)
673 DO JK = 1 , KFLEV+1
674 DO JL = 1, KDLON
675 ZFSUPAI(JL,JK) = ZFSUP(JL,JK)
676 ZFSDNAI(JL,JK) = ZFSDN(JL,JK)
677 ZFSUP(JL,JK) = (ZFUP(JL,JK) + ZFU(JL,JK)) * ZFACT(JL)
678 ZFSDN(JL,JK) = (ZFDOWN(JL,JK) + ZFD(JL,JK)) * ZFACT(JL)
679 ENDDO
680 ENDDO
681 ENDIF ! ok_aie
682 cjq -end
683
684 itapsw = 0
685 ENDIF
686 itapsw = itapsw + 1
687 C
688 DO k = 1, KFLEV
689 kpl1 = k+1
690 DO i = 1, KDLON
691 PHEAT(i,k) = -(ZFSUP(i,kpl1)-ZFSUP(i,k))
692 . -(ZFSDN(i,k)-ZFSDN(i,kpl1))
693 PHEAT(i,k) = PHEAT(i,k) * RDAY*RG/RCPD / PDP(i,k)
694 PHEAT0(i,k) = -(ZFSUP0(i,kpl1)-ZFSUP0(i,k))
695 . -(ZFSDN0(i,k)-ZFSDN0(i,kpl1))
696 PHEAT0(i,k) = PHEAT0(i,k) * RDAY*RG/RCPD / PDP(i,k)
697 ENDDO
698 ENDDO
699 DO i = 1, KDLON
700 PALBPLA(i) = ZFSUP(i,KFLEV+1)/(ZFSDN(i,KFLEV+1)+1.0e-20)
701 c
702 PSOLSW(i) = ZFSDN(i,1) - ZFSUP(i,1)
703 PTOPSW(i) = ZFSDN(i,KFLEV+1) - ZFSUP(i,KFLEV+1)
704 c
705 PSOLSW0(i) = ZFSDN0(i,1) - ZFSUP0(i,1)
706 PTOPSW0(i) = ZFSDN0(i,KFLEV+1) - ZFSUP0(i,KFLEV+1)
707 c-OB
708 PSOLSWAD(i) = ZFSDNAD(i,1) - ZFSUPAD(i,1)
709 PTOPSWAD(i) = ZFSDNAD(i,KFLEV+1) - ZFSUPAD(i,KFLEV+1)
710 c
711 PSOLSWAI(i) = ZFSDNAI(i,1) - ZFSUPAI(i,1)
712 PTOPSWAI(i) = ZFSDNAI(i,KFLEV+1) - ZFSUPAI(i,KFLEV+1)
713 c-fin
714 ENDDO
715 C
716 RETURN
717 END
718 c
719 cIM ctes ds clesphys.h SUBROUTINE SWU (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
720 SUBROUTINE SWU (PSCT,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
721 S PTAVE,PWV,PAKI,PCLD,PCLEAR,PDSIG,PFACT,
722 S PRMU,PSEC,PUD)
723 use dimens_m
724 use dimphy
725 use clesphys
726 use YOMCST
727 use raddim
728 use radepsi
729 use radopt
730 IMPLICIT none
731 C
732 C* ARGUMENTS:
733 C
734 REAL*8 PSCT
735 cIM ctes ds clesphys.h REAL*8 RCO2
736 REAL*8 PCLDSW(KDLON,KFLEV)
737 REAL*8 PPMB(KDLON,KFLEV+1)
738 REAL*8 PPSOL(KDLON)
739 REAL*8 PRMU0(KDLON)
740 REAL*8 PFRAC(KDLON)
741 REAL*8 PTAVE(KDLON,KFLEV)
742 REAL*8 PWV(KDLON,KFLEV)
743 C
744 REAL*8 PAKI(KDLON,2)
745 REAL*8 PCLD(KDLON,KFLEV)
746 REAL*8 PCLEAR(KDLON)
747 REAL*8 PDSIG(KDLON,KFLEV)
748 REAL*8 PFACT(KDLON)
749 REAL*8 PRMU(KDLON)
750 REAL*8 PSEC(KDLON)
751 REAL*8 PUD(KDLON,5,KFLEV+1)
752 C
753 C* LOCAL VARIABLES:
754 C
755 INTEGER IIND(2)
756 REAL*8 ZC1J(KDLON,KFLEV+1)
757 REAL*8 ZCLEAR(KDLON)
758 REAL*8 ZCLOUD(KDLON)
759 REAL*8 ZN175(KDLON)
760 REAL*8 ZN190(KDLON)
761 REAL*8 ZO175(KDLON)
762 REAL*8 ZO190(KDLON)
763 REAL*8 ZSIGN(KDLON)
764 REAL*8 ZR(KDLON,2)
765 REAL*8 ZSIGO(KDLON)
766 REAL*8 ZUD(KDLON,2)
767 REAL*8 ZRTH, ZRTU, ZWH2O, ZDSCO2, ZDSH2O, ZFPPW
768 INTEGER jl, jk, jkp1, jkl, jklp1, ja
769 C
770 C* Prescribed Data:
771 c
772 REAL*8 ZPDH2O,ZPDUMG
773 SAVE ZPDH2O,ZPDUMG
774 REAL*8 ZPRH2O,ZPRUMG
775 SAVE ZPRH2O,ZPRUMG
776 REAL*8 RTDH2O,RTDUMG
777 SAVE RTDH2O,RTDUMG
778 REAL*8 RTH2O ,RTUMG
779 SAVE RTH2O ,RTUMG
780 DATA ZPDH2O,ZPDUMG / 0.8 , 0.75 /
781 DATA ZPRH2O,ZPRUMG / 30000., 30000. /
782 DATA RTDH2O,RTDUMG / 0.40 , 0.375 /
783 DATA RTH2O ,RTUMG / 240. , 240. /
784 C ------------------------------------------------------------------
785 C
786 C* 1. COMPUTES AMOUNTS OF ABSORBERS
787 C -----------------------------
788 C
789 100 CONTINUE
790 C
791 IIND(1)=1
792 IIND(2)=2
793 C
794 C
795 C* 1.1 INITIALIZES QUANTITIES
796 C ----------------------
797 C
798 110 CONTINUE
799 C
800 DO 111 JL = 1, KDLON
801 PUD(JL,1,KFLEV+1)=0.
802 PUD(JL,2,KFLEV+1)=0.
803 PUD(JL,3,KFLEV+1)=0.
804 PUD(JL,4,KFLEV+1)=0.
805 PUD(JL,5,KFLEV+1)=0.
806 PFACT(JL)= PRMU0(JL) * PFRAC(JL) * PSCT
807 PRMU(JL)=SQRT(1224.* PRMU0(JL) * PRMU0(JL) + 1.) / 35.
808 PSEC(JL)=1./PRMU(JL)
809 ZC1J(JL,KFLEV+1)=0.
810 111 CONTINUE
811 C
812 C* 1.3 AMOUNTS OF ABSORBERS
813 C --------------------
814 C
815 130 CONTINUE
816 C
817 DO 131 JL= 1, KDLON
818 ZUD(JL,1) = 0.
819 ZUD(JL,2) = 0.
820 ZO175(JL) = PPSOL(JL)** (ZPDUMG+1.)
821 ZO190(JL) = PPSOL(JL)** (ZPDH2O+1.)
822 ZSIGO(JL) = PPSOL(JL)
823 ZCLEAR(JL)=1.
824 ZCLOUD(JL)=0.
825 131 CONTINUE
826 C
827 DO 133 JK = 1 , KFLEV
828 JKP1 = JK + 1
829 JKL = KFLEV+1 - JK
830 JKLP1 = JKL+1
831 DO 132 JL = 1, KDLON
832 ZRTH=(RTH2O/PTAVE(JL,JK))**RTDH2O
833 ZRTU=(RTUMG/PTAVE(JL,JK))**RTDUMG
834 ZWH2O = MAX (PWV(JL,JK) , ZEPSCQ )
835 ZSIGN(JL) = 100. * PPMB(JL,JKP1)
836 PDSIG(JL,JK) = (ZSIGO(JL) - ZSIGN(JL))/PPSOL(JL)
837 ZN175(JL) = ZSIGN(JL) ** (ZPDUMG+1.)
838 ZN190(JL) = ZSIGN(JL) ** (ZPDH2O+1.)
839 ZDSCO2 = ZO175(JL) - ZN175(JL)
840 ZDSH2O = ZO190(JL) - ZN190(JL)
841 PUD(JL,1,JK) = 1./( 10.* RG * (ZPDH2O+1.) )/(ZPRH2O**ZPDH2O)
842 . * ZDSH2O * ZWH2O * ZRTH
843 PUD(JL,2,JK) = 1./( 10.* RG * (ZPDUMG+1.) )/(ZPRUMG**ZPDUMG)
844 . * ZDSCO2 * RCO2 * ZRTU
845 ZFPPW=1.6078*ZWH2O/(1.+0.608*ZWH2O)
846 PUD(JL,4,JK)=PUD(JL,1,JK)*ZFPPW
847 PUD(JL,5,JK)=PUD(JL,1,JK)*(1.-ZFPPW)
848 ZUD(JL,1) = ZUD(JL,1) + PUD(JL,1,JK)
849 ZUD(JL,2) = ZUD(JL,2) + PUD(JL,2,JK)
850 ZSIGO(JL) = ZSIGN(JL)
851 ZO175(JL) = ZN175(JL)
852 ZO190(JL) = ZN190(JL)
853 C
854 IF (NOVLP.EQ.1) THEN
855 ZCLEAR(JL)=ZCLEAR(JL)
856 S *(1.-MAX(PCLDSW(JL,JKL),ZCLOUD(JL)))
857 S /(1.-MIN(ZCLOUD(JL),1.-ZEPSEC))
858 ZC1J(JL,JKL)= 1.0 - ZCLEAR(JL)
859 ZCLOUD(JL) = PCLDSW(JL,JKL)
860 ELSE IF (NOVLP.EQ.2) THEN
861 ZCLOUD(JL) = MAX(PCLDSW(JL,JKL),ZCLOUD(JL))
862 ZC1J(JL,JKL) = ZCLOUD(JL)
863 ELSE IF (NOVLP.EQ.3) THEN
864 ZCLEAR(JL) = ZCLEAR(JL)*(1.-PCLDSW(JL,JKL))
865 ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
866 ZC1J(JL,JKL) = ZCLOUD(JL)
867 END IF
868 132 CONTINUE
869 133 CONTINUE
870 DO 134 JL=1, KDLON
871 PCLEAR(JL)=1.-ZC1J(JL,1)
872 134 CONTINUE
873 DO 136 JK=1,KFLEV
874 DO 135 JL=1, KDLON
875 IF (PCLEAR(JL).LT.1.) THEN
876 PCLD(JL,JK)=PCLDSW(JL,JK)/(1.-PCLEAR(JL))
877 ELSE
878 PCLD(JL,JK)=0.
879 END IF
880 135 CONTINUE
881 136 CONTINUE
882 C
883 C
884 C* 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
885 C -----------------------------------------------
886 C
887 140 CONTINUE
888 C
889 DO 142 JA = 1,2
890 DO 141 JL = 1, KDLON
891 ZUD(JL,JA) = ZUD(JL,JA) * PSEC(JL)
892 141 CONTINUE
893 142 CONTINUE
894 C
895 CALL SWTT1(2, 2, IIND, ZUD, ZR)
896 C
897 DO 144 JA = 1,2
898 DO 143 JL = 1, KDLON
899 PAKI(JL,JA) = -LOG( ZR(JL,JA) ) / ZUD(JL,JA)
900 143 CONTINUE
901 144 CONTINUE
902 C
903 C
904 C ------------------------------------------------------------------
905 C
906 RETURN
907 END
908 SUBROUTINE SW1S ( KNU
909 S , PAER , flag_aer, tauae, pizae, cgae
910 S , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW
911 S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD
912 S , PFD , PFU)
913 use dimens_m
914 use dimphy
915 use raddim
916 IMPLICIT none
917 C
918 C ------------------------------------------------------------------
919 C PURPOSE.
920 C --------
921 C
922 C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
923 C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
924 C
925 C METHOD.
926 C -------
927 C
928 C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
929 C CONTINUUM SCATTERING
930 C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
931 C
932 C REFERENCE.
933 C ----------
934 C
935 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
936 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
937 C
938 C AUTHOR.
939 C -------
940 C JEAN-JACQUES MORCRETTE *ECMWF*
941 C
942 C MODIFICATIONS.
943 C --------------
944 C ORIGINAL : 89-07-14
945 C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
946 C ------------------------------------------------------------------
947 C
948 C* ARGUMENTS:
949 C
950 INTEGER KNU
951 c-OB
952 real*8 flag_aer
953 real*8 tauae(kdlon,kflev,2)
954 real*8 pizae(kdlon,kflev,2)
955 real*8 cgae(kdlon,kflev,2)
956 REAL*8 PAER(KDLON,KFLEV,5)
957 REAL*8 PALBD(KDLON,2)
958 REAL*8 PALBP(KDLON,2)
959 REAL*8 PCG(KDLON,2,KFLEV)
960 REAL*8 PCLD(KDLON,KFLEV)
961 REAL*8 PCLDSW(KDLON,KFLEV)
962 REAL*8 PCLEAR(KDLON)
963 REAL*8 PDSIG(KDLON,KFLEV)
964 REAL*8 POMEGA(KDLON,2,KFLEV)
965 REAL*8 POZ(KDLON,KFLEV)
966 REAL*8 PRMU(KDLON)
967 REAL*8 PSEC(KDLON)
968 REAL*8 PTAU(KDLON,2,KFLEV)
969 REAL*8 PUD(KDLON,5,KFLEV+1)
970 C
971 REAL*8 PFD(KDLON,KFLEV+1)
972 REAL*8 PFU(KDLON,KFLEV+1)
973 C
974 C* LOCAL VARIABLES:
975 C
976 INTEGER IIND(4)
977 C
978 REAL*8 ZCGAZ(KDLON,KFLEV)
979 REAL*8 ZDIFF(KDLON)
980 REAL*8 ZDIRF(KDLON)
981 REAL*8 ZPIZAZ(KDLON,KFLEV)
982 REAL*8 ZRAYL(KDLON)
983 REAL*8 ZRAY1(KDLON,KFLEV+1)
984 REAL*8 ZRAY2(KDLON,KFLEV+1)
985 REAL*8 ZREFZ(KDLON,2,KFLEV+1)
986 REAL*8 ZRJ(KDLON,6,KFLEV+1)
987 REAL*8 ZRJ0(KDLON,6,KFLEV+1)
988 REAL*8 ZRK(KDLON,6,KFLEV+1)
989 REAL*8 ZRK0(KDLON,6,KFLEV+1)
990 REAL*8 ZRMUE(KDLON,KFLEV+1)
991 REAL*8 ZRMU0(KDLON,KFLEV+1)
992 REAL*8 ZR(KDLON,4)
993 REAL*8 ZTAUAZ(KDLON,KFLEV)
994 REAL*8 ZTRA1(KDLON,KFLEV+1)
995 REAL*8 ZTRA2(KDLON,KFLEV+1)
996 REAL*8 ZW(KDLON,4)
997 C
998 INTEGER jl, jk, k, jaj, ikm1, ikl
999 c
1000 c Prescribed Data:
1001 c
1002 REAL*8 RSUN(2)
1003 SAVE RSUN
1004 REAL*8 RRAY(2,6)
1005 SAVE RRAY
1006 DATA RSUN(1) / 0.441676 /
1007 DATA RSUN(2) / 0.558324 /
1008 DATA (RRAY(1,K),K=1,6) /
1009 S .428937E-01, .890743E+00,-.288555E+01,
1010 S .522744E+01,-.469173E+01, .161645E+01/
1011 DATA (RRAY(2,K),K=1,6) /
1012 S .697200E-02, .173297E-01,-.850903E-01,
1013 S .248261E+00,-.302031E+00, .129662E+00/
1014 C ------------------------------------------------------------------
1015 C
1016 C* 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
1017 C ----------------------- ------------------
1018 C
1019 100 CONTINUE
1020 C
1021 C
1022 C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
1023 C -----------------------------------------
1024 C
1025 110 CONTINUE
1026 C
1027 DO 111 JL = 1, KDLON
1028 ZRAYL(JL) = RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)
1029 S * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)
1030 S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) ))))
1031 111 CONTINUE
1032 C
1033 C
1034 C ------------------------------------------------------------------
1035 C
1036 C* 2. CONTINUUM SCATTERING CALCULATIONS
1037 C ---------------------------------
1038 C
1039 200 CONTINUE
1040 C
1041 C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
1042 C --------------------------------
1043 C
1044 210 CONTINUE
1045 C
1046 CALL SWCLR ( KNU
1047 S , PAER , flag_aer, tauae, pizae, cgae
1048 S , PALBP , PDSIG , ZRAYL, PSEC
1049 S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
1050 S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
1051 C
1052 C
1053 C* 2.2 CLOUDY FRACTION OF THE COLUMN
1054 C -----------------------------
1055 C
1056 220 CONTINUE
1057 C
1058 CALL SWR ( KNU
1059 S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL
1060 S , PSEC ,PTAU
1061 S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE
1062 S , ZTAUAZ,ZTRA1 ,ZTRA2)
1063 C
1064 C
1065 C ------------------------------------------------------------------
1066 C
1067 C* 3. OZONE ABSORPTION
1068 C ----------------
1069 C
1070 300 CONTINUE
1071 C
1072 IIND(1)=1
1073 IIND(2)=3
1074 IIND(3)=1
1075 IIND(4)=3
1076 C
1077 C
1078 C* 3.1 DOWNWARD FLUXES
1079 C ---------------
1080 C
1081 310 CONTINUE
1082 C
1083 JAJ = 2
1084 C
1085 DO 311 JL = 1, KDLON
1086 ZW(JL,1)=0.
1087 ZW(JL,2)=0.
1088 ZW(JL,3)=0.
1089 ZW(JL,4)=0.
1090 PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
1091 S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
1092 311 CONTINUE
1093 DO 314 JK = 1 , KFLEV
1094 IKL = KFLEV+1-JK
1095 DO 312 JL = 1, KDLON
1096 ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)
1097 ZW(JL,2)=ZW(JL,2)+POZ(JL, IKL)/ZRMUE(JL,IKL)
1098 ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
1099 ZW(JL,4)=ZW(JL,4)+POZ(JL, IKL)/ZRMU0(JL,IKL)
1100 312 CONTINUE
1101 C
1102 CALL SWTT1(KNU, 4, IIND, ZW, ZR)
1103 C
1104 DO 313 JL = 1, KDLON
1105 ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)
1106 ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)
1107 PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
1108 S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU)
1109 313 CONTINUE
1110 314 CONTINUE
1111 C
1112 C
1113 C* 3.2 UPWARD FLUXES
1114 C -------------
1115 C
1116 320 CONTINUE
1117 C
1118 DO 325 JL = 1, KDLON
1119 PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
1120 S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
1121 S * RSUN(KNU)
1122 325 CONTINUE
1123 C
1124 DO 328 JK = 2 , KFLEV+1
1125 IKM1=JK-1
1126 DO 326 JL = 1, KDLON
1127 ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
1128 ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66
1129 ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
1130 ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66
1131 326 CONTINUE
1132 C
1133 CALL SWTT1(KNU, 4, IIND, ZW, ZR)
1134 C
1135 DO 327 JL = 1, KDLON
1136 ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
1137 ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
1138 PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
1139 S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU)
1140 327 CONTINUE
1141 328 CONTINUE
1142 C
1143 C ------------------------------------------------------------------
1144 C
1145 RETURN
1146 END
1147 SUBROUTINE SW2S ( KNU
1148 S , PAER , flag_aer, tauae, pizae, cgae
1149 S , PAKI, PALBD, PALBP, PCG , PCLD, PCLEAR, PCLDSW
1150 S , PDSIG ,POMEGA,POZ , PRMU , PSEC , PTAU
1151 S , PUD ,PWV , PQS
1152 S , PFDOWN,PFUP )
1153 use dimens_m
1154 use dimphy
1155 use raddim
1156 use radepsi
1157 IMPLICIT none
1158 C
1159 C ------------------------------------------------------------------
1160 C PURPOSE.
1161 C --------
1162 C
1163 C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
1164 C SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
1165 C
1166 C METHOD.
1167 C -------
1168 C
1169 C 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
1170 C CONTINUUM SCATTERING
1171 C 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
1172 C A GREY MOLECULAR ABSORPTION
1173 C 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
1174 C OF ABSORBERS
1175 C 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
1176 C 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
1177 C
1178 C REFERENCE.
1179 C ----------
1180 C
1181 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
1182 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
1183 C
1184 C AUTHOR.
1185 C -------
1186 C JEAN-JACQUES MORCRETTE *ECMWF*
1187 C
1188 C MODIFICATIONS.
1189 C --------------
1190 C ORIGINAL : 89-07-14
1191 C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
1192 C ------------------------------------------------------------------
1193 C* ARGUMENTS:
1194 C
1195 INTEGER KNU
1196 c-OB
1197 real*8 flag_aer
1198 real*8 tauae(kdlon,kflev,2)
1199 real*8 pizae(kdlon,kflev,2)
1200 real*8 cgae(kdlon,kflev,2)
1201 REAL*8 PAER(KDLON,KFLEV,5)
1202 REAL*8 PAKI(KDLON,2)
1203 REAL*8 PALBD(KDLON,2)
1204 REAL*8 PALBP(KDLON,2)
1205 REAL*8 PCG(KDLON,2,KFLEV)
1206 REAL*8 PCLD(KDLON,KFLEV)
1207 REAL*8 PCLDSW(KDLON,KFLEV)
1208 REAL*8 PCLEAR(KDLON)
1209 REAL*8 PDSIG(KDLON,KFLEV)
1210 REAL*8 POMEGA(KDLON,2,KFLEV)
1211 REAL*8 POZ(KDLON,KFLEV)
1212 REAL*8 PQS(KDLON,KFLEV)
1213 REAL*8 PRMU(KDLON)
1214 REAL*8 PSEC(KDLON)
1215 REAL*8 PTAU(KDLON,2,KFLEV)
1216 REAL*8 PUD(KDLON,5,KFLEV+1)
1217 REAL*8 PWV(KDLON,KFLEV)
1218 C
1219 REAL*8 PFDOWN(KDLON,KFLEV+1)
1220 REAL*8 PFUP(KDLON,KFLEV+1)
1221 C
1222 C* LOCAL VARIABLES:
1223 C
1224 INTEGER IIND2(2), IIND3(3)
1225 REAL*8 ZCGAZ(KDLON,KFLEV)
1226 REAL*8 ZFD(KDLON,KFLEV+1)
1227 REAL*8 ZFU(KDLON,KFLEV+1)
1228 REAL*8 ZG(KDLON)
1229 REAL*8 ZGG(KDLON)
1230 REAL*8 ZPIZAZ(KDLON,KFLEV)
1231 REAL*8 ZRAYL(KDLON)
1232 REAL*8 ZRAY1(KDLON,KFLEV+1)
1233 REAL*8 ZRAY2(KDLON,KFLEV+1)
1234 REAL*8 ZREF(KDLON)
1235 REAL*8 ZREFZ(KDLON,2,KFLEV+1)
1236 REAL*8 ZRE1(KDLON)
1237 REAL*8 ZRE2(KDLON)
1238 REAL*8 ZRJ(KDLON,6,KFLEV+1)
1239 REAL*8 ZRJ0(KDLON,6,KFLEV+1)
1240 REAL*8 ZRK(KDLON,6,KFLEV+1)
1241 REAL*8 ZRK0(KDLON,6,KFLEV+1)
1242 REAL*8 ZRL(KDLON,8)
1243 REAL*8 ZRMUE(KDLON,KFLEV+1)
1244 REAL*8 ZRMU0(KDLON,KFLEV+1)
1245 REAL*8 ZRMUZ(KDLON)
1246 REAL*8 ZRNEB(KDLON)
1247 REAL*8 ZRUEF(KDLON,8)
1248 REAL*8 ZR1(KDLON)
1249 REAL*8 ZR2(KDLON,2)
1250 REAL*8 ZR3(KDLON,3)
1251 REAL*8 ZR4(KDLON)
1252 REAL*8 ZR21(KDLON)
1253 REAL*8 ZR22(KDLON)
1254 REAL*8 ZS(KDLON)
1255 REAL*8 ZTAUAZ(KDLON,KFLEV)
1256 REAL*8 ZTO1(KDLON)
1257 REAL*8 ZTR(KDLON,2,KFLEV+1)
1258 REAL*8 ZTRA1(KDLON,KFLEV+1)
1259 REAL*8 ZTRA2(KDLON,KFLEV+1)
1260 REAL*8 ZTR1(KDLON)
1261 REAL*8 ZTR2(KDLON)
1262 REAL*8 ZW(KDLON)
1263 REAL*8 ZW1(KDLON)
1264 REAL*8 ZW2(KDLON,2)
1265 REAL*8 ZW3(KDLON,3)
1266 REAL*8 ZW4(KDLON)
1267 REAL*8 ZW5(KDLON)
1268 C
1269 INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
1270 INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
1271 REAL*8 ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
1272 C
1273 C* Prescribed Data:
1274 C
1275 REAL*8 RSUN(2)
1276 SAVE RSUN
1277 REAL*8 RRAY(2,6)
1278 SAVE RRAY
1279 DATA RSUN(1) / 0.441676 /
1280 DATA RSUN(2) / 0.558324 /
1281 DATA (RRAY(1,K),K=1,6) /
1282 S .428937E-01, .890743E+00,-.288555E+01,
1283 S .522744E+01,-.469173E+01, .161645E+01/
1284 DATA (RRAY(2,K),K=1,6) /
1285 S .697200E-02, .173297E-01,-.850903E-01,
1286 S .248261E+00,-.302031E+00, .129662E+00/
1287 C
1288 C ------------------------------------------------------------------
1289 C
1290 C* 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
1291 C -------------------------------------------
1292 C
1293 100 CONTINUE
1294 C
1295 C
1296 C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
1297 C -----------------------------------------
1298 C
1299 110 CONTINUE
1300 C
1301 DO 111 JL = 1, KDLON
1302 ZRMUM1 = 1. - PRMU(JL)
1303 ZRAYL(JL) = RRAY(KNU,1) + ZRMUM1 * (RRAY(KNU,2) + ZRMUM1
1304 S * (RRAY(KNU,3) + ZRMUM1 * (RRAY(KNU,4) + ZRMUM1
1305 S * (RRAY(KNU,5) + ZRMUM1 * RRAY(KNU,6) ))))
1306 111 CONTINUE
1307 C
1308 C
1309 C ------------------------------------------------------------------
1310 C
1311 C* 2. CONTINUUM SCATTERING CALCULATIONS
1312 C ---------------------------------
1313 C
1314 200 CONTINUE
1315 C
1316 C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
1317 C --------------------------------
1318 C
1319 210 CONTINUE
1320 C
1321 CALL SWCLR ( KNU
1322 S , PAER , flag_aer, tauae, pizae, cgae
1323 S , PALBP , PDSIG , ZRAYL, PSEC
1324 S , ZCGAZ , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0
1325 S , ZRK0 , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)
1326 C
1327 C
1328 C* 2.2 CLOUDY FRACTION OF THE COLUMN
1329 C -----------------------------
1330 C
1331 220 CONTINUE
1332 C
1333 CALL SWR ( KNU
1334 S , PALBD , PCG , PCLD , PDSIG, POMEGA, ZRAYL
1335 S , PSEC , PTAU
1336 S , ZCGAZ , ZPIZAZ, ZRAY1, ZRAY2, ZREFZ , ZRJ , ZRK, ZRMUE
1337 S , ZTAUAZ, ZTRA1 , ZTRA2)
1338 C
1339 C
1340 C ------------------------------------------------------------------
1341 C
1342 C* 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
1343 C ------------------------------------------------------
1344 C
1345 300 CONTINUE
1346 C
1347 JN = 2
1348 C
1349 DO 361 JABS=1,2
1350 C
1351 C
1352 C* 3.1 SURFACE CONDITIONS
1353 C ------------------
1354 C
1355 310 CONTINUE
1356 C
1357 DO 311 JL = 1, KDLON
1358 ZREFZ(JL,2,1) = PALBD(JL,KNU)
1359 ZREFZ(JL,1,1) = PALBD(JL,KNU)
1360 311 CONTINUE
1361 C
1362 C
1363 C* 3.2 INTRODUCING CLOUD EFFECTS
1364 C -------------------------
1365 C
1366 320 CONTINUE
1367 C
1368 DO 324 JK = 2 , KFLEV+1
1369 JKM1 = JK - 1
1370 IKL=KFLEV+1-JKM1
1371 DO 322 JL = 1, KDLON
1372 ZRNEB(JL) = PCLD(JL,JKM1)
1373 IF (JABS.EQ.1 .AND. ZRNEB(JL).GT.2.*ZEELOG) THEN
1374 ZWH2O=MAX(PWV(JL,JKM1),ZEELOG)
1375 ZCNEB=MAX(ZEELOG,MIN(ZRNEB(JL),1.-ZEELOG))
1376 ZBB=PUD(JL,JABS,JKM1)*PQS(JL,JKM1)/ZWH2O
1377 ZAA=MAX((PUD(JL,JABS,JKM1)-ZCNEB*ZBB)/(1.-ZCNEB),ZEELOG)
1378 ELSE
1379 ZAA=PUD(JL,JABS,JKM1)
1380 ZBB=ZAA
1381 END IF
1382 ZRKI = PAKI(JL,JABS)
1383 ZS(JL) = EXP(-ZRKI * ZAA * 1.66)
1384 ZG(JL) = EXP(-ZRKI * ZAA / ZRMUE(JL,JK))
1385 ZTR1(JL) = 0.
1386 ZRE1(JL) = 0.
1387 ZTR2(JL) = 0.
1388 ZRE2(JL) = 0.
1389 C
1390 ZW(JL)= POMEGA(JL,KNU,JKM1)
1391 ZTO1(JL) = PTAU(JL,KNU,JKM1) / ZW(JL)
1392 S + ZTAUAZ(JL,JKM1) / ZPIZAZ(JL,JKM1)
1393 S + ZBB * ZRKI
1394
1395 ZR21(JL) = PTAU(JL,KNU,JKM1) + ZTAUAZ(JL,JKM1)
1396 ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
1397 ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
1398 S + (1. - ZR22(JL)) * ZCGAZ(JL,JKM1)
1399 ZW(JL) = ZR21(JL) / ZTO1(JL)
1400 ZREF(JL) = ZREFZ(JL,1,JKM1)
1401 ZRMUZ(JL) = ZRMUE(JL,JK)
1402 322 CONTINUE
1403 C
1404 CALL SWDE(ZGG, ZREF, ZRMUZ, ZTO1, ZW,
1405 S ZRE1, ZRE2, ZTR1, ZTR2)
1406 C
1407 DO 323 JL = 1, KDLON
1408 C
1409 ZREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (ZRAY1(JL,JKM1)
1410 S + ZREFZ(JL,2,JKM1) * ZTRA1(JL,JKM1)
1411 S * ZTRA2(JL,JKM1) ) * ZG(JL) * ZS(JL)
1412 S + ZRNEB(JL) * ZRE1(JL)
1413 C
1414 ZTR(JL,2,JKM1)=ZRNEB(JL)*ZTR1(JL)
1415 S + (ZTRA1(JL,JKM1)) * ZG(JL) * (1.-ZRNEB(JL))
1416 C
1417 ZREFZ(JL,1,JK)=(1.-ZRNEB(JL))*(ZRAY1(JL,JKM1)
1418 S +ZREFZ(JL,1,JKM1)*ZTRA1(JL,JKM1)*ZTRA2(JL,JKM1)
1419 S /(1.-ZRAY2(JL,JKM1)*ZREFZ(JL,1,JKM1)))*ZG(JL)*ZS(JL)
1420 S + ZRNEB(JL) * ZRE2(JL)
1421 C
1422 ZTR(JL,1,JKM1)= ZRNEB(JL) * ZTR2(JL)
1423 S + (ZTRA1(JL,JKM1)/(1.-ZRAY2(JL,JKM1)
1424 S * ZREFZ(JL,1,JKM1)))
1425 S * ZG(JL) * (1. -ZRNEB(JL))
1426 C
1427 323 CONTINUE
1428 324 CONTINUE
1429 C
1430 C* 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
1431 C -------------------------------------------------
1432 C
1433 330 CONTINUE
1434 C
1435 DO 351 JREF=1,2
1436 C
1437 JN = JN + 1
1438 C
1439 DO 331 JL = 1, KDLON
1440 ZRJ(JL,JN,KFLEV+1) = 1.
1441 ZRK(JL,JN,KFLEV+1) = ZREFZ(JL,JREF,KFLEV+1)
1442 331 CONTINUE
1443 C
1444 DO 333 JK = 1 , KFLEV
1445 JKL = KFLEV+1 - JK
1446 JKLP1 = JKL + 1
1447 DO 332 JL = 1, KDLON
1448 ZRE11 = ZRJ(JL,JN,JKLP1) * ZTR(JL,JREF,JKL)
1449 ZRJ(JL,JN,JKL) = ZRE11
1450 ZRK(JL,JN,JKL) = ZRE11 * ZREFZ(JL,JREF,JKL)
1451 332 CONTINUE
1452 333 CONTINUE
1453 351 CONTINUE
1454 361 CONTINUE
1455 C
1456 C
1457 C ------------------------------------------------------------------
1458 C
1459 C* 4. INVERT GREY AND CONTINUUM FLUXES
1460 C --------------------------------
1461 C
1462 400 CONTINUE
1463 C
1464 C
1465 C* 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
1466 C ---------------------------------------------
1467 C
1468 410 CONTINUE
1469 C
1470 DO 414 JK = 1 , KFLEV+1
1471 DO 413 JAJ = 1 , 5 , 2
1472 JAJP = JAJ + 1
1473 DO 412 JL = 1, KDLON
1474 ZRJ(JL,JAJ,JK)= ZRJ(JL,JAJ,JK) - ZRJ(JL,JAJP,JK)
1475 ZRK(JL,JAJ,JK)= ZRK(JL,JAJ,JK) - ZRK(JL,JAJP,JK)
1476 ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
1477 ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
1478 412 CONTINUE
1479 413 CONTINUE
1480 414 CONTINUE
1481 C
1482 DO 417 JK = 1 , KFLEV+1
1483 DO 416 JAJ = 2 , 6 , 2
1484 DO 415 JL = 1, KDLON
1485 ZRJ(JL,JAJ,JK)= MAX( ZRJ(JL,JAJ,JK) , ZEELOG )
1486 ZRK(JL,JAJ,JK)= MAX( ZRK(JL,JAJ,JK) , ZEELOG )
1487 415 CONTINUE
1488 416 CONTINUE
1489 417 CONTINUE
1490 C
1491 C* 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
1492 C ---------------------------------------------
1493 C
1494 420 CONTINUE
1495 C
1496 DO 437 JK = 1 , KFLEV+1
1497 JKKI = 1
1498 DO 425 JAJ = 1 , 2
1499 IIND2(1)=JAJ
1500 IIND2(2)=JAJ
1501 DO 424 JN = 1 , 2
1502 JN2J = JN + 2 * JAJ
1503 JKKP4 = JKKI + 4
1504 C
1505 C* 4.2.1 EFFECTIVE ABSORBER AMOUNTS
1506 C --------------------------
1507 C
1508 4210 CONTINUE
1509 C
1510 DO 4211 JL = 1, KDLON
1511 ZW2(JL,1) = LOG( ZRJ(JL,JN,JK) / ZRJ(JL,JN2J,JK))
1512 S / PAKI(JL,JAJ)
1513 ZW2(JL,2) = LOG( ZRK(JL,JN,JK) / ZRK(JL,JN2J,JK))
1514 S / PAKI(JL,JAJ)
1515 4211 CONTINUE
1516 C
1517 C* 4.2.2 TRANSMISSION FUNCTION
1518 C ---------------------
1519 C
1520 4220 CONTINUE
1521 C
1522 CALL SWTT1(KNU, 2, IIND2, ZW2, ZR2)
1523 C
1524 DO 4221 JL = 1, KDLON
1525 ZRL(JL,JKKI) = ZR2(JL,1)
1526 ZRUEF(JL,JKKI) = ZW2(JL,1)
1527 ZRL(JL,JKKP4) = ZR2(JL,2)
1528 ZRUEF(JL,JKKP4) = ZW2(JL,2)
1529 4221 CONTINUE
1530 C
1531 JKKI=JKKI+1
1532 424 CONTINUE
1533 425 CONTINUE
1534 C
1535 C* 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
1536 C ------------------------------------------------------
1537 C
1538 430 CONTINUE
1539 C
1540 DO 431 JL = 1, KDLON
1541 PFDOWN(JL,JK) = ZRJ(JL,1,JK) * ZRL(JL,1) * ZRL(JL,3)
1542 S + ZRJ(JL,2,JK) * ZRL(JL,2) * ZRL(JL,4)
1543 PFUP(JL,JK) = ZRK(JL,1,JK) * ZRL(JL,5) * ZRL(JL,7)
1544 S + ZRK(JL,2,JK) * ZRL(JL,6) * ZRL(JL,8)
1545 431 CONTINUE
1546 437 CONTINUE
1547 C
1548 C
1549 C ------------------------------------------------------------------
1550 C
1551 C* 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
1552 C ----------------------------------------
1553 C
1554 500 CONTINUE
1555 C
1556 C
1557 C* 5.1 DOWNWARD FLUXES
1558 C ---------------
1559 C
1560 510 CONTINUE
1561 C
1562 JAJ = 2
1563 IIND3(1)=1
1564 IIND3(2)=2
1565 IIND3(3)=3
1566 C
1567 DO 511 JL = 1, KDLON
1568 ZW3(JL,1)=0.
1569 ZW3(JL,2)=0.
1570 ZW3(JL,3)=0.
1571 ZW4(JL) =0.
1572 ZW5(JL) =0.
1573 ZR4(JL) =1.
1574 ZFD(JL,KFLEV+1)= ZRJ0(JL,JAJ,KFLEV+1)
1575 511 CONTINUE
1576 DO 514 JK = 1 , KFLEV
1577 IKL = KFLEV+1-JK
1578 DO 512 JL = 1, KDLON
1579 ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)
1580 ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKL)/ZRMU0(JL,IKL)
1581 ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKL)/ZRMU0(JL,IKL)
1582 ZW4(JL) =ZW4(JL) +PUD(JL,4,IKL)/ZRMU0(JL,IKL)
1583 ZW5(JL) =ZW5(JL) +PUD(JL,5,IKL)/ZRMU0(JL,IKL)
1584 512 CONTINUE
1585 C
1586 CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
1587 C
1588 DO 513 JL = 1, KDLON
1589 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
1590 ZFD(JL,IKL) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
1591 S * ZRJ0(JL,JAJ,IKL)
1592 513 CONTINUE
1593 514 CONTINUE
1594 C
1595 C
1596 C* 5.2 UPWARD FLUXES
1597 C -------------
1598 C
1599 520 CONTINUE
1600 C
1601 DO 525 JL = 1, KDLON
1602 ZFU(JL,1) = ZFD(JL,1)*PALBP(JL,KNU)
1603 525 CONTINUE
1604 C
1605 DO 528 JK = 2 , KFLEV+1
1606 IKM1=JK-1
1607 DO 526 JL = 1, KDLON
1608 ZW3(JL,1)=ZW3(JL,1)+PUD(JL,1,IKM1)*1.66
1609 ZW3(JL,2)=ZW3(JL,2)+PUD(JL,2,IKM1)*1.66
1610 ZW3(JL,3)=ZW3(JL,3)+POZ(JL, IKM1)*1.66
1611 ZW4(JL) =ZW4(JL) +PUD(JL,4,IKM1)*1.66
1612 ZW5(JL) =ZW5(JL) +PUD(JL,5,IKM1)*1.66
1613 526 CONTINUE
1614 C
1615 CALL SWTT1(KNU, 3, IIND3, ZW3, ZR3)
1616 C
1617 DO 527 JL = 1, KDLON
1618 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
1619 ZFU(JL,JK) = ZR3(JL,1)*ZR3(JL,2)*ZR3(JL,3)*ZR4(JL)
1620 S * ZRK0(JL,JAJ,JK)
1621 527 CONTINUE
1622 528 CONTINUE
1623 C
1624 C
1625 C ------------------------------------------------------------------
1626 C
1627 C* 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
1628 C --------------------------------------------------
1629 C
1630 600 CONTINUE
1631 IABS=3
1632 C
1633 C* 6.1 DOWNWARD FLUXES
1634 C ---------------
1635 C
1636 610 CONTINUE
1637 DO 611 JL = 1, KDLON
1638 ZW1(JL)=0.
1639 ZW4(JL)=0.
1640 ZW5(JL)=0.
1641 ZR1(JL)=0.
1642 PFDOWN(JL,KFLEV+1) = ((1.-PCLEAR(JL))*PFDOWN(JL,KFLEV+1)
1643 S + PCLEAR(JL) * ZFD(JL,KFLEV+1)) * RSUN(KNU)
1644 611 CONTINUE
1645 C
1646 DO 614 JK = 1 , KFLEV
1647 IKL=KFLEV+1-JK
1648 DO 612 JL = 1, KDLON
1649 ZW1(JL) = ZW1(JL)+POZ(JL, IKL)/ZRMUE(JL,IKL)
1650 ZW4(JL) = ZW4(JL)+PUD(JL,4,IKL)/ZRMUE(JL,IKL)
1651 ZW5(JL) = ZW5(JL)+PUD(JL,5,IKL)/ZRMUE(JL,IKL)
1652 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
1653 612 CONTINUE
1654 C
1655 CALL SWTT(KNU, IABS, ZW1, ZR1)
1656 C
1657 DO 613 JL = 1, KDLON
1658 PFDOWN(JL,IKL) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL)*PFDOWN(JL,IKL)
1659 S +PCLEAR(JL)*ZFD(JL,IKL)) * RSUN(KNU)
1660 613 CONTINUE
1661 614 CONTINUE
1662 C
1663 C
1664 C* 6.2 UPWARD FLUXES
1665 C -------------
1666 C
1667 620 CONTINUE
1668 DO 621 JL = 1, KDLON
1669 PFUP(JL,1) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,1)
1670 S +PCLEAR(JL)*ZFU(JL,1)) * RSUN(KNU)
1671 621 CONTINUE
1672 C
1673 DO 624 JK = 2 , KFLEV+1
1674 IKM1=JK-1
1675 DO 622 JL = 1, KDLON
1676 ZW1(JL) = ZW1(JL)+POZ(JL ,IKM1)*1.66
1677 ZW4(JL) = ZW4(JL)+PUD(JL,4,IKM1)*1.66
1678 ZW5(JL) = ZW5(JL)+PUD(JL,5,IKM1)*1.66
1679 C ZR4(JL) = EXP(-RSWCE*ZW4(JL)-RSWCP*ZW5(JL))
1680 622 CONTINUE
1681 C
1682 CALL SWTT(KNU, IABS, ZW1, ZR1)
1683 C
1684 DO 623 JL = 1, KDLON
1685 PFUP(JL,JK) = ((1.-PCLEAR(JL))*ZR1(JL)*ZR4(JL) * PFUP(JL,JK)
1686 S +PCLEAR(JL)*ZFU(JL,JK)) * RSUN(KNU)
1687 623 CONTINUE
1688 624 CONTINUE
1689 C
1690 C ------------------------------------------------------------------
1691 C
1692 RETURN
1693 END
1694 SUBROUTINE SWCLR ( KNU
1695 S , PAER , flag_aer, tauae, pizae, cgae
1696 S , PALBP , PDSIG , PRAYL , PSEC
1697 S , PCGAZ , PPIZAZ, PRAY1 , PRAY2 , PREFZ , PRJ
1698 S , PRK , PRMU0 , PTAUAZ, PTRA1 , PTRA2 )
1699 use dimens_m
1700 use dimphy
1701 use raddim
1702 use radepsi
1703 use radopt
1704 IMPLICIT none
1705 C
1706 C ------------------------------------------------------------------
1707 C PURPOSE.
1708 C --------
1709 C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
1710 C CLEAR-SKY COLUMN
1711 C
1712 C REFERENCE.
1713 C ----------
1714 C
1715 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
1716 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
1717 C
1718 C AUTHOR.
1719 C -------
1720 C JEAN-JACQUES MORCRETTE *ECMWF*
1721 C
1722 C MODIFICATIONS.
1723 C --------------
1724 C ORIGINAL : 94-11-15
1725 C ------------------------------------------------------------------
1726 C* ARGUMENTS:
1727 C
1728 INTEGER KNU
1729 c-OB
1730 real*8 flag_aer
1731 real*8 tauae(kdlon,kflev,2)
1732 real*8 pizae(kdlon,kflev,2)
1733 real*8 cgae(kdlon,kflev,2)
1734 REAL*8 PAER(KDLON,KFLEV,5)
1735 REAL*8 PALBP(KDLON,2)
1736 REAL*8 PDSIG(KDLON,KFLEV)
1737 REAL*8 PRAYL(KDLON)
1738 REAL*8 PSEC(KDLON)
1739 C
1740 REAL*8 PCGAZ(KDLON,KFLEV)
1741 REAL*8 PPIZAZ(KDLON,KFLEV)
1742 REAL*8 PRAY1(KDLON,KFLEV+1)
1743 REAL*8 PRAY2(KDLON,KFLEV+1)
1744 REAL*8 PREFZ(KDLON,2,KFLEV+1)
1745 REAL*8 PRJ(KDLON,6,KFLEV+1)
1746 REAL*8 PRK(KDLON,6,KFLEV+1)
1747 REAL*8 PRMU0(KDLON,KFLEV+1)
1748 REAL*8 PTAUAZ(KDLON,KFLEV)
1749 REAL*8 PTRA1(KDLON,KFLEV+1)
1750 REAL*8 PTRA2(KDLON,KFLEV+1)
1751 C
1752 C* LOCAL VARIABLES:
1753 C
1754 REAL*8 ZC0I(KDLON,KFLEV+1)
1755 REAL*8 ZCLE0(KDLON,KFLEV)
1756 REAL*8 ZCLEAR(KDLON)
1757 REAL*8 ZR21(KDLON)
1758 REAL*8 ZR23(KDLON)
1759 REAL*8 ZSS0(KDLON)
1760 REAL*8 ZSCAT(KDLON)
1761 REAL*8 ZTR(KDLON,2,KFLEV+1)
1762 C
1763 INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
1764 REAL*8 ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
1765 REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
1766 REAL*8 ZBMU0, ZBMU1, ZRE11
1767 C
1768 C* Prescribed Data for Aerosols:
1769 C
1770 REAL*8 TAUA(2,5), RPIZA(2,5), RCGA(2,5)
1771 SAVE TAUA, RPIZA, RCGA
1772 DATA ((TAUA(IN,JA),JA=1,5),IN=1,2) /
1773 S .730719, .912819, .725059, .745405, .682188 ,
1774 S .730719, .912819, .725059, .745405, .682188 /
1775 DATA ((RPIZA(IN,JA),JA=1,5),IN=1,2) /
1776 S .872212, .982545, .623143, .944887, .997975 ,
1777 S .872212, .982545, .623143, .944887, .997975 /
1778 DATA ((RCGA (IN,JA),JA=1,5),IN=1,2) /
1779 S .647596, .739002, .580845, .662657, .624246 ,
1780 S .647596, .739002, .580845, .662657, .624246 /
1781 C ------------------------------------------------------------------
1782 C
1783 C* 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
1784 C --------------------------------------------
1785 C
1786 100 CONTINUE
1787 C
1788 DO 103 JK = 1 , KFLEV+1
1789 DO 102 JA = 1 , 6
1790 DO 101 JL = 1, KDLON
1791 PRJ(JL,JA,JK) = 0.
1792 PRK(JL,JA,JK) = 0.
1793 101 CONTINUE
1794 102 CONTINUE
1795 103 CONTINUE
1796 C
1797 DO 108 JK = 1 , KFLEV
1798 c-OB
1799 c DO 104 JL = 1, KDLON
1800 c PCGAZ(JL,JK) = 0.
1801 c PPIZAZ(JL,JK) = 0.
1802 c PTAUAZ(JL,JK) = 0.
1803 c 104 CONTINUE
1804 c-OB
1805 c DO 106 JAE=1,5
1806 c DO 105 JL = 1, KDLON
1807 c PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
1808 c S +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
1809 c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
1810 c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
1811 c PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE)
1812 c S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)*RCGA(KNU,JAE)
1813 c 105 CONTINUE
1814 c 106 CONTINUE
1815 c-OB
1816 DO 105 JL = 1, KDLON
1817 PTAUAZ(JL,JK)=flag_aer * tauae(JL,JK,KNU)
1818 PPIZAZ(JL,JK)=flag_aer * pizae(JL,JK,KNU)
1819 PCGAZ (JL,JK)=flag_aer * cgae(JL,JK,KNU)
1820 105 CONTINUE
1821 C
1822 IF (flag_aer.GT.0) THEN
1823 c-OB
1824 DO 107 JL = 1, KDLON
1825 c PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
1826 c PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
1827 ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
1828 ZRATIO = ZTRAY / (ZTRAY + PTAUAZ(JL,JK))
1829 ZGAR = PCGAZ(JL,JK)
1830 ZFF = ZGAR * ZGAR
1831 PTAUAZ(JL,JK)=ZTRAY+PTAUAZ(JL,JK)*(1.-PPIZAZ(JL,JK)*ZFF)
1832 PCGAZ(JL,JK) = ZGAR * (1. - ZRATIO) / (1. + ZGAR)
1833 PPIZAZ(JL,JK) =ZRATIO+(1.-ZRATIO)*PPIZAZ(JL,JK)*(1.-ZFF)
1834 S / (1. - PPIZAZ(JL,JK) * ZFF)
1835 107 CONTINUE
1836 ELSE
1837 DO JL = 1, KDLON
1838 ZTRAY = PRAYL(JL) * PDSIG(JL,JK)
1839 PTAUAZ(JL,JK) = ZTRAY
1840 PCGAZ(JL,JK) = 0.
1841 PPIZAZ(JL,JK) = 1.-REPSCT
1842 END DO
1843 END IF ! check flag_aer
1844 c 107 CONTINUE
1845 c PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
1846 c $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
1847 c 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
1848 C
1849 108 CONTINUE
1850 C
1851 C ------------------------------------------------------------------
1852 C
1853 C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
1854 C ----------------------------------------------
1855 C
1856 200 CONTINUE
1857 C
1858 DO 201 JL = 1, KDLON
1859 ZR23(JL) = 0.
1860 ZC0I(JL,KFLEV+1) = 0.
1861 ZCLEAR(JL) = 1.
1862 ZSCAT(JL) = 0.
1863 201 CONTINUE
1864 C
1865 JK = 1
1866 JKL = KFLEV+1 - JK
1867 JKLP1 = JKL + 1
1868 DO 202 JL = 1, KDLON
1869 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
1870 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
1871 ZR21(JL) = EXP(-ZCORAE )
1872 ZSS0(JL) = 1.-ZR21(JL)
1873 ZCLE0(JL,JKL) = ZSS0(JL)
1874 C
1875 IF (NOVLP.EQ.1) THEN
1876 c* maximum-random
1877 ZCLEAR(JL) = ZCLEAR(JL)
1878 S *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
1879 S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
1880 ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
1881 ZSCAT(JL) = ZSS0(JL)
1882 ELSE IF (NOVLP.EQ.2) THEN
1883 C* maximum
1884 ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
1885 ZC0I(JL,JKL) = ZSCAT(JL)
1886 ELSE IF (NOVLP.EQ.3) THEN
1887 c* random
1888 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
1889 ZSCAT(JL) = 1.0 - ZCLEAR(JL)
1890 ZC0I(JL,JKL) = ZSCAT(JL)
1891 END IF
1892 202 CONTINUE
1893 C
1894 DO 205 JK = 2 , KFLEV
1895 JKL = KFLEV+1 - JK
1896 JKLP1 = JKL + 1
1897 DO 204 JL = 1, KDLON
1898 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
1899 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
1900 ZR21(JL) = EXP(-ZCORAE )
1901 ZSS0(JL) = 1.-ZR21(JL)
1902 ZCLE0(JL,JKL) = ZSS0(JL)
1903 c
1904 IF (NOVLP.EQ.1) THEN
1905 c* maximum-random
1906 ZCLEAR(JL) = ZCLEAR(JL)
1907 S *(1.0-MAX(ZSS0(JL),ZSCAT(JL)))
1908 S /(1.0-MIN(ZSCAT(JL),1.-ZEPSEC))
1909 ZC0I(JL,JKL) = 1.0 - ZCLEAR(JL)
1910 ZSCAT(JL) = ZSS0(JL)
1911 ELSE IF (NOVLP.EQ.2) THEN
1912 C* maximum
1913 ZSCAT(JL) = MAX( ZSS0(JL) , ZSCAT(JL) )
1914 ZC0I(JL,JKL) = ZSCAT(JL)
1915 ELSE IF (NOVLP.EQ.3) THEN
1916 c* random
1917 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-ZSS0(JL))
1918 ZSCAT(JL) = 1.0 - ZCLEAR(JL)
1919 ZC0I(JL,JKL) = ZSCAT(JL)
1920 END IF
1921 204 CONTINUE
1922 205 CONTINUE
1923 C
1924 C ------------------------------------------------------------------
1925 C
1926 C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
1927 C -----------------------------------------------
1928 C
1929 300 CONTINUE
1930 C
1931 DO 301 JL = 1, KDLON
1932 PRAY1(JL,KFLEV+1) = 0.
1933 PRAY2(JL,KFLEV+1) = 0.
1934 PREFZ(JL,2,1) = PALBP(JL,KNU)
1935 PREFZ(JL,1,1) = PALBP(JL,KNU)
1936 PTRA1(JL,KFLEV+1) = 1.
1937 PTRA2(JL,KFLEV+1) = 1.
1938 301 CONTINUE
1939 C
1940 DO 346 JK = 2 , KFLEV+1
1941 JKM1 = JK-1
1942 DO 342 JL = 1, KDLON
1943 C
1944 C
1945 C ------------------------------------------------------------------
1946 C
1947 C* 3.1 EQUIVALENT ZENITH ANGLE
1948 C -----------------------
1949 C
1950 310 CONTINUE
1951 C
1952 ZMUE = (1.-ZC0I(JL,JK)) * PSEC(JL)
1953 S + ZC0I(JL,JK) * 1.66
1954 PRMU0(JL,JK) = 1./ZMUE
1955 C
1956 C
1957 C ------------------------------------------------------------------
1958 C
1959 C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
1960 C ----------------------------------------------------
1961 C
1962 320 CONTINUE
1963 C
1964 ZGAP = PCGAZ(JL,JKM1)
1965 ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
1966 ZWW = PPIZAZ(JL,JKM1)
1967 ZTO = PTAUAZ(JL,JKM1)
1968 ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
1969 S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
1970 PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
1971 PTRA1(JL,JKM1) = 1. / ZDEN
1972 C
1973 ZMU1 = 0.5
1974 ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
1975 ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
1976 S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
1977 PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
1978 PTRA2(JL,JKM1) = 1. / ZDEN1
1979 C
1980 C
1981 C
1982 PREFZ(JL,1,JK) = (PRAY1(JL,JKM1)
1983 S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
1984 S * PTRA2(JL,JKM1)
1985 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
1986 C
1987 ZTR(JL,1,JKM1) = (PTRA1(JL,JKM1)
1988 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
1989 C
1990 PREFZ(JL,2,JK) = (PRAY1(JL,JKM1)
1991 S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
1992 S * PTRA2(JL,JKM1) )
1993 C
1994 ZTR(JL,2,JKM1) = PTRA1(JL,JKM1)
1995 C
1996 342 CONTINUE
1997 346 CONTINUE
1998 DO 347 JL = 1, KDLON
1999 ZMUE = (1.-ZC0I(JL,1))*PSEC(JL)+ZC0I(JL,1)*1.66
2000 PRMU0(JL,1)=1./ZMUE
2001 347 CONTINUE
2002 C
2003 C
2004 C ------------------------------------------------------------------
2005 C
2006 C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
2007 C -------------------------------------------------
2008 C
2009 350 CONTINUE
2010 C
2011 IF (KNU.EQ.1) THEN
2012 JAJ = 2
2013 DO 351 JL = 1, KDLON
2014 PRJ(JL,JAJ,KFLEV+1) = 1.
2015 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
2016 351 CONTINUE
2017 C
2018 DO 353 JK = 1 , KFLEV
2019 JKL = KFLEV+1 - JK
2020 JKLP1 = JKL + 1
2021 DO 352 JL = 1, KDLON
2022 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL)
2023 PRJ(JL,JAJ,JKL) = ZRE11
2024 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL)
2025 352 CONTINUE
2026 353 CONTINUE
2027 354 CONTINUE
2028 C
2029 ELSE
2030 C
2031 DO 358 JAJ = 1 , 2
2032 DO 355 JL = 1, KDLON
2033 PRJ(JL,JAJ,KFLEV+1) = 1.
2034 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
2035 355 CONTINUE
2036 C
2037 DO 357 JK = 1 , KFLEV
2038 JKL = KFLEV+1 - JK
2039 JKLP1 = JKL + 1
2040 DO 356 JL = 1, KDLON
2041 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
2042 PRJ(JL,JAJ,JKL) = ZRE11
2043 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
2044 356 CONTINUE
2045 357 CONTINUE
2046 358 CONTINUE
2047 C
2048 END IF
2049 C
2050 C ------------------------------------------------------------------
2051 C
2052 RETURN
2053 END
2054 SUBROUTINE SWR ( KNU
2055 S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL
2056 S , PSEC , PTAU
2057 S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE
2058 S , PTAUAZ, PTRA1 , PTRA2 )
2059 use dimens_m
2060 use dimphy
2061 use raddim
2062 use radepsi
2063 use radopt
2064 IMPLICIT none
2065 C
2066 C ------------------------------------------------------------------
2067 C PURPOSE.
2068 C --------
2069 C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
2070 C CONTINUUM SCATTERING
2071 C
2072 C METHOD.
2073 C -------
2074 C
2075 C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
2076 C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
2077 C
2078 C REFERENCE.
2079 C ----------
2080 C
2081 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
2082 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
2083 C
2084 C AUTHOR.
2085 C -------
2086 C JEAN-JACQUES MORCRETTE *ECMWF*
2087 C
2088 C MODIFICATIONS.
2089 C --------------
2090 C ORIGINAL : 89-07-14
2091 C ------------------------------------------------------------------
2092 C* ARGUMENTS:
2093 C
2094 INTEGER KNU
2095 REAL*8 PALBD(KDLON,2)
2096 REAL*8 PCG(KDLON,2,KFLEV)
2097 REAL*8 PCLD(KDLON,KFLEV)
2098 REAL*8 PDSIG(KDLON,KFLEV)
2099 REAL*8 POMEGA(KDLON,2,KFLEV)
2100 REAL*8 PRAYL(KDLON)
2101 REAL*8 PSEC(KDLON)
2102 REAL*8 PTAU(KDLON,2,KFLEV)
2103 C
2104 REAL*8 PRAY1(KDLON,KFLEV+1)
2105 REAL*8 PRAY2(KDLON,KFLEV+1)
2106 REAL*8 PREFZ(KDLON,2,KFLEV+1)
2107 REAL*8 PRJ(KDLON,6,KFLEV+1)
2108 REAL*8 PRK(KDLON,6,KFLEV+1)
2109 REAL*8 PRMUE(KDLON,KFLEV+1)
2110 REAL*8 PCGAZ(KDLON,KFLEV)
2111 REAL*8 PPIZAZ(KDLON,KFLEV)
2112 REAL*8 PTAUAZ(KDLON,KFLEV)
2113 REAL*8 PTRA1(KDLON,KFLEV+1)
2114 REAL*8 PTRA2(KDLON,KFLEV+1)
2115 C
2116 C* LOCAL VARIABLES:
2117 C
2118 REAL*8 ZC1I(KDLON,KFLEV+1)
2119 REAL*8 ZCLEQ(KDLON,KFLEV)
2120 REAL*8 ZCLEAR(KDLON)
2121 REAL*8 ZCLOUD(KDLON)
2122 REAL*8 ZGG(KDLON)
2123 REAL*8 ZREF(KDLON)
2124 REAL*8 ZRE1(KDLON)
2125 REAL*8 ZRE2(KDLON)
2126 REAL*8 ZRMUZ(KDLON)
2127 REAL*8 ZRNEB(KDLON)
2128 REAL*8 ZR21(KDLON)
2129 REAL*8 ZR22(KDLON)
2130 REAL*8 ZR23(KDLON)
2131 REAL*8 ZSS1(KDLON)
2132 REAL*8 ZTO1(KDLON)
2133 REAL*8 ZTR(KDLON,2,KFLEV+1)
2134 REAL*8 ZTR1(KDLON)
2135 REAL*8 ZTR2(KDLON)
2136 REAL*8 ZW(KDLON)
2137 C
2138 INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
2139 REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
2140 REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
2141 REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
2142 C
2143 C ------------------------------------------------------------------
2144 C
2145 C* 1. INITIALIZATION
2146 C --------------
2147 C
2148 100 CONTINUE
2149 C
2150 DO 103 JK = 1 , KFLEV+1
2151 DO 102 JA = 1 , 6
2152 DO 101 JL = 1, KDLON
2153 PRJ(JL,JA,JK) = 0.
2154 PRK(JL,JA,JK) = 0.
2155 101 CONTINUE
2156 102 CONTINUE
2157 103 CONTINUE
2158 C
2159 C
2160 C ------------------------------------------------------------------
2161 C
2162 C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
2163 C ----------------------------------------------
2164 C
2165 200 CONTINUE
2166 C
2167 DO 201 JL = 1, KDLON
2168 ZR23(JL) = 0.
2169 ZC1I(JL,KFLEV+1) = 0.
2170 ZCLEAR(JL) = 1.
2171 ZCLOUD(JL) = 0.
2172 201 CONTINUE
2173 C
2174 JK = 1
2175 JKL = KFLEV+1 - JK
2176 JKLP1 = JKL + 1
2177 DO 202 JL = 1, KDLON
2178 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
2179 ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
2180 S * PCG(JL,KNU,JKL)
2181 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
2182 ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
2183 ZR21(JL) = EXP(-ZCORAE )
2184 ZR22(JL) = EXP(-ZCORCD )
2185 ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
2186 S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
2187 ZCLEQ(JL,JKL) = ZSS1(JL)
2188 C
2189 IF (NOVLP.EQ.1) THEN
2190 c* maximum-random
2191 ZCLEAR(JL) = ZCLEAR(JL)
2192 S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
2193 S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
2194 ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
2195 ZCLOUD(JL) = ZSS1(JL)
2196 ELSE IF (NOVLP.EQ.2) THEN
2197 C* maximum
2198 ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
2199 ZC1I(JL,JKL) = ZCLOUD(JL)
2200 ELSE IF (NOVLP.EQ.3) THEN
2201 c* random
2202 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
2203 ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
2204 ZC1I(JL,JKL) = ZCLOUD(JL)
2205 END IF
2206 202 CONTINUE
2207 C
2208 DO 205 JK = 2 , KFLEV
2209 JKL = KFLEV+1 - JK
2210 JKLP1 = JKL + 1
2211 DO 204 JL = 1, KDLON
2212 ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
2213 ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
2214 S * PCG(JL,KNU,JKL)
2215 ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
2216 ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
2217 ZR21(JL) = EXP(-ZCORAE )
2218 ZR22(JL) = EXP(-ZCORCD )
2219 ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
2220 S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
2221 ZCLEQ(JL,JKL) = ZSS1(JL)
2222 c
2223 IF (NOVLP.EQ.1) THEN
2224 c* maximum-random
2225 ZCLEAR(JL) = ZCLEAR(JL)
2226 S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
2227 S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
2228 ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
2229 ZCLOUD(JL) = ZSS1(JL)
2230 ELSE IF (NOVLP.EQ.2) THEN
2231 C* maximum
2232 ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
2233 ZC1I(JL,JKL) = ZCLOUD(JL)
2234 ELSE IF (NOVLP.EQ.3) THEN
2235 c* random
2236 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
2237 ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
2238 ZC1I(JL,JKL) = ZCLOUD(JL)
2239 END IF
2240 204 CONTINUE
2241 205 CONTINUE
2242 C
2243 C ------------------------------------------------------------------
2244 C
2245 C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
2246 C -----------------------------------------------
2247 C
2248 300 CONTINUE
2249 C
2250 DO 301 JL = 1, KDLON
2251 PRAY1(JL,KFLEV+1) = 0.
2252 PRAY2(JL,KFLEV+1) = 0.
2253 PREFZ(JL,2,1) = PALBD(JL,KNU)
2254 PREFZ(JL,1,1) = PALBD(JL,KNU)
2255 PTRA1(JL,KFLEV+1) = 1.
2256 PTRA2(JL,KFLEV+1) = 1.
2257 301 CONTINUE
2258 C
2259 DO 346 JK = 2 , KFLEV+1
2260 JKM1 = JK-1
2261 DO 342 JL = 1, KDLON
2262 ZRNEB(JL)= PCLD(JL,JKM1)
2263 ZRE1(JL)=0.
2264 ZTR1(JL)=0.
2265 ZRE2(JL)=0.
2266 ZTR2(JL)=0.
2267 C
2268 C
2269 C ------------------------------------------------------------------
2270 C
2271 C* 3.1 EQUIVALENT ZENITH ANGLE
2272 C -----------------------
2273 C
2274 310 CONTINUE
2275 C
2276 ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
2277 S + ZC1I(JL,JK) * 1.66
2278 PRMUE(JL,JK) = 1./ZMUE
2279 C
2280 C
2281 C ------------------------------------------------------------------
2282 C
2283 C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
2284 C ----------------------------------------------------
2285 C
2286 320 CONTINUE
2287 C
2288 ZGAP = PCGAZ(JL,JKM1)
2289 ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
2290 ZWW = PPIZAZ(JL,JKM1)
2291 ZTO = PTAUAZ(JL,JKM1)
2292 ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
2293 S + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
2294 PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
2295 PTRA1(JL,JKM1) = 1. / ZDEN
2296 c PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
2297 C
2298 ZMU1 = 0.5
2299 ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
2300 ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
2301 S + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
2302 PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
2303 PTRA2(JL,JKM1) = 1. / ZDEN1
2304 C
2305 C
2306 C ------------------------------------------------------------------
2307 C
2308 C* 3.3 EFFECT OF CLOUD LAYER
2309 C ---------------------
2310 C
2311 330 CONTINUE
2312 C
2313 ZW(JL) = POMEGA(JL,KNU,JKM1)
2314 ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
2315 S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
2316 ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
2317 ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
2318 ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
2319 S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
2320 C Modif PhD - JJM 19/03/96 pour erreurs arrondis
2321 C machine
2322 C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
2323 IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
2324 ZW(JL)=1.
2325 ELSE
2326 ZW(JL) = ZR21(JL) / ZTO1(JL)
2327 END IF
2328 ZREF(JL) = PREFZ(JL,1,JKM1)
2329 ZRMUZ(JL) = PRMUE(JL,JK)
2330 342 CONTINUE
2331 C
2332 CALL SWDE(ZGG , ZREF , ZRMUZ , ZTO1 , ZW,
2333 S ZRE1 , ZRE2 , ZTR1 , ZTR2)
2334 C
2335 DO 345 JL = 1, KDLON
2336 C
2337 PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
2338 S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
2339 S * PTRA2(JL,JKM1)
2340 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
2341 S + ZRNEB(JL) * ZRE2(JL)
2342 C
2343 ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
2344 S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
2345 S * (1.-ZRNEB(JL))
2346 C
2347 PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
2348 S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
2349 S * PTRA2(JL,JKM1) )
2350 S + ZRNEB(JL) * ZRE1(JL)
2351 C
2352 ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
2353 S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
2354 C
2355 345 CONTINUE
2356 346 CONTINUE
2357 DO 347 JL = 1, KDLON
2358 ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
2359 PRMUE(JL,1)=1./ZMUE
2360 347 CONTINUE
2361 C
2362 C
2363 C ------------------------------------------------------------------
2364 C
2365 C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
2366 C -------------------------------------------------
2367 C
2368 350 CONTINUE
2369 C
2370 IF (KNU.EQ.1) THEN
2371 JAJ = 2
2372 DO 351 JL = 1, KDLON
2373 PRJ(JL,JAJ,KFLEV+1) = 1.
2374 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
2375 351 CONTINUE
2376 C
2377 DO 353 JK = 1 , KFLEV
2378 JKL = KFLEV+1 - JK
2379 JKLP1 = JKL + 1
2380 DO 352 JL = 1, KDLON
2381 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL)
2382 PRJ(JL,JAJ,JKL) = ZRE11
2383 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL)
2384 352 CONTINUE
2385 353 CONTINUE
2386 354 CONTINUE
2387 C
2388 ELSE
2389 C
2390 DO 358 JAJ = 1 , 2
2391 DO 355 JL = 1, KDLON
2392 PRJ(JL,JAJ,KFLEV+1) = 1.
2393 PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
2394 355 CONTINUE
2395 C
2396 DO 357 JK = 1 , KFLEV
2397 JKL = KFLEV+1 - JK
2398 JKLP1 = JKL + 1
2399 DO 356 JL = 1, KDLON
2400 ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
2401 PRJ(JL,JAJ,JKL) = ZRE11
2402 PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
2403 356 CONTINUE
2404 357 CONTINUE
2405 358 CONTINUE
2406 C
2407 END IF
2408 C
2409 C ------------------------------------------------------------------
2410 C
2411 RETURN
2412 END
2413 SUBROUTINE SWDE (PGG,PREF,PRMUZ,PTO1,PW,
2414 S PRE1,PRE2,PTR1,PTR2)
2415 use dimens_m
2416 use dimphy
2417 use raddim
2418 IMPLICIT none
2419 C
2420 C ------------------------------------------------------------------
2421 C PURPOSE.
2422 C --------
2423 C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
2424 C LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
2425 C
2426 C METHOD.
2427 C -------
2428 C
2429 C STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
2430 C
2431 C REFERENCE.
2432 C ----------
2433 C
2434 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2435 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2436 C
2437 C AUTHOR.
2438 C -------
2439 C JEAN-JACQUES MORCRETTE *ECMWF*
2440 C
2441 C MODIFICATIONS.
2442 C --------------
2443 C ORIGINAL : 88-12-15
2444 C ------------------------------------------------------------------
2445 C* ARGUMENTS:
2446 C
2447 REAL*8 PGG(KDLON) ! ASSYMETRY FACTOR
2448 REAL*8 PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER
2449 REAL*8 PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
2450 REAL*8 PTO1(KDLON) ! OPTICAL THICKNESS
2451 REAL*8 PW(KDLON) ! SINGLE SCATTERING ALBEDO
2452 REAL*8 PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
2453 REAL*8 PRE2(KDLON) ! LAYER REFLECTIVITY
2454 REAL*8 PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
2455 REAL*8 PTR2(KDLON) ! LAYER TRANSMISSIVITY
2456 C
2457 C* LOCAL VARIABLES:
2458 C
2459 INTEGER jl
2460 REAL*8 ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
2461 REAL*8 ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
2462 REAL*8 ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B, ZAM2B
2463 REAL*8 ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
2464 REAL*8 ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
2465 REAL*8 ZRI0B, ZRI1B
2466 REAL*8 ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
2467 REAL*8 ZRI0C, ZRI1C, ZRI0D, ZRI1D
2468 C ------------------------------------------------------------------
2469 C
2470 C* 1. DELTA-EDDINGTON CALCULATIONS
2471 C
2472 100 CONTINUE
2473 C
2474 DO 131 JL = 1, KDLON
2475 C
2476 C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS
2477 C
2478 110 CONTINUE
2479 C
2480 ZFF = PGG(JL)*PGG(JL)
2481 ZGP = PGG(JL)/(1.+PGG(JL))
2482 ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
2483 ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
2484 ZDT = 2./3.
2485 ZX1 = 1.-ZWCP*ZGP
2486 ZWM = 1.-ZWCP
2487 ZRM2 = PRMUZ(JL) * PRMUZ(JL)
2488 ZRK = SQRT(3.*ZWM*ZX1)
2489 ZX2 = 4.*(1.-ZRK*ZRK*ZRM2)
2490 ZRP=ZRK/ZX1
2491 ZALPHA = 3.*ZWCP*ZRM2*(1.+ZGP*ZWM)/ZX2
2492 ZBETA = 3.*ZWCP* PRMUZ(JL) *(1.+3.*ZGP*ZRM2*ZWM)/ZX2
2493 CMAF ZARG=MIN(ZTOP/PRMUZ(JL),200.)
2494 ZARG=MIN(ZTOP/PRMUZ(JL),2.0d+2)
2495 ZEXMU0=EXP(-ZARG)
2496 CMAF ZARG2=MIN(ZRK*ZTOP,200.)
2497 ZARG2=MIN(ZRK*ZTOP,2.0d+2)
2498 ZEXKP=EXP(ZARG2)
2499 ZEXKM = 1./ZEXKP
2500 ZXP2P = 1.+ZDT*ZRP
2501 ZXM2P = 1.-ZDT*ZRP
2502 ZAP2B = ZALPHA+ZDT*ZBETA
2503 ZAM2B = ZALPHA-ZDT*ZBETA
2504 C
2505 C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER
2506 C
2507 120 CONTINUE
2508 C
2509 ZA11 = ZXP2P
2510 ZA12 = ZXM2P
2511 ZA13 = ZAP2B
2512 ZA22 = ZXP2P*ZEXKP
2513 ZA21 = ZXM2P*ZEXKM
2514 ZA23 = ZAM2B*ZEXMU0
2515 ZDENA = ZA11 * ZA22 - ZA21 * ZA12
2516 ZC1A = (ZA22*ZA13-ZA12*ZA23)/ZDENA
2517 ZC2A = (ZA11*ZA23-ZA21*ZA13)/ZDENA
2518 ZRI0A = ZC1A+ZC2A-ZALPHA
2519 ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
2520 PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
2521 ZRI0B = ZC1A*ZEXKM+ZC2A*ZEXKP-ZALPHA*ZEXMU0
2522 ZRI1B = ZRP*(ZC1A*ZEXKM-ZC2A*ZEXKP)-ZBETA*ZEXMU0
2523 PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
2524 C
2525 C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER
2526 C
2527 130 CONTINUE
2528 C
2529 ZB21 = ZA21- PREF(JL) *ZXP2P*ZEXKM
2530 ZB22 = ZA22- PREF(JL) *ZXM2P*ZEXKP
2531 ZB23 = ZA23- PREF(JL) *ZEXMU0*(ZAP2B - PRMUZ(JL) )
2532 ZDENB = ZA11 * ZB22 - ZB21 * ZA12
2533 ZC1B = (ZB22*ZA13-ZA12*ZB23)/ZDENB
2534 ZC2B = (ZA11*ZB23-ZB21*ZA13)/ZDENB
2535 ZRI0C = ZC1B+ZC2B-ZALPHA
2536 ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
2537 PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
2538 ZRI0D = ZC1B*ZEXKM + ZC2B*ZEXKP - ZALPHA*ZEXMU0
2539 ZRI1D = ZRP * (ZC1B*ZEXKM - ZC2B*ZEXKP) - ZBETA*ZEXMU0
2540 PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
2541 C
2542 131 CONTINUE
2543 RETURN
2544 END
2545 SUBROUTINE SWTT (KNU,KA,PU,PTR)
2546 use dimens_m
2547 use dimphy
2548 use raddim
2549 IMPLICIT none
2550 C
2551 C-----------------------------------------------------------------------
2552 C PURPOSE.
2553 C --------
2554 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2555 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2556 C INTERVALS.
2557 C
2558 C METHOD.
2559 C -------
2560 C
2561 C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2562 C AND HORNER'S ALGORITHM.
2563 C
2564 C REFERENCE.
2565 C ----------
2566 C
2567 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2568 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2569 C
2570 C AUTHOR.
2571 C -------
2572 C JEAN-JACQUES MORCRETTE *ECMWF*
2573 C
2574 C MODIFICATIONS.
2575 C --------------
2576 C ORIGINAL : 88-12-15
2577 C-----------------------------------------------------------------------
2578 C
2579 C* ARGUMENTS
2580 C
2581 INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2582 INTEGER KA ! INDEX OF THE ABSORBER
2583 REAL*8 PU(KDLON) ! ABSORBER AMOUNT
2584 C
2585 REAL*8 PTR(KDLON) ! TRANSMISSION FUNCTION
2586 C
2587 C* LOCAL VARIABLES:
2588 C
2589 REAL*8 ZR1(KDLON), ZR2(KDLON)
2590 INTEGER jl, i,j
2591 C
2592 C* Prescribed Data:
2593 C
2594 REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
2595 SAVE APAD, BPAD, D
2596 DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2597 S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2598 S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2599 S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2600 S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2601 S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2602 S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2603 S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2604 DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2605 S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2606 S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2607 S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2608 S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2609 S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2610 S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2611 S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2612 C
2613 DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2614 S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2615 S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2616 S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2617 S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2618 S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2619 S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2620 S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2621 DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2622 S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2623 S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2624 S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2625 S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2626 S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2627 S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2628 S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2629 c
2630 DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2631 DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2632 C
2633 C-----------------------------------------------------------------------
2634 C
2635 C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2636 C
2637 100 CONTINUE
2638 C
2639 DO 201 JL = 1, KDLON
2640 ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
2641 S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
2642 S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
2643 S * ( APAD(KNU,KA,7) ))))))
2644 C
2645 ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
2646 S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
2647 S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
2648 S * ( BPAD(KNU,KA,7) ))))))
2649 C
2650 C
2651 C* 2. ADD THE BACKGROUND TRANSMISSION
2652 C
2653 200 CONTINUE
2654 C
2655 C
2656 PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
2657 201 CONTINUE
2658 C
2659 RETURN
2660 END
2661 SUBROUTINE SWTT1(KNU,KABS,KIND, PU, PTR)
2662 use dimens_m
2663 use dimphy
2664 use raddim
2665 IMPLICIT none
2666 C
2667 C-----------------------------------------------------------------------
2668 C PURPOSE.
2669 C --------
2670 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2671 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2672 C INTERVALS.
2673 C
2674 C METHOD.
2675 C -------
2676 C
2677 C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2678 C AND HORNER'S ALGORITHM.
2679 C
2680 C REFERENCE.
2681 C ----------
2682 C
2683 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2684 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2685 C
2686 C AUTHOR.
2687 C -------
2688 C JEAN-JACQUES MORCRETTE *ECMWF*
2689 C
2690 C MODIFICATIONS.
2691 C --------------
2692 C ORIGINAL : 95-01-20
2693 C-----------------------------------------------------------------------
2694 C* ARGUMENTS:
2695 C
2696 INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2697 INTEGER KABS ! NUMBER OF ABSORBERS
2698 INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS
2699 REAL*8 PU(KDLON,KABS) ! ABSORBER AMOUNT
2700 C
2701 REAL*8 PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
2702 C
2703 C* LOCAL VARIABLES:
2704 C
2705 REAL*8 ZR1(KDLON)
2706 REAL*8 ZR2(KDLON)
2707 REAL*8 ZU(KDLON)
2708 INTEGER jl, ja, i, j, ia
2709 C
2710 C* Prescribed Data:
2711 C
2712 REAL*8 APAD(2,3,7), BPAD(2,3,7), D(2,3)
2713 SAVE APAD, BPAD, D
2714 DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2715 S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2716 S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2717 S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2718 S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2719 S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2720 S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2721 S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2722 DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2723 S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2724 S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2725 S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2726 S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2727 S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2728 S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2729 S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2730 C
2731 DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2732 S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2733 S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2734 S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2735 S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2736 S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2737 S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2738 S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2739 DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2740 S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2741 S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2742 S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2743 S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2744 S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2745 S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2746 S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2747 c
2748 DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2749 DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2750 C-----------------------------------------------------------------------
2751 C
2752 C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2753 C
2754 100 CONTINUE
2755 C
2756 DO 202 JA = 1,KABS
2757 IA=KIND(JA)
2758 DO 201 JL = 1, KDLON
2759 ZU(JL) = PU(JL,JA)
2760 ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
2761 S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
2762 S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
2763 S * ( APAD(KNU,IA,7) ))))))
2764 C
2765 ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
2766 S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
2767 S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
2768 S * ( BPAD(KNU,IA,7) ))))))
2769 C
2770 C
2771 C* 2. ADD THE BACKGROUND TRANSMISSION
2772 C
2773 200 CONTINUE
2774 C
2775 PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)
2776 201 CONTINUE
2777 202 CONTINUE
2778 C
2779 RETURN
2780 END
2781 cIM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
2782 SUBROUTINE LW(
2783 . PPMB, PDP,
2784 . PPSOL,PDT0,PEMIS,
2785 . PTL, PTAVE, PWV, POZON, PAER,
2786 . PCLDLD,PCLDLU,
2787 . PVIEW,
2788 . PCOLR, PCOLR0,
2789 . PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
2790 . psollwdown,
2791 . plwup, plwdn, plwup0, plwdn0)
2792 use dimens_m
2793 use dimphy
2794 use clesphys
2795 use YOMCST
2796 use raddim
2797 use raddimlw
2798 IMPLICIT none
2799 C
2800 C-----------------------------------------------------------------------
2801 C METHOD.
2802 C -------
2803 C
2804 C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2805 C ABSORBERS.
2806 C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
2807 C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
2808 C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
2809 C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
2810 C BOUNDARIES.
2811 C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
2812 C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
2813 C
2814 C
2815 C REFERENCE.
2816 C ----------
2817 C
2818 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2819 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2820 C
2821 C AUTHOR.
2822 C -------
2823 C JEAN-JACQUES MORCRETTE *ECMWF*
2824 C
2825 C MODIFICATIONS.
2826 C --------------
2827 C ORIGINAL : 89-07-14
2828 C-----------------------------------------------------------------------
2829 cIM ctes ds clesphys.h
2830 c REAL*8 RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
2831 c REAL*8 RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
2832 c REAL*8 RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
2833 c REAL*8 RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
2834 c REAL*8 RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
2835 REAL*8 PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER
2836 REAL*8 PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER
2837 REAL*8 PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa)
2838 REAL*8 PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K)
2839 REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
2840 REAL*8 PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb)
2841 REAL*8 PPSOL(KDLON) ! SURFACE PRESSURE (Pa)
2842 REAL*8 POZON(KDLON,KFLEV) ! O3 CONCENTRATION (kg/kg)
2843 REAL*8 PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K)
2844 REAL*8 PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS
2845 REAL*8 PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
2846 REAL*8 PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE
2847 REAL*8 PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg)
2848 C
2849 REAL*8 PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day)
2850 REAL*8 PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky
2851 REAL*8 PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A.
2852 REAL*8 PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE
2853 REAL*8 PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
2854 REAL*8 PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
2855 c Rajout LF
2856 real*8 psollwdown(kdlon) ! LONGWAVE downwards flux at surface
2857 cIM
2858 REAL*8 plwup(KDLON,KFLEV+1) ! LW up total sky
2859 REAL*8 plwup0(KDLON,KFLEV+1) ! LW up clear sky
2860 REAL*8 plwdn(KDLON,KFLEV+1) ! LW down total sky
2861 REAL*8 plwdn0(KDLON,KFLEV+1) ! LW down clear sky
2862 C-------------------------------------------------------------------------
2863 REAL*8 ZABCU(KDLON,NUA,3*KFLEV+1)
2864 REAL*8 ZOZ(KDLON,KFLEV)
2865 c
2866 REAL*8 ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
2867 REAL*8 ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
2868 REAL*8 ZBINT(KDLON,KFLEV+1) ! Intermediate variable
2869 REAL*8 ZBSUI(KDLON) ! Intermediate variable
2870 REAL*8 ZCTS(KDLON,KFLEV) ! Intermediate variable
2871 REAL*8 ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable
2872 SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
2873 c
2874 INTEGER ilim, i, k, kpl1
2875 C
2876 INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
2877 PARAMETER (lw0pas=1)
2878 INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
2879 PARAMETER (lwpas=1)
2880 c
2881 INTEGER itaplw0, itaplw
2882 LOGICAL appel1er
2883 SAVE appel1er, itaplw0, itaplw
2884 DATA appel1er /.TRUE./
2885 DATA itaplw0,itaplw /0,0/
2886 C ------------------------------------------------------------------
2887 IF (appel1er) THEN
2888 PRINT*, "LW clear-sky calling frequency: ", lw0pas
2889 PRINT*, "LW cloudy-sky calling frequency: ", lwpas
2890 PRINT*, " In general, they should be 1"
2891 appel1er=.FALSE.
2892 ENDIF
2893 C
2894 IF (MOD(itaplw0,lw0pas).EQ.0) THEN
2895 DO k = 1, KFLEV ! convertir ozone de kg/kg en pa/pa
2896 DO i = 1, KDLON
2897 c convertir ozone de kg/kg en pa (modif MPL 100505)
2898 ZOZ(i,k) = POZON(i,k)*PDP(i,k) * RMD/RMO3
2899 c print *,'LW: ZOZ*10**6=',ZOZ(i,k)*1000000.
2900 ENDDO
2901 ENDDO
2902 cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
2903 CALL LWU(
2904 S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
2905 CALL LWBV(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
2906 S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
2907 itaplw0 = 0
2908 ENDIF
2909 itaplw0 = itaplw0 + 1
2910 C
2911 IF (MOD(itaplw,lwpas).EQ.0) THEN
2912 CALL LWC(ILIM,PCLDLD,PCLDLU,PEMIS,
2913 S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
2914 S ZFLUX)
2915 itaplw = 0
2916 ENDIF
2917 itaplw = itaplw + 1
2918 C
2919 DO k = 1, KFLEV
2920 kpl1 = k+1
2921 DO i = 1, KDLON
2922 PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
2923 . - ZFLUX(i,1,k)- ZFLUX(i,2,k)
2924 PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
2925 PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
2926 . - ZFLUC(i,1,k)- ZFLUC(i,2,k)
2927 PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
2928 ENDDO
2929 ENDDO
2930 DO i = 1, KDLON
2931 PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
2932 PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
2933 c
2934 PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
2935 PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
2936 psollwdown(i) = -ZFLUX(i,2,1)
2937 c
2938 cIM attention aux signes !; LWtop >0, LWdn < 0
2939 DO k = 1, KFLEV+1
2940 plwup(i,k) = ZFLUX(i,1,k)
2941 plwup0(i,k) = ZFLUC(i,1,k)
2942 plwdn(i,k) = ZFLUX(i,2,k)
2943 plwdn0(i,k) = ZFLUC(i,2,k)
2944 ENDDO
2945 ENDDO
2946 C ------------------------------------------------------------------
2947 RETURN
2948 END
2949 cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
2950 SUBROUTINE LWU(
2951 S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
2952 S PABCU)
2953 use dimens_m
2954 use dimphy
2955 use clesphys
2956 use YOMCST
2957 use raddim
2958 use radepsi
2959 use radopt
2960 use raddimlw
2961 IMPLICIT none
2962 C
2963 C PURPOSE.
2964 C --------
2965 C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
2966 C TEMPERATURE EFFECTS
2967 C
2968 C METHOD.
2969 C -------
2970 C
2971 C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2972 C ABSORBERS.
2973 C
2974 C
2975 C REFERENCE.
2976 C ----------
2977 C
2978 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2979 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2980 C
2981 C AUTHOR.
2982 C -------
2983 C JEAN-JACQUES MORCRETTE *ECMWF*
2984 C
2985 C MODIFICATIONS.
2986 C --------------
2987 C ORIGINAL : 89-07-14
2988 C Voigt lines (loop 404 modified) - JJM & PhD - 01/96
2989 C-----------------------------------------------------------------------
2990 C* ARGUMENTS:
2991 cIM ctes ds clesphys.h
2992 c REAL*8 RCO2
2993 c REAL*8 RCH4, RN2O, RCFC11, RCFC12
2994 REAL*8 PAER(KDLON,KFLEV,5)
2995 REAL*8 PDP(KDLON,KFLEV)
2996 REAL*8 PPMB(KDLON,KFLEV+1)
2997 REAL*8 PPSOL(KDLON)
2998 REAL*8 POZ(KDLON,KFLEV)
2999 REAL*8 PTAVE(KDLON,KFLEV)
3000 REAL*8 PVIEW(KDLON)
3001 REAL*8 PWV(KDLON,KFLEV)
3002 C
3003 REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
3004 C
3005 C-----------------------------------------------------------------------
3006 C* LOCAL VARIABLES:
3007 REAL*8 ZABLY(KDLON,NUA,3*KFLEV+1)
3008 REAL*8 ZDUC(KDLON,3*KFLEV+1)
3009 REAL*8 ZPHIO(KDLON)
3010 REAL*8 ZPSC2(KDLON)
3011 REAL*8 ZPSC3(KDLON)
3012 REAL*8 ZPSH1(KDLON)
3013 REAL*8 ZPSH2(KDLON)
3014 REAL*8 ZPSH3(KDLON)
3015 REAL*8 ZPSH4(KDLON)
3016 REAL*8 ZPSH5(KDLON)
3017 REAL*8 ZPSH6(KDLON)
3018 REAL*8 ZPSIO(KDLON)
3019 REAL*8 ZTCON(KDLON)
3020 REAL*8 ZPHM6(KDLON)
3021 REAL*8 ZPSM6(KDLON)
3022 REAL*8 ZPHN6(KDLON)
3023 REAL*8 ZPSN6(KDLON)
3024 REAL*8 ZSSIG(KDLON,3*KFLEV+1)
3025 REAL*8 ZTAVI(KDLON)
3026 REAL*8 ZUAER(KDLON,Ninter)
3027 REAL*8 ZXOZ(KDLON)
3028 REAL*8 ZXWV(KDLON)
3029 C
3030 INTEGER jl, jk, jkj, jkjr, jkjp, ig1
3031 INTEGER jki, jkip1, ja, jj
3032 INTEGER jkl, jkp1, jkk, jkjpn
3033 INTEGER jae1, jae2, jae3, jae, jjpn
3034 INTEGER ir, jc, jcp1
3035 REAL*8 zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
3036 REAL*8 zfppw, ztx, ztx2, zzably
3037 REAL*8 zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
3038 REAL*8 zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
3039 REAL*8 zcac8, zcbc8
3040 REAL*8 zalup, zdiff
3041 c
3042 REAL*8 PVGCO2, PVGH2O, PVGO3
3043 C
3044 REAL*8 R10E ! DECIMAL/NATURAL LOG.FACTOR
3045 PARAMETER (R10E=0.4342945)
3046 c
3047 c Used Data Block:
3048 c
3049 REAL*8 TREF
3050 SAVE TREF
3051 REAL*8 RT1(2)
3052 SAVE RT1
3053 REAL*8 RAER(5,5)
3054 SAVE RAER
3055 REAL*8 AT(8,3), BT(8,3)
3056 SAVE AT, BT
3057 REAL*8 OCT(4)
3058 SAVE OCT
3059 DATA TREF /250.0/
3060 DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
3061 DATA RAER / .038520, .037196, .040532, .054934, .038520
3062 1 , .12613 , .18313 , .10357 , .064106, .126130
3063 2 , .012579, .013649, .018652, .025181, .012579
3064 3 , .011890, .016142, .021105, .028908, .011890
3065 4 , .013792, .026810, .052203, .066338, .013792 /
3066 DATA (AT(1,IR),IR=1,3) /
3067 S 0.298199E-02,-.394023E-03,0.319566E-04 /
3068 DATA (BT(1,IR),IR=1,3) /
3069 S-0.106432E-04,0.660324E-06,0.174356E-06 /
3070 DATA (AT(2,IR),IR=1,3) /
3071 S 0.143676E-01,0.366501E-02,-.160822E-02 /
3072 DATA (BT(2,IR),IR=1,3) /
3073 S-0.553979E-04,-.101701E-04,0.920868E-05 /
3074 DATA (AT(3,IR),IR=1,3) /
3075 S 0.197861E-01,0.315541E-02,-.174547E-02 /
3076 DATA (BT(3,IR),IR=1,3) /
3077 S-0.877012E-04,0.513302E-04,0.523138E-06 /
3078 DATA (AT(4,IR),IR=1,3) /
3079 S 0.289560E-01,-.208807E-02,-.121943E-02 /
3080 DATA (BT(4,IR),IR=1,3) /
3081 S-0.165960E-03,0.157704E-03,-.146427E-04 /
3082 DATA (AT(5,IR),IR=1,3) /
3083 S 0.103800E-01,0.436296E-02,-.161431E-02 /
3084 DATA (BT(5,IR),IR=1,3) /
3085 S -.276744E-04,-.327381E-04,0.127646E-04 /
3086 DATA (AT(6,IR),IR=1,3) /
3087 S 0.868859E-02,-.972752E-03,0.000000E-00 /
3088 DATA (BT(6,IR),IR=1,3) /
3089 S -.278412E-04,-.713940E-06,0.117469E-05 /
3090 DATA (AT(7,IR),IR=1,3) /
3091 S 0.250073E-03,0.455875E-03,0.109242E-03 /
3092 DATA (BT(7,IR),IR=1,3) /
3093 S 0.199846E-05,-.216313E-05,0.175991E-06 /
3094 DATA (AT(8,IR),IR=1,3) /
3095 S 0.307423E-01,0.110879E-02,-.322172E-03 /
3096 DATA (BT(8,IR),IR=1,3) /
3097 S-0.108482E-03,0.258096E-05,-.814575E-06 /
3098 c
3099 DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
3100 C-----------------------------------------------------------------------
3101 c
3102 IF (LEVOIGT) THEN
3103 PVGCO2= 60.
3104 PVGH2O= 30.
3105 PVGO3 =400.
3106 ELSE
3107 PVGCO2= 0.
3108 PVGH2O= 0.
3109 PVGO3 = 0.
3110 ENDIF
3111 C
3112 C
3113 C* 2. PRESSURE OVER GAUSS SUB-LEVELS
3114 C ------------------------------
3115 C
3116 200 CONTINUE
3117 C
3118 DO 201 JL = 1, KDLON
3119 ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
3120 201 CONTINUE
3121 C
3122 DO 206 JK = 1 , KFLEV
3123 JKJ=(JK-1)*NG1P1+1
3124 JKJR = JKJ
3125 JKJP = JKJ + NG1P1
3126 DO 203 JL = 1, KDLON
3127 ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
3128 203 CONTINUE
3129 DO 205 IG1=1,NG1
3130 JKJ=JKJ+1
3131 DO 204 JL = 1, KDLON
3132 ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
3133 S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
3134 204 CONTINUE
3135 205 CONTINUE
3136 206 CONTINUE
3137 C
3138 C-----------------------------------------------------------------------
3139 C
3140 C
3141 C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
3142 C --------------------------------------------------
3143 C
3144 400 CONTINUE
3145 C
3146 DO 402 JKI=1,3*KFLEV
3147 JKIP1=JKI+1
3148 DO 401 JL = 1, KDLON
3149 ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
3150 ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
3151 S /(10.*RG)
3152 401 CONTINUE
3153 402 CONTINUE
3154 C
3155 DO 406 JK = 1 , KFLEV
3156 JKP1=JK+1
3157 JKL = KFLEV+1 - JK
3158 DO 403 JL = 1, KDLON
3159 ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
3160 ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
3161 403 CONTINUE
3162 JKJ=(JK-1)*NG1P1+1
3163 JKJPN=JKJ+NG1
3164 DO 405 JKK=JKJ,JKJPN
3165 DO 404 JL = 1, KDLON
3166 ZDPM = ZABLY(JL,3,JKK)
3167 ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325.
3168 ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
3169 ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
3170 ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325.
3171 ZDUC(JL,JKK) = ZDPM
3172 ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
3173 ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
3174 ZU6 = ZXWV(JL) * ZUPM
3175 ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
3176 ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
3177 ZABLY(JL,11,JKK) = ZU6 * ZFPPW
3178 ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
3179 ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
3180 ZABLY(JL,8,JKK) = RCO2 * ZDPM
3181 404 CONTINUE
3182 405 CONTINUE
3183 406 CONTINUE
3184 C
3185 C-----------------------------------------------------------------------
3186 C
3187 C
3188 C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
3189 C --------------------------------------------------
3190 C
3191 500 CONTINUE
3192 C
3193 DO 502 JA = 1, NUA
3194 DO 501 JL = 1, KDLON
3195 PABCU(JL,JA,3*KFLEV+1) = 0.
3196 501 CONTINUE
3197 502 CONTINUE
3198 C
3199 DO 529 JK = 1 , KFLEV
3200 JJ=(JK-1)*NG1P1+1
3201 JJPN=JJ+NG1
3202 JKL=KFLEV+1-JK
3203 C
3204 C
3205 C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
3206 C --------------------------------------------------
3207 C
3208 510 CONTINUE
3209 C
3210 JAE1=3*KFLEV+1-JJ
3211 JAE2=3*KFLEV+1-(JJ+1)
3212 JAE3=3*KFLEV+1-JJPN
3213 DO 512 JAE=1,5
3214 DO 511 JL = 1, KDLON
3215 ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
3216 S +RAER(JAE,2)*PAER(JL,JKL,2)+RAER(JAE,3)*PAER(JL,JKL,3)
3217 S +RAER(JAE,4)*PAER(JL,JKL,4)+RAER(JAE,5)*PAER(JL,JKL,5))
3218 S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
3219 511 CONTINUE
3220 512 CONTINUE
3221 C
3222 C
3223 C
3224 C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
3225 C --------------------------------------------------
3226 C
3227 520 CONTINUE
3228 C
3229 DO 521 JL = 1, KDLON
3230 ZTAVI(JL)=PTAVE(JL,JKL)
3231 ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
3232 ZTX=ZTAVI(JL)-TREF
3233 ZTX2=ZTX*ZTX
3234 ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
3235 CMAF ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.), 6.0)
3236 ZUP=MIN( MAX( 0.5*R10E*LOG( ZZABLY ) + 5., 0.d+0), 6.d+0)
3237 ZCAH1=AT(1,1)+ZUP*(AT(1,2)+ZUP*(AT(1,3)))
3238 ZCBH1=BT(1,1)+ZUP*(BT(1,2)+ZUP*(BT(1,3)))
3239 ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
3240 ZCAH2=AT(2,1)+ZUP*(AT(2,2)+ZUP*(AT(2,3)))
3241 ZCBH2=BT(2,1)+ZUP*(BT(2,2)+ZUP*(BT(2,3)))
3242 ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
3243 ZCAH3=AT(3,1)+ZUP*(AT(3,2)+ZUP*(AT(3,3)))
3244 ZCBH3=BT(3,1)+ZUP*(BT(3,2)+ZUP*(BT(3,3)))
3245 ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
3246 ZCAH4=AT(4,1)+ZUP*(AT(4,2)+ZUP*(AT(4,3)))
3247 ZCBH4=BT(4,1)+ZUP*(BT(4,2)+ZUP*(BT(4,3)))
3248 ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
3249 ZCAH5=AT(5,1)+ZUP*(AT(5,2)+ZUP*(AT(5,3)))
3250 ZCBH5=BT(5,1)+ZUP*(BT(5,2)+ZUP*(BT(5,3)))
3251 ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
3252 ZCAH6=AT(6,1)+ZUP*(AT(6,2)+ZUP*(AT(6,3)))
3253 ZCBH6=BT(6,1)+ZUP*(BT(6,2)+ZUP*(BT(6,3)))
3254 ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
3255 ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
3256 ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
3257 ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
3258 ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
3259 521 CONTINUE
3260 C
3261 DO 522 JL = 1, KDLON
3262 ZTAVI(JL)=PTAVE(JL,JKL)
3263 ZTX=ZTAVI(JL)-TREF
3264 ZTX2=ZTX*ZTX
3265 ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
3266 ZALUP = R10E * LOG ( ZZABLY )
3267 CMAF ZUP = MAX( 0.0 , 5.0 + 0.5 * ZALUP )
3268 ZUP = MAX( 0.d+0 , 5.0 + 0.5 * ZALUP )
3269 ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
3270 ZCAC8=AT(8,1)+ZUP*(AT(8,2)+ZUP*(AT(8,3)))
3271 ZCBC8=BT(8,1)+ZUP*(BT(8,2)+ZUP*(BT(8,3)))
3272 ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
3273 ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
3274 ZPSIO(JL) = EXP( 2.* (OCT(3)*ZTX+OCT(4)*ZTX2))
3275 522 CONTINUE
3276 C
3277 DO 524 JKK=JJ,JJPN
3278 JC=3*KFLEV+1-JKK
3279 JCP1=JC+1
3280 DO 523 JL = 1, KDLON
3281 ZDIFF = PVIEW(JL)
3282 PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
3283 S +ZABLY(JL,10,JC) *ZDIFF
3284 PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
3285 S +ZABLY(JL,11,JC)*ZTCON(JL)*ZDIFF
3286 C
3287 PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
3288 S +ZABLY(JL,12,JC)*ZPHIO(JL)*ZDIFF
3289 PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
3290 S +ZABLY(JL,13,JC)*ZPSIO(JL)*ZDIFF
3291 C
3292 PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
3293 S +ZABLY(JL,9,JC)*ZPSC2(JL)*ZDIFF
3294 PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
3295 S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
3296 PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
3297 S +ZABLY(JL,9,JC)*ZPSC3(JL)*ZDIFF
3298 C
3299 PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
3300 S +ZABLY(JL,6,JC)*ZPSH1(JL)*ZDIFF
3301 PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
3302 S +ZABLY(JL,6,JC)*ZPSH2(JL)*ZDIFF
3303 PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
3304 S +ZABLY(JL,6,JC)*ZPSH5(JL)*ZDIFF
3305 PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
3306 S +ZABLY(JL,6,JC)*ZPSH3(JL)*ZDIFF
3307 PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
3308 S +ZABLY(JL,6,JC)*ZPSH4(JL)*ZDIFF
3309 PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
3310 S +ZABLY(JL,6,JC)*ZPSH6(JL)*ZDIFF
3311 C
3312 PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
3313 S +ZUAER(JL,1) *ZDUC(JL,JC)*ZDIFF
3314 PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
3315 S +ZUAER(JL,2) *ZDUC(JL,JC)*ZDIFF
3316 PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
3317 S +ZUAER(JL,3) *ZDUC(JL,JC)*ZDIFF
3318 PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
3319 S +ZUAER(JL,4) *ZDUC(JL,JC)*ZDIFF
3320 PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
3321 S +ZUAER(JL,5) *ZDUC(JL,JC)*ZDIFF
3322 C
3323 PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
3324 S +ZABLY(JL,8,JC)*RCH4/RCO2*ZPHM6(JL)*ZDIFF
3325 PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
3326 S +ZABLY(JL,9,JC)*RCH4/RCO2*ZPSM6(JL)*ZDIFF
3327 PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
3328 S +ZABLY(JL,8,JC)*RN2O/RCO2*ZPHN6(JL)*ZDIFF
3329 PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
3330 S +ZABLY(JL,9,JC)*RN2O/RCO2*ZPSN6(JL)*ZDIFF
3331 C
3332 PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
3333 S +ZABLY(JL,8,JC)*RCFC11/RCO2 *ZDIFF
3334 PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
3335 S +ZABLY(JL,8,JC)*RCFC12/RCO2 *ZDIFF
3336 523 CONTINUE
3337 524 CONTINUE
3338 C
3339 529 CONTINUE
3340 C
3341 C
3342 RETURN
3343 END
3344 SUBROUTINE LWBV(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
3345 S PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
3346 use dimens_m
3347 use dimphy
3348 use YOMCST
3349 use raddim
3350 use raddimlw
3351 IMPLICIT none
3352 C
3353 C PURPOSE.
3354 C --------
3355 C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
3356 C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
3357 C SAVING
3358 C
3359 C METHOD.
3360 C -------
3361 C
3362 C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
3363 C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
3364 C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
3365 C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
3366 C BOUNDARIES.
3367 C 3. COMPUTES THE CLEAR-SKY COOLING RATES.
3368 C
3369 C REFERENCE.
3370 C ----------
3371 C
3372 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3373 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3374 C
3375 C AUTHOR.
3376 C -------
3377 C JEAN-JACQUES MORCRETTE *ECMWF*
3378 C
3379 C MODIFICATIONS.
3380 C --------------
3381 C ORIGINAL : 89-07-14
3382 C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
3383 C MEMORY)
3384 C-----------------------------------------------------------------------
3385 C* ARGUMENTS:
3386 INTEGER KLIM
3387 C
3388 REAL*8 PDP(KDLON,KFLEV)
3389 REAL*8 PDT0(KDLON)
3390 REAL*8 PEMIS(KDLON)
3391 REAL*8 PPMB(KDLON,KFLEV+1)
3392 REAL*8 PTL(KDLON,KFLEV+1)
3393 REAL*8 PTAVE(KDLON,KFLEV)
3394 C
3395 REAL*8 PFLUC(KDLON,2,KFLEV+1)
3396 C
3397 REAL*8 PABCU(KDLON,NUA,3*KFLEV+1)
3398 REAL*8 PBINT(KDLON,KFLEV+1)
3399 REAL*8 PBSUI(KDLON)
3400 REAL*8 PCTS(KDLON,KFLEV)
3401 REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1)
3402 C
3403 C-------------------------------------------------------------------------
3404 C
3405 C* LOCAL VARIABLES:
3406 REAL*8 ZB(KDLON,Ninter,KFLEV+1)
3407 REAL*8 ZBSUR(KDLON,Ninter)
3408 REAL*8 ZBTOP(KDLON,Ninter)
3409 REAL*8 ZDBSL(KDLON,Ninter,KFLEV*2)
3410 REAL*8 ZGA(KDLON,8,2,KFLEV)
3411 REAL*8 ZGB(KDLON,8,2,KFLEV)
3412 REAL*8 ZGASUR(KDLON,8,2)
3413 REAL*8 ZGBSUR(KDLON,8,2)
3414 REAL*8 ZGATOP(KDLON,8,2)
3415 REAL*8 ZGBTOP(KDLON,8,2)
3416 C
3417 INTEGER nuaer, ntraer
3418 C ------------------------------------------------------------------
3419 C* COMPUTES PLANCK FUNCTIONS:
3420 CALL LWB(PDT0,PTAVE,PTL,
3421 S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
3422 S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
3423 C ------------------------------------------------------------------
3424 C* PERFORMS THE VERTICAL INTEGRATION:
3425 NUAER = NUA
3426 NTRAER = NTRA
3427 CALL LWV(NUAER,NTRAER, KLIM
3428 R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
3429 R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
3430 S , PCNTRB,PCTS,PFLUC)
3431 C ------------------------------------------------------------------
3432 RETURN
3433 END
3434 SUBROUTINE LWC(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
3435 R PBINT,PBSUIN,PCTS,PCNTRB,
3436 S PFLUX)
3437 use dimens_m
3438 use dimphy
3439 use raddim
3440 use radepsi
3441 use radopt
3442 IMPLICIT none
3443 C
3444 C PURPOSE.
3445 C --------
3446 C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
3447 C RADIANCES
3448 C
3449 C EXPLICIT ARGUMENTS :
3450 C --------------------
3451 C ==== INPUTS ===
3452 C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION
3453 C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3454 C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION
3455 C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION
3456 C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
3457 C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE
3458 C PEMIS : (KDLON) ; SURFACE EMISSIVITY
3459 C PFLUC
3460 C ==== OUTPUTS ===
3461 C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES :
3462 C 1 ==> UPWARD FLUX TOTAL
3463 C 2 ==> DOWNWARD FLUX TOTAL
3464 C
3465 C METHOD.
3466 C -------
3467 C
3468 C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
3469 C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
3470 C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
3471 C CLOUDS
3472 C
3473 C REFERENCE.
3474 C ----------
3475 C
3476 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3477 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3478 C
3479 C AUTHOR.
3480 C -------
3481 C JEAN-JACQUES MORCRETTE *ECMWF*
3482 C
3483 C MODIFICATIONS.
3484 C --------------
3485 C ORIGINAL : 89-07-14
3486 C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96
3487 C-----------------------------------------------------------------------
3488 C* ARGUMENTS:
3489 INTEGER klim
3490 REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
3491 REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3492 REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3493 REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
3494 REAL*8 PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE
3495 c
3496 REAL*8 PCLDLD(KDLON,KFLEV)
3497 REAL*8 PCLDLU(KDLON,KFLEV)
3498 REAL*8 PEMIS(KDLON)
3499 C
3500 REAL*8 PFLUX(KDLON,2,KFLEV+1)
3501 C-----------------------------------------------------------------------
3502 C* LOCAL VARIABLES:
3503 INTEGER IMX(KDLON), IMXP(KDLON)
3504 C
3505 REAL*8 ZCLEAR(KDLON),ZCLOUD(KDLON),ZDNF(KDLON,KFLEV+1,KFLEV+1)
3506 S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
3507 S , ZUPF(KDLON,KFLEV+1,KFLEV+1)
3508 REAL*8 ZCLM(KDLON,KFLEV+1,KFLEV+1)
3509 C
3510 INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
3511 INTEGER jk1, jk2, jkc, jkcp1, jcloud
3512 INTEGER imxm1, imxp1
3513 REAL*8 zcfrac
3514 C ------------------------------------------------------------------
3515 C
3516 C* 1. INITIALIZATION
3517 C --------------
3518 C
3519 100 CONTINUE
3520 C
3521 IMAXC = 0
3522 C
3523 DO 101 JL = 1, KDLON
3524 IMX(JL)=0
3525 IMXP(JL)=0
3526 ZCLOUD(JL) = 0.
3527 101 CONTINUE
3528 C
3529 C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
3530 C -------------------------------------------
3531 C
3532 110 CONTINUE
3533 C
3534 DO 112 JK = 1 , KFLEV
3535 DO 111 JL = 1, KDLON
3536 IMX1=IMX(JL)
3537 IMX2=JK
3538 IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
3539 IMXP(JL)=IMX2
3540 ELSE
3541 IMXP(JL)=IMX1
3542 END IF
3543 IMAXC=MAX(IMXP(JL),IMAXC)
3544 IMX(JL)=IMXP(JL)
3545 111 CONTINUE
3546 112 CONTINUE
3547 CGM*******
3548 IMAXC=KFLEV
3549 CGM*******
3550 C
3551 DO 114 JK = 1 , KFLEV+1
3552 DO 113 JL = 1, KDLON
3553 PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
3554 PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
3555 113 CONTINUE
3556 114 CONTINUE
3557 C
3558 C ------------------------------------------------------------------
3559 C
3560 C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
3561 C ---------------------------------------
3562 C
3563 IF (IMAXC.GT.0) THEN
3564 C
3565 IMXP1 = IMAXC + 1
3566 IMXM1 = IMAXC - 1
3567 C
3568 C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES
3569 C ------------------------------
3570 C
3571 200 CONTINUE
3572 C
3573 DO 203 JK1=1,KFLEV+1
3574 DO 202 JK2=1,KFLEV+1
3575 DO 201 JL = 1, KDLON
3576 ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
3577 ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
3578 201 CONTINUE
3579 202 CONTINUE
3580 203 CONTINUE
3581 C
3582 C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
3583 C ----------------------------------------------
3584 C
3585 210 CONTINUE
3586 C
3587 DO 213 JKC = 1 , IMAXC
3588 JCLOUD=JKC
3589 JKCP1=JCLOUD+1
3590 C
3591 C* 2.1.1 ABOVE THE CLOUD
3592 C ---------------
3593 C
3594 2110 CONTINUE
3595 C
3596 DO 2115 JK=JKCP1,KFLEV+1
3597 JKM1=JK-1
3598 DO 2111 JL = 1, KDLON
3599 ZFU(JL)=0.
3600 2111 CONTINUE
3601 IF (JK .GT. JKCP1) THEN
3602 DO 2113 JKJ=JKCP1,JKM1
3603 DO 2112 JL = 1, KDLON
3604 ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
3605 2112 CONTINUE
3606 2113 CONTINUE
3607 END IF
3608 C
3609 DO 2114 JL = 1, KDLON
3610 ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
3611 2114 CONTINUE
3612 2115 CONTINUE
3613 C
3614 C* 2.1.2 BELOW THE CLOUD
3615 C ---------------
3616 C
3617 2120 CONTINUE
3618 C
3619 DO 2125 JK=1,JCLOUD
3620 JKP1=JK+1
3621 DO 2121 JL = 1, KDLON
3622 ZFD(JL)=0.
3623 2121 CONTINUE
3624 C
3625 IF (JK .LT. JCLOUD) THEN
3626 DO 2123 JKJ=JKP1,JCLOUD
3627 DO 2122 JL = 1, KDLON
3628 ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
3629 2122 CONTINUE
3630 2123 CONTINUE
3631 END IF
3632 DO 2124 JL = 1, KDLON
3633 ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
3634 2124 CONTINUE
3635 2125 CONTINUE
3636 C
3637 213 CONTINUE
3638 C
3639 C
3640 C* 2.2 CLOUD COVER MATRIX
3641 C ------------------
3642 C
3643 C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
3644 C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
3645 C
3646 220 CONTINUE
3647 C
3648 DO 223 JK1 = 1 , KFLEV+1
3649 DO 222 JK2 = 1 , KFLEV+1
3650 DO 221 JL = 1, KDLON
3651 ZCLM(JL,JK1,JK2) = 0.
3652 221 CONTINUE
3653 222 CONTINUE
3654 223 CONTINUE
3655 C
3656 C
3657 C
3658 C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION
3659 C ------------------------------------------
3660 C
3661 240 CONTINUE
3662 C
3663 DO 244 JK1 = 2 , KFLEV+1
3664 DO 241 JL = 1, KDLON
3665 ZCLEAR(JL)=1.
3666 ZCLOUD(JL)=0.
3667 241 CONTINUE
3668 DO 243 JK = JK1 - 1 , 1 , -1
3669 DO 242 JL = 1, KDLON
3670 IF (NOVLP.EQ.1) THEN
3671 c* maximum-random
3672 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
3673 * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3674 ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3675 ZCLOUD(JL) = PCLDLU(JL,JK)
3676 ELSE IF (NOVLP.EQ.2) THEN
3677 c* maximum
3678 ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
3679 ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3680 ELSE IF (NOVLP.EQ.3) THEN
3681 c* random
3682 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
3683 ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3684 ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3685 END IF
3686 242 CONTINUE
3687 243 CONTINUE
3688 244 CONTINUE
3689 C
3690 C
3691 C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION
3692 C ------------------------------------------
3693 C
3694 250 CONTINUE
3695 C
3696 DO 254 JK1 = 1 , KFLEV
3697 DO 251 JL = 1, KDLON
3698 ZCLEAR(JL)=1.
3699 ZCLOUD(JL)=0.
3700 251 CONTINUE
3701 DO 253 JK = JK1 , KFLEV
3702 DO 252 JL = 1, KDLON
3703 IF (NOVLP.EQ.1) THEN
3704 c* maximum-random
3705 ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
3706 * /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3707 ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3708 ZCLOUD(JL) = PCLDLD(JL,JK)
3709 ELSE IF (NOVLP.EQ.2) THEN
3710 c* maximum
3711 ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
3712 ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3713 ELSE IF (NOVLP.EQ.3) THEN
3714 c* random
3715 ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
3716 ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3717 ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3718 END IF
3719 252 CONTINUE
3720 253 CONTINUE
3721 254 CONTINUE
3722 C
3723 C
3724 C
3725 C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
3726 C ----------------------------------------------
3727 C
3728 300 CONTINUE
3729 C
3730 C* 3.1 DOWNWARD FLUXES
3731 C ---------------
3732 C
3733 310 CONTINUE
3734 C
3735 DO 311 JL = 1, KDLON
3736 PFLUX(JL,2,KFLEV+1) = 0.
3737 311 CONTINUE
3738 C
3739 DO 317 JK1 = KFLEV , 1 , -1
3740 C
3741 C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3742 C
3743 DO 312 JL = 1, KDLON
3744 ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
3745 312 CONTINUE
3746 C
3747 C* CONTRIBUTION FROM ADJACENT CLOUD
3748 C
3749 DO 313 JL = 1, KDLON
3750 ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
3751 313 CONTINUE
3752 C
3753 C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3754 C
3755 DO 315 JK = KFLEV-1 , JK1 , -1
3756 DO 314 JL = 1, KDLON
3757 ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
3758 ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
3759 314 CONTINUE
3760 315 CONTINUE
3761 C
3762 DO 316 JL = 1, KDLON
3763 PFLUX(JL,2,JK1) = ZFD (JL)
3764 316 CONTINUE
3765 C
3766 317 CONTINUE
3767 C
3768 C
3769 C
3770 C
3771 C* 3.2 UPWARD FLUX AT THE SURFACE
3772 C --------------------------
3773 C
3774 320 CONTINUE
3775 C
3776 DO 321 JL = 1, KDLON
3777 PFLUX(JL,1,1) = PEMIS(JL)*PBSUIN(JL)-(1.-PEMIS(JL))*PFLUX(JL,2,1)
3778 321 CONTINUE
3779 C
3780 C
3781 C
3782 C* 3.3 UPWARD FLUXES
3783 C -------------
3784 C
3785 330 CONTINUE
3786 C
3787 DO 337 JK1 = 2 , KFLEV+1
3788 C
3789 C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3790 C
3791 DO 332 JL = 1, KDLON
3792 ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
3793 332 CONTINUE
3794 C
3795 C* CONTRIBUTION FROM ADJACENT CLOUD
3796 C
3797 DO 333 JL = 1, KDLON
3798 ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
3799 333 CONTINUE
3800 C
3801 C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3802 C
3803 DO 335 JK = 2 , JK1-1
3804 DO 334 JL = 1, KDLON
3805 ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
3806 ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1)
3807 334 CONTINUE
3808 335 CONTINUE
3809 C
3810 DO 336 JL = 1, KDLON
3811 PFLUX(JL,1,JK1) = ZFU (JL)
3812 336 CONTINUE
3813 C
3814 337 CONTINUE
3815 C
3816 C
3817 END IF
3818 C
3819 C
3820 C* 2.3 END OF CLOUD EFFECT COMPUTATIONS
3821 C
3822 230 CONTINUE
3823 C
3824 IF (.NOT.LEVOIGT) THEN
3825 DO 231 JL = 1, KDLON
3826 ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
3827 231 CONTINUE
3828 DO 233 JK = KLIM+1 , KFLEV+1
3829 DO 232 JL = 1, KDLON
3830 ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
3831 PFLUX(JL,1,JK) = ZFN10(JL)
3832 PFLUX(JL,2,JK) = 0.0
3833 232 CONTINUE
3834 233 CONTINUE
3835 ENDIF
3836 C
3837 RETURN
3838 END
3839 SUBROUTINE LWB(PDT0,PTAVE,PTL
3840 S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
3841 S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
3842 use dimens_m
3843 use dimphy
3844 use raddim
3845 use raddimlw
3846 IMPLICIT none
3847 C
3848 C-----------------------------------------------------------------------
3849 C PURPOSE.
3850 C --------
3851 C COMPUTES PLANCK FUNCTIONS
3852 C
3853 C EXPLICIT ARGUMENTS :
3854 C --------------------
3855 C ==== INPUTS ===
3856 C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY
3857 C PTAVE : (KDLON,KFLEV) ; TEMPERATURE
3858 C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE
3859 C ==== OUTPUTS ===
3860 C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
3861 C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION
3862 C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3863 C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION
3864 C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION
3865 C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
3866 C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3867 C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3868 C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS
3869 C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS
3870 C
3871 C IMPLICIT ARGUMENTS : NONE
3872 C --------------------
3873 C
3874 C METHOD.
3875 C -------
3876 C
3877 C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
3878 C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
3879 C
3880 C REFERENCE.
3881 C ----------
3882 C
3883 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3884 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS "
3885 C
3886 C AUTHOR.
3887 C -------
3888 C JEAN-JACQUES MORCRETTE *ECMWF*
3889 C
3890 C MODIFICATIONS.
3891 C --------------
3892 C ORIGINAL : 89-07-14
3893 C
3894 C-----------------------------------------------------------------------
3895 C
3896 C ARGUMENTS:
3897 C
3898 REAL*8 PDT0(KDLON)
3899 REAL*8 PTAVE(KDLON,KFLEV)
3900 REAL*8 PTL(KDLON,KFLEV+1)
3901 C
3902 REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
3903 REAL*8 PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3904 REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3905 REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
3906 REAL*8 PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
3907 REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
3908 REAL*8 PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3909 REAL*8 PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3910 REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3911 REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3912 REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3913 REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3914 C
3915 C-------------------------------------------------------------------------
3916 C* LOCAL VARIABLES:
3917 INTEGER INDB(KDLON),INDS(KDLON)
3918 REAL*8 ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
3919 REAL*8 ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
3920 c
3921 INTEGER jk, jl, ic, jnu, jf, jg
3922 INTEGER jk1, jk2
3923 INTEGER k, j, ixtox, indto, ixtx, indt
3924 INTEGER indsu, indtp
3925 REAL*8 zdsto1, zdstox, zdst1, zdstx
3926 c
3927 C* Quelques parametres:
3928 REAL*8 TSTAND
3929 PARAMETER (TSTAND=250.0)
3930 REAL*8 TSTP
3931 PARAMETER (TSTP=12.5)
3932 INTEGER MXIXT
3933 PARAMETER (MXIXT=10)
3934 C
3935 C* Used Data Block:
3936 REAL*8 TINTP(11)
3937 SAVE TINTP
3938 REAL*8 GA(11,16,3), GB(11,16,3)
3939 SAVE GA, GB
3940 REAL*8 XP(6,6)
3941 SAVE XP
3942 c
3943 DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
3944 S 262.5, 275., 287.5, 300., 312.5 /
3945 C-----------------------------------------------------------------------
3946 C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
3947 C
3948 C
3949 C
3950 C
3951 C-- R.D. -- G = - 0.2 SLA
3952 C
3953 C
3954 C----- INTERVAL = 1 ----- T = 187.5
3955 C
3956 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3957 DATA (GA( 1, 1,IC),IC=1,3) /
3958 S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
3959 DATA (GB( 1, 1,IC),IC=1,3) /
3960 S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
3961 DATA (GA( 1, 2,IC),IC=1,3) /
3962 S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
3963 DATA (GB( 1, 2,IC),IC=1,3) /
3964 S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
3965 C
3966 C----- INTERVAL = 1 ----- T = 200.0
3967 C
3968 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3969 DATA (GA( 2, 1,IC),IC=1,3) /
3970 S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
3971 DATA (GB( 2, 1,IC),IC=1,3) /
3972 S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
3973 DATA (GA( 2, 2,IC),IC=1,3) /
3974 S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
3975 DATA (GB( 2, 2,IC),IC=1,3) /
3976 S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
3977 C
3978 C----- INTERVAL = 1 ----- T = 212.5
3979 C
3980 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3981 DATA (GA( 3, 1,IC),IC=1,3) /
3982 S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
3983 DATA (GB( 3, 1,IC),IC=1,3) /
3984 S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
3985 DATA (GA( 3, 2,IC),IC=1,3) /
3986 S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
3987 DATA (GB( 3, 2,IC),IC=1,3) /
3988 S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
3989 C
3990 C----- INTERVAL = 1 ----- T = 225.0
3991 C
3992 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3993 DATA (GA( 4, 1,IC),IC=1,3) /
3994 S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
3995 DATA (GB( 4, 1,IC),IC=1,3) /
3996 S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
3997 DATA (GA( 4, 2,IC),IC=1,3) /
3998 S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
3999 DATA (GB( 4, 2,IC),IC=1,3) /
4000 S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
4001 C
4002 C----- INTERVAL = 1 ----- T = 237.5
4003 C
4004 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4005 DATA (GA( 5, 1,IC),IC=1,3) /
4006 S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
4007 DATA (GB( 5, 1,IC),IC=1,3) /
4008 S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
4009 DATA (GA( 5, 2,IC),IC=1,3) /
4010 S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
4011 DATA (GB( 5, 2,IC),IC=1,3) /
4012 S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
4013 C
4014 C----- INTERVAL = 1 ----- T = 250.0
4015 C
4016 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4017 DATA (GA( 6, 1,IC),IC=1,3) /
4018 S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
4019 DATA (GB( 6, 1,IC),IC=1,3) /
4020 S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
4021 DATA (GA( 6, 2,IC),IC=1,3) /
4022 S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
4023 DATA (GB( 6, 2,IC),IC=1,3) /
4024 S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
4025 C
4026 C----- INTERVAL = 1 ----- T = 262.5
4027 C
4028 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4029 DATA (GA( 7, 1,IC),IC=1,3) /
4030 S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
4031 DATA (GB( 7, 1,IC),IC=1,3) /
4032 S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
4033 DATA (GA( 7, 2,IC),IC=1,3) /
4034 S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
4035 DATA (GB( 7, 2,IC),IC=1,3) /
4036 S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
4037 C
4038 C----- INTERVAL = 1 ----- T = 275.0
4039 C
4040 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4041 DATA (GA( 8, 1,IC),IC=1,3) /
4042 S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
4043 DATA (GB( 8, 1,IC),IC=1,3) /
4044 S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
4045 DATA (GA( 8, 2,IC),IC=1,3) /
4046 S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
4047 DATA (GB( 8, 2,IC),IC=1,3) /
4048 S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
4049 C
4050 C----- INTERVAL = 1 ----- T = 287.5
4051 C
4052 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4053 DATA (GA( 9, 1,IC),IC=1,3) /
4054 S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
4055 DATA (GB( 9, 1,IC),IC=1,3) /
4056 S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
4057 DATA (GA( 9, 2,IC),IC=1,3) /
4058 S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
4059 DATA (GB( 9, 2,IC),IC=1,3) /
4060 S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
4061 C
4062 C----- INTERVAL = 1 ----- T = 300.0
4063 C
4064 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4065 DATA (GA(10, 1,IC),IC=1,3) /
4066 S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
4067 DATA (GB(10, 1,IC),IC=1,3) /
4068 S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
4069 DATA (GA(10, 2,IC),IC=1,3) /
4070 S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
4071 DATA (GB(10, 2,IC),IC=1,3) /
4072 S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
4073 C
4074 C----- INTERVAL = 1 ----- T = 312.5
4075 C
4076 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4077 DATA (GA(11, 1,IC),IC=1,3) /
4078 S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
4079 DATA (GB(11, 1,IC),IC=1,3) /
4080 S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
4081 DATA (GA(11, 2,IC),IC=1,3) /
4082 S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
4083 DATA (GB(11, 2,IC),IC=1,3) /
4084 S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
4085 C
4086 C
4087 C
4088 C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
4089 C
4090 C
4091 C
4092 C
4093 C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U )
4094 C
4095 C
4096 C----- INTERVAL = 2 ----- T = 187.5
4097 C
4098 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4099 DATA (GA( 1, 3,IC),IC=1,3) /
4100 S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
4101 DATA (GB( 1, 3,IC),IC=1,3) /
4102 S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
4103 DATA (GA( 1, 4,IC),IC=1,3) /
4104 S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
4105 DATA (GB( 1, 4,IC),IC=1,3) /
4106 S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
4107 C
4108 C----- INTERVAL = 2 ----- T = 200.0
4109 C
4110 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4111 DATA (GA( 2, 3,IC),IC=1,3) /
4112 S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
4113 DATA (GB( 2, 3,IC),IC=1,3) /
4114 S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
4115 DATA (GA( 2, 4,IC),IC=1,3) /
4116 S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
4117 DATA (GB( 2, 4,IC),IC=1,3) /
4118 S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
4119 C
4120 C----- INTERVAL = 2 ----- T = 212.5
4121 C
4122 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4123 DATA (GA( 3, 3,IC),IC=1,3) /
4124 S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
4125 DATA (GB( 3, 3,IC),IC=1,3) /
4126 S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
4127 DATA (GA( 3, 4,IC),IC=1,3) /
4128 S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
4129 DATA (GB( 3, 4,IC),IC=1,3) /
4130 S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
4131 C
4132 C----- INTERVAL = 2 ----- T = 225.0
4133 C
4134 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4135 DATA (GA( 4, 3,IC),IC=1,3) /
4136 S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
4137 DATA (GB( 4, 3,IC),IC=1,3) /
4138 S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
4139 DATA (GA( 4, 4,IC),IC=1,3) /
4140 S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
4141 DATA (GB( 4, 4,IC),IC=1,3) /
4142 S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
4143 C
4144 C----- INTERVAL = 2 ----- T = 237.5
4145 C
4146 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4147 DATA (GA( 5, 3,IC),IC=1,3) /
4148 S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
4149 DATA (GB( 5, 3,IC),IC=1,3) /
4150 S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
4151 DATA (GA( 5, 4,IC),IC=1,3) /
4152 S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
4153 DATA (GB( 5, 4,IC),IC=1,3) /
4154 S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
4155 C
4156 C----- INTERVAL = 2 ----- T = 250.0
4157 C
4158 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4159 DATA (GA( 6, 3,IC),IC=1,3) /
4160 S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
4161 DATA (GB( 6, 3,IC),IC=1,3) /
4162 S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
4163 DATA (GA( 6, 4,IC),IC=1,3) /
4164 S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
4165 DATA (GB( 6, 4,IC),IC=1,3) /
4166 S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
4167 C
4168 C----- INTERVAL = 2 ----- T = 262.5
4169 C
4170 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4171 DATA (GA( 7, 3,IC),IC=1,3) /
4172 S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
4173 DATA (GB( 7, 3,IC),IC=1,3) /
4174 S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
4175 DATA (GA( 7, 4,IC),IC=1,3) /
4176 S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
4177 DATA (GB( 7, 4,IC),IC=1,3) /
4178 S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
4179 C
4180 C----- INTERVAL = 2 ----- T = 275.0
4181 C
4182 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4183 DATA (GA( 8, 3,IC),IC=1,3) /
4184 S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
4185 DATA (GB( 8, 3,IC),IC=1,3) /
4186 S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
4187 DATA (GA( 8, 4,IC),IC=1,3) /
4188 S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
4189 DATA (GB( 8, 4,IC),IC=1,3) /
4190 S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
4191 C
4192 C----- INTERVAL = 2 ----- T = 287.5
4193 C
4194 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4195 DATA (GA( 9, 3,IC),IC=1,3) /
4196 S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
4197 DATA (GB( 9, 3,IC),IC=1,3) /
4198 S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
4199 DATA (GA( 9, 4,IC),IC=1,3) /
4200 S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
4201 DATA (GB( 9, 4,IC),IC=1,3) /
4202 S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
4203 C
4204 C----- INTERVAL = 2 ----- T = 300.0
4205 C
4206 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4207 DATA (GA(10, 3,IC),IC=1,3) /
4208 S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
4209 DATA (GB(10, 3,IC),IC=1,3) /
4210 S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
4211 DATA (GA(10, 4,IC),IC=1,3) /
4212 S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
4213 DATA (GB(10, 4,IC),IC=1,3) /
4214 S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
4215 C
4216 C----- INTERVAL = 2 ----- T = 312.5
4217 C
4218 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4219 DATA (GA(11, 3,IC),IC=1,3) /
4220 S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
4221 DATA (GB(11, 3,IC),IC=1,3) /
4222 S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
4223 DATA (GA(11, 4,IC),IC=1,3) /
4224 S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
4225 DATA (GB(11, 4,IC),IC=1,3) /
4226 S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
4227 C
4228 C
4229 C
4230 C
4231 C
4232 C
4233 C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
4234 C
4235 C
4236 C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
4237 C
4238 C
4239 C
4240 C--- G = 3.875E-03 ---------------
4241 C
4242 C----- INTERVAL = 3 ----- T = 187.5
4243 C
4244 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4245 DATA (GA( 1, 7,IC),IC=1,3) /
4246 S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
4247 DATA (GB( 1, 7,IC),IC=1,3) /
4248 S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
4249 DATA (GA( 1, 8,IC),IC=1,3) /
4250 S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
4251 DATA (GB( 1, 8,IC),IC=1,3) /
4252 S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
4253 C
4254 C----- INTERVAL = 3 ----- T = 200.0
4255 C
4256 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4257 DATA (GA( 2, 7,IC),IC=1,3) /
4258 S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
4259 DATA (GB( 2, 7,IC),IC=1,3) /
4260 S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
4261 DATA (GA( 2, 8,IC),IC=1,3) /
4262 S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
4263 DATA (GB( 2, 8,IC),IC=1,3) /
4264 S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
4265 C
4266 C----- INTERVAL = 3 ----- T = 212.5
4267 C
4268 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4269 DATA (GA( 3, 7,IC),IC=1,3) /
4270 S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
4271 DATA (GB( 3, 7,IC),IC=1,3) /
4272 S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
4273 DATA (GA( 3, 8,IC),IC=1,3) /
4274 S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
4275 DATA (GB( 3, 8,IC),IC=1,3) /
4276 S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
4277 C
4278 C----- INTERVAL = 3 ----- T = 225.0
4279 C
4280 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4281 DATA (GA( 4, 7,IC),IC=1,3) /
4282 S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
4283 DATA (GB( 4, 7,IC),IC=1,3) /
4284 S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
4285 DATA (GA( 4, 8,IC),IC=1,3) /
4286 S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
4287 DATA (GB( 4, 8,IC),IC=1,3) /
4288 S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
4289 C
4290 C----- INTERVAL = 3 ----- T = 237.5
4291 C
4292 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4293 DATA (GA( 5, 7,IC),IC=1,3) /
4294 S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
4295 DATA (GB( 5, 7,IC),IC=1,3) /
4296 S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
4297 DATA (GA( 5, 8,IC),IC=1,3) /
4298 S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
4299 DATA (GB( 5, 8,IC),IC=1,3) /
4300 S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
4301 C
4302 C----- INTERVAL = 3 ----- T = 250.0
4303 C
4304 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4305 DATA (GA( 6, 7,IC),IC=1,3) /
4306 S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
4307 DATA (GB( 6, 7,IC),IC=1,3) /
4308 S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
4309 DATA (GA( 6, 8,IC),IC=1,3) /
4310 S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
4311 DATA (GB( 6, 8,IC),IC=1,3) /
4312 S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
4313 C
4314 C----- INTERVAL = 3 ----- T = 262.5
4315 C
4316 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4317 DATA (GA( 7, 7,IC),IC=1,3) /
4318 S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
4319 DATA (GB( 7, 7,IC),IC=1,3) /
4320 S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
4321 DATA (GA( 7, 8,IC),IC=1,3) /
4322 S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
4323 DATA (GB( 7, 8,IC),IC=1,3) /
4324 S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
4325 C
4326 C----- INTERVAL = 3 ----- T = 275.0
4327 C
4328 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4329 DATA (GA( 8, 7,IC),IC=1,3) /
4330 S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
4331 DATA (GB( 8, 7,IC),IC=1,3) /
4332 S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
4333 DATA (GA( 8, 8,IC),IC=1,3) /
4334 S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
4335 DATA (GB( 8, 8,IC),IC=1,3) /
4336 S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
4337 C
4338 C----- INTERVAL = 3 ----- T = 287.5
4339 C
4340 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4341 DATA (GA( 9, 7,IC),IC=1,3) /
4342 S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
4343 DATA (GB( 9, 7,IC),IC=1,3) /
4344 S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
4345 DATA (GA( 9, 8,IC),IC=1,3) /
4346 S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
4347 DATA (GB( 9, 8,IC),IC=1,3) /
4348 S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
4349 C
4350 C----- INTERVAL = 3 ----- T = 300.0
4351 C
4352 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4353 DATA (GA(10, 7,IC),IC=1,3) /
4354 S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
4355 DATA (GB(10, 7,IC),IC=1,3) /
4356 S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
4357 DATA (GA(10, 8,IC),IC=1,3) /
4358 S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
4359 DATA (GB(10, 8,IC),IC=1,3) /
4360 S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
4361 C
4362 C----- INTERVAL = 3 ----- T = 312.5
4363 C
4364 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4365 DATA (GA(11, 7,IC),IC=1,3) /
4366 S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
4367 DATA (GB(11, 7,IC),IC=1,3) /
4368 S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
4369 DATA (GA(11, 8,IC),IC=1,3) /
4370 S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
4371 DATA (GB(11, 8,IC),IC=1,3) /
4372 S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
4373 C
4374 C
4375 C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
4376 C
4377 C-- G = 3.6E-03
4378 C
4379 C----- INTERVAL = 4 ----- T = 187.5
4380 C
4381 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4382 DATA (GA( 1, 9,IC),IC=1,3) /
4383 S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
4384 DATA (GB( 1, 9,IC),IC=1,3) /
4385 S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
4386 DATA (GA( 1,10,IC),IC=1,3) /
4387 S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
4388 DATA (GB( 1,10,IC),IC=1,3) /
4389 S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
4390 C
4391 C----- INTERVAL = 4 ----- T = 200.0
4392 C
4393 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4394 DATA (GA( 2, 9,IC),IC=1,3) /
4395 S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
4396 DATA (GB( 2, 9,IC),IC=1,3) /
4397 S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
4398 DATA (GA( 2,10,IC),IC=1,3) /
4399 S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
4400 DATA (GB( 2,10,IC),IC=1,3) /
4401 S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
4402 C
4403 C----- INTERVAL = 4 ----- T = 212.5
4404 C
4405 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4406 DATA (GA( 3, 9,IC),IC=1,3) /
4407 S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
4408 DATA (GB( 3, 9,IC),IC=1,3) /
4409 S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
4410 DATA (GA( 3,10,IC),IC=1,3) /
4411 S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
4412 DATA (GB( 3,10,IC),IC=1,3) /
4413 S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
4414 C
4415 C----- INTERVAL = 4 ----- T = 225.0
4416 C
4417 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4418 DATA (GA( 4, 9,IC),IC=1,3) /
4419 S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
4420 DATA (GB( 4, 9,IC),IC=1,3) /
4421 S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
4422 DATA (GA( 4,10,IC),IC=1,3) /
4423 S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
4424 DATA (GB( 4,10,IC),IC=1,3) /
4425 S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
4426 C
4427 C----- INTERVAL = 4 ----- T = 237.5
4428 C
4429 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4430 DATA (GA( 5, 9,IC),IC=1,3) /
4431 S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
4432 DATA (GB( 5, 9,IC),IC=1,3) /
4433 S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
4434 DATA (GA( 5,10,IC),IC=1,3) /
4435 S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
4436 DATA (GB( 5,10,IC),IC=1,3) /
4437 S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
4438 C
4439 C----- INTERVAL = 4 ----- T = 250.0
4440 C
4441 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4442 DATA (GA( 6, 9,IC),IC=1,3) /
4443 S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
4444 DATA (GB( 6, 9,IC),IC=1,3) /
4445 S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
4446 DATA (GA( 6,10,IC),IC=1,3) /
4447 S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
4448 DATA (GB( 6,10,IC),IC=1,3) /
4449 S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
4450 C
4451 C----- INTERVAL = 4 ----- T = 262.5
4452 C
4453 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4454 DATA (GA( 7, 9,IC),IC=1,3) /
4455 S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
4456 DATA (GB( 7, 9,IC),IC=1,3) /
4457 S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
4458 DATA (GA( 7,10,IC),IC=1,3) /
4459 S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
4460 DATA (GB( 7,10,IC),IC=1,3) /
4461 S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
4462 C
4463 C----- INTERVAL = 4 ----- T = 275.0
4464 C
4465 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4466 DATA (GA( 8, 9,IC),IC=1,3) /
4467 S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
4468 DATA (GB( 8, 9,IC),IC=1,3) /
4469 S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
4470 DATA (GA( 8,10,IC),IC=1,3) /
4471 S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
4472 DATA (GB( 8,10,IC),IC=1,3) /
4473 S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
4474 C
4475 C----- INTERVAL = 4 ----- T = 287.5
4476 C
4477 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4478 DATA (GA( 9, 9,IC),IC=1,3) /
4479 S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
4480 DATA (GB( 9, 9,IC),IC=1,3) /
4481 S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
4482 DATA (GA( 9,10,IC),IC=1,3) /
4483 S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
4484 DATA (GB( 9,10,IC),IC=1,3) /
4485 S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
4486 C
4487 C----- INTERVAL = 4 ----- T = 300.0
4488 C
4489 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4490 DATA (GA(10, 9,IC),IC=1,3) /
4491 S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
4492 DATA (GB(10, 9,IC),IC=1,3) /
4493 S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
4494 DATA (GA(10,10,IC),IC=1,3) /
4495 S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
4496 DATA (GB(10,10,IC),IC=1,3) /
4497 S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
4498 C
4499 C----- INTERVAL = 4 ----- T = 312.5
4500 C
4501 C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4502 DATA (GA(11, 9,IC),IC=1,3) /
4503 S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
4504 DATA (GB(11, 9,IC),IC=1,3) /
4505 S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
4506 DATA (GA(11,10,IC),IC=1,3) /
4507 S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
4508 DATA (GB(11,10,IC),IC=1,3) /
4509 S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
4510 C
4511 C
4512 C
4513 C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ----
4514 C
4515 C-- WATER VAPOR --- 350 - 500 CM-1
4516 C
4517 C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
4518 C
4519 C----- INTERVAL = 5 ----- T = 187.5
4520 C
4521 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4522 DATA (GA( 1, 5,IC),IC=1,3) /
4523 S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
4524 DATA (GB( 1, 5,IC),IC=1,3) /
4525 S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
4526 DATA (GA( 1, 6,IC),IC=1,3) /
4527 S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
4528 DATA (GB( 1, 6,IC),IC=1,3) /
4529 S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
4530 C
4531 C----- INTERVAL = 5 ----- T = 200.0
4532 C
4533 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4534 DATA (GA( 2, 5,IC),IC=1,3) /
4535 S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
4536 DATA (GB( 2, 5,IC),IC=1,3) /
4537 S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
4538 DATA (GA( 2, 6,IC),IC=1,3) /
4539 S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
4540 DATA (GB( 2, 6,IC),IC=1,3) /
4541 S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
4542 C
4543 C----- INTERVAL = 5 ----- T = 212.5
4544 C
4545 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4546 DATA (GA( 3, 5,IC),IC=1,3) /
4547 S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
4548 DATA (GB( 3, 5,IC),IC=1,3) /
4549 S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
4550 DATA (GA( 3, 6,IC),IC=1,3) /
4551 S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
4552 DATA (GB( 3, 6,IC),IC=1,3) /
4553 S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
4554 C
4555 C----- INTERVAL = 5 ----- T = 225.0
4556 C
4557 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4558 DATA (GA( 4, 5,IC),IC=1,3) /
4559 S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
4560 DATA (GB( 4, 5,IC),IC=1,3) /
4561 S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
4562 DATA (GA( 4, 6,IC),IC=1,3) /
4563 S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
4564 DATA (GB( 4, 6,IC),IC=1,3) /
4565 S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
4566 C
4567 C----- INTERVAL = 5 ----- T = 237.5
4568 C
4569 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4570 DATA (GA( 5, 5,IC),IC=1,3) /
4571 S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
4572 DATA (GB( 5, 5,IC),IC=1,3) /
4573 S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
4574 DATA (GA( 5, 6,IC),IC=1,3) /
4575 S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
4576 DATA (GB( 5, 6,IC),IC=1,3) /
4577 S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
4578 C
4579 C----- INTERVAL = 5 ----- T = 250.0
4580 C
4581 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4582 DATA (GA( 6, 5,IC),IC=1,3) /
4583 S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
4584 DATA (GB( 6, 5,IC),IC=1,3) /
4585 S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
4586 DATA (GA( 6, 6,IC),IC=1,3) /
4587 S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
4588 DATA (GB( 6, 6,IC),IC=1,3) /
4589 S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
4590 C
4591 C----- INTERVAL = 5 ----- T = 262.5
4592 C
4593 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4594 DATA (GA( 7, 5,IC),IC=1,3) /
4595 S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
4596 DATA (GB( 7, 5,IC),IC=1,3) /
4597 S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
4598 DATA (GA( 7, 6,IC),IC=1,3) /
4599 S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
4600 DATA (GB( 7, 6,IC),IC=1,3) /
4601 S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
4602 C
4603 C----- INTERVAL = 5 ----- T = 275.0
4604 C
4605 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4606 DATA (GA( 8, 5,IC),IC=1,3) /
4607 S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
4608 DATA (GB( 8, 5,IC),IC=1,3) /
4609 S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
4610 DATA (GA( 8, 6,IC),IC=1,3) /
4611 S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
4612 DATA (GB( 8, 6,IC),IC=1,3) /
4613 S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
4614 C
4615 C----- INTERVAL = 5 ----- T = 287.5
4616 C
4617 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4618 DATA (GA( 9, 5,IC),IC=1,3) /
4619 S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
4620 DATA (GB( 9, 5,IC),IC=1,3) /
4621 S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
4622 DATA (GA( 9, 6,IC),IC=1,3) /
4623 S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
4624 DATA (GB( 9, 6,IC),IC=1,3) /
4625 S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
4626 C
4627 C----- INTERVAL = 5 ----- T = 300.0
4628 C
4629 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4630 DATA (GA(10, 5,IC),IC=1,3) /
4631 S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
4632 DATA (GB(10, 5,IC),IC=1,3) /
4633 S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
4634 DATA (GA(10, 6,IC),IC=1,3) /
4635 S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
4636 DATA (GB(10, 6,IC),IC=1,3) /
4637 S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
4638 C
4639 C----- INTERVAL = 5 ----- T = 312.5
4640 C
4641 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4642 DATA (GA(11, 5,IC),IC=1,3) /
4643 S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
4644 DATA (GB(11, 5,IC),IC=1,3) /
4645 S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
4646 DATA (GA(11, 6,IC),IC=1,3) /
4647 S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
4648 DATA (GB(11, 6,IC),IC=1,3) /
4649 S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
4650 C
4651 C
4652 C
4653 C
4654 C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
4655 C--- G = 0.0
4656 C
4657 C
4658 C----- INTERVAL = 6 ----- T = 187.5
4659 C
4660 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4661 DATA (GA( 1,11,IC),IC=1,3) /
4662 S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
4663 DATA (GB( 1,11,IC),IC=1,3) /
4664 S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
4665 DATA (GA( 1,12,IC),IC=1,3) /
4666 S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
4667 DATA (GB( 1,12,IC),IC=1,3) /
4668 S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
4669 C
4670 C----- INTERVAL = 6 ----- T = 200.0
4671 C
4672 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4673 DATA (GA( 2,11,IC),IC=1,3) /
4674 S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
4675 DATA (GB( 2,11,IC),IC=1,3) /
4676 S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
4677 DATA (GA( 2,12,IC),IC=1,3) /
4678 S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
4679 DATA (GB( 2,12,IC),IC=1,3) /
4680 S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
4681 C
4682 C----- INTERVAL = 6 ----- T = 212.5
4683 C
4684 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4685 DATA (GA( 3,11,IC),IC=1,3) /
4686 S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
4687 DATA (GB( 3,11,IC),IC=1,3) /
4688 S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
4689 DATA (GA( 3,12,IC),IC=1,3) /
4690 S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
4691 DATA (GB( 3,12,IC),IC=1,3) /
4692 S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
4693 C
4694 C----- INTERVAL = 6 ----- T = 225.0
4695 C
4696 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4697 DATA (GA( 4,11,IC),IC=1,3) /
4698 S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
4699 DATA (GB( 4,11,IC),IC=1,3) /
4700 S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
4701 DATA (GA( 4,12,IC),IC=1,3) /
4702 S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
4703 DATA (GB( 4,12,IC),IC=1,3) /
4704 S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
4705 C
4706 C----- INTERVAL = 6 ----- T = 237.5
4707 C
4708 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4709 DATA (GA( 5,11,IC),IC=1,3) /
4710 S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
4711 DATA (GB( 5,11,IC),IC=1,3) /
4712 S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
4713 DATA (GA( 5,12,IC),IC=1,3) /
4714 S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
4715 DATA (GB( 5,12,IC),IC=1,3) /
4716 S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
4717 C
4718 C----- INTERVAL = 6 ----- T = 250.0
4719 C
4720 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4721 DATA (GA( 6,11,IC),IC=1,3) /
4722 S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
4723 DATA (GB( 6,11,IC),IC=1,3) /
4724 S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
4725 DATA (GA( 6,12,IC),IC=1,3) /
4726 S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
4727 DATA (GB( 6,12,IC),IC=1,3) /
4728 S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
4729 C
4730 C----- INTERVAL = 6 ----- T = 262.5
4731 C
4732 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4733 DATA (GA( 7,11,IC),IC=1,3) /
4734 S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
4735 DATA (GB( 7,11,IC),IC=1,3) /
4736 S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
4737 DATA (GA( 7,12,IC),IC=1,3) /
4738 S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
4739 DATA (GB( 7,12,IC),IC=1,3) /
4740 S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
4741 C
4742 C----- INTERVAL = 6 ----- T = 275.0
4743 C
4744 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4745 DATA (GA( 8,11,IC),IC=1,3) /
4746 S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
4747 DATA (GB( 8,11,IC),IC=1,3) /
4748 S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
4749 DATA (GA( 8,12,IC),IC=1,3) /
4750 S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
4751 DATA (GB( 8,12,IC),IC=1,3) /
4752 S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
4753 C
4754 C----- INTERVAL = 6 ----- T = 287.5
4755 C
4756 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4757 DATA (GA( 9,11,IC),IC=1,3) /
4758 S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
4759 DATA (GB( 9,11,IC),IC=1,3) /
4760 S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
4761 DATA (GA( 9,12,IC),IC=1,3) /
4762 S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
4763 DATA (GB( 9,12,IC),IC=1,3) /
4764 S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
4765 C
4766 C----- INTERVAL = 6 ----- T = 300.0
4767 C
4768 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4769 DATA (GA(10,11,IC),IC=1,3) /
4770 S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
4771 DATA (GB(10,11,IC),IC=1,3) /
4772 S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
4773 DATA (GA(10,12,IC),IC=1,3) /
4774 S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
4775 DATA (GB(10,12,IC),IC=1,3) /
4776 S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
4777 C
4778 C----- INTERVAL = 6 ----- T = 312.5
4779 C
4780 C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4781 DATA (GA(11,11,IC),IC=1,3) /
4782 S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
4783 DATA (GB(11,11,IC),IC=1,3) /
4784 S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
4785 DATA (GA(11,12,IC),IC=1,3) /
4786 S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
4787 DATA (GB(11,12,IC),IC=1,3) /
4788 S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
4789 C
4790 C
4791 C
4792 C
4793 C
4794 C-- END WATER VAPOR
4795 C
4796 C
4797 C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
4798 C
4799 C
4800 C
4801 C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9
4802 C
4803 C----- INTERVAL = 2 ----- T = 187.5
4804 C
4805 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4806 DATA (GA( 1,13,IC),IC=1,3) /
4807 S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
4808 DATA (GB( 1,13,IC),IC=1,3) /
4809 S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
4810 DATA (GA( 1,14,IC),IC=1,3) /
4811 S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
4812 DATA (GB( 1,14,IC),IC=1,3) /
4813 S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
4814 C
4815 C----- INTERVAL = 2 ----- T = 200.0
4816 C
4817 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4818 DATA (GA( 2,13,IC),IC=1,3) /
4819 S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
4820 DATA (GB( 2,13,IC),IC=1,3) /
4821 S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
4822 DATA (GA( 2,14,IC),IC=1,3) /
4823 S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
4824 DATA (GB( 2,14,IC),IC=1,3) /
4825 S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
4826 C
4827 C----- INTERVAL = 2 ----- T = 212.5
4828 C
4829 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4830 DATA (GA( 3,13,IC),IC=1,3) /
4831 S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
4832 DATA (GB( 3,13,IC),IC=1,3) /
4833 S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
4834 DATA (GA( 3,14,IC),IC=1,3) /
4835 S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
4836 DATA (GB( 3,14,IC),IC=1,3) /
4837 S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
4838 C
4839 C----- INTERVAL = 2 ----- T = 225.0
4840 C
4841 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4842 DATA (GA( 4,13,IC),IC=1,3) /
4843 S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
4844 DATA (GB( 4,13,IC),IC=1,3) /
4845 S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
4846 DATA (GA( 4,14,IC),IC=1,3) /
4847 S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
4848 DATA (GB( 4,14,IC),IC=1,3) /
4849 S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
4850 C
4851 C----- INTERVAL = 2 ----- T = 237.5
4852 C
4853 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4854 DATA (GA( 5,13,IC),IC=1,3) /
4855 S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
4856 DATA (GB( 5,13,IC),IC=1,3) /
4857 S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
4858 DATA (GA( 5,14,IC),IC=1,3) /
4859 S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
4860 DATA (GB( 5,14,IC),IC=1,3) /
4861 S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
4862 C
4863 C----- INTERVAL = 2 ----- T = 250.0
4864 C
4865 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4866 DATA (GA( 6,13,IC),IC=1,3) /
4867 S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
4868 DATA (GB( 6,13,IC),IC=1,3) /
4869 S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
4870 DATA (GA( 6,14,IC),IC=1,3) /
4871 S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
4872 DATA (GB( 6,14,IC),IC=1,3) /
4873 S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
4874 C
4875 C----- INTERVAL = 2 ----- T = 262.5
4876 C
4877 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4878 DATA (GA( 7,13,IC),IC=1,3) /
4879 S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
4880 DATA (GB( 7,13,IC),IC=1,3) /
4881 S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
4882 DATA (GA( 7,14,IC),IC=1,3) /
4883 S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
4884 DATA (GB( 7,14,IC),IC=1,3) /
4885 S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
4886 C
4887 C----- INTERVAL = 2 ----- T = 275.0
4888 C
4889 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4890 DATA (GA( 8,13,IC),IC=1,3) /
4891 S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
4892 DATA (GB( 8,13,IC),IC=1,3) /
4893 S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
4894 DATA (GA( 8,14,IC),IC=1,3) /
4895 S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
4896 DATA (GB( 8,14,IC),IC=1,3) /
4897 S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
4898 C
4899 C----- INTERVAL = 2 ----- T = 287.5
4900 C
4901 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4902 DATA (GA( 9,13,IC),IC=1,3) /
4903 S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
4904 DATA (GB( 9,13,IC),IC=1,3) /
4905 S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
4906 DATA (GA( 9,14,IC),IC=1,3) /
4907 S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
4908 DATA (GB( 9,14,IC),IC=1,3) /
4909 S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
4910 C
4911 C----- INTERVAL = 2 ----- T = 300.0
4912 C
4913 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4914 DATA (GA(10,13,IC),IC=1,3) /
4915 S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
4916 DATA (GB(10,13,IC),IC=1,3) /
4917 S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
4918 DATA (GA(10,14,IC),IC=1,3) /
4919 S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
4920 DATA (GB(10,14,IC),IC=1,3) /
4921 S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
4922 C
4923 C----- INTERVAL = 2 ----- T = 312.5
4924 C
4925 C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4926 DATA (GA(11,13,IC),IC=1,3) /
4927 S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
4928 DATA (GB(11,13,IC),IC=1,3) /
4929 S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
4930 DATA (GA(11,14,IC),IC=1,3) /
4931 S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
4932 DATA (GB(11,14,IC),IC=1,3) /
4933 S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
4934 C
4935 C
4936 C
4937 C
4938 C
4939 C
4940 C
4941 C
4942 C
4943 C
4944 C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
4945 C
4946 C
4947 C-- G = 0.0
4948 C
4949 C
4950 C----- INTERVAL = 4 ----- T = 187.5
4951 C
4952 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4953 DATA (GA( 1,15,IC),IC=1,3) /
4954 S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
4955 DATA (GB( 1,15,IC),IC=1,3) /
4956 S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
4957 DATA (GA( 1,16,IC),IC=1,3) /
4958 S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
4959 DATA (GB( 1,16,IC),IC=1,3) /
4960 S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
4961 C
4962 C----- INTERVAL = 4 ----- T = 200.0
4963 C
4964 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4965 DATA (GA( 2,15,IC),IC=1,3) /
4966 S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
4967 DATA (GB( 2,15,IC),IC=1,3) /
4968 S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
4969 DATA (GA( 2,16,IC),IC=1,3) /
4970 S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
4971 DATA (GB( 2,16,IC),IC=1,3) /
4972 S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
4973 C
4974 C----- INTERVAL = 4 ----- T = 212.5
4975 C
4976 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4977 DATA (GA( 3,15,IC),IC=1,3) /
4978 S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
4979 DATA (GB( 3,15,IC),IC=1,3) /
4980 S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
4981 DATA (GA( 3,16,IC),IC=1,3) /
4982 S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
4983 DATA (GB( 3,16,IC),IC=1,3) /
4984 S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
4985 C
4986 C----- INTERVAL = 4 ----- T = 225.0
4987 C
4988 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4989 DATA (GA( 4,15,IC),IC=1,3) /
4990 S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
4991 DATA (GB( 4,15,IC),IC=1,3) /
4992 S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
4993 DATA (GA( 4,16,IC),IC=1,3) /
4994 S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
4995 DATA (GB( 4,16,IC),IC=1,3) /
4996 S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
4997 C
4998 C----- INTERVAL = 4 ----- T = 237.5
4999 C
5000 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5001 DATA (GA( 5,15,IC),IC=1,3) /
5002 S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
5003 DATA (GB( 5,15,IC),IC=1,3) /
5004 S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
5005 DATA (GA( 5,16,IC),IC=1,3) /
5006 S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
5007 DATA (GB( 5,16,IC),IC=1,3) /
5008 S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
5009 C
5010 C----- INTERVAL = 4 ----- T = 250.0
5011 C
5012 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5013 DATA (GA( 6,15,IC),IC=1,3) /
5014 S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
5015 DATA (GB( 6,15,IC),IC=1,3) /
5016 S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
5017 DATA (GA( 6,16,IC),IC=1,3) /
5018 S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
5019 DATA (GB( 6,16,IC),IC=1,3) /
5020 S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
5021 C
5022 C----- INTERVAL = 4 ----- T = 262.5
5023 C
5024 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5025 DATA (GA( 7,15,IC),IC=1,3) /
5026 S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
5027 DATA (GB( 7,15,IC),IC=1,3) /
5028 S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
5029 DATA (GA( 7,16,IC),IC=1,3) /
5030 S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
5031 DATA (GB( 7,16,IC),IC=1,3) /
5032 S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
5033 C
5034 C----- INTERVAL = 4 ----- T = 275.0
5035 C
5036 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5037 DATA (GA( 8,15,IC),IC=1,3) /
5038 S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
5039 DATA (GB( 8,15,IC),IC=1,3) /
5040 S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
5041 DATA (GA( 8,16,IC),IC=1,3) /
5042 S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
5043 DATA (GB( 8,16,IC),IC=1,3) /
5044 S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
5045 C
5046 C----- INTERVAL = 4 ----- T = 287.5
5047 C
5048 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5049 DATA (GA( 9,15,IC),IC=1,3) /
5050 S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
5051 DATA (GB( 9,15,IC),IC=1,3) /
5052 S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
5053 DATA (GA( 9,16,IC),IC=1,3) /
5054 S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
5055 DATA (GB( 9,16,IC),IC=1,3) /
5056 S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
5057 C
5058 C----- INTERVAL = 4 ----- T = 300.0
5059 C
5060 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5061 DATA (GA(10,15,IC),IC=1,3) /
5062 S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
5063 DATA (GB(10,15,IC),IC=1,3) /
5064 S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
5065 DATA (GA(10,16,IC),IC=1,3) /
5066 S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
5067 DATA (GB(10,16,IC),IC=1,3) /
5068 S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
5069 C
5070 C----- INTERVAL = 4 ----- T = 312.5
5071 C
5072 C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
5073 DATA (GA(11,15,IC),IC=1,3) /
5074 S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
5075 DATA (GB(11,15,IC),IC=1,3) /
5076 S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
5077 DATA (GA(11,16,IC),IC=1,3) /
5078 S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
5079 DATA (GB(11,16,IC),IC=1,3) /
5080 S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
5081
5082 C ------------------------------------------------------------------
5083 DATA (( XP( J,K),J=1,6), K=1,6) /
5084 S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
5085 S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
5086 S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
5087 S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
5088 S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
5089 S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
5090 S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
5091 S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
5092 S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
5093 S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
5094 S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
5095 S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
5096 C
5097 C
5098 C* 1.0 PLANCK FUNCTIONS AND GRADIENTS
5099 C ------------------------------
5100 C
5101 100 CONTINUE
5102 C
5103 DO 102 JK = 1 , KFLEV+1
5104 DO 101 JL = 1, KDLON
5105 PBINT(JL,JK) = 0.
5106 101 CONTINUE
5107 102 CONTINUE
5108 DO 103 JL = 1, KDLON
5109 PBSUIN(JL) = 0.
5110 103 CONTINUE
5111 C
5112 DO 141 JNU=1,Ninter
5113 C
5114 C
5115 C* 1.1 LEVELS FROM SURFACE TO KFLEV
5116 C ----------------------------
5117 C
5118 110 CONTINUE
5119 C
5120 DO 112 JK = 1 , KFLEV
5121 DO 111 JL = 1, KDLON
5122 ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
5123 ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
5124 S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
5125 S )))))
5126 PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
5127 PB(JL,JNU,JK)= ZRES(JL)
5128 ZBLEV(JL,JK) = ZRES(JL)
5129 ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
5130 ZRES2(JL)=XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
5131 S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
5132 S )))))
5133 ZBLAY(JL,JK) = ZRES2(JL)
5134 111 CONTINUE
5135 112 CONTINUE
5136 C
5137 C
5138 C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE
5139 C ---------------------------------
5140 C
5141 120 CONTINUE
5142 C
5143 DO 121 JL = 1, KDLON
5144 ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
5145 ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
5146 ZRES(JL) = XP(1,JNU)+ZTI(JL)*(XP(2,JNU)+ZTI(JL)*(XP(3,JNU)
5147 S +ZTI(JL)*(XP(4,JNU)+ZTI(JL)*(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
5148 S )))))
5149 ZRES2(JL) = XP(1,JNU)+ZTI2(JL)*(XP(2,JNU)+ZTI2(JL)*(XP(3,JNU)
5150 S +ZTI2(JL)*(XP(4,JNU)+ZTI2(JL)*(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
5151 S )))))
5152 PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
5153 PB(JL,JNU,KFLEV+1)= ZRES(JL)
5154 ZBLEV(JL,KFLEV+1) = ZRES(JL)
5155 PBTOP(JL,JNU) = ZRES(JL)
5156 PBSUR(JL,JNU) = ZRES2(JL)
5157 PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
5158 121 CONTINUE
5159 C
5160 C
5161 C* 1.3 GRADIENTS IN SUB-LAYERS
5162 C -----------------------
5163 C
5164 130 CONTINUE
5165 C
5166 DO 132 JK = 1 , KFLEV
5167 JK2 = 2 * JK
5168 JK1 = JK2 - 1
5169 DO 131 JL = 1, KDLON
5170 PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK)
5171 PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
5172 131 CONTINUE
5173 132 CONTINUE
5174 C
5175 141 CONTINUE
5176 C
5177 C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
5178 C ---------------------------------------------
5179 C
5180 200 CONTINUE
5181 C
5182 C
5183 210 CONTINUE
5184 C
5185 DO 211 JL=1, KDLON
5186 ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
5187 IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
5188 ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
5189 IF (ZDSTOX.LT.0.5) THEN
5190 INDTO=IXTOX
5191 ELSE
5192 INDTO=IXTOX+1
5193 END IF
5194 INDB(JL)=INDTO
5195 ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
5196 IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
5197 ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
5198 IF (ZDSTX.LT.0.5) THEN
5199 INDT=IXTX
5200 ELSE
5201 INDT=IXTX+1
5202 END IF
5203 INDS(JL)=INDT
5204 211 CONTINUE
5205 C
5206 DO 214 JF=1,2
5207 DO 213 JG=1, 8
5208 DO 212 JL=1, KDLON
5209 INDSU=INDS(JL)
5210 PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
5211 PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
5212 INDTP=INDB(JL)
5213 PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
5214 PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
5215 212 CONTINUE
5216 213 CONTINUE
5217 214 CONTINUE
5218 C
5219 220 CONTINUE
5220 C
5221 DO 225 JK=1,KFLEV
5222 DO 221 JL=1, KDLON
5223 ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
5224 IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
5225 ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
5226 IF (ZDSTX.LT.0.5) THEN
5227 INDT=IXTX
5228 ELSE
5229 INDT=IXTX+1
5230 END IF
5231 INDB(JL)=INDT
5232 221 CONTINUE
5233 C
5234 DO 224 JF=1,2
5235 DO 223 JG=1, 8
5236 DO 222 JL=1, KDLON
5237 INDT=INDB(JL)
5238 PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
5239 PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
5240 222 CONTINUE
5241 223 CONTINUE
5242 224 CONTINUE
5243 225 CONTINUE
5244 C
5245 C ------------------------------------------------------------------
5246 C
5247 RETURN
5248 END
5249 SUBROUTINE LWV(KUAER,KTRAER, KLIM
5250 R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
5251 R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5252 S , PCNTRB,PCTS,PFLUC)
5253 use dimens_m
5254 use dimphy
5255 use YOMCST
5256 use raddim
5257 use raddimlw
5258 IMPLICIT none
5259 C
5260 C-----------------------------------------------------------------------
5261 C PURPOSE.
5262 C --------
5263 C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
5264 C FLUXES OR RADIANCES
5265 C
5266 C METHOD.
5267 C -------
5268 C
5269 C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
5270 C CONTRIBUTIONS BY - THE NEARBY LAYERS
5271 C - THE DISTANT LAYERS
5272 C - THE BOUNDARY TERMS
5273 C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
5274 C
5275 C REFERENCE.
5276 C ----------
5277 C
5278 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5279 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5280 C
5281 C AUTHOR.
5282 C -------
5283 C JEAN-JACQUES MORCRETTE *ECMWF*
5284 C
5285 C MODIFICATIONS.
5286 C --------------
5287 C ORIGINAL : 89-07-14
5288 C-----------------------------------------------------------------------
5289 C
5290 C* ARGUMENTS:
5291 INTEGER KUAER,KTRAER, KLIM
5292 C
5293 REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
5294 REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5295 REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5296 REAL*8 PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
5297 REAL*8 PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
5298 REAL*8 PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
5299 REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5300 REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
5301 REAL*8 PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
5302 REAL*8 PTAVE(KDLON,KFLEV) ! TEMPERATURE
5303 REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5304 REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5305 REAL*8 PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
5306 REAL*8 PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
5307 REAL*8 PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
5308 REAL*8 PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
5309 C
5310 REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5311 REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5312 REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5313 C-----------------------------------------------------------------------
5314 C LOCAL VARIABLES:
5315 REAL*8 ZADJD(KDLON,KFLEV+1)
5316 REAL*8 ZADJU(KDLON,KFLEV+1)
5317 REAL*8 ZDBDT(KDLON,Ninter,KFLEV)
5318 REAL*8 ZDISD(KDLON,KFLEV+1)
5319 REAL*8 ZDISU(KDLON,KFLEV+1)
5320 C
5321 INTEGER jk, jl
5322 C-----------------------------------------------------------------------
5323 C
5324 DO 112 JK=1,KFLEV+1
5325 DO 111 JL=1, KDLON
5326 ZADJD(JL,JK)=0.
5327 ZADJU(JL,JK)=0.
5328 ZDISD(JL,JK)=0.
5329 ZDISU(JL,JK)=0.
5330 111 CONTINUE
5331 112 CONTINUE
5332 C
5333 DO 114 JK=1,KFLEV
5334 DO 113 JL=1, KDLON
5335 PCTS(JL,JK)=0.
5336 113 CONTINUE
5337 114 CONTINUE
5338 C
5339 C* CONTRIBUTION FROM ADJACENT LAYERS
5340 C
5341 CALL LWVN(KUAER,KTRAER
5342 R , PABCU,PDBSL,PGA,PGB
5343 S , ZADJD,ZADJU,PCNTRB,ZDBDT)
5344 C* CONTRIBUTION FROM DISTANT LAYERS
5345 C
5346 CALL LWVD(KUAER,KTRAER
5347 R , PABCU,ZDBDT,PGA,PGB
5348 S , PCNTRB,ZDISD,ZDISU)
5349 C
5350 C* EXCHANGE WITH THE BOUNDARIES
5351 C
5352 CALL LWVB(KUAER,KTRAER, KLIM
5353 R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
5354 R , ZDISD,ZDISU,PEMIS,PPMB
5355 R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5356 S , PCTS,PFLUC)
5357 C
5358 C
5359 RETURN
5360 END
5361 SUBROUTINE LWVB(KUAER,KTRAER, KLIM
5362 R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
5363 R , PDISD,PDISU,PEMIS,PPMB
5364 R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5365 S , PCTS,PFLUC)
5366 use dimens_m
5367 use dimphy
5368 use raddim
5369 use radopt
5370 use raddimlw
5371 IMPLICIT none
5372 C
5373 C-----------------------------------------------------------------------
5374 C PURPOSE.
5375 C --------
5376 C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
5377 C INTEGRATION
5378 C
5379 C METHOD.
5380 C -------
5381 C
5382 C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
5383 C ATMOSPHERE
5384 C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
5385 C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
5386 C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
5387 C
5388 C REFERENCE.
5389 C ----------
5390 C
5391 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5392 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5393 C
5394 C AUTHOR.
5395 C -------
5396 C JEAN-JACQUES MORCRETTE *ECMWF*
5397 C
5398 C MODIFICATIONS.
5399 C --------------
5400 C ORIGINAL : 89-07-14
5401 C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
5402 C-----------------------------------------------------------------------
5403 C
5404 C* 0.1 ARGUMENTS
5405 C ---------
5406 C
5407 INTEGER KUAER,KTRAER, KLIM
5408 C
5409 REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
5410 REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5411 REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5412 REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5413 REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5414 REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
5415 REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
5416 REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
5417 REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5418 REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5419 REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
5420 REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
5421 REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5422 REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5423 REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5424 REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5425 REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5426 REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5427 C
5428 REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5429 REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5430 C
5431 C* LOCAL VARIABLES:
5432 C
5433 REAL*8 ZBGND(KDLON)
5434 REAL*8 ZFD(KDLON)
5435 REAL*8 ZFN10(KDLON)
5436 REAL*8 ZFU(KDLON)
5437 REAL*8 ZTT(KDLON,NTRA)
5438 REAL*8 ZTT1(KDLON,NTRA)
5439 REAL*8 ZTT2(KDLON,NTRA)
5440 REAL*8 ZUU(KDLON,NUA)
5441 REAL*8 ZCNSOL(KDLON)
5442 REAL*8 ZCNTOP(KDLON)
5443 C
5444 INTEGER jk, jl, ja
5445 INTEGER jstra, jstru
5446 INTEGER ind1, ind2, ind3, ind4, in, jlim
5447 REAL*8 zctstr
5448 C-----------------------------------------------------------------------
5449 C
5450 C* 1. INITIALIZATION
5451 C --------------
5452 C
5453 100 CONTINUE
5454 C
5455 C
5456 C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5457 C ---------------------------------
5458 C
5459 120 CONTINUE
5460 C
5461 DO 122 JA=1,NTRA
5462 DO 121 JL=1, KDLON
5463 ZTT (JL,JA)=1.0
5464 ZTT1(JL,JA)=1.0
5465 ZTT2(JL,JA)=1.0
5466 121 CONTINUE
5467 122 CONTINUE
5468 C
5469 DO 124 JA=1,NUA
5470 DO 123 JL=1, KDLON
5471 ZUU(JL,JA)=1.0
5472 123 CONTINUE
5473 124 CONTINUE
5474 C
5475 C ------------------------------------------------------------------
5476 C
5477 C* 2. VERTICAL INTEGRATION
5478 C --------------------
5479 C
5480 200 CONTINUE
5481 C
5482 IND1=0
5483 IND3=0
5484 IND4=1
5485 IND2=1
5486 C
5487 C
5488 C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
5489 C -----------------------------------
5490 C
5491 230 CONTINUE
5492 C
5493 DO 235 JK = 1 , KFLEV
5494 IN=(JK-1)*NG1P1+1
5495 C
5496 DO 232 JA=1,KUAER
5497 DO 231 JL=1, KDLON
5498 ZUU(JL,JA)=PABCU(JL,JA,IN)
5499 231 CONTINUE
5500 232 CONTINUE
5501 C
5502 C
5503 CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
5504 C
5505 DO 234 JL = 1, KDLON
5506 ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1) *ZTT(JL,10)
5507 2 +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
5508 3 +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
5509 4 +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
5510 5 +PBTOP(JL,5)*ZTT(JL,3) *ZTT(JL,14)
5511 6 +PBTOP(JL,6)*ZTT(JL,6) *ZTT(JL,15)
5512 ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5513 PFLUC(JL,2,JK)=ZFD(JL)
5514 234 CONTINUE
5515 C
5516 235 CONTINUE
5517 C
5518 JK = KFLEV+1
5519 IN=(JK-1)*NG1P1+1
5520 C
5521 DO 236 JL = 1, KDLON
5522 ZCNTOP(JL)= PBTOP(JL,1)
5523 1 + PBTOP(JL,2)
5524 2 + PBTOP(JL,3)
5525 3 + PBTOP(JL,4)
5526 4 + PBTOP(JL,5)
5527 5 + PBTOP(JL,6)
5528 ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5529 PFLUC(JL,2,JK)=ZFD(JL)
5530 236 CONTINUE
5531 C
5532 C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
5533 C ---------------------------------------
5534 C
5535 240 CONTINUE
5536 C
5537 C
5538 C* 2.4.1 INITIALIZATION
5539 C --------------
5540 C
5541 2410 CONTINUE
5542 C
5543 JLIM = KFLEV
5544 C
5545 IF (.NOT.LEVOIGT) THEN
5546 DO 2412 JK = KFLEV,1,-1
5547 IF(PPMB(1,JK).LT.10.0) THEN
5548 JLIM=JK
5549 ENDIF
5550 2412 CONTINUE
5551 ENDIF
5552 KLIM=JLIM
5553 C
5554 IF (.NOT.LEVOIGT) THEN
5555 DO 2414 JA=1,KTRAER
5556 DO 2413 JL=1, KDLON
5557 ZTT1(JL,JA)=1.0
5558 2413 CONTINUE
5559 2414 CONTINUE
5560 C
5561 C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
5562 C -----------------------------
5563 C
5564 2420 CONTINUE
5565 C
5566 DO 2427 JSTRA = KFLEV,JLIM,-1
5567 JSTRU=(JSTRA-1)*NG1P1+1
5568 C
5569 DO 2423 JA=1,KUAER
5570 DO 2422 JL=1, KDLON
5571 ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
5572 2422 CONTINUE
5573 2423 CONTINUE
5574 C
5575 C
5576 CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
5577 C
5578 DO 2424 JL = 1, KDLON
5579 ZCTSTR =
5580 1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
5581 1 *(ZTT1(JL,1) *ZTT1(JL,10)
5582 1 - ZTT (JL,1) *ZTT (JL,10))
5583 2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
5584 2 *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
5585 2 - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
5586 3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
5587 3 *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
5588 3 - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
5589 4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
5590 4 *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
5591 4 - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
5592 5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
5593 5 *(ZTT1(JL,3) *ZTT1(JL,14)
5594 5 - ZTT (JL,3) *ZTT (JL,14))
5595 6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
5596 6 *(ZTT1(JL,6) *ZTT1(JL,15)
5597 6 - ZTT (JL,6) *ZTT (JL,15))
5598 PCTS(JL,JSTRA)=ZCTSTR*0.5
5599 2424 CONTINUE
5600 DO 2426 JA=1,KTRAER
5601 DO 2425 JL=1, KDLON
5602 ZTT1(JL,JA)=ZTT(JL,JA)
5603 2425 CONTINUE
5604 2426 CONTINUE
5605 2427 CONTINUE
5606 ENDIF
5607 C Mise a zero de securite pour PCTS en cas de LEVOIGT
5608 IF(LEVOIGT)THEN
5609 DO 2429 JSTRA = 1,KFLEV
5610 DO 2428 JL = 1, KDLON
5611 PCTS(JL,JSTRA)=0.
5612 2428 CONTINUE
5613 2429 CONTINUE
5614 ENDIF
5615 C
5616 C
5617 C* 2.5 EXCHANGE WITH LOWER LIMIT
5618 C -------------------------
5619 C
5620 250 CONTINUE
5621 C
5622 DO 251 JL = 1, KDLON
5623 ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
5624 S *PFLUC(JL,2,1)-PBINT(JL,1)
5625 251 CONTINUE
5626 C
5627 JK = 1
5628 IN=(JK-1)*NG1P1+1
5629 C
5630 DO 252 JL = 1, KDLON
5631 ZCNSOL(JL)=PBSUR(JL,1)
5632 1 +PBSUR(JL,2)
5633 2 +PBSUR(JL,3)
5634 3 +PBSUR(JL,4)
5635 4 +PBSUR(JL,5)
5636 5 +PBSUR(JL,6)
5637 ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5638 ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5639 PFLUC(JL,1,JK)=ZFU(JL)
5640 252 CONTINUE
5641 C
5642 DO 257 JK = 2 , KFLEV+1
5643 IN=(JK-1)*NG1P1+1
5644 C
5645 C
5646 DO 255 JA=1,KUAER
5647 DO 254 JL=1, KDLON
5648 ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
5649 254 CONTINUE
5650 255 CONTINUE
5651 C
5652 C
5653 CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
5654 C
5655 DO 256 JL = 1, KDLON
5656 ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1) *ZTT(JL,10)
5657 2 +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
5658 3 +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
5659 4 +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
5660 5 +PBSUR(JL,5)*ZTT(JL,3) *ZTT(JL,14)
5661 6 +PBSUR(JL,6)*ZTT(JL,6) *ZTT(JL,15)
5662 ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5663 ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5664 PFLUC(JL,1,JK)=ZFU(JL)
5665 256 CONTINUE
5666 C
5667 C
5668 257 CONTINUE
5669 C
5670 C
5671 C
5672 C* 2.7 CLEAR-SKY FLUXES
5673 C ----------------
5674 C
5675 270 CONTINUE
5676 C
5677 IF (.NOT.LEVOIGT) THEN
5678 DO 271 JL = 1, KDLON
5679 ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
5680 271 CONTINUE
5681 DO 273 JK = JLIM+1,KFLEV+1
5682 DO 272 JL = 1, KDLON
5683 ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
5684 PFLUC(JL,1,JK) = ZFN10(JL)
5685 PFLUC(JL,2,JK) = 0.
5686 272 CONTINUE
5687 273 CONTINUE
5688 ENDIF
5689 C
5690 C ------------------------------------------------------------------
5691 C
5692 RETURN
5693 END
5694 SUBROUTINE LWVD(KUAER,KTRAER
5695 S , PABCU,PDBDT
5696 R , PGA,PGB
5697 S , PCNTRB,PDISD,PDISU)
5698 use dimens_m
5699 use dimphy
5700 use raddim
5701 use raddimlw
5702 IMPLICIT none
5703 C
5704 C-----------------------------------------------------------------------
5705 C PURPOSE.
5706 C --------
5707 C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
5708 C
5709 C METHOD.
5710 C -------
5711 C
5712 C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5713 C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
5714 C
5715 C REFERENCE.
5716 C ----------
5717 C
5718 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5719 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5720 C
5721 C AUTHOR.
5722 C -------
5723 C JEAN-JACQUES MORCRETTE *ECMWF*
5724 C
5725 C MODIFICATIONS.
5726 C --------------
5727 C ORIGINAL : 89-07-14
5728 C-----------------------------------------------------------------------
5729 C* ARGUMENTS:
5730 C
5731 INTEGER KUAER,KTRAER
5732 C
5733 REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
5734 REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5735 REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5736 REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5737 C
5738 REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
5739 REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5740 REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5741 C
5742 C* LOCAL VARIABLES:
5743 C
5744 REAL*8 ZGLAYD(KDLON)
5745 REAL*8 ZGLAYU(KDLON)
5746 REAL*8 ZTT(KDLON,NTRA)
5747 REAL*8 ZTT1(KDLON,NTRA)
5748 REAL*8 ZTT2(KDLON,NTRA)
5749 C
5750 INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
5751 INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
5752 INTEGER ind1, ind2, ind3, ind4, itt
5753 REAL*8 zww, zdzxdg, zdzxmg
5754 C
5755 C* 1. INITIALIZATION
5756 C --------------
5757 C
5758 100 CONTINUE
5759 C
5760 C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5761 C ------------------------------
5762 C
5763 110 CONTINUE
5764 C
5765 DO 112 JK = 1, KFLEV+1
5766 DO 111 JL = 1, KDLON
5767 PDISD(JL,JK) = 0.
5768 PDISU(JL,JK) = 0.
5769 111 CONTINUE
5770 112 CONTINUE
5771 C
5772 C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5773 C ---------------------------------
5774 C
5775 120 CONTINUE
5776 C
5777 C
5778 DO 122 JA = 1, NTRA
5779 DO 121 JL = 1, KDLON
5780 ZTT (JL,JA) = 1.0
5781 ZTT1(JL,JA) = 1.0
5782 ZTT2(JL,JA) = 1.0
5783 121 CONTINUE
5784 122 CONTINUE
5785 C
5786 C ------------------------------------------------------------------
5787 C
5788 C* 2. VERTICAL INTEGRATION
5789 C --------------------
5790 C
5791 200 CONTINUE
5792 C
5793 IND1=0
5794 IND3=0
5795 IND4=1
5796 IND2=1
5797 C
5798 C
5799 C* 2.2 CONTRIBUTION FROM DISTANT LAYERS
5800 C ---------------------------------
5801 C
5802 220 CONTINUE
5803 C
5804 C
5805 C* 2.2.1 DISTANT AND ABOVE LAYERS
5806 C ------------------------
5807 C
5808 2210 CONTINUE
5809 C
5810 C
5811 C
5812 C* 2.2.2 FIRST UPPER LEVEL
5813 C -----------------
5814 C
5815 2220 CONTINUE
5816 C
5817 DO 225 JK = 1 , KFLEV-1
5818 IKP1=JK+1
5819 IKN=(JK-1)*NG1P1+1
5820 IKD1= JK *NG1P1+1
5821 C
5822 CALL LWTTM(PGA(1,1,1,JK), PGB(1,1,1,JK)
5823 2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
5824 C
5825 C
5826 C
5827 C* 2.2.3 HIGHER UP
5828 C ---------
5829 C
5830 2230 CONTINUE
5831 C
5832 ITT=1
5833 DO 224 JKJ=IKP1,KFLEV
5834 IF(ITT.EQ.1) THEN
5835 ITT=2
5836 ELSE
5837 ITT=1
5838 ENDIF
5839 IKJP1=JKJ+1
5840 IKD2= JKJ *NG1P1+1
5841 C
5842 IF(ITT.EQ.1) THEN
5843 CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5844 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
5845 ELSE
5846 CALL LWTTM(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5847 2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
5848 ENDIF
5849 C
5850 DO 2235 JA = 1, KTRAER
5851 DO 2234 JL = 1, KDLON
5852 ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5853 2234 CONTINUE
5854 2235 CONTINUE
5855 C
5856 DO 2236 JL = 1, KDLON
5857 ZWW=PDBDT(JL,1,JKJ)*ZTT(JL,1) *ZTT(JL,10)
5858 S +PDBDT(JL,2,JKJ)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
5859 S +PDBDT(JL,3,JKJ)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
5860 S +PDBDT(JL,4,JKJ)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
5861 S +PDBDT(JL,5,JKJ)*ZTT(JL,3) *ZTT(JL,14)
5862 S +PDBDT(JL,6,JKJ)*ZTT(JL,6) *ZTT(JL,15)
5863 ZGLAYD(JL)=ZWW
5864 ZDZXDG=ZGLAYD(JL)
5865 PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
5866 PCNTRB(JL,JK,IKJP1)=ZDZXDG
5867 2236 CONTINUE
5868 C
5869 C
5870 224 CONTINUE
5871 225 CONTINUE
5872 C
5873 C
5874 C* 2.2.4 DISTANT AND BELOW LAYERS
5875 C ------------------------
5876 C
5877 2240 CONTINUE
5878 C
5879 C
5880 C
5881 C* 2.2.5 FIRST LOWER LEVEL
5882 C -----------------
5883 C
5884 2250 CONTINUE
5885 C
5886 DO 228 JK=3,KFLEV+1
5887 IKN=(JK-1)*NG1P1+1
5888 IKM1=JK-1
5889 IKJ=JK-2
5890 IKU1= IKJ *NG1P1+1
5891 C
5892 C
5893 CALL LWTTM(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
5894 2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
5895 C
5896 C
5897 C
5898 C* 2.2.6 DOWN BELOW
5899 C ----------
5900 C
5901 2260 CONTINUE
5902 C
5903 ITT=1
5904 DO 227 JLK=1,IKJ
5905 IF(ITT.EQ.1) THEN
5906 ITT=2
5907 ELSE
5908 ITT=1
5909 ENDIF
5910 IJKL=IKM1-JLK
5911 IKU2=(IJKL-1)*NG1P1+1
5912 C
5913 C
5914 IF(ITT.EQ.1) THEN
5915 CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5916 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
5917 ELSE
5918 CALL LWTTM(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5919 2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
5920 ENDIF
5921 C
5922 DO 2265 JA = 1, KTRAER
5923 DO 2264 JL = 1, KDLON
5924 ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5925 2264 CONTINUE
5926 2265 CONTINUE
5927 C
5928 DO 2266 JL = 1, KDLON
5929 ZWW=PDBDT(JL,1,IJKL)*ZTT(JL,1) *ZTT(JL,10)
5930 S +PDBDT(JL,2,IJKL)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
5931 S +PDBDT(JL,3,IJKL)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
5932 S +PDBDT(JL,4,IJKL)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
5933 S +PDBDT(JL,5,IJKL)*ZTT(JL,3) *ZTT(JL,14)
5934 S +PDBDT(JL,6,IJKL)*ZTT(JL,6) *ZTT(JL,15)
5935 ZGLAYU(JL)=ZWW
5936 ZDZXMG=ZGLAYU(JL)
5937 PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
5938 PCNTRB(JL,JK,IJKL)=ZDZXMG
5939 2266 CONTINUE
5940 C
5941 C
5942 227 CONTINUE
5943 228 CONTINUE
5944 C
5945 RETURN
5946 END
5947 SUBROUTINE LWVN(KUAER,KTRAER
5948 R , PABCU,PDBSL,PGA,PGB
5949 S , PADJD,PADJU,PCNTRB,PDBDT)
5950 use dimens_m
5951 use dimphy
5952 use raddim
5953 use raddimlw
5954 IMPLICIT none
5955 C
5956 C-----------------------------------------------------------------------
5957 C PURPOSE.
5958 C --------
5959 C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
5960 C TO GIVE LONGWAVE FLUXES OR RADIANCES
5961 C
5962 C METHOD.
5963 C -------
5964 C
5965 C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5966 C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
5967 C
5968 C REFERENCE.
5969 C ----------
5970 C
5971 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5972 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5973 C
5974 C AUTHOR.
5975 C -------
5976 C JEAN-JACQUES MORCRETTE *ECMWF*
5977 C
5978 C MODIFICATIONS.
5979 C --------------
5980 C ORIGINAL : 89-07-14
5981 C-----------------------------------------------------------------------
5982 C
5983 C* ARGUMENTS:
5984 C
5985 INTEGER KUAER,KTRAER
5986 C
5987 REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
5988 REAL*8 PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5989 REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5990 REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5991 C
5992 REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5993 REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5994 REAL*8 PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5995 REAL*8 PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5996 C
5997 C* LOCAL ARRAYS:
5998 C
5999 REAL*8 ZGLAYD(KDLON)
6000 REAL*8 ZGLAYU(KDLON)
6001 REAL*8 ZTT(KDLON,NTRA)
6002 REAL*8 ZTT1(KDLON,NTRA)
6003 REAL*8 ZTT2(KDLON,NTRA)
6004 REAL*8 ZUU(KDLON,NUA)
6005 C
6006 INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
6007 INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
6008 REAL*8 zwtr
6009 c
6010 C* Data Block:
6011 c
6012 REAL*8 WG1(2)
6013 SAVE WG1
6014 DATA (WG1(jk),jk=1,2) /1.0, 1.0/
6015 C-----------------------------------------------------------------------
6016 C
6017 C* 1. INITIALIZATION
6018 C --------------
6019 C
6020 100 CONTINUE
6021 C
6022 C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
6023 C ------------------------------
6024 C
6025 110 CONTINUE
6026 C
6027 DO 112 JK = 1 , KFLEV+1
6028 DO 111 JL = 1, KDLON
6029 PADJD(JL,JK) = 0.
6030 PADJU(JL,JK) = 0.
6031 111 CONTINUE
6032 112 CONTINUE
6033 C
6034 C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
6035 C ---------------------------------
6036 C
6037 120 CONTINUE
6038 C
6039 DO 122 JA = 1 , NTRA
6040 DO 121 JL = 1, KDLON
6041 ZTT (JL,JA) = 1.0
6042 ZTT1(JL,JA) = 1.0
6043 ZTT2(JL,JA) = 1.0
6044 121 CONTINUE
6045 122 CONTINUE
6046 C
6047 DO 124 JA = 1 , NUA
6048 DO 123 JL = 1, KDLON
6049 ZUU(JL,JA) = 0.
6050 123 CONTINUE
6051 124 CONTINUE
6052 C
6053 C ------------------------------------------------------------------
6054 C
6055 C* 2. VERTICAL INTEGRATION
6056 C --------------------
6057 C
6058 200 CONTINUE
6059 C
6060 C
6061 C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS
6062 C ---------------------------------
6063 C
6064 210 CONTINUE
6065 C
6066 DO 215 JK = 1 , KFLEV
6067 C
6068 C* 2.1.1 DOWNWARD LAYERS
6069 C ---------------
6070 C
6071 2110 CONTINUE
6072 C
6073 IM12 = 2 * (JK - 1)
6074 IND = (JK - 1) * NG1P1 + 1
6075 IXD = IND
6076 INU = JK * NG1P1 + 1
6077 IXU = IND
6078 C
6079 DO 2111 JL = 1, KDLON
6080 ZGLAYD(JL) = 0.
6081 ZGLAYU(JL) = 0.
6082 2111 CONTINUE
6083 C
6084 DO 213 JG = 1 , NG1
6085 IBS = IM12 + JG
6086 IDD = IXD + JG
6087 DO 2113 JA = 1 , KUAER
6088 DO 2112 JL = 1, KDLON
6089 ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
6090 2112 CONTINUE
6091 2113 CONTINUE
6092 C
6093 C
6094 CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
6095 C
6096 DO 2114 JL = 1, KDLON
6097 ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10)
6098 S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
6099 S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
6100 S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
6101 S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14)
6102 S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15)
6103 ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
6104 2114 CONTINUE
6105 C
6106 C* 2.1.2 DOWNWARD LAYERS
6107 C ---------------
6108 C
6109 2120 CONTINUE
6110 C
6111 IMU = IXU + JG
6112 DO 2122 JA = 1 , KUAER
6113 DO 2121 JL = 1, KDLON
6114 ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
6115 2121 CONTINUE
6116 2122 CONTINUE
6117 C
6118 C
6119 CALL LWTT(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
6120 C
6121 DO 2123 JL = 1, KDLON
6122 ZWTR=PDBSL(JL,1,IBS)*ZTT(JL,1) *ZTT(JL,10)
6123 S +PDBSL(JL,2,IBS)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
6124 S +PDBSL(JL,3,IBS)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
6125 S +PDBSL(JL,4,IBS)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
6126 S +PDBSL(JL,5,IBS)*ZTT(JL,3) *ZTT(JL,14)
6127 S +PDBSL(JL,6,IBS)*ZTT(JL,6) *ZTT(JL,15)
6128 ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
6129 2123 CONTINUE
6130 C
6131 213 CONTINUE
6132 C
6133 DO 214 JL = 1, KDLON
6134 PADJD(JL,JK) = ZGLAYD(JL)
6135 PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
6136 PADJU(JL,JK+1) = ZGLAYU(JL)
6137 PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
6138 PCNTRB(JL,JK ,JK) = 0.0
6139 214 CONTINUE
6140 C
6141 215 CONTINUE
6142 C
6143 DO 218 JK = 1 , KFLEV
6144 JK2 = 2 * JK
6145 JK1 = JK2 - 1
6146 DO 217 JNU = 1 , Ninter
6147 DO 216 JL = 1, KDLON
6148 PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
6149 216 CONTINUE
6150 217 CONTINUE
6151 218 CONTINUE
6152 C
6153 RETURN
6154 C
6155 END
6156 SUBROUTINE LWTT(PGA,PGB,PUU, PTT)
6157 use dimens_m
6158 use dimphy
6159 use raddim
6160 use raddimlw
6161 IMPLICIT none
6162 C
6163 C-----------------------------------------------------------------------
6164 C PURPOSE.
6165 C --------
6166 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
6167 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
6168 C INTERVALS.
6169 C
6170 C METHOD.
6171 C -------
6172 C
6173 C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
6174 C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
6175 C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
6176 C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
6177 C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
6178 C
6179 C REFERENCE.
6180 C ----------
6181 C
6182 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6183 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6184 C
6185 C AUTHOR.
6186 C -------
6187 C JEAN-JACQUES MORCRETTE *ECMWF*
6188 C
6189 C MODIFICATIONS.
6190 C --------------
6191 C ORIGINAL : 88-12-15
6192 C
6193 C-----------------------------------------------------------------------
6194 REAL*8 O1H, O2H
6195 PARAMETER (O1H=2230.)
6196 PARAMETER (O2H=100.)
6197 REAL*8 RPIALF0
6198 PARAMETER (RPIALF0=2.0)
6199 C
6200 C* ARGUMENTS:
6201 C
6202 REAL*8 PUU(KDLON,NUA)
6203 REAL*8 PTT(KDLON,NTRA)
6204 REAL*8 PGA(KDLON,8,2)
6205 REAL*8 PGB(KDLON,8,2)
6206 C
6207 C* LOCAL VARIABLES:
6208 C
6209 REAL*8 zz, zxd, zxn
6210 REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
6211 REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
6212 REAL*8 zx, zy, zsq1, zsq2, zvxy, zuxy
6213 REAL*8 zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
6214 REAL*8 zsqn21, zodn21, zsqh42, zodh42
6215 REAL*8 zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
6216 REAL*8 zuu11, zuu12, za11, za12
6217 INTEGER jl, ja
6218 C ------------------------------------------------------------------
6219 C
6220 C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6221 C -----------------------------------------------
6222 C
6223 100 CONTINUE
6224 C
6225 C
6226 DO 130 JA = 1 , 8
6227 DO 120 JL = 1, KDLON
6228 ZZ =SQRT(PUU(JL,JA))
6229 c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
6230 c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
6231 c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
6232 ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6233 ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6234 PTT(JL,JA)=ZXN /ZXD
6235 120 CONTINUE
6236 130 CONTINUE
6237 C
6238 C ------------------------------------------------------------------
6239 C
6240 C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6241 C ---------------------------------------------------
6242 C
6243 200 CONTINUE
6244 C
6245 DO 201 JL = 1, KDLON
6246 PTT(JL, 9) = PTT(JL, 8)
6247 C
6248 C- CONTINUUM ABSORPTION: E- AND P-TYPE
6249 C
6250 ZPU = 0.002 * PUU(JL,10)
6251 ZPU10 = 112. * ZPU
6252 ZPU11 = 6.25 * ZPU
6253 ZPU12 = 5.00 * ZPU
6254 ZPU13 = 80.0 * ZPU
6255 ZEU = PUU(JL,11)
6256 ZEU10 = 12. * ZEU
6257 ZEU11 = 6.25 * ZEU
6258 ZEU12 = 5.00 * ZEU
6259 ZEU13 = 80.0 * ZEU
6260 C
6261 C- OZONE ABSORPTION
6262 C
6263 ZX = PUU(JL,12)
6264 ZY = PUU(JL,13)
6265 ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6266 ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6267 ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6268 ZVXY = RPIALF0 * ZY / (2. * ZX)
6269 ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
6270 ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6271 ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6272 C
6273 C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6274 C
6275 C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6276 C
6277 c NEXOTIC=1
6278 c IF (NEXOTIC.EQ.1) THEN
6279 ZXCH4 = PUU(JL,19)
6280 ZYCH4 = PUU(JL,20)
6281 ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
6282 ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6283 ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6284 ZODH41 = ZVXY * ZSQH41
6285 C
6286 C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6287 C
6288 ZXN2O = PUU(JL,21)
6289 ZYN2O = PUU(JL,22)
6290 ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
6291 ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6292 ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6293 ZODN21 = ZVXY * ZSQN21
6294 C
6295 C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6296 C
6297 ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
6298 ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6299 ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6300 ZODH42 = ZVXY * ZSQH42
6301 C
6302 C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6303 C
6304 ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
6305 ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6306 ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6307 ZODN22 = ZVXY * ZSQN22
6308 C
6309 C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6310 C
6311 ZA11 = 2. * PUU(JL,23) * 4.404E+05
6312 ZTTF11 = 1. - ZA11 * 0.003225
6313 C
6314 C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6315 C
6316 ZA12 = 2. * PUU(JL,24) * 6.7435E+05
6317 ZTTF12 = 1. - ZA12 * 0.003225
6318 C
6319 ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
6320 ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
6321 PTT(JL,10) = EXP( - PUU(JL,14) )
6322 PTT(JL,11) = EXP( ZUU11 )
6323 PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6324 PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6325 PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6326 PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
6327 201 CONTINUE
6328 C
6329 RETURN
6330 END
6331 SUBROUTINE LWTTM(PGA,PGB,PUU1,PUU2, PTT)
6332 use dimens_m
6333 use dimphy
6334 use raddim
6335 use raddimlw
6336 IMPLICIT none
6337 C
6338 C ------------------------------------------------------------------
6339 C PURPOSE.
6340 C --------
6341 C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
6342 C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
6343 C INTERVALS.
6344 C
6345 C METHOD.
6346 C -------
6347 C
6348 C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
6349 C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
6350 C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
6351 C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
6352 C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
6353 C
6354 C REFERENCE.
6355 C ----------
6356 C
6357 C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6358 C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6359 C
6360 C AUTHOR.
6361 C -------
6362 C JEAN-JACQUES MORCRETTE *ECMWF*
6363 C
6364 C MODIFICATIONS.
6365 C --------------
6366 C ORIGINAL : 88-12-15
6367 C
6368 C-----------------------------------------------------------------------
6369 REAL*8 O1H, O2H
6370 PARAMETER (O1H=2230.)
6371 PARAMETER (O2H=100.)
6372 REAL*8 RPIALF0
6373 PARAMETER (RPIALF0=2.0)
6374 C
6375 C* ARGUMENTS:
6376 C
6377 REAL*8 PGA(KDLON,8,2) ! PADE APPROXIMANTS
6378 REAL*8 PGB(KDLON,8,2) ! PADE APPROXIMANTS
6379 REAL*8 PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
6380 REAL*8 PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
6381 REAL*8 PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
6382 C
6383 C* LOCAL VARIABLES:
6384 C
6385 INTEGER ja, jl
6386 REAL*8 zz, zxd, zxn
6387 REAL*8 zpu, zpu10, zpu11, zpu12, zpu13
6388 REAL*8 zeu, zeu10, zeu11, zeu12, zeu13
6389 REAL*8 zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
6390 REAL*8 zxch4, zych4, zsqh41, zodh41
6391 REAL*8 zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
6392 REAL*8 zsqn22, zodn22, za11, zttf11, za12, zttf12
6393 REAL*8 zuu11, zuu12
6394 C ------------------------------------------------------------------
6395 C
6396 C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6397 C -----------------------------------------------
6398 C
6399 100 CONTINUE
6400 C
6401 C
6402 DO 130 JA = 1 , 8
6403 DO 120 JL = 1, KDLON
6404 ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
6405 ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6406 ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6407 PTT(JL,JA)=ZXN /ZXD
6408 120 CONTINUE
6409 130 CONTINUE
6410 C
6411 C ------------------------------------------------------------------
6412 C
6413 C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6414 C ---------------------------------------------------
6415 C
6416 200 CONTINUE
6417 C
6418 DO 201 JL = 1, KDLON
6419 PTT(JL, 9) = PTT(JL, 8)
6420 C
6421 C- CONTINUUM ABSORPTION: E- AND P-TYPE
6422 C
6423 ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
6424 ZPU10 = 112. * ZPU
6425 ZPU11 = 6.25 * ZPU
6426 ZPU12 = 5.00 * ZPU
6427 ZPU13 = 80.0 * ZPU
6428 ZEU = (PUU1(JL,11) - PUU2(JL,11))
6429 ZEU10 = 12. * ZEU
6430 ZEU11 = 6.25 * ZEU
6431 ZEU12 = 5.00 * ZEU
6432 ZEU13 = 80.0 * ZEU
6433 C
6434 C- OZONE ABSORPTION
6435 C
6436 ZX = (PUU1(JL,12) - PUU2(JL,12))
6437 ZY = (PUU1(JL,13) - PUU2(JL,13))
6438 ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6439 ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6440 ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6441 ZVXY = RPIALF0 * ZY / (2. * ZX)
6442 ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
6443 ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6444 ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6445 C
6446 C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6447 C
6448 C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6449 C
6450 ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
6451 ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
6452 ZUXY = 4. * ZXCH4*ZXCH4/(0.103*ZYCH4)
6453 ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6454 ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6455 ZODH41 = ZVXY * ZSQH41
6456 C
6457 C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6458 C
6459 ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
6460 ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
6461 ZUXY = 4. * ZXN2O*ZXN2O/(0.416*ZYN2O)
6462 ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6463 ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6464 ZODN21 = ZVXY * ZSQN21
6465 C
6466 C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6467 C
6468 ZUXY = 4. * ZXCH4*ZXCH4/(0.113*ZYCH4)
6469 ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6470 ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6471 ZODH42 = ZVXY * ZSQH42
6472 C
6473 C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6474 C
6475 ZUXY = 4. * ZXN2O*ZXN2O/(0.197*ZYN2O)
6476 ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6477 ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6478 ZODN22 = ZVXY * ZSQN22
6479 C
6480 C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6481 C
6482 ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
6483 ZTTF11 = 1. - ZA11 * 0.003225
6484 C
6485 C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6486 C
6487 ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
6488 ZTTF12 = 1. - ZA12 * 0.003225
6489 C
6490 ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
6491 ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
6492 S ZODH41 - ZODN21
6493 PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
6494 PTT(JL,11) = EXP( ZUU11 )
6495 PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6496 PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6497 PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6498 PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
6499 201 CONTINUE
6500 C
6501 RETURN
6502 END
  ViewVC Help
Powered by ViewVC 1.1.21