Head

GCC Code Coverage Report

Directory:	./		Exec	Total	Coverage
File:	phylmd/radiation_AR4.F90	Lines:	0	1467	0.0 %
Date:	2023-06-30 12:51:15	Branches:	0	734	0.0 %

Line	Branch	Exec	Source
1			! IM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
2			SUBROUTINE sw_lmdar4(psct, prmu0, pfrac, ppmb, pdp, ppsol, palbd, palbp, &
3			ptave, pwv, pqs, pozon, paer, pcldsw, ptau, pomega, pcg, pheat, pheat0, &
4			palbpla, ptopsw, psolsw, ptopsw0, psolsw0, zfsup, zfsdn, zfsup0, zfsdn0, &
5			tauae, pizae, cgae, ptaua, pomegaa, ptopswad, psolswad, ptopswai, &
6			psolswai, ok_ade, ok_aie)
7			USE dimphy
8			USE print_control_mod, ONLY: lunout
9			IMPLICIT NONE
10
11			include "YOMCST.h"
12
13			! ------------------------------------------------------------------
14
15			! PURPOSE.
16			! --------
17
18			! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
19			! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
20
21			! METHOD.
22			! -------
23
24			! 1. COMPUTES ABSORBER AMOUNTS (SWU)
25			! 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S)
26			! 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S)
27
28			! REFERENCE.
29			! ----------
30
31			! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
32			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
33
34			! AUTHOR.
35			! -------
36			! JEAN-JACQUES MORCRETTE ECMWF
37
38			! MODIFICATIONS.
39			! --------------
40			! ORIGINAL : 89-07-14
41			! 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo
42			! 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER)
43			! ------------------------------------------------------------------
44
45			! * ARGUMENTS:
46
47			REAL (KIND=8) psct ! constante solaire (valeur conseillee: 1370)
48			! IM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC:
49			! 353.E-06*44.011/28.97)
50			include "clesphys.h"
51
52			REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (PA)
53			REAL (KIND=8) pdp(kdlon, kflev) ! LAYER THICKNESS (PA)
54			REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
55
56			REAL (KIND=8) prmu0(kdlon) ! COSINE OF ZENITHAL ANGLE
57			REAL (KIND=8) pfrac(kdlon) ! fraction de la journee
58
59			REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K)
60			REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (KG/KG)
61			REAL (KIND=8) pqs(kdlon, kflev) ! SATURATED WATER VAPOUR (KG/KG)
62			REAL (KIND=8) pozon(kdlon, kflev) ! OZONE CONCENTRATION (KG/KG)
63			REAL (KIND=8) paer(kdlon, kflev, 5) ! AEROSOLS' OPTICAL THICKNESS
64
65			REAL (KIND=8) palbd(kdlon, 2) ! albedo du sol (lumiere diffuse)
66			REAL (KIND=8) palbp(kdlon, 2) ! albedo du sol (lumiere parallele)
67
68			REAL (KIND=8) pcldsw(kdlon, kflev) ! CLOUD FRACTION
69			REAL (KIND=8) ptau(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS
70			REAL (KIND=8) pcg(kdlon, 2, kflev) ! ASYMETRY FACTOR
71			REAL (KIND=8) pomega(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO
72
73			REAL (KIND=8) pheat(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY)
74			REAL (KIND=8) pheat0(kdlon, kflev) ! SHORTWAVE HEATING (K/DAY) clear-sky
75			REAL (KIND=8) palbpla(kdlon) ! PLANETARY ALBEDO
76			REAL (KIND=8) ptopsw(kdlon) ! SHORTWAVE FLUX AT T.O.A.
77			REAL (KIND=8) psolsw(kdlon) ! SHORTWAVE FLUX AT SURFACE
78			REAL (KIND=8) ptopsw0(kdlon) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
79			REAL (KIND=8) psolsw0(kdlon) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
80
81			! * LOCAL VARIABLES:
82
83			REAL, PARAMETER :: dobson_u = 2.1415E-05 ! Dobson unit, in kg m-2
84
85			REAL (KIND=8) zoz(kdlon, kflev)
86			! column-density of ozone in layer, in kilo-Dobsons
87
88			REAL (KIND=8) zaki(kdlon, 2)
89			REAL (KIND=8) zcld(kdlon, kflev)
90			REAL (KIND=8) zclear(kdlon)
91			REAL (KIND=8) zdsig(kdlon, kflev)
92			REAL (KIND=8) zfact(kdlon)
93			REAL (KIND=8) zfd(kdlon, kflev+1)
94			REAL (KIND=8) zfdown(kdlon, kflev+1)
95			REAL (KIND=8) zfu(kdlon, kflev+1)
96			REAL (KIND=8) zfup(kdlon, kflev+1)
97			REAL (KIND=8) zrmu(kdlon)
98			REAL (KIND=8) zsec(kdlon)
99			REAL (KIND=8) zud(kdlon, 5, kflev+1)
100			REAL (KIND=8) zcldsw0(kdlon, kflev)
101
102			REAL (KIND=8) zfsup(kdlon, kflev+1)
103			REAL (KIND=8) zfsdn(kdlon, kflev+1)
104			REAL (KIND=8) zfsup0(kdlon, kflev+1)
105			REAL (KIND=8) zfsdn0(kdlon, kflev+1)
106
107			INTEGER inu, jl, jk, i, k, kpl1
108
109			INTEGER swpas ! Every swpas steps, sw is calculated
110			PARAMETER (swpas=1)
111
112			INTEGER itapsw
113			LOGICAL appel1er
114			DATA itapsw/0/
115			DATA appel1er/.TRUE./
116			SAVE itapsw, appel1er
117			!$OMP THREADPRIVATE(appel1er)
118			!$OMP THREADPRIVATE(itapsw)
119			! jq-Introduced for aerosol forcings
120			REAL (KIND=8) flag_aer
121			LOGICAL ok_ade, ok_aie ! use aerosol forcings or not?
122			REAL (KIND=8) tauae(kdlon, kflev, 2) ! aerosol optical properties
123			REAL (KIND=8) pizae(kdlon, kflev, 2) ! (see aeropt.F)
124			REAL (KIND=8) cgae(kdlon, kflev, 2) ! -"-
125			REAL (KIND=8) ptaua(kdlon, 2, kflev) ! CLOUD OPTICAL THICKNESS (pre-industrial value)
126			REAL (KIND=8) pomegaa(kdlon, 2, kflev) ! SINGLE SCATTERING ALBEDO
127			REAL (KIND=8) ptopswad(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
128			REAL (KIND=8) psolswad(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
129			REAL (KIND=8) ptopswai(kdlon) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
130			REAL (KIND=8) psolswai(kdlon) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
131			! jq - Fluxes including aerosol effects
132			REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupad(:, :)
133			!$OMP THREADPRIVATE(ZFSUPAD)
134			REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnad(:, :)
135			!$OMP THREADPRIVATE(ZFSDNAD)
136			REAL (KIND=8), ALLOCATABLE, SAVE :: zfsupai(:, :)
137			!$OMP THREADPRIVATE(ZFSUPAI)
138			REAL (KIND=8), ALLOCATABLE, SAVE :: zfsdnai(:, :)
139			!$OMP THREADPRIVATE(ZFSDNAI)
140			LOGICAL initialized
141			! ym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
142			! rv
143			SAVE flag_aer
144			!$OMP THREADPRIVATE(flag_aer)
145			DATA initialized/.FALSE./
146			SAVE initialized
147			!$OMP THREADPRIVATE(initialized)
148			! jq-end
149			REAL tmp_
150
151			IF (.NOT. initialized) THEN
152			flag_aer = 0.
153			initialized = .TRUE.
154			ALLOCATE (zfsupad(kdlon,kflev+1))
155			ALLOCATE (zfsdnad(kdlon,kflev+1))
156			ALLOCATE (zfsupai(kdlon,kflev+1))
157			ALLOCATE (zfsdnai(kdlon,kflev+1))
158
159			zfsupad(:, :) = 0.
160			zfsdnad(:, :) = 0.
161			zfsupai(:, :) = 0.
162			zfsdnai(:, :) = 0.
163			END IF
164
165			IF (appel1er) THEN
166			WRITE (lunout, *) 'SW calling frequency : ', swpas
167			WRITE (lunout, *) ' In general, it should be 1'
168			appel1er = .FALSE.
169			END IF
170			! ------------------------------------------------------------------
171			IF (mod(itapsw,swpas)==0) THEN
172
173			tmp_ = 1./(dobson_u1E3rg)
174			! cdir collapse
175			DO jk = 1, kflev
176			DO jl = 1, kdlon
177			zcldsw0(jl, jk) = 0.0
178			zoz(jl, jk) = pozon(jl, jk)tmp_pdp(jl, jk)
179			END DO
180			END DO
181
182
183			! clear-sky:
184			! IM ctes ds clesphys.h CALL SWU(PSCT,RCO2,ZCLDSW0,PPMB,PPSOL,
185			CALL swu_lmdar4(psct, zcldsw0, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
186			zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
187			inu = 1
188			CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
189			pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
190			zfd, zfu)
191			inu = 2
192			CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
193			palbp, pcg, zcld, zclear, zcldsw0, zdsig, pomega, zoz, zrmu, zsec, &
194			ptau, zud, pwv, pqs, zfdown, zfup)
195			DO jk = 1, kflev + 1
196			DO jl = 1, kdlon
197			zfsup0(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
198			zfsdn0(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
199			END DO
200			END DO
201
202			flag_aer = 0.0
203			CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
204			zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
205			inu = 1
206			CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
207			pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
208			zfd, zfu)
209			inu = 2
210			CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
211			palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, &
212			zud, pwv, pqs, zfdown, zfup)
213
214			! cloudy-sky:
215
216			DO jk = 1, kflev + 1
217			DO jl = 1, kdlon
218			zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
219			zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
220			END DO
221			END DO
222
223
224			IF (ok_ade) THEN
225
226			! cloudy-sky + aerosol dir OB
227			flag_aer = 1.0
228			CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
229			zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
230			inu = 1
231			CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
232			pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, ptau, zud, &
233			zfd, zfu)
234			inu = 2
235			CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
236			palbp, pcg, zcld, zclear, pcldsw, zdsig, pomega, zoz, zrmu, zsec, &
237			ptau, zud, pwv, pqs, zfdown, zfup)
238			DO jk = 1, kflev + 1
239			DO jl = 1, kdlon
240			zfsupad(jl, jk) = zfsup(jl, jk)
241			zfsdnad(jl, jk) = zfsdn(jl, jk)
242			zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
243			zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
244			END DO
245			END DO
246
247			END IF ! ok_ade
248
249			IF (ok_aie) THEN
250
251			! jq cloudy-sky + aerosol direct + aerosol indirect
252			flag_aer = 1.0
253			CALL swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
254			zaki, zcld, zclear, zdsig, zfact, zrmu, zsec, zud)
255			inu = 1
256			CALL sw1s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
257			pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, ptaua, &
258			zud, zfd, zfu)
259			inu = 2
260			CALL sw2s_lmdar4(inu, paer, flag_aer, tauae, pizae, cgae, zaki, palbd, &
261			palbp, pcg, zcld, zclear, pcldsw, zdsig, pomegaa, zoz, zrmu, zsec, &
262			ptaua, zud, pwv, pqs, zfdown, zfup)
263			DO jk = 1, kflev + 1
264			DO jl = 1, kdlon
265			zfsupai(jl, jk) = zfsup(jl, jk)
266			zfsdnai(jl, jk) = zfsdn(jl, jk)
267			zfsup(jl, jk) = (zfup(jl,jk)+zfu(jl,jk))*zfact(jl)
268			zfsdn(jl, jk) = (zfdown(jl,jk)+zfd(jl,jk))*zfact(jl)
269			END DO
270			END DO
271			END IF ! ok_aie
272			! jq -end
273
274			itapsw = 0
275			END IF
276			itapsw = itapsw + 1
277
278			DO k = 1, kflev
279			kpl1 = k + 1
280			DO i = 1, kdlon
281			pheat(i, k) = -(zfsup(i,kpl1)-zfsup(i,k)) - (zfsdn(i,k)-zfsdn(i,kpl1))
282			pheat(i, k) = pheat(i, k)rdayrg/rcpd/pdp(i, k)
283			pheat0(i, k) = -(zfsup0(i,kpl1)-zfsup0(i,k)) - &
284			(zfsdn0(i,k)-zfsdn0(i,kpl1))
285			pheat0(i, k) = pheat0(i, k)rdayrg/rcpd/pdp(i, k)
286			END DO
287			END DO
288			DO i = 1, kdlon
289			palbpla(i) = zfsup(i, kflev+1)/(zfsdn(i,kflev+1)+1.0E-20)
290
291			psolsw(i) = zfsdn(i, 1) - zfsup(i, 1)
292			ptopsw(i) = zfsdn(i, kflev+1) - zfsup(i, kflev+1)
293
294			psolsw0(i) = zfsdn0(i, 1) - zfsup0(i, 1)
295			ptopsw0(i) = zfsdn0(i, kflev+1) - zfsup0(i, kflev+1)
296			! -OB
297			psolswad(i) = zfsdnad(i, 1) - zfsupad(i, 1)
298			ptopswad(i) = zfsdnad(i, kflev+1) - zfsupad(i, kflev+1)
299
300			psolswai(i) = zfsdnai(i, 1) - zfsupai(i, 1)
301			ptopswai(i) = zfsdnai(i, kflev+1) - zfsupai(i, kflev+1)
302			! -fin
303			END DO
304
305			RETURN
306			END SUBROUTINE sw_lmdar4
307
308			! IM ctes ds clesphys.h SUBROUTINE SWU
309			! (PSCT,RCO2,PCLDSW,PPMB,PPSOL,PRMU0,PFRAC,
310			SUBROUTINE swu_lmdar4(psct, pcldsw, ppmb, ppsol, prmu0, pfrac, ptave, pwv, &
311			paki, pcld, pclear, pdsig, pfact, prmu, psec, pud)
312			USE dimphy
313			USE radiation_ar4_param, ONLY: zpdh2o, zpdumg, zprh2o, zprumg, rtdh2o, &
314			rtdumg, rth2o, rtumg
315			IMPLICIT NONE
316			include "radepsi.h"
317			include "radopt.h"
318			include "YOMCST.h"
319
320			! * ARGUMENTS:
321
322			REAL (KIND=8) psct
323			! IM ctes ds clesphys.h REAL(KIND=8) RCO2
324			include "clesphys.h"
325			REAL (KIND=8) pcldsw(kdlon, kflev)
326			REAL (KIND=8) ppmb(kdlon, kflev+1)
327			REAL (KIND=8) ppsol(kdlon)
328			REAL (KIND=8) prmu0(kdlon)
329			REAL (KIND=8) pfrac(kdlon)
330			REAL (KIND=8) ptave(kdlon, kflev)
331			REAL (KIND=8) pwv(kdlon, kflev)
332
333			REAL (KIND=8) paki(kdlon, 2)
334			REAL (KIND=8) pcld(kdlon, kflev)
335			REAL (KIND=8) pclear(kdlon)
336			REAL (KIND=8) pdsig(kdlon, kflev)
337			REAL (KIND=8) pfact(kdlon)
338			REAL (KIND=8) prmu(kdlon)
339			REAL (KIND=8) psec(kdlon)
340			REAL (KIND=8) pud(kdlon, 5, kflev+1)
341
342			! * LOCAL VARIABLES:
343
344			INTEGER iind(2)
345			REAL (KIND=8) zc1j(kdlon, kflev+1)
346			REAL (KIND=8) zclear(kdlon)
347			REAL (KIND=8) zcloud(kdlon)
348			REAL (KIND=8) zn175(kdlon)
349			REAL (KIND=8) zn190(kdlon)
350			REAL (KIND=8) zo175(kdlon)
351			REAL (KIND=8) zo190(kdlon)
352			REAL (KIND=8) zsign(kdlon)
353			REAL (KIND=8) zr(kdlon, 2)
354			REAL (KIND=8) zsigo(kdlon)
355			REAL (KIND=8) zud(kdlon, 2)
356			REAL (KIND=8) zrth, zrtu, zwh2o, zdsco2, zdsh2o, zfppw
357			INTEGER jl, jk, jkp1, jkl, jklp1, ja
358
359			! ------------------------------------------------------------------
360
361			! * 1. COMPUTES AMOUNTS OF ABSORBERS
362			! -----------------------------
363
364
365			iind(1) = 1
366			iind(2) = 2
367
368			! * 1.1 INITIALIZES QUANTITIES
369			! ----------------------
370
371
372			DO jl = 1, kdlon
373			pud(jl, 1, kflev+1) = 0.
374			pud(jl, 2, kflev+1) = 0.
375			pud(jl, 3, kflev+1) = 0.
376			pud(jl, 4, kflev+1) = 0.
377			pud(jl, 5, kflev+1) = 0.
378			pfact(jl) = prmu0(jl)pfrac(jl)psct
379			prmu(jl) = sqrt(1224.prmu0(jl)prmu0(jl)+1.)/35.
380			psec(jl) = 1./prmu(jl)
381			zc1j(jl, kflev+1) = 0.
382			END DO
383
384			! * 1.3 AMOUNTS OF ABSORBERS
385			! --------------------
386
387
388			DO jl = 1, kdlon
389			zud(jl, 1) = 0.
390			zud(jl, 2) = 0.
391			zo175(jl) = ppsol(jl)**(zpdumg+1.)
392			zo190(jl) = ppsol(jl)**(zpdh2o+1.)
393			zsigo(jl) = ppsol(jl)
394			zclear(jl) = 1.
395			zcloud(jl) = 0.
396			END DO
397
398			DO jk = 1, kflev
399			jkp1 = jk + 1
400			jkl = kflev + 1 - jk
401			jklp1 = jkl + 1
402			DO jl = 1, kdlon
403			zrth = (rth2o/ptave(jl,jk))**rtdh2o
404			zrtu = (rtumg/ptave(jl,jk))**rtdumg
405			zwh2o = max(pwv(jl,jk), zepscq)
406			zsign(jl) = 100.*ppmb(jl, jkp1)
407			pdsig(jl, jk) = (zsigo(jl)-zsign(jl))/ppsol(jl)
408			zn175(jl) = zsign(jl)**(zpdumg+1.)
409			zn190(jl) = zsign(jl)**(zpdh2o+1.)
410			zdsco2 = zo175(jl) - zn175(jl)
411			zdsh2o = zo190(jl) - zn190(jl)
412			pud(jl, 1, jk) = 1./(10.rg(zpdh2o+1.))/(zprh2o*zpdh2o)zdsh2ozwh2o &
413			zrth
414			pud(jl, 2, jk) = 1./(10.rg(zpdumg+1.))/(zprumg*zpdumg)zdsco2rco2 &
415			zrtu
416			zfppw = 1.6078zwh2o/(1.+0.608zwh2o)
417			pud(jl, 4, jk) = pud(jl, 1, jk)*zfppw
418			pud(jl, 5, jk) = pud(jl, 1, jk)*(1.-zfppw)
419			zud(jl, 1) = zud(jl, 1) + pud(jl, 1, jk)
420			zud(jl, 2) = zud(jl, 2) + pud(jl, 2, jk)
421			zsigo(jl) = zsign(jl)
422			zo175(jl) = zn175(jl)
423			zo190(jl) = zn190(jl)
424
425			IF (novlp==1) THEN
426			zclear(jl) = zclear(jl)*(1.-max(pcldsw(jl,jkl),zcloud(jl)))/(1.-min( &
427			zcloud(jl),1.-zepsec))
428			zc1j(jl, jkl) = 1.0 - zclear(jl)
429			zcloud(jl) = pcldsw(jl, jkl)
430			ELSE IF (novlp==2) THEN
431			zcloud(jl) = max(pcldsw(jl,jkl), zcloud(jl))
432			zc1j(jl, jkl) = zcloud(jl)
433			ELSE IF (novlp==3) THEN
434			zclear(jl) = zclear(jl)*(1.-pcldsw(jl,jkl))
435			zcloud(jl) = 1.0 - zclear(jl)
436			zc1j(jl, jkl) = zcloud(jl)
437			END IF
438			END DO
439			END DO
440			DO jl = 1, kdlon
441			pclear(jl) = 1. - zc1j(jl, 1)
442			END DO
443			DO jk = 1, kflev
444			DO jl = 1, kdlon
445			IF (pclear(jl)<1.) THEN
446			pcld(jl, jk) = pcldsw(jl, jk)/(1.-pclear(jl))
447			ELSE
448			pcld(jl, jk) = 0.
449			END IF
450			END DO
451			END DO
452
453			! * 1.4 COMPUTES CLEAR-SKY GREY ABSORPTION COEFFICIENTS
454			! -----------------------------------------------
455
456
457			DO ja = 1, 2
458			DO jl = 1, kdlon
459			zud(jl, ja) = zud(jl, ja)*psec(jl)
460			END DO
461			END DO
462
463			CALL swtt1_lmdar4(2, 2, iind, zud, zr)
464
465			DO ja = 1, 2
466			DO jl = 1, kdlon
467			paki(jl, ja) = -log(zr(jl,ja))/zud(jl, ja)
468			END DO
469			END DO
470
471
472			! ------------------------------------------------------------------
473
474			RETURN
475			END SUBROUTINE swu_lmdar4
476			SUBROUTINE sw1s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, &
477			pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, &
478			pfd, pfu)
479			USE dimphy
480			USE radiation_ar4_param, ONLY: rsun, rray
481			USE infotrac_phy, ONLY: type_trac
482			#ifdef REPROBUS
483			USE chem_rep, ONLY: rsuntime, ok_suntime
484			USE print_control_mod, ONLY: lunout
485			#endif
486
487			IMPLICIT NONE
488
489			! ------------------------------------------------------------------
490			! PURPOSE.
491			! --------
492
493			! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
494			! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
495
496			! METHOD.
497			! -------
498
499			! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
500			! CONTINUUM SCATTERING
501			! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
502
503			! REFERENCE.
504			! ----------
505
506			! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
507			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
508
509			! AUTHOR.
510			! -------
511			! JEAN-JACQUES MORCRETTE ECMWF
512
513			! MODIFICATIONS.
514			! --------------
515			! ORIGINAL : 89-07-14
516			! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
517			! ------------------------------------------------------------------
518
519			! * ARGUMENTS:
520
521			INTEGER knu
522			! -OB
523			REAL (KIND=8) flag_aer
524			REAL (KIND=8) tauae(kdlon, kflev, 2)
525			REAL (KIND=8) pizae(kdlon, kflev, 2)
526			REAL (KIND=8) cgae(kdlon, kflev, 2)
527			REAL (KIND=8) paer(kdlon, kflev, 5)
528			REAL (KIND=8) palbd(kdlon, 2)
529			REAL (KIND=8) palbp(kdlon, 2)
530			REAL (KIND=8) pcg(kdlon, 2, kflev)
531			REAL (KIND=8) pcld(kdlon, kflev)
532			REAL (KIND=8) pcldsw(kdlon, kflev)
533			REAL (KIND=8) pclear(kdlon)
534			REAL (KIND=8) pdsig(kdlon, kflev)
535			REAL (KIND=8) pomega(kdlon, 2, kflev)
536			REAL (KIND=8) poz(kdlon, kflev)
537			REAL (KIND=8) prmu(kdlon)
538			REAL (KIND=8) psec(kdlon)
539			REAL (KIND=8) ptau(kdlon, 2, kflev)
540			REAL (KIND=8) pud(kdlon, 5, kflev+1)
541
542			REAL (KIND=8) pfd(kdlon, kflev+1)
543			REAL (KIND=8) pfu(kdlon, kflev+1)
544
545			! * LOCAL VARIABLES:
546
547			INTEGER iind(4)
548
549			REAL (KIND=8) zcgaz(kdlon, kflev)
550			REAL (KIND=8) zdiff(kdlon)
551			REAL (KIND=8) zdirf(kdlon)
552			REAL (KIND=8) zpizaz(kdlon, kflev)
553			REAL (KIND=8) zrayl(kdlon)
554			REAL (KIND=8) zray1(kdlon, kflev+1)
555			REAL (KIND=8) zray2(kdlon, kflev+1)
556			REAL (KIND=8) zrefz(kdlon, 2, kflev+1)
557			REAL (KIND=8) zrj(kdlon, 6, kflev+1)
558			REAL (KIND=8) zrj0(kdlon, 6, kflev+1)
559			REAL (KIND=8) zrk(kdlon, 6, kflev+1)
560			REAL (KIND=8) zrk0(kdlon, 6, kflev+1)
561			REAL (KIND=8) zrmue(kdlon, kflev+1)
562			REAL (KIND=8) zrmu0(kdlon, kflev+1)
563			REAL (KIND=8) zr(kdlon, 4)
564			REAL (KIND=8) ztauaz(kdlon, kflev)
565			REAL (KIND=8) ztra1(kdlon, kflev+1)
566			REAL (KIND=8) ztra2(kdlon, kflev+1)
567			REAL (KIND=8) zw(kdlon, 4)
568
569			INTEGER jl, jk, k, jaj, ikm1, ikl
570
571			! If running with Reporbus, overwrite default values of RSUN.
572			! Otherwise keep default values from radiation_AR4_param module.
573			IF (type_trac=='repr') THEN
574			#ifdef REPROBUS
575			IF (ok_suntime) THEN
576			rsun(1) = rsuntime(1)
577			rsun(2) = rsuntime(2)
578			END IF
579			WRITE (lunout, *) 'RSUN(1): ', rsun(1)
580			#endif
581			END IF
582
583			! ------------------------------------------------------------------
584
585			! * 1. FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
586			! ----------------------- ------------------
587
588
589
590			! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
591			! -----------------------------------------
592
593
594			DO jl = 1, kdlon
595			zrayl(jl) = rray(knu, 1) + prmu(jl)(rray(knu,2)+prmu(jl)(rray(knu, &
596			3)+prmu(jl)(rray(knu,4)+prmu(jl)(rray(knu,5)+prmu(jl)*rray(knu,6)))))
597			END DO
598
599
600			! ------------------------------------------------------------------
601
602			! * 2. CONTINUUM SCATTERING CALCULATIONS
603			! ---------------------------------
604
605
606			! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN
607			! --------------------------------
608
609
610			CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, &
611			zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, &
612			ztauaz, ztra1, ztra2)
613
614			! * 2.2 CLOUDY FRACTION OF THE COLUMN
615			! -----------------------------
616
617
618			CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, &
619			zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, &
620			ztra2)
621
622			! ------------------------------------------------------------------
623
624			! * 3. OZONE ABSORPTION
625			! ----------------
626
627
628			iind(1) = 1
629			iind(2) = 3
630			iind(3) = 1
631			iind(4) = 3
632
633			! * 3.1 DOWNWARD FLUXES
634			! ---------------
635
636
637			jaj = 2
638
639			DO jl = 1, kdlon
640			zw(jl, 1) = 0.
641			zw(jl, 2) = 0.
642			zw(jl, 3) = 0.
643			zw(jl, 4) = 0.
644			pfd(jl, kflev+1) = ((1.-pclear(jl))zrj(jl,jaj,kflev+1)+pclear(jl)zrj0( &
645			jl,jaj,kflev+1))*rsun(knu)
646			END DO
647			DO jk = 1, kflev
648			ikl = kflev + 1 - jk
649			DO jl = 1, kdlon
650			zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
651			zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
652			zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
653			zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
654			END DO
655
656			CALL swtt1_lmdar4(knu, 4, iind, zw, zr)
657
658			DO jl = 1, kdlon
659			zdiff(jl) = zr(jl, 1)zr(jl, 2)zrj(jl, jaj, ikl)
660			zdirf(jl) = zr(jl, 3)zr(jl, 4)zrj0(jl, jaj, ikl)
661			pfd(jl, ikl) = ((1.-pclear(jl))zdiff(jl)+pclear(jl)zdirf(jl))* &
662			rsun(knu)
663			END DO
664			END DO
665
666			! * 3.2 UPWARD FLUXES
667			! -------------
668
669
670			DO jl = 1, kdlon
671			pfu(jl, 1) = ((1.-pclear(jl))zdiff(jl)palbd(jl,knu)+pclear(jl)*zdirf(jl &
672			)palbp(jl,knu))rsun(knu)
673			END DO
674
675			DO jk = 2, kflev + 1
676			ikm1 = jk - 1
677			DO jl = 1, kdlon
678			zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
679			zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
680			zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
681			zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
682			END DO
683
684			CALL swtt1_lmdar4(knu, 4, iind, zw, zr)
685
686			DO jl = 1, kdlon
687			zdiff(jl) = zr(jl, 1)zr(jl, 2)zrk(jl, jaj, jk)
688			zdirf(jl) = zr(jl, 3)zr(jl, 4)zrk0(jl, jaj, jk)
689			pfu(jl, jk) = ((1.-pclear(jl))zdiff(jl)+pclear(jl)zdirf(jl))* &
690			rsun(knu)
691			END DO
692			END DO
693
694			! ------------------------------------------------------------------
695
696			RETURN
697			END SUBROUTINE sw1s_lmdar4
698			SUBROUTINE sw2s_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, paki, palbd, &
699			palbp, pcg, pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, &
700			pud, pwv, pqs, pfdown, pfup)
701			USE dimphy
702			USE radiation_ar4_param, ONLY: rsun, rray
703			USE infotrac_phy, ONLY: type_trac
704			#ifdef REPROBUS
705			USE chem_rep, ONLY: rsuntime, ok_suntime
706			#endif
707
708			IMPLICIT NONE
709			include "radepsi.h"
710
711			! ------------------------------------------------------------------
712			! PURPOSE.
713			! --------
714
715			! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN THE
716			! SECOND SPECTRAL INTERVAL FOLLOWING FOUQUART AND BONNEL (1980).
717
718			! METHOD.
719			! -------
720
721			! 1. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING TO
722			! CONTINUUM SCATTERING
723			! 2. COMPUTES REFLECTIVITY/TRANSMISSIVITY CORRESPONDING FOR
724			! A GREY MOLECULAR ABSORPTION
725			! 3. LAPLACE TRANSFORM ON THE PREVIOUS TO GET EFFECTIVE AMOUNTS
726			! OF ABSORBERS
727			! 4. APPLY H2O AND U.M.G. TRANSMISSION FUNCTIONS
728			! 5. MULTIPLY BY OZONE TRANSMISSION FUNCTION
729
730			! REFERENCE.
731			! ----------
732
733			! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
734			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
735
736			! AUTHOR.
737			! -------
738			! JEAN-JACQUES MORCRETTE ECMWF
739
740			! MODIFICATIONS.
741			! --------------
742			! ORIGINAL : 89-07-14
743			! 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
744			! ------------------------------------------------------------------
745			! * ARGUMENTS:
746
747			INTEGER knu
748			! -OB
749			REAL (KIND=8) flag_aer
750			REAL (KIND=8) tauae(kdlon, kflev, 2)
751			REAL (KIND=8) pizae(kdlon, kflev, 2)
752			REAL (KIND=8) cgae(kdlon, kflev, 2)
753			REAL (KIND=8) paer(kdlon, kflev, 5)
754			REAL (KIND=8) paki(kdlon, 2)
755			REAL (KIND=8) palbd(kdlon, 2)
756			REAL (KIND=8) palbp(kdlon, 2)
757			REAL (KIND=8) pcg(kdlon, 2, kflev)
758			REAL (KIND=8) pcld(kdlon, kflev)
759			REAL (KIND=8) pcldsw(kdlon, kflev)
760			REAL (KIND=8) pclear(kdlon)
761			REAL (KIND=8) pdsig(kdlon, kflev)
762			REAL (KIND=8) pomega(kdlon, 2, kflev)
763			REAL (KIND=8) poz(kdlon, kflev)
764			REAL (KIND=8) pqs(kdlon, kflev)
765			REAL (KIND=8) prmu(kdlon)
766			REAL (KIND=8) psec(kdlon)
767			REAL (KIND=8) ptau(kdlon, 2, kflev)
768			REAL (KIND=8) pud(kdlon, 5, kflev+1)
769			REAL (KIND=8) pwv(kdlon, kflev)
770
771			REAL (KIND=8) pfdown(kdlon, kflev+1)
772			REAL (KIND=8) pfup(kdlon, kflev+1)
773
774			! * LOCAL VARIABLES:
775
776			INTEGER iind2(2), iind3(3)
777			REAL (KIND=8) zcgaz(kdlon, kflev)
778			REAL (KIND=8) zfd(kdlon, kflev+1)
779			REAL (KIND=8) zfu(kdlon, kflev+1)
780			REAL (KIND=8) zg(kdlon)
781			REAL (KIND=8) zgg(kdlon)
782			REAL (KIND=8) zpizaz(kdlon, kflev)
783			REAL (KIND=8) zrayl(kdlon)
784			REAL (KIND=8) zray1(kdlon, kflev+1)
785			REAL (KIND=8) zray2(kdlon, kflev+1)
786			REAL (KIND=8) zref(kdlon)
787			REAL (KIND=8) zrefz(kdlon, 2, kflev+1)
788			REAL (KIND=8) zre1(kdlon)
789			REAL (KIND=8) zre2(kdlon)
790			REAL (KIND=8) zrj(kdlon, 6, kflev+1)
791			REAL (KIND=8) zrj0(kdlon, 6, kflev+1)
792			REAL (KIND=8) zrk(kdlon, 6, kflev+1)
793			REAL (KIND=8) zrk0(kdlon, 6, kflev+1)
794			REAL (KIND=8) zrl(kdlon, 8)
795			REAL (KIND=8) zrmue(kdlon, kflev+1)
796			REAL (KIND=8) zrmu0(kdlon, kflev+1)
797			REAL (KIND=8) zrmuz(kdlon)
798			REAL (KIND=8) zrneb(kdlon)
799			REAL (KIND=8) zruef(kdlon, 8)
800			REAL (KIND=8) zr1(kdlon)
801			REAL (KIND=8) zr2(kdlon, 2)
802			REAL (KIND=8) zr3(kdlon, 3)
803			REAL (KIND=8) zr4(kdlon)
804			REAL (KIND=8) zr21(kdlon)
805			REAL (KIND=8) zr22(kdlon)
806			REAL (KIND=8) zs(kdlon)
807			REAL (KIND=8) ztauaz(kdlon, kflev)
808			REAL (KIND=8) zto1(kdlon)
809			REAL (KIND=8) ztr(kdlon, 2, kflev+1)
810			REAL (KIND=8) ztra1(kdlon, kflev+1)
811			REAL (KIND=8) ztra2(kdlon, kflev+1)
812			REAL (KIND=8) ztr1(kdlon)
813			REAL (KIND=8) ztr2(kdlon)
814			REAL (KIND=8) zw(kdlon)
815			REAL (KIND=8) zw1(kdlon)
816			REAL (KIND=8) zw2(kdlon, 2)
817			REAL (KIND=8) zw3(kdlon, 3)
818			REAL (KIND=8) zw4(kdlon)
819			REAL (KIND=8) zw5(kdlon)
820
821			INTEGER jl, jk, k, jaj, ikm1, ikl, jn, jabs, jkm1
822			INTEGER jref, jkl, jklp1, jajp, jkki, jkkp4, jn2j, iabs
823			REAL (KIND=8) zrmum1, zwh2o, zcneb, zaa, zbb, zrki, zre11
824
825			! If running with Reporbus, overwrite default values of RSUN.
826			! Otherwise keep default values from radiation_AR4_param module.
827			IF (type_trac=='repr') THEN
828			#ifdef REPROBUS
829			IF (ok_suntime) THEN
830			rsun(1) = rsuntime(1)
831			rsun(2) = rsuntime(2)
832			END IF
833			#endif
834			END IF
835
836			! ------------------------------------------------------------------
837
838			! * 1. SECOND SPECTRAL INTERVAL (0.68-4.00 MICRON)
839			! -------------------------------------------
840
841
842
843			! * 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
844			! -----------------------------------------
845
846
847			DO jl = 1, kdlon
848			zrmum1 = 1. - prmu(jl)
849			zrayl(jl) = rray(knu, 1) + zrmum1(rray(knu,2)+zrmum1(rray(knu, &
850			3)+zrmum1(rray(knu,4)+zrmum1(rray(knu,5)+zrmum1*rray(knu,6)))))
851			END DO
852
853			! ------------------------------------------------------------------
854
855			! * 2. CONTINUUM SCATTERING CALCULATIONS
856			! ---------------------------------
857
858
859			! * 2.1 CLEAR-SKY FRACTION OF THE COLUMN
860			! --------------------------------
861
862
863			CALL swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, &
864			zrayl, psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, &
865			ztauaz, ztra1, ztra2)
866
867			! * 2.2 CLOUDY FRACTION OF THE COLUMN
868			! -----------------------------
869
870
871			CALL swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, &
872			zcgaz, zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, &
873			ztra2)
874
875			! ------------------------------------------------------------------
876
877			! * 3. SCATTERING CALCULATIONS WITH GREY MOLECULAR ABSORPTION
878			! ------------------------------------------------------
879
880
881			jn = 2
882
883			DO jabs = 1, 2
884			! * 3.1 SURFACE CONDITIONS
885			! ------------------
886
887
888			DO jl = 1, kdlon
889			zrefz(jl, 2, 1) = palbd(jl, knu)
890			zrefz(jl, 1, 1) = palbd(jl, knu)
891			END DO
892
893			! * 3.2 INTRODUCING CLOUD EFFECTS
894			! -------------------------
895
896
897			DO jk = 2, kflev + 1
898			jkm1 = jk - 1
899			ikl = kflev + 1 - jkm1
900			DO jl = 1, kdlon
901			zrneb(jl) = pcld(jl, jkm1)
902			IF (jabs==1 .AND. zrneb(jl)>2.*zeelog) THEN
903			zwh2o = max(pwv(jl,jkm1), zeelog)
904			zcneb = max(zeelog, min(zrneb(jl),1.-zeelog))
905			zbb = pud(jl, jabs, jkm1)*pqs(jl, jkm1)/zwh2o
906			zaa = max((pud(jl,jabs,jkm1)-zcneb*zbb)/(1.-zcneb), zeelog)
907			ELSE
908			zaa = pud(jl, jabs, jkm1)
909			zbb = zaa
910			END IF
911			zrki = paki(jl, jabs)
912			zs(jl) = exp(-zrkizaa1.66)
913			zg(jl) = exp(-zrki*zaa/zrmue(jl,jk))
914			ztr1(jl) = 0.
915			zre1(jl) = 0.
916			ztr2(jl) = 0.
917			zre2(jl) = 0.
918
919			zw(jl) = pomega(jl, knu, jkm1)
920			zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ztauaz(jl, jkm1)/zpizaz(jl, &
921			jkm1) + zbb*zrki
922
923			zr21(jl) = ptau(jl, knu, jkm1) + ztauaz(jl, jkm1)
924			zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
925			zgg(jl) = zr22(jl)pcg(jl, knu, jkm1) + (1.-zr22(jl))zcgaz(jl, jkm1)
926			zw(jl) = zr21(jl)/zto1(jl)
927			zref(jl) = zrefz(jl, 1, jkm1)
928			zrmuz(jl) = zrmue(jl, jk)
929			END DO
930
931			CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
932
933			DO jl = 1, kdlon
934
935			zrefz(jl, 2, jk) = (1.-zrneb(jl))(zray1(jl,jkm1)+zrefz(jl,2,jkm1) &
936			ztra1(jl,jkm1)ztra2(jl,jkm1))zg(jl)zs(jl) + zrneb(jl)zre1(jl)
937
938			ztr(jl, 2, jkm1) = zrneb(jl)ztr1(jl) + (ztra1(jl,jkm1))zg(jl)*(1.- &
939			zrneb(jl))
940
941			zrefz(jl, 1, jk) = (1.-zrneb(jl))(zray1(jl,jkm1)+zrefz(jl,1,jkm1) &
942			ztra1(jl,jkm1)ztra2(jl,jkm1)/(1.-zray2(jl,jkm1)zrefz(jl,1, &
943			jkm1)))zg(jl)zs(jl) + zrneb(jl)*zre2(jl)
944
945			ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ztra1(jl,jkm1)/(1.-zray2(jl, &
946			jkm1)zrefz(jl,1,jkm1)))zg(jl)*(1.-zrneb(jl))
947
948			END DO
949			END DO
950
951			! * 3.3 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
952			! -------------------------------------------------
953
954
955			DO jref = 1, 2
956
957			jn = jn + 1
958
959			DO jl = 1, kdlon
960			zrj(jl, jn, kflev+1) = 1.
961			zrk(jl, jn, kflev+1) = zrefz(jl, jref, kflev+1)
962			END DO
963
964			DO jk = 1, kflev
965			jkl = kflev + 1 - jk
966			jklp1 = jkl + 1
967			DO jl = 1, kdlon
968			zre11 = zrj(jl, jn, jklp1)*ztr(jl, jref, jkl)
969			zrj(jl, jn, jkl) = zre11
970			zrk(jl, jn, jkl) = zre11*zrefz(jl, jref, jkl)
971			END DO
972			END DO
973			END DO
974			END DO
975
976			! ------------------------------------------------------------------
977
978			! * 4. INVERT GREY AND CONTINUUM FLUXES
979			! --------------------------------
980
981
982
983			! * 4.1 UPWARD (ZRK) AND DOWNWARD (ZRJ) PSEUDO-FLUXES
984			! ---------------------------------------------
985
986
987			DO jk = 1, kflev + 1
988			DO jaj = 1, 5, 2
989			jajp = jaj + 1
990			DO jl = 1, kdlon
991			zrj(jl, jaj, jk) = zrj(jl, jaj, jk) - zrj(jl, jajp, jk)
992			zrk(jl, jaj, jk) = zrk(jl, jaj, jk) - zrk(jl, jajp, jk)
993			zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
994			zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
995			END DO
996			END DO
997			END DO
998
999			DO jk = 1, kflev + 1
1000			DO jaj = 2, 6, 2
1001			DO jl = 1, kdlon
1002			zrj(jl, jaj, jk) = max(zrj(jl,jaj,jk), zeelog)
1003			zrk(jl, jaj, jk) = max(zrk(jl,jaj,jk), zeelog)
1004			END DO
1005			END DO
1006			END DO
1007
1008			! * 4.2 EFFECTIVE ABSORBER AMOUNTS BY INVERSE LAPLACE
1009			! ---------------------------------------------
1010
1011
1012			DO jk = 1, kflev + 1
1013			jkki = 1
1014			DO jaj = 1, 2
1015			iind2(1) = jaj
1016			iind2(2) = jaj
1017			DO jn = 1, 2
1018			jn2j = jn + 2*jaj
1019			jkkp4 = jkki + 4
1020
1021			! * 4.2.1 EFFECTIVE ABSORBER AMOUNTS
1022			! --------------------------
1023
1024
1025			DO jl = 1, kdlon
1026			zw2(jl, 1) = log(zrj(jl,jn,jk)/zrj(jl,jn2j,jk))/paki(jl, jaj)
1027			zw2(jl, 2) = log(zrk(jl,jn,jk)/zrk(jl,jn2j,jk))/paki(jl, jaj)
1028			END DO
1029
1030			! * 4.2.2 TRANSMISSION FUNCTION
1031			! ---------------------
1032
1033
1034			CALL swtt1_lmdar4(knu, 2, iind2, zw2, zr2)
1035
1036			DO jl = 1, kdlon
1037			zrl(jl, jkki) = zr2(jl, 1)
1038			zruef(jl, jkki) = zw2(jl, 1)
1039			zrl(jl, jkkp4) = zr2(jl, 2)
1040			zruef(jl, jkkp4) = zw2(jl, 2)
1041			END DO
1042
1043			jkki = jkki + 1
1044			END DO
1045			END DO
1046
1047			! * 4.3 UPWARD AND DOWNWARD FLUXES WITH H2O AND UMG ABSORPTION
1048			! ------------------------------------------------------
1049
1050
1051			DO jl = 1, kdlon
1052			pfdown(jl, jk) = zrj(jl, 1, jk)zrl(jl, 1)zrl(jl, 3) + &
1053			zrj(jl, 2, jk)zrl(jl, 2)zrl(jl, 4)
1054			pfup(jl, jk) = zrk(jl, 1, jk)zrl(jl, 5)zrl(jl, 7) + &
1055			zrk(jl, 2, jk)zrl(jl, 6)zrl(jl, 8)
1056			END DO
1057			END DO
1058
1059			! ------------------------------------------------------------------
1060
1061			! * 5. MOLECULAR ABSORPTION ON CLEAR-SKY FLUXES
1062			! ----------------------------------------
1063
1064
1065
1066			! * 5.1 DOWNWARD FLUXES
1067			! ---------------
1068
1069
1070			jaj = 2
1071			iind3(1) = 1
1072			iind3(2) = 2
1073			iind3(3) = 3
1074
1075			DO jl = 1, kdlon
1076			zw3(jl, 1) = 0.
1077			zw3(jl, 2) = 0.
1078			zw3(jl, 3) = 0.
1079			zw4(jl) = 0.
1080			zw5(jl) = 0.
1081			zr4(jl) = 1.
1082			zfd(jl, kflev+1) = zrj0(jl, jaj, kflev+1)
1083			END DO
1084			DO jk = 1, kflev
1085			ikl = kflev + 1 - jk
1086			DO jl = 1, kdlon
1087			zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
1088			zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikl)/zrmu0(jl, ikl)
1089			zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikl)/zrmu0(jl, ikl)
1090			zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmu0(jl, ikl)
1091			zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmu0(jl, ikl)
1092			END DO
1093
1094			CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3)
1095
1096			DO jl = 1, kdlon
1097			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1098			zfd(jl, ikl) = zr3(jl, 1)zr3(jl, 2)zr3(jl, 3)zr4(jl) &
1099			zrj0(jl, jaj, ikl)
1100			END DO
1101			END DO
1102
1103			! * 5.2 UPWARD FLUXES
1104			! -------------
1105
1106
1107			DO jl = 1, kdlon
1108			zfu(jl, 1) = zfd(jl, 1)*palbp(jl, knu)
1109			END DO
1110
1111			DO jk = 2, kflev + 1
1112			ikm1 = jk - 1
1113			DO jl = 1, kdlon
1114			zw3(jl, 1) = zw3(jl, 1) + pud(jl, 1, ikm1)*1.66
1115			zw3(jl, 2) = zw3(jl, 2) + pud(jl, 2, ikm1)*1.66
1116			zw3(jl, 3) = zw3(jl, 3) + poz(jl, ikm1)*1.66
1117			zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
1118			zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
1119			END DO
1120
1121			CALL swtt1_lmdar4(knu, 3, iind3, zw3, zr3)
1122
1123			DO jl = 1, kdlon
1124			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1125			zfu(jl, jk) = zr3(jl, 1)zr3(jl, 2)zr3(jl, 3)zr4(jl) &
1126			zrk0(jl, jaj, jk)
1127			END DO
1128			END DO
1129
1130			! ------------------------------------------------------------------
1131
1132			! * 6. INTRODUCTION OF OZONE AND H2O CONTINUUM ABSORPTION
1133			! --------------------------------------------------
1134
1135			iabs = 3
1136
1137			! * 6.1 DOWNWARD FLUXES
1138			! ---------------
1139
1140			DO jl = 1, kdlon
1141			zw1(jl) = 0.
1142			zw4(jl) = 0.
1143			zw5(jl) = 0.
1144			zr1(jl) = 0.
1145			pfdown(jl, kflev+1) = ((1.-pclear(jl))pfdown(jl,kflev+1)+pclear(jl)zfd( &
1146			jl,kflev+1))*rsun(knu)
1147			END DO
1148
1149			DO jk = 1, kflev
1150			ikl = kflev + 1 - jk
1151			DO jl = 1, kdlon
1152			zw1(jl) = zw1(jl) + poz(jl, ikl)/zrmue(jl, ikl)
1153			zw4(jl) = zw4(jl) + pud(jl, 4, ikl)/zrmue(jl, ikl)
1154			zw5(jl) = zw5(jl) + pud(jl, 5, ikl)/zrmue(jl, ikl)
1155			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1156			END DO
1157
1158			CALL swtt_lmdar4(knu, iabs, zw1, zr1)
1159
1160			DO jl = 1, kdlon
1161			pfdown(jl, ikl) = ((1.-pclear(jl))zr1(jl)zr4(jl)*pfdown(jl,ikl)+ &
1162			pclear(jl)zfd(jl,ikl))rsun(knu)
1163			END DO
1164			END DO
1165
1166			! * 6.2 UPWARD FLUXES
1167			! -------------
1168
1169			DO jl = 1, kdlon
1170			pfup(jl, 1) = ((1.-pclear(jl))zr1(jl)zr4(jl)pfup(jl,1)+pclear(jl)zfu( &
1171			jl,1))*rsun(knu)
1172			END DO
1173
1174			DO jk = 2, kflev + 1
1175			ikm1 = jk - 1
1176			DO jl = 1, kdlon
1177			zw1(jl) = zw1(jl) + poz(jl, ikm1)*1.66
1178			zw4(jl) = zw4(jl) + pud(jl, 4, ikm1)*1.66
1179			zw5(jl) = zw5(jl) + pud(jl, 5, ikm1)*1.66
1180			! ZR4(JL) = EXP(-RSWCEZW4(JL)-RSWCPZW5(JL))
1181			END DO
1182
1183			CALL swtt_lmdar4(knu, iabs, zw1, zr1)
1184
1185			DO jl = 1, kdlon
1186			pfup(jl, jk) = ((1.-pclear(jl))zr1(jl)zr4(jl)pfup(jl,jk)+pclear(jl) &
1187			zfu(jl,jk))*rsun(knu)
1188			END DO
1189			END DO
1190
1191			! ------------------------------------------------------------------
1192
1193			RETURN
1194			END SUBROUTINE sw2s_lmdar4
1195			SUBROUTINE swclr_lmdar4(knu, paer, flag_aer, tauae, pizae, cgae, palbp, &
1196			pdsig, prayl, psec, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmu0, &
1197			ptauaz, ptra1, ptra2)
1198			USE dimphy
1199			USE radiation_ar4_param, ONLY: taua, rpiza, rcga
1200			IMPLICIT NONE
1201			include "radepsi.h"
1202			include "radopt.h"
1203
1204			! ------------------------------------------------------------------
1205			! PURPOSE.
1206			! --------
1207			! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
1208			! CLEAR-SKY COLUMN
1209
1210			! REFERENCE.
1211			! ----------
1212
1213			! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
1214			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
1215
1216			! AUTHOR.
1217			! -------
1218			! JEAN-JACQUES MORCRETTE ECMWF
1219
1220			! MODIFICATIONS.
1221			! --------------
1222			! ORIGINAL : 94-11-15
1223			! ------------------------------------------------------------------
1224			! * ARGUMENTS:
1225
1226			INTEGER knu
1227			! -OB
1228			REAL (KIND=8) flag_aer
1229			REAL (KIND=8) tauae(kdlon, kflev, 2)
1230			REAL (KIND=8) pizae(kdlon, kflev, 2)
1231			REAL (KIND=8) cgae(kdlon, kflev, 2)
1232			REAL (KIND=8) paer(kdlon, kflev, 5)
1233			REAL (KIND=8) palbp(kdlon, 2)
1234			REAL (KIND=8) pdsig(kdlon, kflev)
1235			REAL (KIND=8) prayl(kdlon)
1236			REAL (KIND=8) psec(kdlon)
1237
1238			REAL (KIND=8) pcgaz(kdlon, kflev)
1239			REAL (KIND=8) ppizaz(kdlon, kflev)
1240			REAL (KIND=8) pray1(kdlon, kflev+1)
1241			REAL (KIND=8) pray2(kdlon, kflev+1)
1242			REAL (KIND=8) prefz(kdlon, 2, kflev+1)
1243			REAL (KIND=8) prj(kdlon, 6, kflev+1)
1244			REAL (KIND=8) prk(kdlon, 6, kflev+1)
1245			REAL (KIND=8) prmu0(kdlon, kflev+1)
1246			REAL (KIND=8) ptauaz(kdlon, kflev)
1247			REAL (KIND=8) ptra1(kdlon, kflev+1)
1248			REAL (KIND=8) ptra2(kdlon, kflev+1)
1249
1250			! * LOCAL VARIABLES:
1251
1252			REAL (KIND=8) zc0i(kdlon, kflev+1)
1253			REAL (KIND=8) zcle0(kdlon, kflev)
1254			REAL (KIND=8) zclear(kdlon)
1255			REAL (KIND=8) zr21(kdlon)
1256			REAL (KIND=8) zr23(kdlon)
1257			REAL (KIND=8) zss0(kdlon)
1258			REAL (KIND=8) zscat(kdlon)
1259			REAL (KIND=8) ztr(kdlon, 2, kflev+1)
1260
1261			INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
1262			REAL (KIND=8) ztray, zgar, zratio, zff, zfacoa, zcorae
1263			REAL (KIND=8) zmue, zgap, zww, zto, zden, zmu1, zden1
1264			REAL (KIND=8) zbmu0, zbmu1, zre11
1265
1266			! ------------------------------------------------------------------
1267
1268			! * 1. OPTICAL PARAMETERS FOR AEROSOLS AND RAYLEIGH
1269			! --------------------------------------------
1270
1271
1272			! cdir collapse
1273			DO jk = 1, kflev + 1
1274			DO ja = 1, 6
1275			DO jl = 1, kdlon
1276			prj(jl, ja, jk) = 0.
1277			prk(jl, ja, jk) = 0.
1278			END DO
1279			END DO
1280			END DO
1281
1282			DO jk = 1, kflev
1283			! -OB
1284			! DO 104 JL = 1, KDLON
1285			! PCGAZ(JL,JK) = 0.
1286			! PPIZAZ(JL,JK) = 0.
1287			! PTAUAZ(JL,JK) = 0.
1288			! 104 CONTINUE
1289			! -OB
1290			! DO 106 JAE=1,5
1291			! DO 105 JL = 1, KDLON
1292			! PTAUAZ(JL,JK)=PTAUAZ(JL,JK)
1293			! S +PAER(JL,JK,JAE)*TAUA(KNU,JAE)
1294			! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)+PAER(JL,JK,JAE)
1295			! S * TAUA(KNU,JAE)*RPIZA(KNU,JAE)
1296			! PCGAZ(JL,JK) = PCGAZ(JL,JK) +PAER(JL,JK,JAE)
1297			! S * TAUA(KNU,JAE)RPIZA(KNU,JAE)RCGA(KNU,JAE)
1298			! 105 CONTINUE
1299			! 106 CONTINUE
1300			! -OB
1301			DO jl = 1, kdlon
1302			ptauaz(jl, jk) = flag_aer*tauae(jl, jk, knu)
1303			ppizaz(jl, jk) = flag_aer*pizae(jl, jk, knu)
1304			pcgaz(jl, jk) = flag_aer*cgae(jl, jk, knu)
1305			END DO
1306
1307			IF (flag_aer>0) THEN
1308			! -OB
1309			DO jl = 1, kdlon
1310			! PCGAZ(JL,JK)=PCGAZ(JL,JK)/PPIZAZ(JL,JK)
1311			! PPIZAZ(JL,JK)=PPIZAZ(JL,JK)/PTAUAZ(JL,JK)
1312			ztray = prayl(jl)*pdsig(jl, jk)
1313			zratio = ztray/(ztray+ptauaz(jl,jk))
1314			zgar = pcgaz(jl, jk)
1315			zff = zgar*zgar
1316			ptauaz(jl, jk) = ztray + ptauaz(jl, jk)(1.-ppizaz(jl,jk)zff)
1317			pcgaz(jl, jk) = zgar*(1.-zratio)/(1.+zgar)
1318			ppizaz(jl, jk) = zratio + (1.-zratio)ppizaz(jl, jk)(1.-zff)/(1.- &
1319			ppizaz(jl,jk)*zff)
1320			END DO
1321			ELSE
1322			DO jl = 1, kdlon
1323			ztray = prayl(jl)*pdsig(jl, jk)
1324			ptauaz(jl, jk) = ztray
1325			pcgaz(jl, jk) = 0.
1326			ppizaz(jl, jk) = 1. - repsct
1327			END DO
1328			END IF ! check flag_aer
1329			! 107 CONTINUE
1330			! PRINT 9107,JK,((PAER(JL,JK,JAE),JAE=1,5)
1331			! $ ,PTAUAZ(JL,JK),PPIZAZ(JL,JK),PCGAZ(JL,JK),JL=1,KDLON)
1332			! 9107 FORMAT(1X,'SWCLR_107',I3,8E12.5)
1333
1334			END DO
1335
1336			! ------------------------------------------------------------------
1337
1338			! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
1339			! ----------------------------------------------
1340
1341
1342			DO jl = 1, kdlon
1343			zr23(jl) = 0.
1344			zc0i(jl, kflev+1) = 0.
1345			zclear(jl) = 1.
1346			zscat(jl) = 0.
1347			END DO
1348
1349			jk = 1
1350			jkl = kflev + 1 - jk
1351			jklp1 = jkl + 1
1352			DO jl = 1, kdlon
1353			zfacoa = 1. - ppizaz(jl, jkl)pcgaz(jl, jkl)pcgaz(jl, jkl)
1354			zcorae = zfacoaptauaz(jl, jkl)psec(jl)
1355			zr21(jl) = exp(-zcorae)
1356			zss0(jl) = 1. - zr21(jl)
1357			zcle0(jl, jkl) = zss0(jl)
1358
1359			IF (novlp==1) THEN
1360			! * maximum-random
1361			zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
1362			(1.0-min(zscat(jl),1.-zepsec))
1363			zc0i(jl, jkl) = 1.0 - zclear(jl)
1364			zscat(jl) = zss0(jl)
1365			ELSE IF (novlp==2) THEN
1366			! * maximum
1367			zscat(jl) = max(zss0(jl), zscat(jl))
1368			zc0i(jl, jkl) = zscat(jl)
1369			ELSE IF (novlp==3) THEN
1370			! * random
1371			zclear(jl) = zclear(jl)*(1.0-zss0(jl))
1372			zscat(jl) = 1.0 - zclear(jl)
1373			zc0i(jl, jkl) = zscat(jl)
1374			END IF
1375			END DO
1376
1377			DO jk = 2, kflev
1378			jkl = kflev + 1 - jk
1379			jklp1 = jkl + 1
1380			DO jl = 1, kdlon
1381			zfacoa = 1. - ppizaz(jl, jkl)pcgaz(jl, jkl)pcgaz(jl, jkl)
1382			zcorae = zfacoaptauaz(jl, jkl)psec(jl)
1383			zr21(jl) = exp(-zcorae)
1384			zss0(jl) = 1. - zr21(jl)
1385			zcle0(jl, jkl) = zss0(jl)
1386
1387			IF (novlp==1) THEN
1388			! * maximum-random
1389			zclear(jl) = zclear(jl)*(1.0-max(zss0(jl),zscat(jl)))/ &
1390			(1.0-min(zscat(jl),1.-zepsec))
1391			zc0i(jl, jkl) = 1.0 - zclear(jl)
1392			zscat(jl) = zss0(jl)
1393			ELSE IF (novlp==2) THEN
1394			! * maximum
1395			zscat(jl) = max(zss0(jl), zscat(jl))
1396			zc0i(jl, jkl) = zscat(jl)
1397			ELSE IF (novlp==3) THEN
1398			! * random
1399			zclear(jl) = zclear(jl)*(1.0-zss0(jl))
1400			zscat(jl) = 1.0 - zclear(jl)
1401			zc0i(jl, jkl) = zscat(jl)
1402			END IF
1403			END DO
1404			END DO
1405
1406			! ------------------------------------------------------------------
1407
1408			! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
1409			! -----------------------------------------------
1410
1411
1412			DO jl = 1, kdlon
1413			pray1(jl, kflev+1) = 0.
1414			pray2(jl, kflev+1) = 0.
1415			prefz(jl, 2, 1) = palbp(jl, knu)
1416			prefz(jl, 1, 1) = palbp(jl, knu)
1417			ptra1(jl, kflev+1) = 1.
1418			ptra2(jl, kflev+1) = 1.
1419			END DO
1420
1421			DO jk = 2, kflev + 1
1422			jkm1 = jk - 1
1423			DO jl = 1, kdlon
1424
1425			! ------------------------------------------------------------------
1426
1427			! * 3.1 EQUIVALENT ZENITH ANGLE
1428			! -----------------------
1429
1430
1431			zmue = (1.-zc0i(jl,jk))psec(jl) + zc0i(jl, jk)1.66
1432			prmu0(jl, jk) = 1./zmue
1433
1434			! ------------------------------------------------------------------
1435
1436			! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
1437			! ----------------------------------------------------
1438
1439
1440			zgap = pcgaz(jl, jkm1)
1441			zbmu0 = 0.5 - 0.75*zgap/zmue
1442			zww = ppizaz(jl, jkm1)
1443			zto = ptauaz(jl, jkm1)
1444			zden = 1. + (1.-zww+zbmu0zww)ztozmue + (1-zww)(1.-zww+2.zbmu0zww) &
1445			ztoztozmuezmue
1446			pray1(jl, jkm1) = zbmu0zwwzto*zmue/zden
1447			ptra1(jl, jkm1) = 1./zden
1448
1449			zmu1 = 0.5
1450			zbmu1 = 0.5 - 0.75zgapzmu1
1451			zden1 = 1. + (1.-zww+zbmu1zww)zto/zmu1 + (1-zww)(1.-zww+2.zbmu1*zww &
1452			)ztozto/zmu1/zmu1
1453			pray2(jl, jkm1) = zbmu1zwwzto/zmu1/zden1
1454			ptra2(jl, jkm1) = 1./zden1
1455
1456
1457
1458			prefz(jl, 1, jk) = (pray1(jl,jkm1)+prefz(jl,1,jkm1)ptra1(jl,jkm1) &
1459			ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1,jkm1)))
1460
1461			ztr(jl, 1, jkm1) = (ptra1(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
1462			jkm1)))
1463
1464			prefz(jl, 2, jk) = (pray1(jl,jkm1)+prefz(jl,2,jkm1)ptra1(jl,jkm1) &
1465			ptra2(jl,jkm1))
1466
1467			ztr(jl, 2, jkm1) = ptra1(jl, jkm1)
1468
1469			END DO
1470			END DO
1471			DO jl = 1, kdlon
1472			zmue = (1.-zc0i(jl,1))psec(jl) + zc0i(jl, 1)1.66
1473			prmu0(jl, 1) = 1./zmue
1474			END DO
1475
1476			! ------------------------------------------------------------------
1477
1478			! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
1479			! -------------------------------------------------
1480
1481
1482			IF (knu==1) THEN
1483			jaj = 2
1484			DO jl = 1, kdlon
1485			prj(jl, jaj, kflev+1) = 1.
1486			prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
1487			END DO
1488
1489			DO jk = 1, kflev
1490			jkl = kflev + 1 - jk
1491			jklp1 = jkl + 1
1492			DO jl = 1, kdlon
1493			zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
1494			prj(jl, jaj, jkl) = zre11
1495			prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
1496			END DO
1497			END DO
1498
1499			ELSE
1500
1501			DO jaj = 1, 2
1502			DO jl = 1, kdlon
1503			prj(jl, jaj, kflev+1) = 1.
1504			prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
1505			END DO
1506
1507			DO jk = 1, kflev
1508			jkl = kflev + 1 - jk
1509			jklp1 = jkl + 1
1510			DO jl = 1, kdlon
1511			zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
1512			prj(jl, jaj, jkl) = zre11
1513			prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
1514			END DO
1515			END DO
1516			END DO
1517
1518			END IF
1519
1520			! ------------------------------------------------------------------
1521
1522			RETURN
1523			END SUBROUTINE swclr_lmdar4
1524			SUBROUTINE swr_lmdar4(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, &
1525			ptau, pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &
1526			ptra2)
1527			USE dimphy
1528			IMPLICIT NONE
1529			include "radepsi.h"
1530			include "radopt.h"
1531
1532			! ------------------------------------------------------------------
1533			! PURPOSE.
1534			! --------
1535			! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
1536			! CONTINUUM SCATTERING
1537
1538			! METHOD.
1539			! -------
1540
1541			! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
1542			! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
1543
1544			! REFERENCE.
1545			! ----------
1546
1547			! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
1548			! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
1549
1550			! AUTHOR.
1551			! -------
1552			! JEAN-JACQUES MORCRETTE ECMWF
1553
1554			! MODIFICATIONS.
1555			! --------------
1556			! ORIGINAL : 89-07-14
1557			! ------------------------------------------------------------------
1558			! * ARGUMENTS:
1559
1560			INTEGER knu
1561			REAL (KIND=8) palbd(kdlon, 2)
1562			REAL (KIND=8) pcg(kdlon, 2, kflev)
1563			REAL (KIND=8) pcld(kdlon, kflev)
1564			REAL (KIND=8) pdsig(kdlon, kflev)
1565			REAL (KIND=8) pomega(kdlon, 2, kflev)
1566			REAL (KIND=8) prayl(kdlon)
1567			REAL (KIND=8) psec(kdlon)
1568			REAL (KIND=8) ptau(kdlon, 2, kflev)
1569
1570			REAL (KIND=8) pray1(kdlon, kflev+1)
1571			REAL (KIND=8) pray2(kdlon, kflev+1)
1572			REAL (KIND=8) prefz(kdlon, 2, kflev+1)
1573			REAL (KIND=8) prj(kdlon, 6, kflev+1)
1574			REAL (KIND=8) prk(kdlon, 6, kflev+1)
1575			REAL (KIND=8) prmue(kdlon, kflev+1)
1576			REAL (KIND=8) pcgaz(kdlon, kflev)
1577			REAL (KIND=8) ppizaz(kdlon, kflev)
1578			REAL (KIND=8) ptauaz(kdlon, kflev)
1579			REAL (KIND=8) ptra1(kdlon, kflev+1)
1580			REAL (KIND=8) ptra2(kdlon, kflev+1)
1581
1582			! * LOCAL VARIABLES:
1583
1584			REAL (KIND=8) zc1i(kdlon, kflev+1)
1585			REAL (KIND=8) zcleq(kdlon, kflev)
1586			REAL (KIND=8) zclear(kdlon)
1587			REAL (KIND=8) zcloud(kdlon)
1588			REAL (KIND=8) zgg(kdlon)
1589			REAL (KIND=8) zref(kdlon)
1590			REAL (KIND=8) zre1(kdlon)
1591			REAL (KIND=8) zre2(kdlon)
1592			REAL (KIND=8) zrmuz(kdlon)
1593			REAL (KIND=8) zrneb(kdlon)
1594			REAL (KIND=8) zr21(kdlon)
1595			REAL (KIND=8) zr22(kdlon)
1596			REAL (KIND=8) zr23(kdlon)
1597			REAL (KIND=8) zss1(kdlon)
1598			REAL (KIND=8) zto1(kdlon)
1599			REAL (KIND=8) ztr(kdlon, 2, kflev+1)
1600			REAL (KIND=8) ztr1(kdlon)
1601			REAL (KIND=8) ztr2(kdlon)
1602			REAL (KIND=8) zw(kdlon)
1603
1604			INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
1605			REAL (KIND=8) zfacoa, zfacoc, zcorae, zcorcd
1606			REAL (KIND=8) zmue, zgap, zww, zto, zden, zden1
1607			REAL (KIND=8) zmu1, zre11, zbmu0, zbmu1
1608
1609			! ------------------------------------------------------------------
1610
1611			! * 1. INITIALIZATION
1612			! --------------
1613
1614
1615			DO jk = 1, kflev + 1
1616			DO ja = 1, 6
1617			DO jl = 1, kdlon
1618			prj(jl, ja, jk) = 0.
1619			prk(jl, ja, jk) = 0.
1620			END DO
1621			END DO
1622			END DO
1623
1624			! ------------------------------------------------------------------
1625
1626			! * 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
1627			! ----------------------------------------------
1628
1629
1630			DO jl = 1, kdlon
1631			zr23(jl) = 0.
1632			zc1i(jl, kflev+1) = 0.
1633			zclear(jl) = 1.
1634			zcloud(jl) = 0.
1635			END DO
1636
1637			jk = 1
1638			jkl = kflev + 1 - jk
1639			jklp1 = jkl + 1
1640			DO jl = 1, kdlon
1641			zfacoa = 1. - ppizaz(jl, jkl)pcgaz(jl, jkl)pcgaz(jl, jkl)
1642			zfacoc = 1. - pomega(jl, knu, jkl)pcg(jl, knu, jkl)pcg(jl, knu, jkl)
1643			zcorae = zfacoaptauaz(jl, jkl)psec(jl)
1644			zcorcd = zfacocptau(jl, knu, jkl)psec(jl)
1645			zr21(jl) = exp(-zcorae)
1646			zr22(jl) = exp(-zcorcd)
1647			zss1(jl) = pcld(jl, jkl)(1.0-zr21(jl)zr22(jl)) + &
1648			(1.0-pcld(jl,jkl))*(1.0-zr21(jl))
1649			zcleq(jl, jkl) = zss1(jl)
1650
1651			IF (novlp==1) THEN
1652			! * maximum-random
1653			zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
1654			(1.0-min(zcloud(jl),1.-zepsec))
1655			zc1i(jl, jkl) = 1.0 - zclear(jl)
1656			zcloud(jl) = zss1(jl)
1657			ELSE IF (novlp==2) THEN
1658			! * maximum
1659			zcloud(jl) = max(zss1(jl), zcloud(jl))
1660			zc1i(jl, jkl) = zcloud(jl)
1661			ELSE IF (novlp==3) THEN
1662			! * random
1663			zclear(jl) = zclear(jl)*(1.0-zss1(jl))
1664			zcloud(jl) = 1.0 - zclear(jl)
1665			zc1i(jl, jkl) = zcloud(jl)
1666			END IF
1667			END DO
1668
1669			DO jk = 2, kflev
1670			jkl = kflev + 1 - jk
1671			jklp1 = jkl + 1
1672			DO jl = 1, kdlon
1673			zfacoa = 1. - ppizaz(jl, jkl)pcgaz(jl, jkl)pcgaz(jl, jkl)
1674			zfacoc = 1. - pomega(jl, knu, jkl)pcg(jl, knu, jkl)pcg(jl, knu, jkl)
1675			zcorae = zfacoaptauaz(jl, jkl)psec(jl)
1676			zcorcd = zfacocptau(jl, knu, jkl)psec(jl)
1677			zr21(jl) = exp(-zcorae)
1678			zr22(jl) = exp(-zcorcd)
1679			zss1(jl) = pcld(jl, jkl)(1.0-zr21(jl)zr22(jl)) + &
1680			(1.0-pcld(jl,jkl))*(1.0-zr21(jl))
1681			zcleq(jl, jkl) = zss1(jl)
1682
1683			IF (novlp==1) THEN
1684			! * maximum-random
1685			zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
1686			(1.0-min(zcloud(jl),1.-zepsec))
1687			zc1i(jl, jkl) = 1.0 - zclear(jl)
1688			zcloud(jl) = zss1(jl)
1689			ELSE IF (novlp==2) THEN
1690			! * maximum
1691			zcloud(jl) = max(zss1(jl), zcloud(jl))
1692			zc1i(jl, jkl) = zcloud(jl)
1693			ELSE IF (novlp==3) THEN
1694			! * random
1695			zclear(jl) = zclear(jl)*(1.0-zss1(jl))
1696			zcloud(jl) = 1.0 - zclear(jl)
1697			zc1i(jl, jkl) = zcloud(jl)
1698			END IF
1699			END DO
1700			END DO
1701
1702			! ------------------------------------------------------------------
1703
1704			! * 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
1705			! -----------------------------------------------
1706
1707
1708			DO jl = 1, kdlon
1709			pray1(jl, kflev+1) = 0.
1710			pray2(jl, kflev+1) = 0.
1711			prefz(jl, 2, 1) = palbd(jl, knu)
1712			prefz(jl, 1, 1) = palbd(jl, knu)
1713			ptra1(jl, kflev+1) = 1.
1714			ptra2(jl, kflev+1) = 1.
1715			END DO
1716
1717			DO jk = 2, kflev + 1
1718			jkm1 = jk - 1
1719			DO jl = 1, kdlon
1720			zrneb(jl) = pcld(jl, jkm1)
1721			zre1(jl) = 0.
1722			ztr1(jl) = 0.
1723			zre2(jl) = 0.
1724			ztr2(jl) = 0.
1725
1726			! ------------------------------------------------------------------
1727
1728			! * 3.1 EQUIVALENT ZENITH ANGLE
1729			! -----------------------
1730
1731
1732			zmue = (1.-zc1i(jl,jk))psec(jl) + zc1i(jl, jk)1.66
1733			prmue(jl, jk) = 1./zmue
1734
1735			! ------------------------------------------------------------------
1736
1737			! * 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
1738			! ----------------------------------------------------
1739
1740
1741			zgap = pcgaz(jl, jkm1)
1742			zbmu0 = 0.5 - 0.75*zgap/zmue
1743			zww = ppizaz(jl, jkm1)
1744			zto = ptauaz(jl, jkm1)
1745			zden = 1. + (1.-zww+zbmu0zww)ztozmue + (1-zww)(1.-zww+2.zbmu0zww) &
1746			ztoztozmuezmue
1747			pray1(jl, jkm1) = zbmu0zwwzto*zmue/zden
1748			ptra1(jl, jkm1) = 1./zden
1749			! PRINT ,' LOOP 342 * 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
1750
1751			zmu1 = 0.5
1752			zbmu1 = 0.5 - 0.75zgapzmu1
1753			zden1 = 1. + (1.-zww+zbmu1zww)zto/zmu1 + (1-zww)(1.-zww+2.zbmu1*zww &
1754			)ztozto/zmu1/zmu1
1755			pray2(jl, jkm1) = zbmu1zwwzto/zmu1/zden1
1756			ptra2(jl, jkm1) = 1./zden1
1757
1758			! ------------------------------------------------------------------
1759
1760			! * 3.3 EFFECT OF CLOUD LAYER
1761			! ---------------------
1762
1763
1764			zw(jl) = pomega(jl, knu, jkm1)
1765			zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, &
1766			jkm1)
1767			zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1)
1768			zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
1769			zgg(jl) = zr22(jl)pcg(jl, knu, jkm1) + (1.-zr22(jl))pcgaz(jl, jkm1)
1770			! Modif PhD - JJM 19/03/96 pour erreurs arrondis
1771			! machine
1772			! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
1773			IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN
1774			zw(jl) = 1.
1775			ELSE
1776			zw(jl) = zr21(jl)/zto1(jl)
1777			END IF
1778			zref(jl) = prefz(jl, 1, jkm1)
1779			zrmuz(jl) = prmue(jl, jk)
1780			END DO
1781
1782			CALL swde_lmdar4(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
1783
1784			DO jl = 1, kdlon
1785
1786			prefz(jl, 1, jk) = (1.-zrneb(jl))(pray1(jl,jkm1)+prefz(jl,1,jkm1) &
1787			ptra1(jl,jkm1)ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)prefz(jl,1, &
1788			jkm1))) + zrneb(jl)*zre2(jl)
1789
1790			ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &
1791			jkm1)prefz(jl,1,jkm1)))(1.-zrneb(jl))
1792
1793			prefz(jl, 2, jk) = (1.-zrneb(jl))(pray1(jl,jkm1)+prefz(jl,2,jkm1) &
1794			ptra1(jl,jkm1)ptra2(jl,jkm1)) + zrneb(jl)zre1(jl)
1795
1796			ztr(jl, 2, jkm1) = zrneb(jl)ztr1(jl) + ptra1(jl, jkm1)(1.-zrneb(jl))
1797
1798			END DO
1799			END DO
1800			DO jl = 1, kdlon
1801			zmue = (1.-zc1i(jl,1))psec(jl) + zc1i(jl, 1)1.66
1802			prmue(jl, 1) = 1./zmue
1803			END DO
1804
1805			! ------------------------------------------------------------------
1806
1807			! * 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
1808			! -------------------------------------------------
1809
1810
1811			IF (knu==1) THEN
1812			jaj = 2
1813			DO jl = 1, kdlon
1814			prj(jl, jaj, kflev+1) = 1.
1815			prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
1816			END DO
1817
1818			DO jk = 1, kflev
1819			jkl = kflev + 1 - jk
1820			jklp1 = jkl + 1
1821			DO jl = 1, kdlon
1822			zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
1823			prj(jl, jaj, jkl) = zre11
1824			prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
1825			END DO
1826			END DO
1827
1828			ELSE
1829
1830			DO jaj = 1, 2
1831			DO jl = 1, kdlon
1832			prj(jl, jaj, kflev+1) = 1.
1833			prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
1834			END DO
1835
1836			DO jk = 1, kflev
1837			jkl = kflev + 1 - jk
1838			jklp1 = jkl + 1
1839			DO jl = 1, kdlon
1840			zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
1841			prj(jl, jaj, jkl) = zre11
1842			prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
1843			END DO
1844			END DO
1845			END DO
1846
1847			END IF
1848
1849			! ------------------------------------------------------------------
1850
1851			RETURN
1852			END SUBROUTINE swr_lmdar4
1853			SUBROUTINE swde_lmdar4(pgg, pref, prmuz, pto1, pw, pre1, pre2, ptr1, ptr2)
1854			USE dimphy
1855			IMPLICIT NONE
1856
1857			! ------------------------------------------------------------------
1858			! PURPOSE.
1859			! --------
1860			! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY OF A CLOUDY
1861			! LAYER USING THE DELTA-EDDINGTON'S APPROXIMATION.
1862
1863			! METHOD.
1864			! -------
1865
1866			! STANDARD DELTA-EDDINGTON LAYER CALCULATIONS.
1867
1868			! REFERENCE.
1869			! ----------
1870
1871			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
1872			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
1873
1874			! AUTHOR.
1875			! -------
1876			! JEAN-JACQUES MORCRETTE ECMWF
1877
1878			! MODIFICATIONS.
1879			! --------------
1880			! ORIGINAL : 88-12-15
1881			! ------------------------------------------------------------------
1882			! * ARGUMENTS:
1883
1884			REAL (KIND=8) pgg(kdlon) ! ASSYMETRY FACTOR
1885			REAL (KIND=8) pref(kdlon) ! REFLECTIVITY OF THE UNDERLYING LAYER
1886			REAL (KIND=8) prmuz(kdlon) ! COSINE OF SOLAR ZENITH ANGLE
1887			REAL (KIND=8) pto1(kdlon) ! OPTICAL THICKNESS
1888			REAL (KIND=8) pw(kdlon) ! SINGLE SCATTERING ALBEDO
1889			REAL (KIND=8) pre1(kdlon) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
1890			REAL (KIND=8) pre2(kdlon) ! LAYER REFLECTIVITY
1891			REAL (KIND=8) ptr1(kdlon) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
1892			REAL (KIND=8) ptr2(kdlon) ! LAYER TRANSMISSIVITY
1893
1894			! * LOCAL VARIABLES:
1895
1896			INTEGER jl
1897			REAL (KIND=8) zff, zgp, ztop, zwcp, zdt, zx1, zwm
1898			REAL (KIND=8) zrm2, zrk, zx2, zrp, zalpha, zbeta, zarg
1899			REAL (KIND=8) zexmu0, zarg2, zexkp, zexkm, zxp2p, zxm2p, zap2b, zam2b
1900			REAL (KIND=8) za11, za12, za13, za21, za22, za23
1901			REAL (KIND=8) zdena, zc1a, zc2a, zri0a, zri1a
1902			REAL (KIND=8) zri0b, zri1b
1903			REAL (KIND=8) zb21, zb22, zb23, zdenb, zc1b, zc2b
1904			REAL (KIND=8) zri0c, zri1c, zri0d, zri1d
1905
1906			! ------------------------------------------------------------------
1907
1908			! * 1. DELTA-EDDINGTON CALCULATIONS
1909
1910
1911			DO jl = 1, kdlon
1912			! * 1.1 SET UP THE DELTA-MODIFIED PARAMETERS
1913
1914
1915			zff = pgg(jl)*pgg(jl)
1916			zgp = pgg(jl)/(1.+pgg(jl))
1917			ztop = (1.-pw(jl)zff)pto1(jl)
1918			zwcp = (1-zff)pw(jl)/(1.-pw(jl)zff)
1919			zdt = 2./3.
1920			zx1 = 1. - zwcp*zgp
1921			zwm = 1. - zwcp
1922			zrm2 = prmuz(jl)*prmuz(jl)
1923			zrk = sqrt(3.zwmzx1)
1924			zx2 = 4.(1.-zrkzrk*zrm2)
1925			zrp = zrk/zx1
1926			zalpha = 3.zwcpzrm2(1.+zgpzwm)/zx2
1927			zbeta = 3.zwcpprmuz(jl)(1.+3.zgpzrm2zwm)/zx2
1928			zarg = min(ztop/prmuz(jl), 200._8)
1929			zexmu0 = exp(-zarg)
1930			zarg2 = min(zrk*ztop, 200._8)
1931			zexkp = exp(zarg2)
1932			zexkm = 1./zexkp
1933			zxp2p = 1. + zdt*zrp
1934			zxm2p = 1. - zdt*zrp
1935			zap2b = zalpha + zdt*zbeta
1936			zam2b = zalpha - zdt*zbeta
1937
1938			! * 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER
1939
1940
1941			za11 = zxp2p
1942			za12 = zxm2p
1943			za13 = zap2b
1944			za22 = zxp2p*zexkp
1945			za21 = zxm2p*zexkm
1946			za23 = zam2b*zexmu0
1947			zdena = za11za22 - za21za12
1948			zc1a = (za22za13-za12za23)/zdena
1949			zc2a = (za11za23-za21za13)/zdena
1950			zri0a = zc1a + zc2a - zalpha
1951			zri1a = zrp*(zc1a-zc2a) - zbeta
1952			pre1(jl) = (zri0a-zdt*zri1a)/prmuz(jl)
1953			zri0b = zc1azexkm + zc2azexkp - zalpha*zexmu0
1954			zri1b = zrp(zc1azexkm-zc2azexkp) - zbetazexmu0
1955			ptr1(jl) = zexmu0 + (zri0b+zdt*zri1b)/prmuz(jl)
1956
1957			! * 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER
1958
1959
1960			zb21 = za21 - pref(jl)zxp2pzexkm
1961			zb22 = za22 - pref(jl)zxm2pzexkp
1962			zb23 = za23 - pref(jl)zexmu0(zap2b-prmuz(jl))
1963			zdenb = za11zb22 - zb21za12
1964			zc1b = (zb22za13-za12zb23)/zdenb
1965			zc2b = (za11zb23-zb21za13)/zdenb
1966			zri0c = zc1b + zc2b - zalpha
1967			zri1c = zrp*(zc1b-zc2b) - zbeta
1968			pre2(jl) = (zri0c-zdt*zri1c)/prmuz(jl)
1969			zri0d = zc1bzexkm + zc2bzexkp - zalpha*zexmu0
1970			zri1d = zrp(zc1bzexkm-zc2bzexkp) - zbetazexmu0
1971			ptr2(jl) = zexmu0 + (zri0d+zdt*zri1d)/prmuz(jl)
1972
1973			END DO
1974			RETURN
1975			END SUBROUTINE swde_lmdar4
1976			SUBROUTINE swtt_lmdar4(knu, ka, pu, ptr)
1977			USE dimphy
1978			USE radiation_ar4_param, ONLY: apad, bpad, d
1979			IMPLICIT NONE
1980
1981			! -----------------------------------------------------------------------
1982			! PURPOSE.
1983			! --------
1984			! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
1985			! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
1986			! INTERVALS.
1987
1988			! METHOD.
1989			! -------
1990
1991			! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
1992			! AND HORNER'S ALGORITHM.
1993
1994			! REFERENCE.
1995			! ----------
1996
1997			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
1998			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
1999
2000			! AUTHOR.
2001			! -------
2002			! JEAN-JACQUES MORCRETTE ECMWF
2003
2004			! MODIFICATIONS.
2005			! --------------
2006			! ORIGINAL : 88-12-15
2007			! -----------------------------------------------------------------------
2008
2009			! * ARGUMENTS
2010
2011			INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
2012			INTEGER ka ! INDEX OF THE ABSORBER
2013			REAL (KIND=8) pu(kdlon) ! ABSORBER AMOUNT
2014
2015			REAL (KIND=8) ptr(kdlon) ! TRANSMISSION FUNCTION
2016
2017			! * LOCAL VARIABLES:
2018
2019			REAL (KIND=8) zr1(kdlon), zr2(kdlon)
2020			INTEGER jl, i, j
2021
2022			! -----------------------------------------------------------------------
2023
2024			! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2025
2026
2027			DO jl = 1, kdlon
2028			zr1(jl) = apad(knu, ka, 1) + pu(jl)(apad(knu,ka,2)+pu(jl)(apad(knu,ka, &
2029			3)+pu(jl)(apad(knu,ka,4)+pu(jl)(apad(knu,ka,5)+pu(jl)*(apad(knu,ka,6) &
2030			+pu(jl)*(apad(knu,ka,7)))))))
2031
2032			zr2(jl) = bpad(knu, ka, 1) + pu(jl)(bpad(knu,ka,2)+pu(jl)(bpad(knu,ka, &
2033			3)+pu(jl)(bpad(knu,ka,4)+pu(jl)(bpad(knu,ka,5)+pu(jl)*(bpad(knu,ka,6) &
2034			+pu(jl)*(bpad(knu,ka,7)))))))
2035
2036			! * 2. ADD THE BACKGROUND TRANSMISSION
2037
2038
2039
2040			ptr(jl) = (zr1(jl)/zr2(jl))*(1.-d(knu,ka)) + d(knu, ka)
2041			END DO
2042
2043			RETURN
2044			END SUBROUTINE swtt_lmdar4
2045			SUBROUTINE swtt1_lmdar4(knu, kabs, kind, pu, ptr)
2046			USE dimphy
2047			USE radiation_ar4_param, ONLY: apad, bpad, d
2048			IMPLICIT NONE
2049
2050			! -----------------------------------------------------------------------
2051			! PURPOSE.
2052			! --------
2053			! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2054			! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2055			! INTERVALS.
2056
2057			! METHOD.
2058			! -------
2059
2060			! TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2061			! AND HORNER'S ALGORITHM.
2062
2063			! REFERENCE.
2064			! ----------
2065
2066			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2067			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2068
2069			! AUTHOR.
2070			! -------
2071			! JEAN-JACQUES MORCRETTE ECMWF
2072
2073			! MODIFICATIONS.
2074			! --------------
2075			! ORIGINAL : 95-01-20
2076			! -----------------------------------------------------------------------
2077			! * ARGUMENTS:
2078
2079			INTEGER knu ! INDEX OF THE SPECTRAL INTERVAL
2080			INTEGER kabs ! NUMBER OF ABSORBERS
2081			INTEGER kind(kabs) ! INDICES OF THE ABSORBERS
2082			REAL (KIND=8) pu(kdlon, kabs) ! ABSORBER AMOUNT
2083
2084			REAL (KIND=8) ptr(kdlon, kabs) ! TRANSMISSION FUNCTION
2085
2086			! * LOCAL VARIABLES:
2087
2088			REAL (KIND=8) zr1(kdlon)
2089			REAL (KIND=8) zr2(kdlon)
2090			REAL (KIND=8) zu(kdlon)
2091			INTEGER jl, ja, i, j, ia
2092
2093			! -----------------------------------------------------------------------
2094
2095			! * 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2096
2097
2098			DO ja = 1, kabs
2099			ia = kind(ja)
2100			DO jl = 1, kdlon
2101			zu(jl) = pu(jl, ja)
2102			zr1(jl) = apad(knu, ia, 1) + zu(jl)(apad(knu,ia,2)+zu(jl)(apad(knu, &
2103			ia,3)+zu(jl)(apad(knu,ia,4)+zu(jl)(apad(knu,ia,5)+zu(jl)*(apad(knu, &
2104			ia,6)+zu(jl)*(apad(knu,ia,7)))))))
2105
2106			zr2(jl) = bpad(knu, ia, 1) + zu(jl)(bpad(knu,ia,2)+zu(jl)(bpad(knu, &
2107			ia,3)+zu(jl)(bpad(knu,ia,4)+zu(jl)(bpad(knu,ia,5)+zu(jl)*(bpad(knu, &
2108			ia,6)+zu(jl)*(bpad(knu,ia,7)))))))
2109
2110			! * 2. ADD THE BACKGROUND TRANSMISSION
2111
2112
2113			ptr(jl, ja) = (zr1(jl)/zr2(jl))*(1.-d(knu,ia)) + d(knu, ia)
2114			END DO
2115			END DO
2116
2117			RETURN
2118			END SUBROUTINE swtt1_lmdar4
2119			! IM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
2120			SUBROUTINE lw_lmdar4(ppmb, pdp, ppsol, pdt0, pemis, ptl, ptave, pwv, pozon, &
2121			paer, pcldld, pcldlu, pview, pcolr, pcolr0, ptoplw, psollw, ptoplw0, &
2122			psollw0, psollwdown, & ! IM .
2123			! psollwdown,psollwdownclr,
2124			! IM . ptoplwdown,ptoplwdownclr)
2125			plwup, plwdn, plwup0, plwdn0)
2126			USE dimphy
2127			USE print_control_mod, ONLY: lunout
2128			IMPLICIT NONE
2129			include "raddimlw.h"
2130			include "YOMCST.h"
2131
2132			! -----------------------------------------------------------------------
2133			! METHOD.
2134			! -------
2135
2136			! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2137			! ABSORBERS.
2138			! 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
2139			! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
2140			! 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
2141			! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
2142			! BOUNDARIES.
2143			! 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
2144			! 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
2145
2146
2147			! REFERENCE.
2148			! ----------
2149
2150			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2151			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2152
2153			! AUTHOR.
2154			! -------
2155			! JEAN-JACQUES MORCRETTE ECMWF
2156
2157			! MODIFICATIONS.
2158			! --------------
2159			! ORIGINAL : 89-07-14
2160			! -----------------------------------------------------------------------
2161			! IM ctes ds clesphys.h
2162			! REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
2163			! REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
2164			! REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
2165			! REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12*
2166			! 137.3686/28.97)
2167			! REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12*
2168			! 120.9140/28.97)
2169			include "clesphys.h"
2170			REAL (KIND=8) pcldld(kdlon, kflev) ! DOWNWARD EFFECTIVE CLOUD COVER
2171			REAL (KIND=8) pcldlu(kdlon, kflev) ! UPWARD EFFECTIVE CLOUD COVER
2172			REAL (KIND=8) pdp(kdlon, kflev) ! LAYER PRESSURE THICKNESS (Pa)
2173			REAL (KIND=8) pdt0(kdlon) ! SURFACE TEMPERATURE DISCONTINUITY (K)
2174			REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
2175			REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF LEVEL PRESSURE (mb)
2176			REAL (KIND=8) ppsol(kdlon) ! SURFACE PRESSURE (Pa)
2177			REAL (KIND=8) pozon(kdlon, kflev) ! O3 mass fraction
2178			REAL (KIND=8) ptl(kdlon, kflev+1) ! HALF LEVEL TEMPERATURE (K)
2179			REAL (KIND=8) paer(kdlon, kflev, 5) ! OPTICAL THICKNESS OF THE AEROSOLS
2180			REAL (KIND=8) ptave(kdlon, kflev) ! LAYER TEMPERATURE (K)
2181			REAL (KIND=8) pview(kdlon) ! COSECANT OF VIEWING ANGLE
2182			REAL (KIND=8) pwv(kdlon, kflev) ! SPECIFIC HUMIDITY (kg/kg)
2183
2184			REAL (KIND=8) pcolr(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day)
2185			REAL (KIND=8) pcolr0(kdlon, kflev) ! LONG-WAVE TENDENCY (K/day) clear-sky
2186			REAL (KIND=8) ptoplw(kdlon) ! LONGWAVE FLUX AT T.O.A.
2187			REAL (KIND=8) psollw(kdlon) ! LONGWAVE FLUX AT SURFACE
2188			REAL (KIND=8) ptoplw0(kdlon) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
2189			REAL (KIND=8) psollw0(kdlon) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
2190			! Rajout LF
2191			REAL (KIND=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface
2192			! Rajout IM
2193			! IM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at
2194			! surface
2195			! IM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at
2196			! T.O.A.
2197			! IM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at
2198			! T.O.A.
2199			! IM
2200			REAL (KIND=8) plwup(kdlon, kflev+1) ! LW up total sky
2201			REAL (KIND=8) plwup0(kdlon, kflev+1) ! LW up clear sky
2202			REAL (KIND=8) plwdn(kdlon, kflev+1) ! LW down total sky
2203			REAL (KIND=8) plwdn0(kdlon, kflev+1) ! LW down clear sky
2204			! -------------------------------------------------------------------------
2205			REAL (KIND=8) zabcu(kdlon, nua, 3*kflev+1)
2206
2207			REAL (KIND=8) zoz(kdlon, kflev)
2208			! equivalent pressure of ozone in a layer, in Pa
2209
2210			! ym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up;
2211			! 2:down)
2212			! ym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
2213			! ym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate
2214			! variable
2215			! ym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate
2216			! variable
2217			! ym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate
2218			! variable
2219			! ym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate
2220			! variable
2221			! ym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
2222			REAL (KIND=8), ALLOCATABLE, SAVE :: zflux(:, :, :) ! RADIATIVE FLUXES (1:up; 2:down)
2223			REAL (KIND=8), ALLOCATABLE, SAVE :: zfluc(:, :, :) ! CLEAR-SKY RADIATIVE FLUXES
2224			REAL (KIND=8), ALLOCATABLE, SAVE :: zbint(:, :) ! Intermediate variable
2225			REAL (KIND=8), ALLOCATABLE, SAVE :: zbsui(:) ! Intermediate variable
2226			REAL (KIND=8), ALLOCATABLE, SAVE :: zcts(:, :) ! Intermediate variable
2227			REAL (KIND=8), ALLOCATABLE, SAVE :: zcntrb(:, :, :) ! Intermediate variable
2228			!$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
2229
2230			INTEGER ilim, i, k, kpl1
2231
2232			INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
2233			PARAMETER (lw0pas=1)
2234			INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
2235			PARAMETER (lwpas=1)
2236
2237			INTEGER itaplw0, itaplw
2238			LOGICAL appel1er
2239			SAVE appel1er, itaplw0, itaplw
2240			!$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
2241			DATA appel1er/.TRUE./
2242			DATA itaplw0, itaplw/0, 0/
2243
2244			! ------------------------------------------------------------------
2245			IF (appel1er) THEN
2246			WRITE (lunout, *) 'LW clear-sky calling frequency: ', lw0pas
2247			WRITE (lunout, *) 'LW cloudy-sky calling frequency: ', lwpas
2248			WRITE (lunout, *) ' In general, they should be 1'
2249			! ym
2250			ALLOCATE (zflux(kdlon,2,kflev+1))
2251			ALLOCATE (zfluc(kdlon,2,kflev+1))
2252			ALLOCATE (zbint(kdlon,kflev+1))
2253			ALLOCATE (zbsui(kdlon))
2254			ALLOCATE (zcts(kdlon,kflev))
2255			ALLOCATE (zcntrb(kdlon,kflev+1,kflev+1))
2256			appel1er = .FALSE.
2257			END IF
2258
2259			IF (mod(itaplw0,lw0pas)==0) THEN
2260			! Compute equivalent pressure of ozone from mass fraction:
2261			DO k = 1, kflev
2262			DO i = 1, kdlon
2263			zoz(i, k) = pozon(i, k)*pdp(i, k)
2264			END DO
2265			END DO
2266			! IM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
2267			CALL lwu_lmdar4(paer, pdp, ppmb, ppsol, zoz, ptave, pview, pwv, zabcu)
2268			CALL lwbv_lmdar4(ilim, pdp, pdt0, pemis, ppmb, ptl, ptave, zabcu, zfluc, &
2269			zbint, zbsui, zcts, zcntrb)
2270			itaplw0 = 0
2271			END IF
2272			itaplw0 = itaplw0 + 1
2273
2274			IF (mod(itaplw,lwpas)==0) THEN
2275			CALL lwc_lmdar4(ilim, pcldld, pcldlu, pemis, zfluc, zbint, zbsui, zcts, &
2276			zcntrb, zflux)
2277			itaplw = 0
2278			END IF
2279			itaplw = itaplw + 1
2280
2281			DO k = 1, kflev
2282			kpl1 = k + 1
2283			DO i = 1, kdlon
2284			pcolr(i, k) = zflux(i, 1, kpl1) + zflux(i, 2, kpl1) - zflux(i, 1, k) - &
2285			zflux(i, 2, k)
2286			pcolr(i, k) = pcolr(i, k)rdayrg/rcpd/pdp(i, k)
2287			pcolr0(i, k) = zfluc(i, 1, kpl1) + zfluc(i, 2, kpl1) - zfluc(i, 1, k) - &
2288			zfluc(i, 2, k)
2289			pcolr0(i, k) = pcolr0(i, k)rdayrg/rcpd/pdp(i, k)
2290			END DO
2291			END DO
2292			DO i = 1, kdlon
2293			psollw(i) = -zflux(i, 1, 1) - zflux(i, 2, 1)
2294			ptoplw(i) = zflux(i, 1, kflev+1) + zflux(i, 2, kflev+1)
2295
2296			psollw0(i) = -zfluc(i, 1, 1) - zfluc(i, 2, 1)
2297			ptoplw0(i) = zfluc(i, 1, kflev+1) + zfluc(i, 2, kflev+1)
2298			psollwdown(i) = -zflux(i, 2, 1)
2299
2300			! IM attention aux signes !; LWtop >0, LWdn < 0
2301			DO k = 1, kflev + 1
2302			plwup(i, k) = zflux(i, 1, k)
2303			plwup0(i, k) = zfluc(i, 1, k)
2304			plwdn(i, k) = zflux(i, 2, k)
2305			plwdn0(i, k) = zfluc(i, 2, k)
2306			END DO
2307			END DO
2308			! ------------------------------------------------------------------
2309			RETURN
2310			END SUBROUTINE lw_lmdar4
2311			! IM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
2312			SUBROUTINE lwu_lmdar4(paer, pdp, ppmb, ppsol, poz, ptave, pview, pwv, pabcu)
2313			USE dimphy
2314			USE radiation_ar4_param, ONLY: tref, rt1, raer, at, bt, oct
2315			USE infotrac_phy, ONLY: type_trac
2316			#ifdef REPROBUS
2317			USE chem_rep, ONLY: rch42d, rn2o2d, rcfc112d, rcfc122d, ok_rtime2d
2318			#endif
2319
2320			IMPLICIT NONE
2321			include "raddimlw.h"
2322			include "YOMCST.h"
2323			include "radepsi.h"
2324			include "radopt.h"
2325
2326			! PURPOSE.
2327			! --------
2328			! COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
2329			! TEMPERATURE EFFECTS
2330
2331			! METHOD.
2332			! -------
2333
2334			! 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2335			! ABSORBERS.
2336
2337
2338			! REFERENCE.
2339			! ----------
2340
2341			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2342			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2343
2344			! AUTHOR.
2345			! -------
2346			! JEAN-JACQUES MORCRETTE ECMWF
2347
2348			! MODIFICATIONS.
2349			! --------------
2350			! ORIGINAL : 89-07-14
2351			! Voigt lines (loop 404 modified) - JJM & PhD - 01/96
2352			! -----------------------------------------------------------------------
2353			! * ARGUMENTS:
2354			! IM ctes ds clesphys.h
2355			! REAL(KIND=8) RCO2
2356			! REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
2357			include "clesphys.h"
2358			REAL (KIND=8) paer(kdlon, kflev, 5)
2359			REAL (KIND=8) pdp(kdlon, kflev)
2360			REAL (KIND=8) ppmb(kdlon, kflev+1)
2361			REAL (KIND=8) ppsol(kdlon)
2362			REAL (KIND=8) poz(kdlon, kflev)
2363			REAL (KIND=8) ptave(kdlon, kflev)
2364			REAL (KIND=8) pview(kdlon)
2365			REAL (KIND=8) pwv(kdlon, kflev)
2366
2367			REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
2368
2369			! -----------------------------------------------------------------------
2370			! * LOCAL VARIABLES:
2371			REAL (KIND=8) zably(kdlon, nua, 3*kflev+1)
2372			REAL (KIND=8) zduc(kdlon, 3*kflev+1)
2373			REAL (KIND=8) zphio(kdlon)
2374			REAL (KIND=8) zpsc2(kdlon)
2375			REAL (KIND=8) zpsc3(kdlon)
2376			REAL (KIND=8) zpsh1(kdlon)
2377			REAL (KIND=8) zpsh2(kdlon)
2378			REAL (KIND=8) zpsh3(kdlon)
2379			REAL (KIND=8) zpsh4(kdlon)
2380			REAL (KIND=8) zpsh5(kdlon)
2381			REAL (KIND=8) zpsh6(kdlon)
2382			REAL (KIND=8) zpsio(kdlon)
2383			REAL (KIND=8) ztcon(kdlon)
2384			REAL (KIND=8) zphm6(kdlon)
2385			REAL (KIND=8) zpsm6(kdlon)
2386			REAL (KIND=8) zphn6(kdlon)
2387			REAL (KIND=8) zpsn6(kdlon)
2388			REAL (KIND=8) zssig(kdlon, 3*kflev+1)
2389			REAL (KIND=8) ztavi(kdlon)
2390			REAL (KIND=8) zuaer(kdlon, ninter)
2391			REAL (KIND=8) zxoz(kdlon)
2392			REAL (KIND=8) zxwv(kdlon)
2393
2394			INTEGER jl, jk, jkj, jkjr, jkjp, ig1
2395			INTEGER jki, jkip1, ja, jj
2396			INTEGER jkl, jkp1, jkk, jkjpn
2397			INTEGER jae1, jae2, jae3, jae, jjpn
2398			INTEGER ir, jc, jcp1
2399			REAL (KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
2400			REAL (KIND=8) zfppw, ztx, ztx2, zzably
2401			REAL (KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
2402			REAL (KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
2403			REAL (KIND=8) zcac8, zcbc8
2404			REAL (KIND=8) zalup, zdiff
2405
2406			REAL (KIND=8) pvgco2, pvgh2o, pvgo3
2407
2408			REAL (KIND=8) r10e ! DECIMAL/NATURAL LOG.FACTOR
2409			PARAMETER (r10e=0.4342945)
2410
2411			! -----------------------------------------------------------------------
2412
2413			IF (levoigt) THEN
2414			pvgco2 = 60.
2415			pvgh2o = 30.
2416			pvgo3 = 400.
2417			ELSE
2418			pvgco2 = 0.
2419			pvgh2o = 0.
2420			pvgo3 = 0.
2421			END IF
2422
2423			! * 2. PRESSURE OVER GAUSS SUB-LEVELS
2424			! ------------------------------
2425
2426
2427			DO jl = 1, kdlon
2428			zssig(jl, 1) = ppmb(jl, 1)*100.
2429			END DO
2430
2431			DO jk = 1, kflev
2432			jkj = (jk-1)*ng1p1 + 1
2433			jkjr = jkj
2434			jkjp = jkj + ng1p1
2435			DO jl = 1, kdlon
2436			zssig(jl, jkjp) = ppmb(jl, jk+1)*100.
2437			END DO
2438			DO ig1 = 1, ng1
2439			jkj = jkj + 1
2440			DO jl = 1, kdlon
2441			zssig(jl, jkj) = (zssig(jl,jkjr)+zssig(jl,jkjp))*0.5 + &
2442			rt1(ig1)(zssig(jl,jkjp)-zssig(jl,jkjr))0.5
2443			END DO
2444			END DO
2445			END DO
2446
2447			! -----------------------------------------------------------------------
2448
2449
2450			! * 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
2451			! --------------------------------------------------
2452
2453
2454			DO jki = 1, 3*kflev
2455			jkip1 = jki + 1
2456			DO jl = 1, kdlon
2457			zably(jl, 5, jki) = (zssig(jl,jki)+zssig(jl,jkip1))*0.5
2458			zably(jl, 3, jki) = (zssig(jl,jki)-zssig(jl,jkip1))/(10.*rg)
2459			END DO
2460			END DO
2461
2462			DO jk = 1, kflev
2463			jkp1 = jk + 1
2464			jkl = kflev + 1 - jk
2465			DO jl = 1, kdlon
2466			zxwv(jl) = max(pwv(jl,jk), zepscq)
2467			zxoz(jl) = max(poz(jl,jk)/pdp(jl,jk), zepsco)
2468			END DO
2469			jkj = (jk-1)*ng1p1 + 1
2470			jkjpn = jkj + ng1
2471			DO jkk = jkj, jkjpn
2472			DO jl = 1, kdlon
2473			zdpm = zably(jl, 3, jkk)
2474			zupm = zably(jl, 5, jkk)*zdpm/101325.
2475			zupmco2 = (zably(jl,5,jkk)+pvgco2)*zdpm/101325.
2476			zupmh2o = (zably(jl,5,jkk)+pvgh2o)*zdpm/101325.
2477			zupmo3 = (zably(jl,5,jkk)+pvgo3)*zdpm/101325.
2478			zduc(jl, jkk) = zdpm
2479			zably(jl, 12, jkk) = zxoz(jl)*zdpm
2480			zably(jl, 13, jkk) = zxoz(jl)*zupmo3
2481			zu6 = zxwv(jl)*zupm
2482			zfppw = 1.6078zxwv(jl)/(1.+0.608zxwv(jl))
2483			zably(jl, 6, jkk) = zxwv(jl)*zupmh2o
2484			zably(jl, 11, jkk) = zu6*zfppw
2485			zably(jl, 10, jkk) = zu6*(1.-zfppw)
2486			zably(jl, 9, jkk) = rco2*zupmco2
2487			zably(jl, 8, jkk) = rco2*zdpm
2488			END DO
2489			END DO
2490			END DO
2491
2492			! -----------------------------------------------------------------------
2493
2494
2495			! * 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
2496			! --------------------------------------------------
2497
2498
2499			DO ja = 1, nua
2500			DO jl = 1, kdlon
2501			pabcu(jl, ja, 3*kflev+1) = 0.
2502			END DO
2503			END DO
2504
2505			DO jk = 1, kflev
2506			jj = (jk-1)*ng1p1 + 1
2507			jjpn = jj + ng1
2508			jkl = kflev + 1 - jk
2509
2510			! * 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
2511			! --------------------------------------------------
2512
2513
2514			jae1 = 3*kflev + 1 - jj
2515			jae2 = 3*kflev + 1 - (jj+1)
2516			jae3 = 3*kflev + 1 - jjpn
2517			DO jae = 1, 5
2518			DO jl = 1, kdlon
2519			zuaer(jl, jae) = (raer(jae,1)paer(jl,jkl,1)+raer(jae,2)paer(jl,jkl, &
2520			2)+raer(jae,3)paer(jl,jkl,3)+raer(jae,4)paer(jl,jkl,4)+ &
2521			raer(jae,5)*paer(jl,jkl,5))/(zduc(jl,jae1)+zduc(jl,jae2)+zduc(jl, &
2522			jae3))
2523			END DO
2524			END DO
2525
2526			! * 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
2527			! --------------------------------------------------
2528
2529
2530			DO jl = 1, kdlon
2531			ztavi(jl) = ptave(jl, jkl)
2532			ztcon(jl) = exp(6.08*(296./ztavi(jl)-1.))
2533			ztx = ztavi(jl) - tref
2534			ztx2 = ztx*ztx
2535			zzably = zably(jl, 6, jae1) + zably(jl, 6, jae2) + zably(jl, 6, jae3)
2536			zup = min(max(0.5r10elog(zzably)+5.,0._8), 6._8)
2537			zcah1 = at(1, 1) + zup(at(1,2)+zup(at(1,3)))
2538			zcbh1 = bt(1, 1) + zup(bt(1,2)+zup(bt(1,3)))
2539			zpsh1(jl) = exp(zcah1ztx+zcbh1ztx2)
2540			zcah2 = at(2, 1) + zup(at(2,2)+zup(at(2,3)))
2541			zcbh2 = bt(2, 1) + zup(bt(2,2)+zup(bt(2,3)))
2542			zpsh2(jl) = exp(zcah2ztx+zcbh2ztx2)
2543			zcah3 = at(3, 1) + zup(at(3,2)+zup(at(3,3)))
2544			zcbh3 = bt(3, 1) + zup(bt(3,2)+zup(bt(3,3)))
2545			zpsh3(jl) = exp(zcah3ztx+zcbh3ztx2)
2546			zcah4 = at(4, 1) + zup(at(4,2)+zup(at(4,3)))
2547			zcbh4 = bt(4, 1) + zup(bt(4,2)+zup(bt(4,3)))
2548			zpsh4(jl) = exp(zcah4ztx+zcbh4ztx2)
2549			zcah5 = at(5, 1) + zup(at(5,2)+zup(at(5,3)))
2550			zcbh5 = bt(5, 1) + zup(bt(5,2)+zup(bt(5,3)))
2551			zpsh5(jl) = exp(zcah5ztx+zcbh5ztx2)
2552			zcah6 = at(6, 1) + zup(at(6,2)+zup(at(6,3)))
2553			zcbh6 = bt(6, 1) + zup(bt(6,2)+zup(bt(6,3)))
2554			zpsh6(jl) = exp(zcah6ztx+zcbh6ztx2)
2555			zphm6(jl) = exp(-5.81E-4ztx-1.13E-6ztx2)
2556			zpsm6(jl) = exp(-5.57E-4ztx-3.30E-6ztx2)
2557			zphn6(jl) = exp(-3.46E-5ztx+2.05E-7ztx2)
2558			zpsn6(jl) = exp(3.70E-3ztx-2.30E-6ztx2)
2559			END DO
2560
2561			DO jl = 1, kdlon
2562			ztavi(jl) = ptave(jl, jkl)
2563			ztx = ztavi(jl) - tref
2564			ztx2 = ztx*ztx
2565			zzably = zably(jl, 9, jae1) + zably(jl, 9, jae2) + zably(jl, 9, jae3)
2566			zalup = r10e*log(zzably)
2567			zup = max(0._8, 5.0+0.5*zalup)
2568			zpsc2(jl) = (ztavi(jl)/tref)**zup
2569			zcac8 = at(8, 1) + zup(at(8,2)+zup(at(8,3)))
2570			zcbc8 = bt(8, 1) + zup(bt(8,2)+zup(bt(8,3)))
2571			zpsc3(jl) = exp(zcac8ztx+zcbc8ztx2)
2572			zphio(jl) = exp(oct(1)ztx+oct(2)ztx2)
2573			zpsio(jl) = exp(2.(oct(3)ztx+oct(4)*ztx2))
2574			END DO
2575
2576			DO jkk = jj, jjpn
2577			jc = 3*kflev + 1 - jkk
2578			jcp1 = jc + 1
2579			DO jl = 1, kdlon
2580			zdiff = pview(jl)
2581			pabcu(jl, 10, jc) = pabcu(jl, 10, jcp1) + zably(jl, 10, jc)*zdiff
2582			pabcu(jl, 11, jc) = pabcu(jl, 11, jcp1) + zably(jl, 11, jc)*ztcon(jl) &
2583			*zdiff
2584
2585			pabcu(jl, 12, jc) = pabcu(jl, 12, jcp1) + zably(jl, 12, jc)*zphio(jl) &
2586			*zdiff
2587			pabcu(jl, 13, jc) = pabcu(jl, 13, jcp1) + zably(jl, 13, jc)*zpsio(jl) &
2588			*zdiff
2589
2590			pabcu(jl, 7, jc) = pabcu(jl, 7, jcp1) + zably(jl, 9, jc)zpsc2(jl) &
2591			zdiff
2592			pabcu(jl, 8, jc) = pabcu(jl, 8, jcp1) + zably(jl, 9, jc)zpsc3(jl) &
2593			zdiff
2594			pabcu(jl, 9, jc) = pabcu(jl, 9, jcp1) + zably(jl, 9, jc)zpsc3(jl) &
2595			zdiff
2596
2597			pabcu(jl, 1, jc) = pabcu(jl, 1, jcp1) + zably(jl, 6, jc)zpsh1(jl) &
2598			zdiff
2599			pabcu(jl, 2, jc) = pabcu(jl, 2, jcp1) + zably(jl, 6, jc)zpsh2(jl) &
2600			zdiff
2601			pabcu(jl, 3, jc) = pabcu(jl, 3, jcp1) + zably(jl, 6, jc)zpsh5(jl) &
2602			zdiff
2603			pabcu(jl, 4, jc) = pabcu(jl, 4, jcp1) + zably(jl, 6, jc)zpsh3(jl) &
2604			zdiff
2605			pabcu(jl, 5, jc) = pabcu(jl, 5, jcp1) + zably(jl, 6, jc)zpsh4(jl) &
2606			zdiff
2607			pabcu(jl, 6, jc) = pabcu(jl, 6, jcp1) + zably(jl, 6, jc)zpsh6(jl) &
2608			zdiff
2609
2610			pabcu(jl, 14, jc) = pabcu(jl, 14, jcp1) + zuaer(jl, 1)zduc(jl, jc) &
2611			zdiff
2612			pabcu(jl, 15, jc) = pabcu(jl, 15, jcp1) + zuaer(jl, 2)zduc(jl, jc) &
2613			zdiff
2614			pabcu(jl, 16, jc) = pabcu(jl, 16, jcp1) + zuaer(jl, 3)zduc(jl, jc) &
2615			zdiff
2616			pabcu(jl, 17, jc) = pabcu(jl, 17, jcp1) + zuaer(jl, 4)zduc(jl, jc) &
2617			zdiff
2618			pabcu(jl, 18, jc) = pabcu(jl, 18, jcp1) + zuaer(jl, 5)zduc(jl, jc) &
2619			zdiff
2620
2621
2622
2623			IF (type_trac=='repr') THEN
2624			#ifdef REPROBUS
2625			IF (ok_rtime2d) THEN
2626			pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
2627			zably(jl, 8, jc)rch42d(jl, jc)/rco2zphm6(jl)*zdiff
2628			pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
2629			zably(jl, 9, jc)rch42d(jl, jc)/rco2zpsm6(jl)*zdiff
2630			pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
2631			zably(jl, 8, jc)rn2o2d(jl, jc)/rco2zphn6(jl)*zdiff
2632			pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
2633			zably(jl, 9, jc)rn2o2d(jl, jc)/rco2zpsn6(jl)*zdiff
2634
2635			pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
2636			zably(jl, 8, jc)rcfc112d(jl, jc)/rco2zdiff
2637			pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
2638			zably(jl, 8, jc)rcfc122d(jl, jc)/rco2zdiff
2639			ELSE
2640			! Same calculation as for type_trac /= repr
2641			pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
2642			zably(jl, 8, jc)rch4/rco2zphm6(jl)*zdiff
2643			pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
2644			zably(jl, 9, jc)rch4/rco2zpsm6(jl)*zdiff
2645			pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
2646			zably(jl, 8, jc)rn2o/rco2zphn6(jl)*zdiff
2647			pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
2648			zably(jl, 9, jc)rn2o/rco2zpsn6(jl)*zdiff
2649
2650			pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
2651			zably(jl, 8, jc)rcfc11/rco2zdiff
2652			pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
2653			zably(jl, 8, jc)rcfc12/rco2zdiff
2654			END IF
2655			#endif
2656			ELSE
2657			pabcu(jl, 19, jc) = pabcu(jl, 19, jcp1) + &
2658			zably(jl, 8, jc)rch4/rco2zphm6(jl)*zdiff
2659			pabcu(jl, 20, jc) = pabcu(jl, 20, jcp1) + &
2660			zably(jl, 9, jc)rch4/rco2zpsm6(jl)*zdiff
2661			pabcu(jl, 21, jc) = pabcu(jl, 21, jcp1) + &
2662			zably(jl, 8, jc)rn2o/rco2zphn6(jl)*zdiff
2663			pabcu(jl, 22, jc) = pabcu(jl, 22, jcp1) + &
2664			zably(jl, 9, jc)rn2o/rco2zpsn6(jl)*zdiff
2665
2666			pabcu(jl, 23, jc) = pabcu(jl, 23, jcp1) + &
2667			zably(jl, 8, jc)rcfc11/rco2zdiff
2668			pabcu(jl, 24, jc) = pabcu(jl, 24, jcp1) + &
2669			zably(jl, 8, jc)rcfc12/rco2zdiff
2670			END IF
2671
2672			END DO
2673			END DO
2674
2675			END DO
2676
2677
2678			RETURN
2679			END SUBROUTINE lwu_lmdar4
2680			SUBROUTINE lwbv_lmdar4(klim, pdp, pdt0, pemis, ppmb, ptl, ptave, pabcu, &
2681			pfluc, pbint, pbsui, pcts, pcntrb)
2682			USE dimphy
2683			IMPLICIT NONE
2684			include "raddimlw.h"
2685			include "YOMCST.h"
2686
2687			! PURPOSE.
2688			! --------
2689			! TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
2690			! VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
2691			! SAVING
2692
2693			! METHOD.
2694			! -------
2695
2696			! 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
2697			! GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
2698			! 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
2699			! TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
2700			! BOUNDARIES.
2701			! 3. COMPUTES THE CLEAR-SKY COOLING RATES.
2702
2703			! REFERENCE.
2704			! ----------
2705
2706			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2707			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2708
2709			! AUTHOR.
2710			! -------
2711			! JEAN-JACQUES MORCRETTE ECMWF
2712
2713			! MODIFICATIONS.
2714			! --------------
2715			! ORIGINAL : 89-07-14
2716			! MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
2717			! MEMORY)
2718			! -----------------------------------------------------------------------
2719			! * ARGUMENTS:
2720			INTEGER klim
2721
2722			REAL (KIND=8) pdp(kdlon, kflev)
2723			REAL (KIND=8) pdt0(kdlon)
2724			REAL (KIND=8) pemis(kdlon)
2725			REAL (KIND=8) ppmb(kdlon, kflev+1)
2726			REAL (KIND=8) ptl(kdlon, kflev+1)
2727			REAL (KIND=8) ptave(kdlon, kflev)
2728
2729			REAL (KIND=8) pfluc(kdlon, 2, kflev+1)
2730
2731			REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1)
2732			REAL (KIND=8) pbint(kdlon, kflev+1)
2733			REAL (KIND=8) pbsui(kdlon)
2734			REAL (KIND=8) pcts(kdlon, kflev)
2735			REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1)
2736
2737			! -------------------------------------------------------------------------
2738
2739			! * LOCAL VARIABLES:
2740			REAL (KIND=8) zb(kdlon, ninter, kflev+1)
2741			REAL (KIND=8) zbsur(kdlon, ninter)
2742			REAL (KIND=8) zbtop(kdlon, ninter)
2743			REAL (KIND=8) zdbsl(kdlon, ninter, kflev*2)
2744			REAL (KIND=8) zga(kdlon, 8, 2, kflev)
2745			REAL (KIND=8) zgb(kdlon, 8, 2, kflev)
2746			REAL (KIND=8) zgasur(kdlon, 8, 2)
2747			REAL (KIND=8) zgbsur(kdlon, 8, 2)
2748			REAL (KIND=8) zgatop(kdlon, 8, 2)
2749			REAL (KIND=8) zgbtop(kdlon, 8, 2)
2750
2751			INTEGER nuaer, ntraer
2752			! ------------------------------------------------------------------
2753			! * COMPUTES PLANCK FUNCTIONS:
2754			CALL lwb_lmdar4(pdt0, ptave, ptl, zb, pbint, pbsui, zbsur, zbtop, zdbsl, &
2755			zga, zgb, zgasur, zgbsur, zgatop, zgbtop)
2756			! ------------------------------------------------------------------
2757			! * PERFORMS THE VERTICAL INTEGRATION:
2758			nuaer = nua
2759			ntraer = ntra
2760			CALL lwv_lmdar4(nuaer, ntraer, klim, pabcu, zb, pbint, pbsui, zbsur, zbtop, &
2761			zdbsl, pemis, ppmb, ptave, zga, zgb, zgasur, zgbsur, zgatop, zgbtop, &
2762			pcntrb, pcts, pfluc)
2763			! ------------------------------------------------------------------
2764			RETURN
2765			END SUBROUTINE lwbv_lmdar4
2766			SUBROUTINE lwc_lmdar4(klim, pcldld, pcldlu, pemis, pfluc, pbint, pbsuin, &
2767			pcts, pcntrb, pflux)
2768			USE dimphy
2769			IMPLICIT NONE
2770			include "radepsi.h"
2771			include "radopt.h"
2772
2773			! PURPOSE.
2774			! --------
2775			! INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
2776			! RADIANCES
2777
2778			! EXPLICIT ARGUMENTS :
2779			! --------------------
2780			! ==== INPUTS ===
2781			! PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION
2782			! PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
2783			! PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION
2784			! PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION
2785			! PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
2786			! PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE
2787			! PEMIS : (KDLON) ; SURFACE EMISSIVITY
2788			! PFLUC
2789			! ==== OUTPUTS ===
2790			! PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES :
2791			! 1 ==> UPWARD FLUX TOTAL
2792			! 2 ==> DOWNWARD FLUX TOTAL
2793
2794			! METHOD.
2795			! -------
2796
2797			! 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
2798			! 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
2799			! 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
2800			! CLOUDS
2801
2802			! REFERENCE.
2803			! ----------
2804
2805			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2806			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2807
2808			! AUTHOR.
2809			! -------
2810			! JEAN-JACQUES MORCRETTE ECMWF
2811
2812			! MODIFICATIONS.
2813			! --------------
2814			! ORIGINAL : 89-07-14
2815			! Voigt lines (loop 231 to 233) - JJM & PhD - 01/96
2816			! -----------------------------------------------------------------------
2817			! * ARGUMENTS:
2818			INTEGER klim
2819			REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
2820			REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION
2821			REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
2822			REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) !CLEAR-SKY ENERGY EXCHANGE
2823			REAL (KIND=8) pcts(kdlon, kflev) ! CLEAR-SKY LAYER COOLING-TO-SPACE
2824
2825			REAL (KIND=8) pcldld(kdlon, kflev)
2826			REAL (KIND=8) pcldlu(kdlon, kflev)
2827			REAL (KIND=8) pemis(kdlon)
2828
2829			REAL (KIND=8) pflux(kdlon, 2, kflev+1)
2830			! -----------------------------------------------------------------------
2831			! * LOCAL VARIABLES:
2832			INTEGER imx(kdlon), imxp(kdlon)
2833
2834			REAL (KIND=8) zclear(kdlon), zcloud(kdlon), zdnf(kdlon, kflev+1, kflev+1), &
2835			zfd(kdlon), zfn10(kdlon), zfu(kdlon), zupf(kdlon, kflev+1, kflev+1)
2836			REAL (KIND=8) zclm(kdlon, kflev+1, kflev+1)
2837
2838			INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
2839			INTEGER jk1, jk2, jkc, jkcp1, jcloud
2840			INTEGER imxm1, imxp1
2841			REAL (KIND=8) zcfrac
2842
2843			! ------------------------------------------------------------------
2844
2845			! * 1. INITIALIZATION
2846			! --------------
2847
2848
2849			imaxc = 0
2850
2851			DO jl = 1, kdlon
2852			imx(jl) = 0
2853			imxp(jl) = 0
2854			zcloud(jl) = 0.
2855			END DO
2856
2857			! * 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
2858			! -------------------------------------------
2859
2860
2861			DO jk = 1, kflev
2862			DO jl = 1, kdlon
2863			imx1 = imx(jl)
2864			imx2 = jk
2865			IF (pcldlu(jl,jk)>zepsc) THEN
2866			imxp(jl) = imx2
2867			ELSE
2868			imxp(jl) = imx1
2869			END IF
2870			imaxc = max(imxp(jl), imaxc)
2871			imx(jl) = imxp(jl)
2872			END DO
2873			END DO
2874			! GM*******
2875			imaxc = kflev
2876			! GM*******
2877
2878			DO jk = 1, kflev + 1
2879			DO jl = 1, kdlon
2880			pflux(jl, 1, jk) = pfluc(jl, 1, jk)
2881			pflux(jl, 2, jk) = pfluc(jl, 2, jk)
2882			END DO
2883			END DO
2884
2885			! ------------------------------------------------------------------
2886
2887			! * 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
2888			! ---------------------------------------
2889
2890			IF (imaxc>0) THEN
2891
2892			imxp1 = imaxc + 1
2893			imxm1 = imaxc - 1
2894
2895			! * 2.0 INITIALIZE TO CLEAR-SKY FLUXES
2896			! ------------------------------
2897
2898
2899			DO jk1 = 1, kflev + 1
2900			DO jk2 = 1, kflev + 1
2901			DO jl = 1, kdlon
2902			zupf(jl, jk2, jk1) = pfluc(jl, 1, jk1)
2903			zdnf(jl, jk2, jk1) = pfluc(jl, 2, jk1)
2904			END DO
2905			END DO
2906			END DO
2907
2908			! * 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
2909			! ----------------------------------------------
2910
2911
2912			DO jkc = 1, imaxc
2913			jcloud = jkc
2914			jkcp1 = jcloud + 1
2915
2916			! * 2.1.1 ABOVE THE CLOUD
2917			! ---------------
2918
2919
2920			DO jk = jkcp1, kflev + 1
2921			jkm1 = jk - 1
2922			DO jl = 1, kdlon
2923			zfu(jl) = 0.
2924			END DO
2925			IF (jk>jkcp1) THEN
2926			DO jkj = jkcp1, jkm1
2927			DO jl = 1, kdlon
2928			zfu(jl) = zfu(jl) + pcntrb(jl, jk, jkj)
2929			END DO
2930			END DO
2931			END IF
2932
2933			DO jl = 1, kdlon
2934			zupf(jl, jkcp1, jk) = pbint(jl, jk) - zfu(jl)
2935			END DO
2936			END DO
2937
2938			! * 2.1.2 BELOW THE CLOUD
2939			! ---------------
2940
2941
2942			DO jk = 1, jcloud
2943			jkp1 = jk + 1
2944			DO jl = 1, kdlon
2945			zfd(jl) = 0.
2946			END DO
2947
2948			IF (jk<jcloud) THEN
2949			DO jkj = jkp1, jcloud
2950			DO jl = 1, kdlon
2951			zfd(jl) = zfd(jl) + pcntrb(jl, jk, jkj)
2952			END DO
2953			END DO
2954			END IF
2955			DO jl = 1, kdlon
2956			zdnf(jl, jkcp1, jk) = -pbint(jl, jk) - zfd(jl)
2957			END DO
2958			END DO
2959
2960			END DO
2961
2962			! * 2.2 CLOUD COVER MATRIX
2963			! ------------------
2964
2965			! * ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
2966			! HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
2967
2968
2969			DO jk1 = 1, kflev + 1
2970			DO jk2 = 1, kflev + 1
2971			DO jl = 1, kdlon
2972			zclm(jl, jk1, jk2) = 0.
2973			END DO
2974			END DO
2975			END DO
2976
2977			! * 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION
2978			! ------------------------------------------
2979
2980
2981			DO jk1 = 2, kflev + 1
2982			DO jl = 1, kdlon
2983			zclear(jl) = 1.
2984			zcloud(jl) = 0.
2985			END DO
2986			DO jk = jk1 - 1, 1, -1
2987			DO jl = 1, kdlon
2988			IF (novlp==1) THEN
2989			! * maximum-random
2990			zclear(jl) = zclear(jl)*(1.0-max(pcldlu(jl, &
2991			jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec))
2992			zclm(jl, jk1, jk) = 1.0 - zclear(jl)
2993			zcloud(jl) = pcldlu(jl, jk)
2994			ELSE IF (novlp==2) THEN
2995			! * maximum
2996			zcloud(jl) = max(zcloud(jl), pcldlu(jl,jk))
2997			zclm(jl, jk1, jk) = zcloud(jl)
2998			ELSE IF (novlp==3) THEN
2999			! * random
3000			zclear(jl) = zclear(jl)*(1.0-pcldlu(jl,jk))
3001			zcloud(jl) = 1.0 - zclear(jl)
3002			zclm(jl, jk1, jk) = zcloud(jl)
3003			END IF
3004			END DO
3005			END DO
3006			END DO
3007
3008			! * 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION
3009			! ------------------------------------------
3010
3011
3012			DO jk1 = 1, kflev
3013			DO jl = 1, kdlon
3014			zclear(jl) = 1.
3015			zcloud(jl) = 0.
3016			END DO
3017			DO jk = jk1, kflev
3018			DO jl = 1, kdlon
3019			IF (novlp==1) THEN
3020			! * maximum-random
3021			zclear(jl) = zclear(jl)*(1.0-max(pcldld(jl, &
3022			jk),zcloud(jl)))/(1.0-min(zcloud(jl),1.-zepsec))
3023			zclm(jl, jk1, jk) = 1.0 - zclear(jl)
3024			zcloud(jl) = pcldld(jl, jk)
3025			ELSE IF (novlp==2) THEN
3026			! * maximum
3027			zcloud(jl) = max(zcloud(jl), pcldld(jl,jk))
3028			zclm(jl, jk1, jk) = zcloud(jl)
3029			ELSE IF (novlp==3) THEN
3030			! * random
3031			zclear(jl) = zclear(jl)*(1.0-pcldld(jl,jk))
3032			zcloud(jl) = 1.0 - zclear(jl)
3033			zclm(jl, jk1, jk) = zcloud(jl)
3034			END IF
3035			END DO
3036			END DO
3037			END DO
3038
3039			! * 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
3040			! ----------------------------------------------
3041
3042
3043			! * 3.1 DOWNWARD FLUXES
3044			! ---------------
3045
3046
3047			DO jl = 1, kdlon
3048			pflux(jl, 2, kflev+1) = 0.
3049			END DO
3050
3051			DO jk1 = kflev, 1, -1
3052
3053			! * CONTRIBUTION FROM CLEAR-SKY FRACTION
3054
3055			DO jl = 1, kdlon
3056			zfd(jl) = (1.-zclm(jl,jk1,kflev))*zdnf(jl, 1, jk1)
3057			END DO
3058
3059			! * CONTRIBUTION FROM ADJACENT CLOUD
3060
3061			DO jl = 1, kdlon
3062			zfd(jl) = zfd(jl) + zclm(jl, jk1, jk1)*zdnf(jl, jk1+1, jk1)
3063			END DO
3064
3065			! * CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3066
3067			DO jk = kflev - 1, jk1, -1
3068			DO jl = 1, kdlon
3069			zcfrac = zclm(jl, jk1, jk+1) - zclm(jl, jk1, jk)
3070			zfd(jl) = zfd(jl) + zcfrac*zdnf(jl, jk+2, jk1)
3071			END DO
3072			END DO
3073
3074			DO jl = 1, kdlon
3075			pflux(jl, 2, jk1) = zfd(jl)
3076			END DO
3077
3078			END DO
3079
3080			! * 3.2 UPWARD FLUX AT THE SURFACE
3081			! --------------------------
3082
3083
3084			DO jl = 1, kdlon
3085			pflux(jl, 1, 1) = pemis(jl)pbsuin(jl) - (1.-pemis(jl))pflux(jl, 2, 1)
3086			END DO
3087
3088			! * 3.3 UPWARD FLUXES
3089			! -------------
3090
3091
3092			DO jk1 = 2, kflev + 1
3093
3094			! * CONTRIBUTION FROM CLEAR-SKY FRACTION
3095
3096			DO jl = 1, kdlon
3097			zfu(jl) = (1.-zclm(jl,jk1,1))*zupf(jl, 1, jk1)
3098			END DO
3099
3100			! * CONTRIBUTION FROM ADJACENT CLOUD
3101
3102			DO jl = 1, kdlon
3103			zfu(jl) = zfu(jl) + zclm(jl, jk1, jk1-1)*zupf(jl, jk1, jk1)
3104			END DO
3105
3106			! * CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3107
3108			DO jk = 2, jk1 - 1
3109			DO jl = 1, kdlon
3110			zcfrac = zclm(jl, jk1, jk-1) - zclm(jl, jk1, jk)
3111			zfu(jl) = zfu(jl) + zcfrac*zupf(jl, jk, jk1)
3112			END DO
3113			END DO
3114
3115			DO jl = 1, kdlon
3116			pflux(jl, 1, jk1) = zfu(jl)
3117			END DO
3118
3119			END DO
3120
3121
3122			END IF
3123
3124			! * 2.3 END OF CLOUD EFFECT COMPUTATIONS
3125
3126
3127			IF (.NOT. levoigt) THEN
3128			DO jl = 1, kdlon
3129			zfn10(jl) = pflux(jl, 1, klim) + pflux(jl, 2, klim)
3130			END DO
3131			DO jk = klim + 1, kflev + 1
3132			DO jl = 1, kdlon
3133			zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
3134			pflux(jl, 1, jk) = zfn10(jl)
3135			pflux(jl, 2, jk) = 0.0
3136			END DO
3137			END DO
3138			END IF
3139
3140			RETURN
3141			END SUBROUTINE lwc_lmdar4
3142			SUBROUTINE lwb_lmdar4(pdt0, ptave, ptl, pb, pbint, pbsuin, pbsur, pbtop, &
3143			pdbsl, pga, pgb, pgasur, pgbsur, pgatop, pgbtop)
3144			USE dimphy
3145			USE radiation_ar4_param, ONLY: tintp, xp, ga, gb
3146			IMPLICIT NONE
3147			include "raddimlw.h"
3148
3149			! -----------------------------------------------------------------------
3150			! PURPOSE.
3151			! --------
3152			! COMPUTES PLANCK FUNCTIONS
3153
3154			! EXPLICIT ARGUMENTS :
3155			! --------------------
3156			! ==== INPUTS ===
3157			! PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY
3158			! PTAVE : (KDLON,KFLEV) ; TEMPERATURE
3159			! PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE
3160			! ==== OUTPUTS ===
3161			! PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
3162			! PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION
3163			! PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3164			! PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION
3165			! PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION
3166			! PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
3167			! PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3168			! PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3169			! PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS
3170			! PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS
3171
3172			! IMPLICIT ARGUMENTS : NONE
3173			! --------------------
3174
3175			! METHOD.
3176			! -------
3177
3178			! 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
3179			! FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
3180
3181			! REFERENCE.
3182			! ----------
3183
3184			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3185			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS "
3186
3187			! AUTHOR.
3188			! -------
3189			! JEAN-JACQUES MORCRETTE ECMWF
3190
3191			! MODIFICATIONS.
3192			! --------------
3193			! ORIGINAL : 89-07-14
3194
3195			! -----------------------------------------------------------------------
3196
3197			! ARGUMENTS:
3198
3199			REAL (KIND=8) pdt0(kdlon)
3200			REAL (KIND=8) ptave(kdlon, kflev)
3201			REAL (KIND=8) ptl(kdlon, kflev+1)
3202
3203			REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
3204			REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF LEVEL PLANCK FUNCTION
3205			REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
3206			REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
3207			REAL (KIND=8) pbtop(kdlon, ninter) ! TOP SPECTRAL PLANCK FUNCTION
3208			REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
3209			REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3210			REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3211			REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
3212			REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
3213			REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
3214			REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
3215
3216			! -------------------------------------------------------------------------
3217			! * LOCAL VARIABLES:
3218			INTEGER indb(kdlon), inds(kdlon)
3219			REAL (KIND=8) zblay(kdlon, kflev), zblev(kdlon, kflev+1)
3220			REAL (KIND=8) zres(kdlon), zres2(kdlon), zti(kdlon), zti2(kdlon)
3221
3222			INTEGER jk, jl, ic, jnu, jf, jg
3223			INTEGER jk1, jk2
3224			INTEGER k, j, ixtox, indto, ixtx, indt
3225			INTEGER indsu, indtp
3226			REAL (KIND=8) zdsto1, zdstox, zdst1, zdstx
3227
3228			! * Quelques parametres:
3229			REAL (KIND=8) tstand
3230			PARAMETER (tstand=250.0)
3231			REAL (KIND=8) tstp
3232			PARAMETER (tstp=12.5)
3233			INTEGER mxixt
3234			PARAMETER (mxixt=10)
3235
3236			! * Used Data Block:
3237			! REAL*8 TINTP(11)
3238			! SAVE TINTP
3239			! c$OMP THREADPRIVATE(TINTP)
3240			! REAL*8 GA(11,16,3), GB(11,16,3)
3241			! SAVE GA, GB
3242			! c$OMP THREADPRIVATE(GA, GB)
3243			! REAL*8 XP(6,6)
3244			! SAVE XP
3245			! c$OMP THREADPRIVATE(XP)
3246
3247			! DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
3248			! S 262.5, 275., 287.5, 300., 312.5 /
3249			! -----------------------------------------------------------------------
3250			! -- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
3251
3252
3253
3254
3255			! -- R.D. -- G = - 0.2 SLA
3256
3257
3258			! ----- INTERVAL = 1 ----- T = 187.5
3259
3260			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3261			! DATA (GA( 1, 1,IC),IC=1,3) /
3262			! S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
3263			! DATA (GB( 1, 1,IC),IC=1,3) /
3264			! S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
3265			! DATA (GA( 1, 2,IC),IC=1,3) /
3266			! S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
3267			! DATA (GB( 1, 2,IC),IC=1,3) /
3268			! S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
3269
3270			! ----- INTERVAL = 1 ----- T = 200.0
3271
3272			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3273			! DATA (GA( 2, 1,IC),IC=1,3) /
3274			! S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
3275			! DATA (GB( 2, 1,IC),IC=1,3) /
3276			! S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
3277			! DATA (GA( 2, 2,IC),IC=1,3) /
3278			! S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
3279			! DATA (GB( 2, 2,IC),IC=1,3) /
3280			! S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
3281
3282			! ----- INTERVAL = 1 ----- T = 212.5
3283
3284			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3285			! DATA (GA( 3, 1,IC),IC=1,3) /
3286			! S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
3287			! DATA (GB( 3, 1,IC),IC=1,3) /
3288			! S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
3289			! DATA (GA( 3, 2,IC),IC=1,3) /
3290			! S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
3291			! DATA (GB( 3, 2,IC),IC=1,3) /
3292			! S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
3293
3294			! ----- INTERVAL = 1 ----- T = 225.0
3295
3296			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3297			! DATA (GA( 4, 1,IC),IC=1,3) /
3298			! S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
3299			! DATA (GB( 4, 1,IC),IC=1,3) /
3300			! S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
3301			! DATA (GA( 4, 2,IC),IC=1,3) /
3302			! S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
3303			! DATA (GB( 4, 2,IC),IC=1,3) /
3304			! S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
3305
3306			! ----- INTERVAL = 1 ----- T = 237.5
3307
3308			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3309			! DATA (GA( 5, 1,IC),IC=1,3) /
3310			! S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
3311			! DATA (GB( 5, 1,IC),IC=1,3) /
3312			! S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
3313			! DATA (GA( 5, 2,IC),IC=1,3) /
3314			! S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
3315			! DATA (GB( 5, 2,IC),IC=1,3) /
3316			! S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
3317
3318			! ----- INTERVAL = 1 ----- T = 250.0
3319
3320			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3321			! DATA (GA( 6, 1,IC),IC=1,3) /
3322			! S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
3323			! DATA (GB( 6, 1,IC),IC=1,3) /
3324			! S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
3325			! DATA (GA( 6, 2,IC),IC=1,3) /
3326			! S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
3327			! DATA (GB( 6, 2,IC),IC=1,3) /
3328			! S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
3329
3330			! ----- INTERVAL = 1 ----- T = 262.5
3331
3332			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3333			! DATA (GA( 7, 1,IC),IC=1,3) /
3334			! S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
3335			! DATA (GB( 7, 1,IC),IC=1,3) /
3336			! S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
3337			! DATA (GA( 7, 2,IC),IC=1,3) /
3338			! S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
3339			! DATA (GB( 7, 2,IC),IC=1,3) /
3340			! S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
3341
3342			! ----- INTERVAL = 1 ----- T = 275.0
3343
3344			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3345			! DATA (GA( 8, 1,IC),IC=1,3) /
3346			! S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
3347			! DATA (GB( 8, 1,IC),IC=1,3) /
3348			! S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
3349			! DATA (GA( 8, 2,IC),IC=1,3) /
3350			! S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
3351			! DATA (GB( 8, 2,IC),IC=1,3) /
3352			! S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
3353
3354			! ----- INTERVAL = 1 ----- T = 287.5
3355
3356			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3357			! DATA (GA( 9, 1,IC),IC=1,3) /
3358			! S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
3359			! DATA (GB( 9, 1,IC),IC=1,3) /
3360			! S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
3361			! DATA (GA( 9, 2,IC),IC=1,3) /
3362			! S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
3363			! DATA (GB( 9, 2,IC),IC=1,3) /
3364			! S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
3365
3366			! ----- INTERVAL = 1 ----- T = 300.0
3367
3368			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3369			! DATA (GA(10, 1,IC),IC=1,3) /
3370			! S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
3371			! DATA (GB(10, 1,IC),IC=1,3) /
3372			! S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
3373			! DATA (GA(10, 2,IC),IC=1,3) /
3374			! S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
3375			! DATA (GB(10, 2,IC),IC=1,3) /
3376			! S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
3377
3378			! ----- INTERVAL = 1 ----- T = 312.5
3379
3380			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
3381			! DATA (GA(11, 1,IC),IC=1,3) /
3382			! S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
3383			! DATA (GB(11, 1,IC),IC=1,3) /
3384			! S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
3385			! DATA (GA(11, 2,IC),IC=1,3) /
3386			! S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
3387			! DATA (GB(11, 2,IC),IC=1,3) /
3388			! S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
3389
3390
3391
3392			! --- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
3393
3394
3395
3396
3397			! --- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U )
3398
3399
3400			! ----- INTERVAL = 2 ----- T = 187.5
3401
3402			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3403			! DATA (GA( 1, 3,IC),IC=1,3) /
3404			! S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
3405			! DATA (GB( 1, 3,IC),IC=1,3) /
3406			! S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
3407			! DATA (GA( 1, 4,IC),IC=1,3) /
3408			! S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
3409			! DATA (GB( 1, 4,IC),IC=1,3) /
3410			! S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
3411
3412			! ----- INTERVAL = 2 ----- T = 200.0
3413
3414			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3415			! DATA (GA( 2, 3,IC),IC=1,3) /
3416			! S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
3417			! DATA (GB( 2, 3,IC),IC=1,3) /
3418			! S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
3419			! DATA (GA( 2, 4,IC),IC=1,3) /
3420			! S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
3421			! DATA (GB( 2, 4,IC),IC=1,3) /
3422			! S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
3423
3424			! ----- INTERVAL = 2 ----- T = 212.5
3425
3426			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3427			! DATA (GA( 3, 3,IC),IC=1,3) /
3428			! S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
3429			! DATA (GB( 3, 3,IC),IC=1,3) /
3430			! S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
3431			! DATA (GA( 3, 4,IC),IC=1,3) /
3432			! S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
3433			! DATA (GB( 3, 4,IC),IC=1,3) /
3434			! S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
3435
3436			! ----- INTERVAL = 2 ----- T = 225.0
3437
3438			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3439			! DATA (GA( 4, 3,IC),IC=1,3) /
3440			! S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
3441			! DATA (GB( 4, 3,IC),IC=1,3) /
3442			! S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
3443			! DATA (GA( 4, 4,IC),IC=1,3) /
3444			! S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
3445			! DATA (GB( 4, 4,IC),IC=1,3) /
3446			! S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
3447
3448			! ----- INTERVAL = 2 ----- T = 237.5
3449
3450			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3451			! DATA (GA( 5, 3,IC),IC=1,3) /
3452			! S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
3453			! DATA (GB( 5, 3,IC),IC=1,3) /
3454			! S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
3455			! DATA (GA( 5, 4,IC),IC=1,3) /
3456			! S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
3457			! DATA (GB( 5, 4,IC),IC=1,3) /
3458			! S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
3459
3460			! ----- INTERVAL = 2 ----- T = 250.0
3461
3462			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3463			! DATA (GA( 6, 3,IC),IC=1,3) /
3464			! S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
3465			! DATA (GB( 6, 3,IC),IC=1,3) /
3466			! S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
3467			! DATA (GA( 6, 4,IC),IC=1,3) /
3468			! S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
3469			! DATA (GB( 6, 4,IC),IC=1,3) /
3470			! S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
3471
3472			! ----- INTERVAL = 2 ----- T = 262.5
3473
3474			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3475			! DATA (GA( 7, 3,IC),IC=1,3) /
3476			! S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
3477			! DATA (GB( 7, 3,IC),IC=1,3) /
3478			! S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
3479			! DATA (GA( 7, 4,IC),IC=1,3) /
3480			! S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
3481			! DATA (GB( 7, 4,IC),IC=1,3) /
3482			! S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
3483
3484			! ----- INTERVAL = 2 ----- T = 275.0
3485
3486			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3487			! DATA (GA( 8, 3,IC),IC=1,3) /
3488			! S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
3489			! DATA (GB( 8, 3,IC),IC=1,3) /
3490			! S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
3491			! DATA (GA( 8, 4,IC),IC=1,3) /
3492			! S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
3493			! DATA (GB( 8, 4,IC),IC=1,3) /
3494			! S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
3495
3496			! ----- INTERVAL = 2 ----- T = 287.5
3497
3498			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3499			! DATA (GA( 9, 3,IC),IC=1,3) /
3500			! S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
3501			! DATA (GB( 9, 3,IC),IC=1,3) /
3502			! S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
3503			! DATA (GA( 9, 4,IC),IC=1,3) /
3504			! S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
3505			! DATA (GB( 9, 4,IC),IC=1,3) /
3506			! S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
3507
3508			! ----- INTERVAL = 2 ----- T = 300.0
3509
3510			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3511			! DATA (GA(10, 3,IC),IC=1,3) /
3512			! S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
3513			! DATA (GB(10, 3,IC),IC=1,3) /
3514			! S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
3515			! DATA (GA(10, 4,IC),IC=1,3) /
3516			! S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
3517			! DATA (GB(10, 4,IC),IC=1,3) /
3518			! S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
3519
3520			! ----- INTERVAL = 2 ----- T = 312.5
3521
3522			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3523			! DATA (GA(11, 3,IC),IC=1,3) /
3524			! S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
3525			! DATA (GB(11, 3,IC),IC=1,3) /
3526			! S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
3527			! DATA (GA(11, 4,IC),IC=1,3) /
3528			! S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
3529			! DATA (GB(11, 4,IC),IC=1,3) /
3530			! S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
3531
3532
3533
3534
3535
3536
3537			! - WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
3538
3539
3540			! -- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
3541
3542
3543
3544			! --- G = 3.875E-03 ---------------
3545
3546			! ----- INTERVAL = 3 ----- T = 187.5
3547
3548			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3549			! DATA (GA( 1, 7,IC),IC=1,3) /
3550			! S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
3551			! DATA (GB( 1, 7,IC),IC=1,3) /
3552			! S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
3553			! DATA (GA( 1, 8,IC),IC=1,3) /
3554			! S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
3555			! DATA (GB( 1, 8,IC),IC=1,3) /
3556			! S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
3557
3558			! ----- INTERVAL = 3 ----- T = 200.0
3559
3560			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3561			! DATA (GA( 2, 7,IC),IC=1,3) /
3562			! S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
3563			! DATA (GB( 2, 7,IC),IC=1,3) /
3564			! S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
3565			! DATA (GA( 2, 8,IC),IC=1,3) /
3566			! S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
3567			! DATA (GB( 2, 8,IC),IC=1,3) /
3568			! S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
3569
3570			! ----- INTERVAL = 3 ----- T = 212.5
3571
3572			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3573			! DATA (GA( 3, 7,IC),IC=1,3) /
3574			! S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
3575			! DATA (GB( 3, 7,IC),IC=1,3) /
3576			! S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
3577			! DATA (GA( 3, 8,IC),IC=1,3) /
3578			! S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
3579			! DATA (GB( 3, 8,IC),IC=1,3) /
3580			! S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
3581
3582			! ----- INTERVAL = 3 ----- T = 225.0
3583
3584			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3585			! DATA (GA( 4, 7,IC),IC=1,3) /
3586			! S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
3587			! DATA (GB( 4, 7,IC),IC=1,3) /
3588			! S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
3589			! DATA (GA( 4, 8,IC),IC=1,3) /
3590			! S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
3591			! DATA (GB( 4, 8,IC),IC=1,3) /
3592			! S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
3593
3594			! ----- INTERVAL = 3 ----- T = 237.5
3595
3596			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3597			! DATA (GA( 5, 7,IC),IC=1,3) /
3598			! S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
3599			! DATA (GB( 5, 7,IC),IC=1,3) /
3600			! S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
3601			! DATA (GA( 5, 8,IC),IC=1,3) /
3602			! S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
3603			! DATA (GB( 5, 8,IC),IC=1,3) /
3604			! S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
3605
3606			! ----- INTERVAL = 3 ----- T = 250.0
3607
3608			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3609			! DATA (GA( 6, 7,IC),IC=1,3) /
3610			! S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
3611			! DATA (GB( 6, 7,IC),IC=1,3) /
3612			! S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
3613			! DATA (GA( 6, 8,IC),IC=1,3) /
3614			! S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
3615			! DATA (GB( 6, 8,IC),IC=1,3) /
3616			! S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
3617
3618			! ----- INTERVAL = 3 ----- T = 262.5
3619
3620			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3621			! DATA (GA( 7, 7,IC),IC=1,3) /
3622			! S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
3623			! DATA (GB( 7, 7,IC),IC=1,3) /
3624			! S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
3625			! DATA (GA( 7, 8,IC),IC=1,3) /
3626			! S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
3627			! DATA (GB( 7, 8,IC),IC=1,3) /
3628			! S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
3629
3630			! ----- INTERVAL = 3 ----- T = 275.0
3631
3632			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3633			! DATA (GA( 8, 7,IC),IC=1,3) /
3634			! S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
3635			! DATA (GB( 8, 7,IC),IC=1,3) /
3636			! S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
3637			! DATA (GA( 8, 8,IC),IC=1,3) /
3638			! S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
3639			! DATA (GB( 8, 8,IC),IC=1,3) /
3640			! S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
3641
3642			! ----- INTERVAL = 3 ----- T = 287.5
3643
3644			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3645			! DATA (GA( 9, 7,IC),IC=1,3) /
3646			! S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
3647			! DATA (GB( 9, 7,IC),IC=1,3) /
3648			! S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
3649			! DATA (GA( 9, 8,IC),IC=1,3) /
3650			! S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
3651			! DATA (GB( 9, 8,IC),IC=1,3) /
3652			! S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
3653
3654			! ----- INTERVAL = 3 ----- T = 300.0
3655
3656			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3657			! DATA (GA(10, 7,IC),IC=1,3) /
3658			! S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
3659			! DATA (GB(10, 7,IC),IC=1,3) /
3660			! S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
3661			! DATA (GA(10, 8,IC),IC=1,3) /
3662			! S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
3663			! DATA (GB(10, 8,IC),IC=1,3) /
3664			! S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
3665
3666			! ----- INTERVAL = 3 ----- T = 312.5
3667
3668			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3669			! DATA (GA(11, 7,IC),IC=1,3) /
3670			! S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
3671			! DATA (GB(11, 7,IC),IC=1,3) /
3672			! S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
3673			! DATA (GA(11, 8,IC),IC=1,3) /
3674			! S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
3675			! DATA (GB(11, 8,IC),IC=1,3) /
3676			! S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
3677
3678
3679			! -- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
3680
3681			! -- G = 3.6E-03
3682
3683			! ----- INTERVAL = 4 ----- T = 187.5
3684
3685			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3686			! DATA (GA( 1, 9,IC),IC=1,3) /
3687			! S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
3688			! DATA (GB( 1, 9,IC),IC=1,3) /
3689			! S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
3690			! DATA (GA( 1,10,IC),IC=1,3) /
3691			! S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
3692			! DATA (GB( 1,10,IC),IC=1,3) /
3693			! S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
3694
3695			! ----- INTERVAL = 4 ----- T = 200.0
3696
3697			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3698			! DATA (GA( 2, 9,IC),IC=1,3) /
3699			! S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
3700			! DATA (GB( 2, 9,IC),IC=1,3) /
3701			! S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
3702			! DATA (GA( 2,10,IC),IC=1,3) /
3703			! S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
3704			! DATA (GB( 2,10,IC),IC=1,3) /
3705			! S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
3706
3707			! ----- INTERVAL = 4 ----- T = 212.5
3708
3709			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3710			! DATA (GA( 3, 9,IC),IC=1,3) /
3711			! S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
3712			! DATA (GB( 3, 9,IC),IC=1,3) /
3713			! S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
3714			! DATA (GA( 3,10,IC),IC=1,3) /
3715			! S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
3716			! DATA (GB( 3,10,IC),IC=1,3) /
3717			! S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
3718
3719			! ----- INTERVAL = 4 ----- T = 225.0
3720
3721			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3722			! DATA (GA( 4, 9,IC),IC=1,3) /
3723			! S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
3724			! DATA (GB( 4, 9,IC),IC=1,3) /
3725			! S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
3726			! DATA (GA( 4,10,IC),IC=1,3) /
3727			! S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
3728			! DATA (GB( 4,10,IC),IC=1,3) /
3729			! S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
3730
3731			! ----- INTERVAL = 4 ----- T = 237.5
3732
3733			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3734			! DATA (GA( 5, 9,IC),IC=1,3) /
3735			! S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
3736			! DATA (GB( 5, 9,IC),IC=1,3) /
3737			! S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
3738			! DATA (GA( 5,10,IC),IC=1,3) /
3739			! S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
3740			! DATA (GB( 5,10,IC),IC=1,3) /
3741			! S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
3742
3743			! ----- INTERVAL = 4 ----- T = 250.0
3744
3745			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3746			! DATA (GA( 6, 9,IC),IC=1,3) /
3747			! S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
3748			! DATA (GB( 6, 9,IC),IC=1,3) /
3749			! S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
3750			! DATA (GA( 6,10,IC),IC=1,3) /
3751			! S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
3752			! DATA (GB( 6,10,IC),IC=1,3) /
3753			! S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
3754
3755			! ----- INTERVAL = 4 ----- T = 262.5
3756
3757			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3758			! DATA (GA( 7, 9,IC),IC=1,3) /
3759			! S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
3760			! DATA (GB( 7, 9,IC),IC=1,3) /
3761			! S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
3762			! DATA (GA( 7,10,IC),IC=1,3) /
3763			! S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
3764			! DATA (GB( 7,10,IC),IC=1,3) /
3765			! S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
3766
3767			! ----- INTERVAL = 4 ----- T = 275.0
3768
3769			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3770			! DATA (GA( 8, 9,IC),IC=1,3) /
3771			! S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
3772			! DATA (GB( 8, 9,IC),IC=1,3) /
3773			! S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
3774			! DATA (GA( 8,10,IC),IC=1,3) /
3775			! S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
3776			! DATA (GB( 8,10,IC),IC=1,3) /
3777			! S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
3778
3779			! ----- INTERVAL = 4 ----- T = 287.5
3780
3781			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3782			! DATA (GA( 9, 9,IC),IC=1,3) /
3783			! S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
3784			! DATA (GB( 9, 9,IC),IC=1,3) /
3785			! S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
3786			! DATA (GA( 9,10,IC),IC=1,3) /
3787			! S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
3788			! DATA (GB( 9,10,IC),IC=1,3) /
3789			! S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
3790
3791			! ----- INTERVAL = 4 ----- T = 300.0
3792
3793			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3794			! DATA (GA(10, 9,IC),IC=1,3) /
3795			! S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
3796			! DATA (GB(10, 9,IC),IC=1,3) /
3797			! S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
3798			! DATA (GA(10,10,IC),IC=1,3) /
3799			! S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
3800			! DATA (GB(10,10,IC),IC=1,3) /
3801			! S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
3802
3803			! ----- INTERVAL = 4 ----- T = 312.5
3804
3805			! -- INDICES FOR PADE APPROXIMATION 1 28 37 45
3806			! DATA (GA(11, 9,IC),IC=1,3) /
3807			! S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
3808			! DATA (GB(11, 9,IC),IC=1,3) /
3809			! S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
3810			! DATA (GA(11,10,IC),IC=1,3) /
3811			! S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
3812			! DATA (GB(11,10,IC),IC=1,3) /
3813			! S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
3814
3815
3816
3817			! -- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ----
3818
3819			! -- WATER VAPOR --- 350 - 500 CM-1
3820
3821			! -- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
3822
3823			! ----- INTERVAL = 5 ----- T = 187.5
3824
3825			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3826			! DATA (GA( 1, 5,IC),IC=1,3) /
3827			! S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
3828			! DATA (GB( 1, 5,IC),IC=1,3) /
3829			! S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
3830			! DATA (GA( 1, 6,IC),IC=1,3) /
3831			! S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
3832			! DATA (GB( 1, 6,IC),IC=1,3) /
3833			! S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
3834
3835			! ----- INTERVAL = 5 ----- T = 200.0
3836
3837			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3838			! DATA (GA( 2, 5,IC),IC=1,3) /
3839			! S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
3840			! DATA (GB( 2, 5,IC),IC=1,3) /
3841			! S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
3842			! DATA (GA( 2, 6,IC),IC=1,3) /
3843			! S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
3844			! DATA (GB( 2, 6,IC),IC=1,3) /
3845			! S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
3846
3847			! ----- INTERVAL = 5 ----- T = 212.5
3848
3849			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3850			! DATA (GA( 3, 5,IC),IC=1,3) /
3851			! S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
3852			! DATA (GB( 3, 5,IC),IC=1,3) /
3853			! S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
3854			! DATA (GA( 3, 6,IC),IC=1,3) /
3855			! S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
3856			! DATA (GB( 3, 6,IC),IC=1,3) /
3857			! S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
3858
3859			! ----- INTERVAL = 5 ----- T = 225.0
3860
3861			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3862			! DATA (GA( 4, 5,IC),IC=1,3) /
3863			! S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
3864			! DATA (GB( 4, 5,IC),IC=1,3) /
3865			! S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
3866			! DATA (GA( 4, 6,IC),IC=1,3) /
3867			! S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
3868			! DATA (GB( 4, 6,IC),IC=1,3) /
3869			! S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
3870
3871			! ----- INTERVAL = 5 ----- T = 237.5
3872
3873			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3874			! DATA (GA( 5, 5,IC),IC=1,3) /
3875			! S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
3876			! DATA (GB( 5, 5,IC),IC=1,3) /
3877			! S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
3878			! DATA (GA( 5, 6,IC),IC=1,3) /
3879			! S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
3880			! DATA (GB( 5, 6,IC),IC=1,3) /
3881			! S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
3882
3883			! ----- INTERVAL = 5 ----- T = 250.0
3884
3885			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3886			! DATA (GA( 6, 5,IC),IC=1,3) /
3887			! S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
3888			! DATA (GB( 6, 5,IC),IC=1,3) /
3889			! S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
3890			! DATA (GA( 6, 6,IC),IC=1,3) /
3891			! S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
3892			! DATA (GB( 6, 6,IC),IC=1,3) /
3893			! S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
3894
3895			! ----- INTERVAL = 5 ----- T = 262.5
3896
3897			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3898			! DATA (GA( 7, 5,IC),IC=1,3) /
3899			! S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
3900			! DATA (GB( 7, 5,IC),IC=1,3) /
3901			! S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
3902			! DATA (GA( 7, 6,IC),IC=1,3) /
3903			! S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
3904			! DATA (GB( 7, 6,IC),IC=1,3) /
3905			! S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
3906
3907			! ----- INTERVAL = 5 ----- T = 275.0
3908
3909			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3910			! DATA (GA( 8, 5,IC),IC=1,3) /
3911			! S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
3912			! DATA (GB( 8, 5,IC),IC=1,3) /
3913			! S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
3914			! DATA (GA( 8, 6,IC),IC=1,3) /
3915			! S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
3916			! DATA (GB( 8, 6,IC),IC=1,3) /
3917			! S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
3918
3919			! ----- INTERVAL = 5 ----- T = 287.5
3920
3921			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3922			! DATA (GA( 9, 5,IC),IC=1,3) /
3923			! S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
3924			! DATA (GB( 9, 5,IC),IC=1,3) /
3925			! S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
3926			! DATA (GA( 9, 6,IC),IC=1,3) /
3927			! S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
3928			! DATA (GB( 9, 6,IC),IC=1,3) /
3929			! S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
3930
3931			! ----- INTERVAL = 5 ----- T = 300.0
3932
3933			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3934			! DATA (GA(10, 5,IC),IC=1,3) /
3935			! S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
3936			! DATA (GB(10, 5,IC),IC=1,3) /
3937			! S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
3938			! DATA (GA(10, 6,IC),IC=1,3) /
3939			! S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
3940			! DATA (GB(10, 6,IC),IC=1,3) /
3941			! S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
3942
3943			! ----- INTERVAL = 5 ----- T = 312.5
3944
3945			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3946			! DATA (GA(11, 5,IC),IC=1,3) /
3947			! S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
3948			! DATA (GB(11, 5,IC),IC=1,3) /
3949			! S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
3950			! DATA (GA(11, 6,IC),IC=1,3) /
3951			! S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
3952			! DATA (GB(11, 6,IC),IC=1,3) /
3953			! S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
3954
3955
3956
3957
3958			! - WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
3959			! --- G = 0.0
3960
3961
3962			! ----- INTERVAL = 6 ----- T = 187.5
3963
3964			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3965			! DATA (GA( 1,11,IC),IC=1,3) /
3966			! S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
3967			! DATA (GB( 1,11,IC),IC=1,3) /
3968			! S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
3969			! DATA (GA( 1,12,IC),IC=1,3) /
3970			! S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
3971			! DATA (GB( 1,12,IC),IC=1,3) /
3972			! S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
3973
3974			! ----- INTERVAL = 6 ----- T = 200.0
3975
3976			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3977			! DATA (GA( 2,11,IC),IC=1,3) /
3978			! S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
3979			! DATA (GB( 2,11,IC),IC=1,3) /
3980			! S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
3981			! DATA (GA( 2,12,IC),IC=1,3) /
3982			! S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
3983			! DATA (GB( 2,12,IC),IC=1,3) /
3984			! S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
3985
3986			! ----- INTERVAL = 6 ----- T = 212.5
3987
3988			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
3989			! DATA (GA( 3,11,IC),IC=1,3) /
3990			! S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
3991			! DATA (GB( 3,11,IC),IC=1,3) /
3992			! S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
3993			! DATA (GA( 3,12,IC),IC=1,3) /
3994			! S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
3995			! DATA (GB( 3,12,IC),IC=1,3) /
3996			! S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
3997
3998			! ----- INTERVAL = 6 ----- T = 225.0
3999
4000			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4001			! DATA (GA( 4,11,IC),IC=1,3) /
4002			! S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
4003			! DATA (GB( 4,11,IC),IC=1,3) /
4004			! S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
4005			! DATA (GA( 4,12,IC),IC=1,3) /
4006			! S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
4007			! DATA (GB( 4,12,IC),IC=1,3) /
4008			! S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
4009
4010			! ----- INTERVAL = 6 ----- T = 237.5
4011
4012			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4013			! DATA (GA( 5,11,IC),IC=1,3) /
4014			! S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
4015			! DATA (GB( 5,11,IC),IC=1,3) /
4016			! S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
4017			! DATA (GA( 5,12,IC),IC=1,3) /
4018			! S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
4019			! DATA (GB( 5,12,IC),IC=1,3) /
4020			! S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
4021
4022			! ----- INTERVAL = 6 ----- T = 250.0
4023
4024			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4025			! DATA (GA( 6,11,IC),IC=1,3) /
4026			! S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
4027			! DATA (GB( 6,11,IC),IC=1,3) /
4028			! S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
4029			! DATA (GA( 6,12,IC),IC=1,3) /
4030			! S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
4031			! DATA (GB( 6,12,IC),IC=1,3) /
4032			! S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
4033
4034			! ----- INTERVAL = 6 ----- T = 262.5
4035
4036			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4037			! DATA (GA( 7,11,IC),IC=1,3) /
4038			! S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
4039			! DATA (GB( 7,11,IC),IC=1,3) /
4040			! S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
4041			! DATA (GA( 7,12,IC),IC=1,3) /
4042			! S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
4043			! DATA (GB( 7,12,IC),IC=1,3) /
4044			! S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
4045
4046			! ----- INTERVAL = 6 ----- T = 275.0
4047
4048			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4049			! DATA (GA( 8,11,IC),IC=1,3) /
4050			! S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
4051			! DATA (GB( 8,11,IC),IC=1,3) /
4052			! S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
4053			! DATA (GA( 8,12,IC),IC=1,3) /
4054			! S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
4055			! DATA (GB( 8,12,IC),IC=1,3) /
4056			! S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
4057
4058			! ----- INTERVAL = 6 ----- T = 287.5
4059
4060			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4061			! DATA (GA( 9,11,IC),IC=1,3) /
4062			! S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
4063			! DATA (GB( 9,11,IC),IC=1,3) /
4064			! S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
4065			! DATA (GA( 9,12,IC),IC=1,3) /
4066			! S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
4067			! DATA (GB( 9,12,IC),IC=1,3) /
4068			! S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
4069
4070			! ----- INTERVAL = 6 ----- T = 300.0
4071
4072			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4073			! DATA (GA(10,11,IC),IC=1,3) /
4074			! S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
4075			! DATA (GB(10,11,IC),IC=1,3) /
4076			! S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
4077			! DATA (GA(10,12,IC),IC=1,3) /
4078			! S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
4079			! DATA (GB(10,12,IC),IC=1,3) /
4080			! S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
4081
4082			! ----- INTERVAL = 6 ----- T = 312.5
4083
4084			! -- INDICES FOR PADE APPROXIMATION 1 35 40 45
4085			! DATA (GA(11,11,IC),IC=1,3) /
4086			! S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
4087			! DATA (GB(11,11,IC),IC=1,3) /
4088			! S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
4089			! DATA (GA(11,12,IC),IC=1,3) /
4090			! S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
4091			! DATA (GB(11,12,IC),IC=1,3) /
4092			! S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
4093
4094
4095
4096
4097
4098			! -- END WATER VAPOR
4099
4100
4101			! -- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
4102
4103
4104
4105			! -- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9
4106
4107			! ----- INTERVAL = 2 ----- T = 187.5
4108
4109			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4110			! DATA (GA( 1,13,IC),IC=1,3) /
4111			! S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
4112			! DATA (GB( 1,13,IC),IC=1,3) /
4113			! S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
4114			! DATA (GA( 1,14,IC),IC=1,3) /
4115			! S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
4116			! DATA (GB( 1,14,IC),IC=1,3) /
4117			! S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
4118
4119			! ----- INTERVAL = 2 ----- T = 200.0
4120
4121			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4122			! DATA (GA( 2,13,IC),IC=1,3) /
4123			! S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
4124			! DATA (GB( 2,13,IC),IC=1,3) /
4125			! S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
4126			! DATA (GA( 2,14,IC),IC=1,3) /
4127			! S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
4128			! DATA (GB( 2,14,IC),IC=1,3) /
4129			! S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
4130
4131			! ----- INTERVAL = 2 ----- T = 212.5
4132
4133			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4134			! DATA (GA( 3,13,IC),IC=1,3) /
4135			! S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
4136			! DATA (GB( 3,13,IC),IC=1,3) /
4137			! S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
4138			! DATA (GA( 3,14,IC),IC=1,3) /
4139			! S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
4140			! DATA (GB( 3,14,IC),IC=1,3) /
4141			! S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
4142
4143			! ----- INTERVAL = 2 ----- T = 225.0
4144
4145			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4146			! DATA (GA( 4,13,IC),IC=1,3) /
4147			! S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
4148			! DATA (GB( 4,13,IC),IC=1,3) /
4149			! S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
4150			! DATA (GA( 4,14,IC),IC=1,3) /
4151			! S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
4152			! DATA (GB( 4,14,IC),IC=1,3) /
4153			! S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
4154
4155			! ----- INTERVAL = 2 ----- T = 237.5
4156
4157			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4158			! DATA (GA( 5,13,IC),IC=1,3) /
4159			! S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
4160			! DATA (GB( 5,13,IC),IC=1,3) /
4161			! S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
4162			! DATA (GA( 5,14,IC),IC=1,3) /
4163			! S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
4164			! DATA (GB( 5,14,IC),IC=1,3) /
4165			! S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
4166
4167			! ----- INTERVAL = 2 ----- T = 250.0
4168
4169			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4170			! DATA (GA( 6,13,IC),IC=1,3) /
4171			! S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
4172			! DATA (GB( 6,13,IC),IC=1,3) /
4173			! S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
4174			! DATA (GA( 6,14,IC),IC=1,3) /
4175			! S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
4176			! DATA (GB( 6,14,IC),IC=1,3) /
4177			! S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
4178
4179			! ----- INTERVAL = 2 ----- T = 262.5
4180
4181			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4182			! DATA (GA( 7,13,IC),IC=1,3) /
4183			! S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
4184			! DATA (GB( 7,13,IC),IC=1,3) /
4185			! S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
4186			! DATA (GA( 7,14,IC),IC=1,3) /
4187			! S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
4188			! DATA (GB( 7,14,IC),IC=1,3) /
4189			! S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
4190
4191			! ----- INTERVAL = 2 ----- T = 275.0
4192
4193			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4194			! DATA (GA( 8,13,IC),IC=1,3) /
4195			! S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
4196			! DATA (GB( 8,13,IC),IC=1,3) /
4197			! S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
4198			! DATA (GA( 8,14,IC),IC=1,3) /
4199			! S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
4200			! DATA (GB( 8,14,IC),IC=1,3) /
4201			! S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
4202
4203			! ----- INTERVAL = 2 ----- T = 287.5
4204
4205			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4206			! DATA (GA( 9,13,IC),IC=1,3) /
4207			! S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
4208			! DATA (GB( 9,13,IC),IC=1,3) /
4209			! S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
4210			! DATA (GA( 9,14,IC),IC=1,3) /
4211			! S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
4212			! DATA (GB( 9,14,IC),IC=1,3) /
4213			! S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
4214
4215			! ----- INTERVAL = 2 ----- T = 300.0
4216
4217			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4218			! DATA (GA(10,13,IC),IC=1,3) /
4219			! S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
4220			! DATA (GB(10,13,IC),IC=1,3) /
4221			! S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
4222			! DATA (GA(10,14,IC),IC=1,3) /
4223			! S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
4224			! DATA (GB(10,14,IC),IC=1,3) /
4225			! S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
4226
4227			! ----- INTERVAL = 2 ----- T = 312.5
4228
4229			! -- INDICES FOR PADE APPROXIMATION 1 30 38 45
4230			! DATA (GA(11,13,IC),IC=1,3) /
4231			! S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
4232			! DATA (GB(11,13,IC),IC=1,3) /
4233			! S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
4234			! DATA (GA(11,14,IC),IC=1,3) /
4235			! S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
4236			! DATA (GB(11,14,IC),IC=1,3) /
4237			! S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
4238
4239
4240
4241
4242
4243
4244
4245
4246
4247
4248			! -- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
4249
4250
4251			! -- G = 0.0
4252
4253
4254			! ----- INTERVAL = 4 ----- T = 187.5
4255
4256			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4257			! DATA (GA( 1,15,IC),IC=1,3) /
4258			! S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
4259			! DATA (GB( 1,15,IC),IC=1,3) /
4260			! S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
4261			! DATA (GA( 1,16,IC),IC=1,3) /
4262			! S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
4263			! DATA (GB( 1,16,IC),IC=1,3) /
4264			! S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
4265
4266			! ----- INTERVAL = 4 ----- T = 200.0
4267
4268			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4269			! DATA (GA( 2,15,IC),IC=1,3) /
4270			! S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
4271			! DATA (GB( 2,15,IC),IC=1,3) /
4272			! S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
4273			! DATA (GA( 2,16,IC),IC=1,3) /
4274			! S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
4275			! DATA (GB( 2,16,IC),IC=1,3) /
4276			! S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
4277
4278			! ----- INTERVAL = 4 ----- T = 212.5
4279
4280			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4281			! DATA (GA( 3,15,IC),IC=1,3) /
4282			! S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
4283			! DATA (GB( 3,15,IC),IC=1,3) /
4284			! S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
4285			! DATA (GA( 3,16,IC),IC=1,3) /
4286			! S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
4287			! DATA (GB( 3,16,IC),IC=1,3) /
4288			! S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
4289
4290			! ----- INTERVAL = 4 ----- T = 225.0
4291
4292			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4293			! DATA (GA( 4,15,IC),IC=1,3) /
4294			! S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
4295			! DATA (GB( 4,15,IC),IC=1,3) /
4296			! S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
4297			! DATA (GA( 4,16,IC),IC=1,3) /
4298			! S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
4299			! DATA (GB( 4,16,IC),IC=1,3) /
4300			! S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
4301
4302			! ----- INTERVAL = 4 ----- T = 237.5
4303
4304			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4305			! DATA (GA( 5,15,IC),IC=1,3) /
4306			! S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
4307			! DATA (GB( 5,15,IC),IC=1,3) /
4308			! S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
4309			! DATA (GA( 5,16,IC),IC=1,3) /
4310			! S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
4311			! DATA (GB( 5,16,IC),IC=1,3) /
4312			! S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
4313
4314			! ----- INTERVAL = 4 ----- T = 250.0
4315
4316			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4317			! DATA (GA( 6,15,IC),IC=1,3) /
4318			! S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
4319			! DATA (GB( 6,15,IC),IC=1,3) /
4320			! S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
4321			! DATA (GA( 6,16,IC),IC=1,3) /
4322			! S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
4323			! DATA (GB( 6,16,IC),IC=1,3) /
4324			! S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
4325
4326			! ----- INTERVAL = 4 ----- T = 262.5
4327
4328			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4329			! DATA (GA( 7,15,IC),IC=1,3) /
4330			! S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
4331			! DATA (GB( 7,15,IC),IC=1,3) /
4332			! S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
4333			! DATA (GA( 7,16,IC),IC=1,3) /
4334			! S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
4335			! DATA (GB( 7,16,IC),IC=1,3) /
4336			! S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
4337
4338			! ----- INTERVAL = 4 ----- T = 275.0
4339
4340			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4341			! DATA (GA( 8,15,IC),IC=1,3) /
4342			! S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
4343			! DATA (GB( 8,15,IC),IC=1,3) /
4344			! S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
4345			! DATA (GA( 8,16,IC),IC=1,3) /
4346			! S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
4347			! DATA (GB( 8,16,IC),IC=1,3) /
4348			! S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
4349
4350			! ----- INTERVAL = 4 ----- T = 287.5
4351
4352			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4353			! DATA (GA( 9,15,IC),IC=1,3) /
4354			! S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
4355			! DATA (GB( 9,15,IC),IC=1,3) /
4356			! S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
4357			! DATA (GA( 9,16,IC),IC=1,3) /
4358			! S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
4359			! DATA (GB( 9,16,IC),IC=1,3) /
4360			! S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
4361
4362			! ----- INTERVAL = 4 ----- T = 300.0
4363
4364			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4365			! DATA (GA(10,15,IC),IC=1,3) /
4366			! S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
4367			! DATA (GB(10,15,IC),IC=1,3) /
4368			! S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
4369			! DATA (GA(10,16,IC),IC=1,3) /
4370			! S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
4371			! DATA (GB(10,16,IC),IC=1,3) /
4372			! S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
4373
4374			! ----- INTERVAL = 4 ----- T = 312.5
4375
4376			! -- INDICES FOR PADE APPROXIMATION 1 15 29 45
4377			! DATA (GA(11,15,IC),IC=1,3) /
4378			! S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
4379			! DATA (GB(11,15,IC),IC=1,3) /
4380			! S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
4381			! DATA (GA(11,16,IC),IC=1,3) /
4382			! S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
4383			! DATA (GB(11,16,IC),IC=1,3) /
4384			! S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
4385
4386			! ------------------------------------------------------------------
4387			! DATA (( XP( J,K),J=1,6), K=1,6) /
4388			! S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
4389			! S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
4390			! S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
4391			! S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
4392			! S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
4393			! S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
4394			! S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
4395			! S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
4396			! S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
4397			! S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
4398			! S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
4399			! S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
4400
4401
4402
4403			! * 1.0 PLANCK FUNCTIONS AND GRADIENTS
4404			! ------------------------------
4405
4406
4407			! cdir collapse
4408			DO jk = 1, kflev + 1
4409			DO jl = 1, kdlon
4410			pbint(jl, jk) = 0.
4411			END DO
4412			END DO
4413			DO jl = 1, kdlon
4414			pbsuin(jl) = 0.
4415			END DO
4416
4417			DO jnu = 1, ninter
4418
4419			! * 1.1 LEVELS FROM SURFACE TO KFLEV
4420			! ----------------------------
4421
4422
4423			DO jk = 1, kflev
4424			DO jl = 1, kdlon
4425			zti(jl) = (ptl(jl,jk)-tstand)/tstand
4426			zres(jl) = xp(1, jnu) + zti(jl)(xp(2,jnu)+zti(jl)(xp(3, &
4427			jnu)+zti(jl)(xp(4,jnu)+zti(jl)(xp(5,jnu)+zti(jl)*(xp(6,jnu))))))
4428			pbint(jl, jk) = pbint(jl, jk) + zres(jl)
4429			pb(jl, jnu, jk) = zres(jl)
4430			zblev(jl, jk) = zres(jl)
4431			zti2(jl) = (ptave(jl,jk)-tstand)/tstand
4432			zres2(jl) = xp(1, jnu) + zti2(jl)(xp(2,jnu)+zti2(jl)(xp(3, &
4433			jnu)+zti2(jl)(xp(4,jnu)+zti2(jl)(xp(5,jnu)+zti2(jl)*(xp(6,jnu)))) &
4434			))
4435			zblay(jl, jk) = zres2(jl)
4436			END DO
4437			END DO
4438
4439			! * 1.2 TOP OF THE ATMOSPHERE AND SURFACE
4440			! ---------------------------------
4441
4442
4443			DO jl = 1, kdlon
4444			zti(jl) = (ptl(jl,kflev+1)-tstand)/tstand
4445			zti2(jl) = (ptl(jl,1)+pdt0(jl)-tstand)/tstand
4446			zres(jl) = xp(1, jnu) + zti(jl)(xp(2,jnu)+zti(jl)(xp(3, &
4447			jnu)+zti(jl)(xp(4,jnu)+zti(jl)(xp(5,jnu)+zti(jl)*(xp(6,jnu))))))
4448			zres2(jl) = xp(1, jnu) + zti2(jl)(xp(2,jnu)+zti2(jl)(xp(3, &
4449			jnu)+zti2(jl)(xp(4,jnu)+zti2(jl)(xp(5,jnu)+zti2(jl)*(xp(6,jnu))))))
4450			pbint(jl, kflev+1) = pbint(jl, kflev+1) + zres(jl)
4451			pb(jl, jnu, kflev+1) = zres(jl)
4452			zblev(jl, kflev+1) = zres(jl)
4453			pbtop(jl, jnu) = zres(jl)
4454			pbsur(jl, jnu) = zres2(jl)
4455			pbsuin(jl) = pbsuin(jl) + zres2(jl)
4456			END DO
4457
4458			! * 1.3 GRADIENTS IN SUB-LAYERS
4459			! -----------------------
4460
4461
4462			DO jk = 1, kflev
4463			jk2 = 2*jk
4464			jk1 = jk2 - 1
4465			DO jl = 1, kdlon
4466			pdbsl(jl, jnu, jk1) = zblay(jl, jk) - zblev(jl, jk)
4467			pdbsl(jl, jnu, jk2) = zblev(jl, jk+1) - zblay(jl, jk)
4468			END DO
4469			END DO
4470
4471			END DO
4472
4473			! * 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
4474			! ---------------------------------------------
4475
4476
4477
4478
4479			DO jl = 1, kdlon
4480			zdsto1 = (ptl(jl,kflev+1)-tintp(1))/tstp
4481			ixtox = max(1, min(mxixt,int(zdsto1+1.)))
4482			zdstox = (ptl(jl,kflev+1)-tintp(ixtox))/tstp
4483			IF (zdstox<0.5) THEN
4484			indto = ixtox
4485			ELSE
4486			indto = ixtox + 1
4487			END IF
4488			indb(jl) = indto
4489			zdst1 = (ptl(jl,1)-tintp(1))/tstp
4490			ixtx = max(1, min(mxixt,int(zdst1+1.)))
4491			zdstx = (ptl(jl,1)-tintp(ixtx))/tstp
4492			IF (zdstx<0.5) THEN
4493			indt = ixtx
4494			ELSE
4495			indt = ixtx + 1
4496			END IF
4497			inds(jl) = indt
4498			END DO
4499
4500			DO jf = 1, 2
4501			DO jg = 1, 8
4502			DO jl = 1, kdlon
4503			indsu = inds(jl)
4504			pgasur(jl, jg, jf) = ga(indsu, 2*jg-1, jf)
4505			pgbsur(jl, jg, jf) = gb(indsu, 2*jg-1, jf)
4506			indtp = indb(jl)
4507			pgatop(jl, jg, jf) = ga(indtp, 2*jg-1, jf)
4508			pgbtop(jl, jg, jf) = gb(indtp, 2*jg-1, jf)
4509			END DO
4510			END DO
4511			END DO
4512
4513			DO jk = 1, kflev
4514			DO jl = 1, kdlon
4515			zdst1 = (ptave(jl,jk)-tintp(1))/tstp
4516			ixtx = max(1, min(mxixt,int(zdst1+1.)))
4517			zdstx = (ptave(jl,jk)-tintp(ixtx))/tstp
4518			IF (zdstx<0.5) THEN
4519			indt = ixtx
4520			ELSE
4521			indt = ixtx + 1
4522			END IF
4523			indb(jl) = indt
4524			END DO
4525
4526			DO jf = 1, 2
4527			DO jg = 1, 8
4528			DO jl = 1, kdlon
4529			indt = indb(jl)
4530			pga(jl, jg, jf, jk) = ga(indt, 2*jg, jf)
4531			pgb(jl, jg, jf, jk) = gb(indt, 2*jg, jf)
4532			END DO
4533			END DO
4534			END DO
4535			END DO
4536
4537			! ------------------------------------------------------------------
4538
4539			RETURN
4540			END SUBROUTINE lwb_lmdar4
4541			SUBROUTINE lwv_lmdar4(kuaer, ktraer, klim, pabcu, pb, pbint, pbsuin, pbsur, &
4542			pbtop, pdbsl, pemis, ppmb, ptave, pga, pgb, pgasur, pgbsur, pgatop, &
4543			pgbtop, pcntrb, pcts, pfluc)
4544			USE dimphy
4545			IMPLICIT NONE
4546			include "raddimlw.h"
4547			include "YOMCST.h"
4548
4549			! -----------------------------------------------------------------------
4550			! PURPOSE.
4551			! --------
4552			! CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
4553			! FLUXES OR RADIANCES
4554
4555			! METHOD.
4556			! -------
4557
4558			! 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
4559			! CONTRIBUTIONS BY - THE NEARBY LAYERS
4560			! - THE DISTANT LAYERS
4561			! - THE BOUNDARY TERMS
4562			! 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
4563
4564			! REFERENCE.
4565			! ----------
4566
4567			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
4568			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
4569
4570			! AUTHOR.
4571			! -------
4572			! JEAN-JACQUES MORCRETTE ECMWF
4573
4574			! MODIFICATIONS.
4575			! --------------
4576			! ORIGINAL : 89-07-14
4577			! -----------------------------------------------------------------------
4578
4579			! * ARGUMENTS:
4580			INTEGER kuaer, ktraer, klim
4581
4582			REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! EFFECTIVE ABSORBER AMOUNTS
4583			REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
4584			REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
4585			REAL (KIND=8) pbsur(kdlon, ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
4586			REAL (KIND=8) pbsuin(kdlon) ! SURFACE PLANCK FUNCTION
4587			REAL (KIND=8) pbtop(kdlon, ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
4588			REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
4589			REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
4590			REAL (KIND=8) ppmb(kdlon, kflev+1) ! HALF-LEVEL PRESSURE (MB)
4591			REAL (KIND=8) ptave(kdlon, kflev) ! TEMPERATURE
4592			REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
4593			REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
4594			REAL (KIND=8) pgasur(kdlon, 8, 2) ! PADE APPROXIMANTS
4595			REAL (KIND=8) pgbsur(kdlon, 8, 2) ! PADE APPROXIMANTS
4596			REAL (KIND=8) pgatop(kdlon, 8, 2) ! PADE APPROXIMANTS
4597			REAL (KIND=8) pgbtop(kdlon, 8, 2) ! PADE APPROXIMANTS
4598
4599			REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
4600			REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
4601			REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
4602			! -----------------------------------------------------------------------
4603			! LOCAL VARIABLES:
4604			REAL (KIND=8) zadjd(kdlon, kflev+1)
4605			REAL (KIND=8) zadju(kdlon, kflev+1)
4606			REAL (KIND=8) zdbdt(kdlon, ninter, kflev)
4607			REAL (KIND=8) zdisd(kdlon, kflev+1)
4608			REAL (KIND=8) zdisu(kdlon, kflev+1)
4609
4610			INTEGER jk, jl
4611			! -----------------------------------------------------------------------
4612
4613			DO jk = 1, kflev + 1
4614			DO jl = 1, kdlon
4615			zadjd(jl, jk) = 0.
4616			zadju(jl, jk) = 0.
4617			zdisd(jl, jk) = 0.
4618			zdisu(jl, jk) = 0.
4619			END DO
4620			END DO
4621
4622			DO jk = 1, kflev
4623			DO jl = 1, kdlon
4624			pcts(jl, jk) = 0.
4625			END DO
4626			END DO
4627
4628			! * CONTRIBUTION FROM ADJACENT LAYERS
4629
4630			CALL lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, zadjd, zadju, &
4631			pcntrb, zdbdt)
4632			! * CONTRIBUTION FROM DISTANT LAYERS
4633
4634			CALL lwvd_lmdar4(kuaer, ktraer, pabcu, zdbdt, pga, pgb, pcntrb, zdisd, &
4635			zdisu)
4636
4637			! * EXCHANGE WITH THE BOUNDARIES
4638
4639			CALL lwvb_lmdar4(kuaer, ktraer, klim, pabcu, zadjd, zadju, pb, pbint, &
4640			pbsuin, pbsur, pbtop, zdisd, zdisu, pemis, ppmb, pga, pgb, pgasur, &
4641			pgbsur, pgatop, pgbtop, pcts, pfluc)
4642
4643
4644			RETURN
4645			END SUBROUTINE lwv_lmdar4
4646			SUBROUTINE lwvb_lmdar4(kuaer, ktraer, klim, pabcu, padjd, padju, pb, pbint, &
4647			pbsui, pbsur, pbtop, pdisd, pdisu, pemis, ppmb, pga, pgb, pgasur, pgbsur, &
4648			pgatop, pgbtop, pcts, pfluc)
4649			USE dimphy
4650			IMPLICIT NONE
4651			include "raddimlw.h"
4652			include "radopt.h"
4653
4654			! -----------------------------------------------------------------------
4655			! PURPOSE.
4656			! --------
4657			! INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
4658			! INTEGRATION
4659
4660			! METHOD.
4661			! -------
4662
4663			! 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
4664			! ATMOSPHERE
4665			! 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
4666			! TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
4667			! 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
4668
4669			! REFERENCE.
4670			! ----------
4671
4672			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
4673			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
4674
4675			! AUTHOR.
4676			! -------
4677			! JEAN-JACQUES MORCRETTE ECMWF
4678
4679			! MODIFICATIONS.
4680			! --------------
4681			! ORIGINAL : 89-07-14
4682			! Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
4683			! -----------------------------------------------------------------------
4684
4685			! * 0.1 ARGUMENTS
4686			! ---------
4687
4688			INTEGER kuaer, ktraer, klim
4689
4690			REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
4691			REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
4692			REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION BY ADJACENT LAYERS
4693			REAL (KIND=8) pb(kdlon, ninter, kflev+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
4694			REAL (KIND=8) pbint(kdlon, kflev+1) ! HALF-LEVEL PLANCK FUNCTIONS
4695			REAL (KIND=8) pbsur(kdlon, ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
4696			REAL (KIND=8) pbsui(kdlon) ! SURFACE PLANCK FUNCTION
4697			REAL (KIND=8) pbtop(kdlon, ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
4698			REAL (KIND=8) pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
4699			REAL (KIND=8) pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
4700			REAL (KIND=8) pemis(kdlon) ! SURFACE EMISSIVITY
4701			REAL (KIND=8) ppmb(kdlon, kflev+1) ! PRESSURE MB
4702			REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
4703			REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
4704			REAL (KIND=8) pgasur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
4705			REAL (KIND=8) pgbsur(kdlon, 8, 2) ! SURFACE PADE APPROXIMANTS
4706			REAL (KIND=8) pgatop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
4707			REAL (KIND=8) pgbtop(kdlon, 8, 2) ! T.O.A. PADE APPROXIMANTS
4708
4709			REAL (KIND=8) pfluc(kdlon, 2, kflev+1) ! CLEAR-SKY RADIATIVE FLUXES
4710			REAL (KIND=8) pcts(kdlon, kflev) ! COOLING-TO-SPACE TERM
4711
4712			! * LOCAL VARIABLES:
4713
4714			REAL (KIND=8) zbgnd(kdlon)
4715			REAL (KIND=8) zfd(kdlon)
4716			REAL (KIND=8) zfn10(kdlon)
4717			REAL (KIND=8) zfu(kdlon)
4718			REAL (KIND=8) ztt(kdlon, ntra)
4719			REAL (KIND=8) ztt1(kdlon, ntra)
4720			REAL (KIND=8) ztt2(kdlon, ntra)
4721			REAL (KIND=8) zuu(kdlon, nua)
4722			REAL (KIND=8) zcnsol(kdlon)
4723			REAL (KIND=8) zcntop(kdlon)
4724
4725			INTEGER jk, jl, ja
4726			INTEGER jstra, jstru
4727			INTEGER ind1, ind2, ind3, ind4, in, jlim
4728			REAL (KIND=8) zctstr
4729
4730			! -----------------------------------------------------------------------
4731
4732			! * 1. INITIALIZATION
4733			! --------------
4734
4735
4736
4737			! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
4738			! ---------------------------------
4739
4740
4741			DO ja = 1, ntra
4742			DO jl = 1, kdlon
4743			ztt(jl, ja) = 1.0
4744			ztt1(jl, ja) = 1.0
4745			ztt2(jl, ja) = 1.0
4746			END DO
4747			END DO
4748
4749			DO ja = 1, nua
4750			DO jl = 1, kdlon
4751			zuu(jl, ja) = 1.0
4752			END DO
4753			END DO
4754
4755			! ------------------------------------------------------------------
4756
4757			! * 2. VERTICAL INTEGRATION
4758			! --------------------
4759
4760
4761			ind1 = 0
4762			ind3 = 0
4763			ind4 = 1
4764			ind2 = 1
4765
4766			! * 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
4767			! -----------------------------------
4768
4769
4770			DO jk = 1, kflev
4771			in = (jk-1)*ng1p1 + 1
4772
4773			DO ja = 1, kuaer
4774			DO jl = 1, kdlon
4775			zuu(jl, ja) = pabcu(jl, ja, in)
4776			END DO
4777			END DO
4778
4779
4780			CALL lwtt_lmdar4(pgatop(1,1,1), pgbtop(1,1,1), zuu, ztt)
4781
4782			DO jl = 1, kdlon
4783			zcntop(jl) = pbtop(jl, 1)ztt(jl, 1)ztt(jl, 10) + &
4784			pbtop(jl, 2)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
4785			pbtop(jl, 3)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
4786			pbtop(jl, 4)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
4787			pbtop(jl, 5)ztt(jl, 3)ztt(jl, 14) + pbtop(jl, 6)ztt(jl, 6)ztt(jl, &
4788			15)
4789			zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
4790			pfluc(jl, 2, jk) = zfd(jl)
4791			END DO
4792
4793			END DO
4794
4795			jk = kflev + 1
4796			in = (jk-1)*ng1p1 + 1
4797
4798			DO jl = 1, kdlon
4799			zcntop(jl) = pbtop(jl, 1) + pbtop(jl, 2) + pbtop(jl, 3) + pbtop(jl, 4) + &
4800			pbtop(jl, 5) + pbtop(jl, 6)
4801			zfd(jl) = zcntop(jl) - pbint(jl, jk) - pdisd(jl, jk) - padjd(jl, jk)
4802			pfluc(jl, 2, jk) = zfd(jl)
4803			END DO
4804
4805			! * 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
4806			! ---------------------------------------
4807
4808
4809
4810			! * 2.4.1 INITIALIZATION
4811			! --------------
4812
4813
4814			jlim = kflev
4815
4816			IF (.NOT. levoigt) THEN
4817			DO jk = kflev, 1, -1
4818			IF (ppmb(1,jk)<10.0) THEN
4819			jlim = jk
4820			END IF
4821			END DO
4822			END IF
4823			klim = jlim
4824
4825			IF (.NOT. levoigt) THEN
4826			DO ja = 1, ktraer
4827			DO jl = 1, kdlon
4828			ztt1(jl, ja) = 1.0
4829			END DO
4830			END DO
4831
4832			! * 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
4833			! -----------------------------
4834
4835
4836			DO jstra = kflev, jlim, -1
4837			jstru = (jstra-1)*ng1p1 + 1
4838
4839			DO ja = 1, kuaer
4840			DO jl = 1, kdlon
4841			zuu(jl, ja) = pabcu(jl, ja, jstru)
4842			END DO
4843			END DO
4844
4845
4846			CALL lwtt_lmdar4(pga(1,1,1,jstra), pgb(1,1,1,jstra), zuu, ztt)
4847
4848			DO jl = 1, kdlon
4849			zctstr = (pb(jl,1,jstra)+pb(jl,1,jstra+1))* &
4850			(ztt1(jl,1)ztt1(jl,10)-ztt(jl,1)ztt(jl,10)) + &
4851			(pb(jl,2,jstra)+pb(jl,2,jstra+1))(ztt1(jl,2)ztt1(jl,7)*ztt1(jl,11 &
4852			)-ztt(jl,2)ztt(jl,7)ztt(jl,11)) + (pb(jl,3,jstra)+pb(jl,3,jstra+1 &
4853			))(ztt1(jl,4)ztt1(jl,8)ztt1(jl,12)-ztt(jl,4)ztt(jl,8)*ztt(jl,12 &
4854			)) + (pb(jl,4,jstra)+pb(jl,4,jstra+1))(ztt1(jl,5)ztt1(jl,9)*ztt1( &
4855			jl,13)-ztt(jl,5)ztt(jl,9)ztt(jl,13)) + (pb(jl,5,jstra)+pb(jl,5, &
4856			jstra+1))(ztt1(jl,3)ztt1(jl,14)-ztt(jl,3)*ztt(jl,14)) + &
4857			(pb(jl,6,jstra)+pb(jl,6,jstra+1))(ztt1(jl,6)ztt1(jl,15)-ztt(jl,6) &
4858			*ztt(jl,15))
4859			pcts(jl, jstra) = zctstr*0.5
4860			END DO
4861			DO ja = 1, ktraer
4862			DO jl = 1, kdlon
4863			ztt1(jl, ja) = ztt(jl, ja)
4864			END DO
4865			END DO
4866			END DO
4867			END IF
4868			! Mise a zero de securite pour PCTS en cas de LEVOIGT
4869			IF (levoigt) THEN
4870			DO jstra = 1, kflev
4871			DO jl = 1, kdlon
4872			pcts(jl, jstra) = 0.
4873			END DO
4874			END DO
4875			END IF
4876
4877			! * 2.5 EXCHANGE WITH LOWER LIMIT
4878			! -------------------------
4879
4880
4881			DO jl = 1, kdlon
4882			zbgnd(jl) = pbsui(jl)pemis(jl) - (1.-pemis(jl))pfluc(jl, 2, 1) - &
4883			pbint(jl, 1)
4884			END DO
4885
4886			jk = 1
4887			in = (jk-1)*ng1p1 + 1
4888
4889			DO jl = 1, kdlon
4890			zcnsol(jl) = pbsur(jl, 1) + pbsur(jl, 2) + pbsur(jl, 3) + pbsur(jl, 4) + &
4891			pbsur(jl, 5) + pbsur(jl, 6)
4892			zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
4893			zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
4894			pfluc(jl, 1, jk) = zfu(jl)
4895			END DO
4896
4897			DO jk = 2, kflev + 1
4898			in = (jk-1)*ng1p1 + 1
4899
4900
4901			DO ja = 1, kuaer
4902			DO jl = 1, kdlon
4903			zuu(jl, ja) = pabcu(jl, ja, 1) - pabcu(jl, ja, in)
4904			END DO
4905			END DO
4906
4907
4908			CALL lwtt_lmdar4(pgasur(1,1,1), pgbsur(1,1,1), zuu, ztt)
4909
4910			DO jl = 1, kdlon
4911			zcnsol(jl) = pbsur(jl, 1)ztt(jl, 1)ztt(jl, 10) + &
4912			pbsur(jl, 2)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
4913			pbsur(jl, 3)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
4914			pbsur(jl, 4)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
4915			pbsur(jl, 5)ztt(jl, 3)ztt(jl, 14) + pbsur(jl, 6)ztt(jl, 6)ztt(jl, &
4916			15)
4917			zcnsol(jl) = zcnsol(jl)*zbgnd(jl)/pbsui(jl)
4918			zfu(jl) = zcnsol(jl) + pbint(jl, jk) - pdisu(jl, jk) - padju(jl, jk)
4919			pfluc(jl, 1, jk) = zfu(jl)
4920			END DO
4921
4922
4923			END DO
4924
4925			! * 2.7 CLEAR-SKY FLUXES
4926			! ----------------
4927
4928
4929			IF (.NOT. levoigt) THEN
4930			DO jl = 1, kdlon
4931			zfn10(jl) = pfluc(jl, 1, jlim) + pfluc(jl, 2, jlim)
4932			END DO
4933			DO jk = jlim + 1, kflev + 1
4934			DO jl = 1, kdlon
4935			zfn10(jl) = zfn10(jl) + pcts(jl, jk-1)
4936			pfluc(jl, 1, jk) = zfn10(jl)
4937			pfluc(jl, 2, jk) = 0.
4938			END DO
4939			END DO
4940			END IF
4941
4942			! ------------------------------------------------------------------
4943
4944			RETURN
4945			END SUBROUTINE lwvb_lmdar4
4946			SUBROUTINE lwvd_lmdar4(kuaer, ktraer, pabcu, pdbdt, pga, pgb, pcntrb, pdisd, &
4947			pdisu)
4948			USE dimphy
4949			IMPLICIT NONE
4950			include "raddimlw.h"
4951
4952			! -----------------------------------------------------------------------
4953			! PURPOSE.
4954			! --------
4955			! CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
4956
4957			! METHOD.
4958			! -------
4959
4960			! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
4961			! CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
4962
4963			! REFERENCE.
4964			! ----------
4965
4966			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
4967			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
4968
4969			! AUTHOR.
4970			! -------
4971			! JEAN-JACQUES MORCRETTE ECMWF
4972
4973			! MODIFICATIONS.
4974			! --------------
4975			! ORIGINAL : 89-07-14
4976			! -----------------------------------------------------------------------
4977			! * ARGUMENTS:
4978
4979			INTEGER kuaer, ktraer
4980
4981			REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
4982			REAL (KIND=8) pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
4983			REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
4984			REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
4985
4986			REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! ENERGY EXCHANGE MATRIX
4987			REAL (KIND=8) pdisd(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
4988			REAL (KIND=8) pdisu(kdlon, kflev+1) ! CONTRIBUTION BY DISTANT LAYERS
4989
4990			! * LOCAL VARIABLES:
4991
4992			REAL (KIND=8) zglayd(kdlon)
4993			REAL (KIND=8) zglayu(kdlon)
4994			REAL (KIND=8) ztt(kdlon, ntra)
4995			REAL (KIND=8) ztt1(kdlon, ntra)
4996			REAL (KIND=8) ztt2(kdlon, ntra)
4997
4998			INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
4999			INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
5000			INTEGER ind1, ind2, ind3, ind4, itt
5001			REAL (KIND=8) zww, zdzxdg, zdzxmg
5002
5003			! * 1. INITIALIZATION
5004			! --------------
5005
5006
5007			! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
5008			! ------------------------------
5009
5010
5011			DO jk = 1, kflev + 1
5012			DO jl = 1, kdlon
5013			pdisd(jl, jk) = 0.
5014			pdisu(jl, jk) = 0.
5015			END DO
5016			END DO
5017
5018			! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5019			! ---------------------------------
5020
5021
5022
5023			DO ja = 1, ntra
5024			DO jl = 1, kdlon
5025			ztt(jl, ja) = 1.0
5026			ztt1(jl, ja) = 1.0
5027			ztt2(jl, ja) = 1.0
5028			END DO
5029			END DO
5030
5031			! ------------------------------------------------------------------
5032
5033			! * 2. VERTICAL INTEGRATION
5034			! --------------------
5035
5036
5037			ind1 = 0
5038			ind3 = 0
5039			ind4 = 1
5040			ind2 = 1
5041
5042			! * 2.2 CONTRIBUTION FROM DISTANT LAYERS
5043			! ---------------------------------
5044
5045
5046
5047			! * 2.2.1 DISTANT AND ABOVE LAYERS
5048			! ------------------------
5049
5050
5051
5052
5053			! * 2.2.2 FIRST UPPER LEVEL
5054			! -----------------
5055
5056
5057			DO jk = 1, kflev - 1
5058			ikp1 = jk + 1
5059			ikn = (jk-1)*ng1p1 + 1
5060			ikd1 = jk*ng1p1 + 1
5061
5062			CALL lwttm_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), pabcu(1,1,ikn), &
5063			pabcu(1,1,ikd1), ztt1)
5064
5065			! * 2.2.3 HIGHER UP
5066			! ---------
5067
5068
5069			itt = 1
5070			DO jkj = ikp1, kflev
5071			IF (itt==1) THEN
5072			itt = 2
5073			ELSE
5074			itt = 1
5075			END IF
5076			ikjp1 = jkj + 1
5077			ikd2 = jkj*ng1p1 + 1
5078
5079			IF (itt==1) THEN
5080			CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
5081			pabcu(1,1,ikd2), ztt1)
5082			ELSE
5083			CALL lwttm_lmdar4(pga(1,1,1,jkj), pgb(1,1,1,jkj), pabcu(1,1,ikn), &
5084			pabcu(1,1,ikd2), ztt2)
5085			END IF
5086
5087			DO ja = 1, ktraer
5088			DO jl = 1, kdlon
5089			ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
5090			END DO
5091			END DO
5092
5093			DO jl = 1, kdlon
5094			zww = pdbdt(jl, 1, jkj)ztt(jl, 1)ztt(jl, 10) + &
5095			pdbdt(jl, 2, jkj)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
5096			pdbdt(jl, 3, jkj)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
5097			pdbdt(jl, 4, jkj)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
5098			pdbdt(jl, 5, jkj)ztt(jl, 3)ztt(jl, 14) + &
5099			pdbdt(jl, 6, jkj)ztt(jl, 6)ztt(jl, 15)
5100			zglayd(jl) = zww
5101			zdzxdg = zglayd(jl)
5102			pdisd(jl, jk) = pdisd(jl, jk) + zdzxdg
5103			pcntrb(jl, jk, ikjp1) = zdzxdg
5104			END DO
5105
5106
5107			END DO
5108			END DO
5109
5110			! * 2.2.4 DISTANT AND BELOW LAYERS
5111			! ------------------------
5112
5113
5114
5115
5116			! * 2.2.5 FIRST LOWER LEVEL
5117			! -----------------
5118
5119
5120			DO jk = 3, kflev + 1
5121			ikn = (jk-1)*ng1p1 + 1
5122			ikm1 = jk - 1
5123			ikj = jk - 2
5124			iku1 = ikj*ng1p1 + 1
5125
5126
5127			CALL lwttm_lmdar4(pga(1,1,1,ikj), pgb(1,1,1,ikj), pabcu(1,1,iku1), &
5128			pabcu(1,1,ikn), ztt1)
5129
5130			! * 2.2.6 DOWN BELOW
5131			! ----------
5132
5133
5134			itt = 1
5135			DO jlk = 1, ikj
5136			IF (itt==1) THEN
5137			itt = 2
5138			ELSE
5139			itt = 1
5140			END IF
5141			ijkl = ikm1 - jlk
5142			iku2 = (ijkl-1)*ng1p1 + 1
5143
5144
5145			IF (itt==1) THEN
5146			CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
5147			pabcu(1,1,ikn), ztt1)
5148			ELSE
5149			CALL lwttm_lmdar4(pga(1,1,1,ijkl), pgb(1,1,1,ijkl), pabcu(1,1,iku2), &
5150			pabcu(1,1,ikn), ztt2)
5151			END IF
5152
5153			DO ja = 1, ktraer
5154			DO jl = 1, kdlon
5155			ztt(jl, ja) = (ztt1(jl,ja)+ztt2(jl,ja))*0.5
5156			END DO
5157			END DO
5158
5159			DO jl = 1, kdlon
5160			zww = pdbdt(jl, 1, ijkl)ztt(jl, 1)ztt(jl, 10) + &
5161			pdbdt(jl, 2, ijkl)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
5162			pdbdt(jl, 3, ijkl)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
5163			pdbdt(jl, 4, ijkl)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
5164			pdbdt(jl, 5, ijkl)ztt(jl, 3)ztt(jl, 14) + &
5165			pdbdt(jl, 6, ijkl)ztt(jl, 6)ztt(jl, 15)
5166			zglayu(jl) = zww
5167			zdzxmg = zglayu(jl)
5168			pdisu(jl, jk) = pdisu(jl, jk) + zdzxmg
5169			pcntrb(jl, jk, ijkl) = zdzxmg
5170			END DO
5171
5172
5173			END DO
5174			END DO
5175
5176			RETURN
5177			END SUBROUTINE lwvd_lmdar4
5178			SUBROUTINE lwvn_lmdar4(kuaer, ktraer, pabcu, pdbsl, pga, pgb, padjd, padju, &
5179			pcntrb, pdbdt)
5180			USE dimphy
5181			USE radiation_ar4_param, ONLY: wg1
5182			IMPLICIT NONE
5183			include "raddimlw.h"
5184
5185			! -----------------------------------------------------------------------
5186			! PURPOSE.
5187			! --------
5188			! CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
5189			! TO GIVE LONGWAVE FLUXES OR RADIANCES
5190
5191			! METHOD.
5192			! -------
5193
5194			! 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5195			! CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
5196
5197			! REFERENCE.
5198			! ----------
5199
5200			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5201			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5202
5203			! AUTHOR.
5204			! -------
5205			! JEAN-JACQUES MORCRETTE ECMWF
5206
5207			! MODIFICATIONS.
5208			! --------------
5209			! ORIGINAL : 89-07-14
5210			! -----------------------------------------------------------------------
5211
5212			! * ARGUMENTS:
5213
5214			INTEGER kuaer, ktraer
5215
5216			REAL (KIND=8) pabcu(kdlon, nua, 3*kflev+1) ! ABSORBER AMOUNTS
5217			REAL (KIND=8) pdbsl(kdlon, ninter, kflev*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5218			REAL (KIND=8) pga(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
5219			REAL (KIND=8) pgb(kdlon, 8, 2, kflev) ! PADE APPROXIMANTS
5220
5221			REAL (KIND=8) padjd(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
5222			REAL (KIND=8) padju(kdlon, kflev+1) ! CONTRIBUTION OF ADJACENT LAYERS
5223			REAL (KIND=8) pcntrb(kdlon, kflev+1, kflev+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5224			REAL (KIND=8) pdbdt(kdlon, ninter, kflev) ! LAYER PLANCK FUNCTION GRADIENT
5225
5226			! * LOCAL ARRAYS:
5227
5228			REAL (KIND=8) zglayd(kdlon)
5229			REAL (KIND=8) zglayu(kdlon)
5230			REAL (KIND=8) ztt(kdlon, ntra)
5231			REAL (KIND=8) ztt1(kdlon, ntra)
5232			REAL (KIND=8) ztt2(kdlon, ntra)
5233			REAL (KIND=8) zuu(kdlon, nua)
5234
5235			INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
5236			INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
5237			REAL (KIND=8) zwtr
5238
5239			! -----------------------------------------------------------------------
5240
5241			! * 1. INITIALIZATION
5242			! --------------
5243
5244
5245			! * 1.1 INITIALIZE LAYER CONTRIBUTIONS
5246			! ------------------------------
5247
5248
5249			DO jk = 1, kflev + 1
5250			DO jl = 1, kdlon
5251			padjd(jl, jk) = 0.
5252			padju(jl, jk) = 0.
5253			END DO
5254			END DO
5255
5256			! * 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5257			! ---------------------------------
5258
5259
5260			DO ja = 1, ntra
5261			DO jl = 1, kdlon
5262			ztt(jl, ja) = 1.0
5263			ztt1(jl, ja) = 1.0
5264			ztt2(jl, ja) = 1.0
5265			END DO
5266			END DO
5267
5268			DO ja = 1, nua
5269			DO jl = 1, kdlon
5270			zuu(jl, ja) = 0.
5271			END DO
5272			END DO
5273
5274			! ------------------------------------------------------------------
5275
5276			! * 2. VERTICAL INTEGRATION
5277			! --------------------
5278
5279
5280
5281			! * 2.1 CONTRIBUTION FROM ADJACENT LAYERS
5282			! ---------------------------------
5283
5284
5285			DO jk = 1, kflev
5286			! * 2.1.1 DOWNWARD LAYERS
5287			! ---------------
5288
5289
5290			im12 = 2*(jk-1)
5291			ind = (jk-1)*ng1p1 + 1
5292			ixd = ind
5293			inu = jk*ng1p1 + 1
5294			ixu = ind
5295
5296			DO jl = 1, kdlon
5297			zglayd(jl) = 0.
5298			zglayu(jl) = 0.
5299			END DO
5300
5301			DO jg = 1, ng1
5302			ibs = im12 + jg
5303			idd = ixd + jg
5304			DO ja = 1, kuaer
5305			DO jl = 1, kdlon
5306			zuu(jl, ja) = pabcu(jl, ja, ind) - pabcu(jl, ja, idd)
5307			END DO
5308			END DO
5309
5310
5311			CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
5312
5313			DO jl = 1, kdlon
5314			zwtr = pdbsl(jl, 1, ibs)ztt(jl, 1)ztt(jl, 10) + &
5315			pdbsl(jl, 2, ibs)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
5316			pdbsl(jl, 3, ibs)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
5317			pdbsl(jl, 4, ibs)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
5318			pdbsl(jl, 5, ibs)ztt(jl, 3)ztt(jl, 14) + &
5319			pdbsl(jl, 6, ibs)ztt(jl, 6)ztt(jl, 15)
5320			zglayd(jl) = zglayd(jl) + zwtr*wg1(jg)
5321			END DO
5322
5323			! * 2.1.2 DOWNWARD LAYERS
5324			! ---------------
5325
5326
5327			imu = ixu + jg
5328			DO ja = 1, kuaer
5329			DO jl = 1, kdlon
5330			zuu(jl, ja) = pabcu(jl, ja, imu) - pabcu(jl, ja, inu)
5331			END DO
5332			END DO
5333
5334
5335			CALL lwtt_lmdar4(pga(1,1,1,jk), pgb(1,1,1,jk), zuu, ztt)
5336
5337			DO jl = 1, kdlon
5338			zwtr = pdbsl(jl, 1, ibs)ztt(jl, 1)ztt(jl, 10) + &
5339			pdbsl(jl, 2, ibs)ztt(jl, 2)ztt(jl, 7)*ztt(jl, 11) + &
5340			pdbsl(jl, 3, ibs)ztt(jl, 4)ztt(jl, 8)*ztt(jl, 12) + &
5341			pdbsl(jl, 4, ibs)ztt(jl, 5)ztt(jl, 9)*ztt(jl, 13) + &
5342			pdbsl(jl, 5, ibs)ztt(jl, 3)ztt(jl, 14) + &
5343			pdbsl(jl, 6, ibs)ztt(jl, 6)ztt(jl, 15)
5344			zglayu(jl) = zglayu(jl) + zwtr*wg1(jg)
5345			END DO
5346
5347			END DO
5348
5349			DO jl = 1, kdlon
5350			padjd(jl, jk) = zglayd(jl)
5351			pcntrb(jl, jk, jk+1) = zglayd(jl)
5352			padju(jl, jk+1) = zglayu(jl)
5353			pcntrb(jl, jk+1, jk) = zglayu(jl)
5354			pcntrb(jl, jk, jk) = 0.0
5355			END DO
5356
5357			END DO
5358
5359			DO jk = 1, kflev
5360			jk2 = 2*jk
5361			jk1 = jk2 - 1
5362			DO jnu = 1, ninter
5363			DO jl = 1, kdlon
5364			pdbdt(jl, jnu, jk) = pdbsl(jl, jnu, jk1) + pdbsl(jl, jnu, jk2)
5365			END DO
5366			END DO
5367			END DO
5368
5369			RETURN
5370
5371			END SUBROUTINE lwvn_lmdar4
5372			SUBROUTINE lwtt_lmdar4(pga, pgb, puu, ptt)
5373			USE dimphy
5374			IMPLICIT NONE
5375			include "raddimlw.h"
5376
5377			! -----------------------------------------------------------------------
5378			! PURPOSE.
5379			! --------
5380			! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
5381			! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
5382			! INTERVALS.
5383
5384			! METHOD.
5385			! -------
5386
5387			! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
5388			! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
5389			! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
5390			! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
5391			! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
5392
5393			! REFERENCE.
5394			! ----------
5395
5396			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5397			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5398
5399			! AUTHOR.
5400			! -------
5401			! JEAN-JACQUES MORCRETTE ECMWF
5402
5403			! MODIFICATIONS.
5404			! --------------
5405			! ORIGINAL : 88-12-15
5406
5407			! -----------------------------------------------------------------------
5408			REAL (KIND=8) o1h, o2h
5409			PARAMETER (o1h=2230.)
5410			PARAMETER (o2h=100.)
5411			REAL (KIND=8) rpialf0
5412			PARAMETER (rpialf0=2.0)
5413
5414			! * ARGUMENTS:
5415
5416			REAL (KIND=8) puu(kdlon, nua)
5417			REAL (KIND=8) ptt(kdlon, ntra)
5418			REAL (KIND=8) pga(kdlon, 8, 2)
5419			REAL (KIND=8) pgb(kdlon, 8, 2)
5420
5421			! * LOCAL VARIABLES:
5422
5423			REAL (KIND=8) zz, zxd, zxn
5424			REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
5425			REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
5426			REAL (KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
5427			REAL (KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
5428			REAL (KIND=8) zsqn21, zodn21, zsqh42, zodh42
5429			REAL (KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
5430			REAL (KIND=8) zuu11, zuu12, za11, za12
5431			INTEGER jl, ja
5432
5433			! ------------------------------------------------------------------
5434
5435			! * 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
5436			! -----------------------------------------------
5437
5438
5439
5440			! cdir collapse
5441			DO ja = 1, 8
5442			DO jl = 1, kdlon
5443			zz = sqrt(puu(jl,ja))
5444			! ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
5445			! ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
5446			! PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
5447			zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
5448			zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
5449			ptt(jl, ja) = zxn/zxd
5450			END DO
5451			END DO
5452
5453			! ------------------------------------------------------------------
5454
5455			! * 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
5456			! ---------------------------------------------------
5457
5458
5459			DO jl = 1, kdlon
5460			ptt(jl, 9) = ptt(jl, 8)
5461
5462			! - CONTINUUM ABSORPTION: E- AND P-TYPE
5463
5464			zpu = 0.002*puu(jl, 10)
5465			zpu10 = 112.*zpu
5466			zpu11 = 6.25*zpu
5467			zpu12 = 5.00*zpu
5468			zpu13 = 80.0*zpu
5469			zeu = puu(jl, 11)
5470			zeu10 = 12.*zeu
5471			zeu11 = 6.25*zeu
5472			zeu12 = 5.00*zeu
5473			zeu13 = 80.0*zeu
5474
5475			! - OZONE ABSORPTION
5476
5477			zx = puu(jl, 12)
5478			zy = puu(jl, 13)
5479			zuxy = 4.zxzx/(rpialf0*zy)
5480			zsq1 = sqrt(1.+o1h*zuxy) - 1.
5481			zsq2 = sqrt(1.+o2h*zuxy) - 1.
5482			zvxy = rpialf0zy/(2.zx)
5483			zaercn = puu(jl, 17) + zeu12 + zpu12
5484			zto1 = exp(-zvxy*zsq1-zaercn)
5485			zto2 = exp(-zvxy*zsq2-zaercn)
5486
5487			! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
5488
5489			! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
5490
5491			! NEXOTIC=1
5492			! IF (NEXOTIC.EQ.1) THEN
5493			zxch4 = puu(jl, 19)
5494			zych4 = puu(jl, 20)
5495			zuxy = 4.zxch4zxch4/(0.103*zych4)
5496			zsqh41 = sqrt(1.+33.7*zuxy) - 1.
5497			zvxy = 0.103zych4/(2.zxch4)
5498			zodh41 = zvxy*zsqh41
5499
5500			! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
5501
5502			zxn2o = puu(jl, 21)
5503			zyn2o = puu(jl, 22)
5504			zuxy = 4.zxn2ozxn2o/(0.416*zyn2o)
5505			zsqn21 = sqrt(1.+21.3*zuxy) - 1.
5506			zvxy = 0.416zyn2o/(2.zxn2o)
5507			zodn21 = zvxy*zsqn21
5508
5509			! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
5510
5511			zuxy = 4.zxch4zxch4/(0.113*zych4)
5512			zsqh42 = sqrt(1.+400.*zuxy) - 1.
5513			zvxy = 0.113zych4/(2.zxch4)
5514			zodh42 = zvxy*zsqh42
5515
5516			! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
5517
5518			zuxy = 4.zxn2ozxn2o/(0.197*zyn2o)
5519			zsqn22 = sqrt(1.+2000.*zuxy) - 1.
5520			zvxy = 0.197zyn2o/(2.zxn2o)
5521			zodn22 = zvxy*zsqn22
5522
5523			! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
5524
5525			za11 = 2.puu(jl, 23)4.404E+05
5526			zttf11 = 1. - za11*0.003225
5527
5528			! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
5529
5530			za12 = 2.puu(jl, 24)6.7435E+05
5531			zttf12 = 1. - za12*0.003225
5532
5533			zuu11 = -puu(jl, 15) - zeu10 - zpu10
5534			zuu12 = -puu(jl, 16) - zeu11 - zpu11 - zodh41 - zodn21
5535			ptt(jl, 10) = exp(-puu(jl,14))
5536			ptt(jl, 11) = exp(zuu11)
5537			ptt(jl, 12) = exp(zuu12)zttf11zttf12
5538			ptt(jl, 13) = 0.7554zto1 + 0.2446zto2
5539			ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
5540			ptt(jl, 15) = exp(-puu(jl,14)-zodh42-zodn22)
5541			END DO
5542
5543			RETURN
5544			END SUBROUTINE lwtt_lmdar4
5545			SUBROUTINE lwttm_lmdar4(pga, pgb, puu1, puu2, ptt)
5546			USE dimphy
5547			IMPLICIT NONE
5548			include "raddimlw.h"
5549
5550			! ------------------------------------------------------------------
5551			! PURPOSE.
5552			! --------
5553			! THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
5554			! ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
5555			! INTERVALS.
5556
5557			! METHOD.
5558			! -------
5559
5560			! 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
5561			! COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
5562			! 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
5563			! 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
5564			! A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
5565
5566			! REFERENCE.
5567			! ----------
5568
5569			! SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5570			! ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5571
5572			! AUTHOR.
5573			! -------
5574			! JEAN-JACQUES MORCRETTE ECMWF
5575
5576			! MODIFICATIONS.
5577			! --------------
5578			! ORIGINAL : 88-12-15
5579
5580			! -----------------------------------------------------------------------
5581			REAL (KIND=8) o1h, o2h
5582			PARAMETER (o1h=2230.)
5583			PARAMETER (o2h=100.)
5584			REAL (KIND=8) rpialf0
5585			PARAMETER (rpialf0=2.0)
5586
5587			! * ARGUMENTS:
5588
5589			REAL (KIND=8) pga(kdlon, 8, 2) ! PADE APPROXIMANTS
5590			REAL (KIND=8) pgb(kdlon, 8, 2) ! PADE APPROXIMANTS
5591			REAL (KIND=8) puu1(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
5592			REAL (KIND=8) puu2(kdlon, nua) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
5593			REAL (KIND=8) ptt(kdlon, ntra) ! TRANSMISSION FUNCTIONS
5594
5595			! * LOCAL VARIABLES:
5596
5597			INTEGER ja, jl
5598			REAL (KIND=8) zz, zxd, zxn
5599			REAL (KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
5600			REAL (KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
5601			REAL (KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
5602			REAL (KIND=8) zxch4, zych4, zsqh41, zodh41
5603			REAL (KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
5604			REAL (KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
5605			REAL (KIND=8) zuu11, zuu12
5606
5607			! ------------------------------------------------------------------
5608
5609			! * 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
5610			! -----------------------------------------------
5611
5612
5613
5614
5615			! CDIR ON_ADB(PUU1)
5616			! CDIR ON_ADB(PUU2)
5617			! CDIR COLLAPSE
5618			DO ja = 1, 8
5619			DO jl = 1, kdlon
5620			zz = sqrt(puu1(jl,ja)-puu2(jl,ja))
5621			zxd = pgb(jl, ja, 1) + zz*(pgb(jl,ja,2)+zz)
5622			zxn = pga(jl, ja, 1) + zz*(pga(jl,ja,2))
5623			ptt(jl, ja) = zxn/zxd
5624			END DO
5625			END DO
5626
5627			! ------------------------------------------------------------------
5628
5629			! * 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
5630			! ---------------------------------------------------
5631
5632
5633			DO jl = 1, kdlon
5634			ptt(jl, 9) = ptt(jl, 8)
5635
5636			! - CONTINUUM ABSORPTION: E- AND P-TYPE
5637
5638			zpu = 0.002*(puu1(jl,10)-puu2(jl,10))
5639			zpu10 = 112.*zpu
5640			zpu11 = 6.25*zpu
5641			zpu12 = 5.00*zpu
5642			zpu13 = 80.0*zpu
5643			zeu = (puu1(jl,11)-puu2(jl,11))
5644			zeu10 = 12.*zeu
5645			zeu11 = 6.25*zeu
5646			zeu12 = 5.00*zeu
5647			zeu13 = 80.0*zeu
5648
5649			! - OZONE ABSORPTION
5650
5651			zx = (puu1(jl,12)-puu2(jl,12))
5652			zy = (puu1(jl,13)-puu2(jl,13))
5653			zuxy = 4.zxzx/(rpialf0*zy)
5654			zsq1 = sqrt(1.+o1h*zuxy) - 1.
5655			zsq2 = sqrt(1.+o2h*zuxy) - 1.
5656			zvxy = rpialf0zy/(2.zx)
5657			zaercn = (puu1(jl,17)-puu2(jl,17)) + zeu12 + zpu12
5658			zto1 = exp(-zvxy*zsq1-zaercn)
5659			zto2 = exp(-zvxy*zsq2-zaercn)
5660
5661			! -- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
5662
5663			! * CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
5664
5665			zxch4 = (puu1(jl,19)-puu2(jl,19))
5666			zych4 = (puu1(jl,20)-puu2(jl,20))
5667			zuxy = 4.zxch4zxch4/(0.103*zych4)
5668			zsqh41 = sqrt(1.+33.7*zuxy) - 1.
5669			zvxy = 0.103zych4/(2.zxch4)
5670			zodh41 = zvxy*zsqh41
5671
5672			! * N2O IN INTERVAL 800-970 + 1110-1250 CM-1
5673
5674			zxn2o = (puu1(jl,21)-puu2(jl,21))
5675			zyn2o = (puu1(jl,22)-puu2(jl,22))
5676			zuxy = 4.zxn2ozxn2o/(0.416*zyn2o)
5677			zsqn21 = sqrt(1.+21.3*zuxy) - 1.
5678			zvxy = 0.416zyn2o/(2.zxn2o)
5679			zodn21 = zvxy*zsqn21
5680
5681			! * CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
5682
5683			zuxy = 4.zxch4zxch4/(0.113*zych4)
5684			zsqh42 = sqrt(1.+400.*zuxy) - 1.
5685			zvxy = 0.113zych4/(2.zxch4)
5686			zodh42 = zvxy*zsqh42
5687
5688			! * N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
5689
5690			zuxy = 4.zxn2ozxn2o/(0.197*zyn2o)
5691			zsqn22 = sqrt(1.+2000.*zuxy) - 1.
5692			zvxy = 0.197zyn2o/(2.zxn2o)
5693			zodn22 = zvxy*zsqn22
5694
5695			! * CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
5696
5697			za11 = (puu1(jl,23)-puu2(jl,23))*4.404E+05
5698			zttf11 = 1. - za11*0.003225
5699
5700			! * CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
5701
5702			za12 = (puu1(jl,24)-puu2(jl,24))*6.7435E+05
5703			zttf12 = 1. - za12*0.003225
5704
5705			zuu11 = -(puu1(jl,15)-puu2(jl,15)) - zeu10 - zpu10
5706			zuu12 = -(puu1(jl,16)-puu2(jl,16)) - zeu11 - zpu11 - zodh41 - zodn21
5707			ptt(jl, 10) = exp(-(puu1(jl,14)-puu2(jl,14)))
5708			ptt(jl, 11) = exp(zuu11)
5709			ptt(jl, 12) = exp(zuu12)zttf11zttf12
5710			ptt(jl, 13) = 0.7554zto1 + 0.2446zto2
5711			ptt(jl, 14) = ptt(jl, 10)*exp(-zeu13-zpu13)
5712			ptt(jl, 15) = exp(-(puu1(jl,14)-puu2(jl,14))-zodh42-zodn22)
5713			END DO
5714
5715			RETURN
5716			END SUBROUTINE lwttm_lmdar4


Generated by: GCOVR (Version 4.2)