Context Navigation

radlwsw.F @ 413

Last change on this file since 413 was 412, checked in by lmdzadmin, 22 years ago
Rajout des flux shortwave pour l'albedo IM/LF
Property svn:eol-style set to `native` Property svn:executable set to ``* Property svn:keywords set to `Author Date Id Revision`
File size: 185.6 KB

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

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

Download in other formats:

Original Format