Context Navigation

radlwsw.F @ 433

Last change on this file since 433 was 433, checked in by lmdzadmin, 21 years ago

Convergence avec la version de Ionela dec 2002

YOMCST.? : suppression RI0 (IM)
albedo.F : facteur 1.2 sur le nouveau calcul (IM)
clesphys.h : rajout de différentes ctes (concentration des gaz) (IM)
clmain.F : separation des flux LW, SW (JLD)

remplace qsurf par yqsol (IM)

conf_phys.F90 : rajout de différentes ctes (gaz + orbite) (IM)
convect3.F : DPINV+SIGD*0.5*(EVAP(1)+EVAP(2)) (SBL)
cv3_routines.F:
cvparam3.h : compatibilite avec conema3 TEMPORAIRE (FH)
phyetat0.F : lecture de co2_ppm et solaire pour tests de coherence
phyredem.F : co2_ppm et solaire passé en common
physiq.F : separation flux LW, SW

rajout diagnostiques (slp, w500)
suppression iflag_con = 4
clwcon0=qcondc (FH)
position dU "ENDIF ! ok_cvl"

radlwsw.F : passage des concentrations gaz dans un common (IM)

PEMIS(i) = 1.0 (JLD pour cohérence ORCHIDEE)

stdlevvar.F90 :
suphec.F : suppression init. des ctes orbitales (IM)

nouvelles E/S (ini_hist..., write_hist...)

Property svn:eol-style set to native
Property svn:executable set to *
Property svn:keywords set to Author Date Id Revision

File size: 186.7 KB

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

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

Download in other formats:

Original Format