Context Navigation

radiation_AR4.F90 @ 2435

Last change on this file since 2435 was 2408, checked in by Laurent Fairhead, 9 years ago
Merged trunk changes r2298:2396 into testing branch
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 170.1 KB

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

Note: See TracBrowser for help on using the repository browser.

Download in other formats:

Original Format