Context Navigation

radiation_AR4.F90 @ 3814

Last change on this file since 3814 was 3814, checked in by ymipsl, 10 years ago

remove all dynamic dependency in LMDZ physics except for the include "dimensions.h"

File size: 171.7 KB

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

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

Download in other formats:

Original Format