Context Navigation

radiation_AR4.F @ 1215

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

-- Made "ozonecm" a function instead of a subroutine. Used assumed shape
arguments in "ozonecm".

-- Corrected long name and computation of NetCDF variable "ozone" in
the files "hist*".

-- Corrected comments for ozone variables.

-- In the case "read_climoz", used variables "rmd" and "rmo3" from
"YOMCST.h" instead of writing approximate values.

-- Replaced "real*..." declarations (not conforming to Fortran standard)
by "real(kind=...)" declarations.

-- Replaced value "1./46.6968" in ozone computations by the equivalent
(but clearer) "dobson_u * 1e3" (relative difference ~ 1e-5).

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

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

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

Download in other formats:

Original Format