Context Navigation

radiation_AR4.f90 @ 5450

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

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

Download in other formats:

Original Format