Context Navigation

radiation_AR4.F @ 1237

Last change on this file since 1237 was 1231, checked in by lguez, 15 years ago

These are changes related to ozone in radiative transfer computations:

-- Moved "max(ozonecm, 1e-12)" from procedure "radlwsw" to procedure

"ozonecm".

-- Removed ratio "p_surface / p_reference" in the computation of

"pozon" in "radlwsw".

-- Removed ratio "p_reference / p_surface" in the computation of

"zoz" in "SW_LMDAR4" and "SW_AEROAR4".

-- Removed ratio "mass of air / mass of ozone" in the computation of

"zoz" in "LW_LMDAR4".

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

File size: 189.4 KB

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

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

Download in other formats:

Original Format