Context Navigation

radiation_AR4.F @ 1226

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

-- Replaced "integer*4" declarations by "integer", "real*8" by

"real(kind=8)" and "real*4" by "real". Note that these are the only
modifications in the files "radiation_AR4.F" and "sw_aeroAR4.F90".

-- Corrected the kind of arguments to "max" and "min".

-- Replaced "nH" edit descriptors, which is a deleted feature in

Fortran 95, by character strings.

-- "regr_lat_time_climoz" now allows the pressure coordinate in the

input file to be in descending order.

-- Replaced call to not standard function "float" by call to intrinsic

function "real".

-- Included file "radepsi.h" in "physiq" was not used. Removed it.

The following set of modifications is related to the management of time.

-- In "gcm", "leapfrog" and "sortvarc0", "day_ini" was defined as 1

plus number of days between the reference date "(annee_ref,
day_ref)" and the first day of the current simulation. Changed
definition: "(annee_ref, day_ini)" is the first day of the current
simulation. There is an accompanying modification for "day_end".

-- Corrected bug in call to "ioconf_startdate" in "gcm".

-- Added call to "ioconf_calendar" in "create_etat0_limit".

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

File size: 189.5 KB

Line
1	cIM ctes ds clesphys.h SUBROUTINE SW(PSCT, RCO2, PRMU0, PFRAC,
2	SUBROUTINE SW_LMDAR4(PSCT, PRMU0, PFRAC,
3	S PPMB, PDP,
4	S PPSOL, PALBD, PALBP,
5	S PTAVE, PWV, PQS, POZON, PAER,
6	S PCLDSW, PTAU, POMEGA, PCG,
7	S PHEAT, PHEAT0,
8	S PALBPLA,PTOPSW,PSOLSW,PTOPSW0,PSOLSW0,
9	S ZFSUP,ZFSDN,ZFSUP0,ZFSDN0,
10	S tauae, pizae, cgae,
11	s PTAUA, POMEGAA,
12	S PTOPSWAD,PSOLSWAD,PTOPSWAI,PSOLSWAI,
13	J ok_ade, ok_aie )
14	USE dimphy
15	IMPLICIT none
16
17	cym#include "dimensions.h"
18	cym#include "dimphy.h"
19	cym#include "raddim.h"
20	#include "YOMCST.h"
21	C
22	C ------------------------------------------------------------------
23	C
24	C PURPOSE.
25	C --------
26	C
27	C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
28	C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
29	C
30	C METHOD.
31	C -------
32	C
33	C 1. COMPUTES ABSORBER AMOUNTS (SWU)
34	C 2. COMPUTES FLUXES IN 1ST SPECTRAL INTERVAL (SW1S)
35	C 3. COMPUTES FLUXES IN 2ND SPECTRAL INTERVAL (SW2S)
36	C
37	C REFERENCE.
38	C ----------
39	C
40	C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
41	C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
42	C
43	C AUTHOR.
44	C -------
45	C JEAN-JACQUES MORCRETTE ECMWF
46	C
47	C MODIFICATIONS.
48	C --------------
49	C ORIGINAL : 89-07-14
50	C 95-01-01 J.-J. MORCRETTE Direct/Diffuse Albedo
51	c 03-11-27 J. QUAAS Introduce aerosol forcings (based on BOUCHER)
52	C ------------------------------------------------------------------
53	C
54	C* ARGUMENTS:
55	C
56	REAL(KIND=8) PSCT ! constante solaire (valeur conseillee: 1370)
57	cIM ctes ds clesphys.h REAL(KIND=8) RCO2 ! concentration CO2 (IPCC: 353.E-06*44.011/28.97)
58	#include "clesphys.h"
59	C
60	REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (PA)
61	REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER THICKNESS (PA)
62	REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
63	C
64	REAL(KIND=8) PRMU0(KDLON) ! COSINE OF ZENITHAL ANGLE
65	REAL(KIND=8) PFRAC(KDLON) ! fraction de la journee
66	C
67	REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
68	REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (KG/KG)
69	REAL(KIND=8) PQS(KDLON,KFLEV) ! SATURATED WATER VAPOUR (KG/KG)
70	REAL(KIND=8) POZON(KDLON,KFLEV) ! OZONE CONCENTRATION (KG/KG)
71	REAL(KIND=8) PAER(KDLON,KFLEV,5) ! AEROSOLS' OPTICAL THICKNESS
72	C
73	REAL(KIND=8) PALBD(KDLON,2) ! albedo du sol (lumiere diffuse)
74	REAL(KIND=8) PALBP(KDLON,2) ! albedo du sol (lumiere parallele)
75	C
76	REAL(KIND=8) PCLDSW(KDLON,KFLEV) ! CLOUD FRACTION
77	REAL(KIND=8) PTAU(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS
78	REAL(KIND=8) PCG(KDLON,2,KFLEV) ! ASYMETRY FACTOR
79	REAL(KIND=8) POMEGA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO
80	C
81	REAL(KIND=8) PHEAT(KDLON,KFLEV) ! SHORTWAVE HEATING (K/DAY)
82	REAL(KIND=8) PHEAT0(KDLON,KFLEV)! SHORTWAVE HEATING (K/DAY) clear-sky
83	REAL(KIND=8) PALBPLA(KDLON) ! PLANETARY ALBEDO
84	REAL(KIND=8) PTOPSW(KDLON) ! SHORTWAVE FLUX AT T.O.A.
85	REAL(KIND=8) PSOLSW(KDLON) ! SHORTWAVE FLUX AT SURFACE
86	REAL(KIND=8) PTOPSW0(KDLON) ! SHORTWAVE FLUX AT T.O.A. (CLEAR-SKY)
87	REAL(KIND=8) PSOLSW0(KDLON) ! SHORTWAVE FLUX AT SURFACE (CLEAR-SKY)
88	C
89	C* LOCAL VARIABLES:
90	C
91	real, parameter:: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2
92
93	REAL(KIND=8) ZOZ(KDLON,KFLEV)
94	! column-density of ozone in layer, in kilo-Dobsons
95
96	REAL(KIND=8) ZAKI(KDLON,2)
97	REAL(KIND=8) ZCLD(KDLON,KFLEV)
98	REAL(KIND=8) ZCLEAR(KDLON)
99	REAL(KIND=8) ZDSIG(KDLON,KFLEV)
100	REAL(KIND=8) ZFACT(KDLON)
101	REAL(KIND=8) ZFD(KDLON,KFLEV+1)
102	REAL(KIND=8) ZFDOWN(KDLON,KFLEV+1)
103	REAL(KIND=8) ZFU(KDLON,KFLEV+1)
104	REAL(KIND=8) ZFUP(KDLON,KFLEV+1)
105	REAL(KIND=8) ZRMU(KDLON)
106	REAL(KIND=8) ZSEC(KDLON)
107	REAL(KIND=8) ZUD(KDLON,5,KFLEV+1)
108	REAL(KIND=8) ZCLDSW0(KDLON,KFLEV)
109	c
110	REAL(KIND=8) ZFSUP(KDLON,KFLEV+1)
111	REAL(KIND=8) ZFSDN(KDLON,KFLEV+1)
112	REAL(KIND=8) ZFSUP0(KDLON,KFLEV+1)
113	REAL(KIND=8) ZFSDN0(KDLON,KFLEV+1)
114	C
115	INTEGER inu, jl, jk, i, k, kpl1
116	c
117	INTEGER swpas ! Every swpas steps, sw is calculated
118	PARAMETER(swpas=1)
119	c
120	INTEGER itapsw
121	LOGICAL appel1er
122	DATA itapsw /0/
123	DATA appel1er /.TRUE./
124	SAVE itapsw,appel1er
125	c$OMP THREADPRIVATE(appel1er)
126	c$OMP THREADPRIVATE(itapsw)
127	cjq-Introduced for aerosol forcings
128	real(kind=8) flag_aer
129	logical ok_ade, ok_aie ! use aerosol forcings or not?
130	real(kind=8) tauae(kdlon,kflev,2) ! aerosol optical properties
131	real(kind=8) pizae(kdlon,kflev,2) ! (see aeropt.F)
132	real(kind=8) cgae(kdlon,kflev,2) ! -"-
133	REAL(KIND=8) PTAUA(KDLON,2,KFLEV) ! CLOUD OPTICAL THICKNESS (pre-industrial value)
134	REAL(KIND=8) POMEGAA(KDLON,2,KFLEV) ! SINGLE SCATTERING ALBEDO
135	REAL(KIND=8) PTOPSWAD(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL DIR)
136	REAL(KIND=8) PSOLSWAD(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL DIR)
137	REAL(KIND=8) PTOPSWAI(KDLON) ! SHORTWAVE FLUX AT T.O.A.(+AEROSOL IND)
138	REAL(KIND=8) PSOLSWAI(KDLON) ! SHORTWAVE FLUX AT SURFACE(+AEROSOL IND)
139	cjq - Fluxes including aerosol effects
140	REAL(KIND=8),allocatable,save :: ZFSUPAD(:,:)
141	c$OMP THREADPRIVATE(ZFSUPAD)
142	REAL(KIND=8),allocatable,save :: ZFSDNAD(:,:)
143	c$OMP THREADPRIVATE(ZFSDNAD)
144	REAL(KIND=8),allocatable,save :: ZFSUPAI(:,:)
145	c$OMP THREADPRIVATE(ZFSUPAI)
146	REAL(KIND=8),allocatable,save :: ZFSDNAI(:,:)
147	c$OMP THREADPRIVATE(ZFSDNAI)
148	logical initialized
149	cym SAVE ZFSUPAD, ZFSDNAD, ZFSUPAI, ZFSDNAI ! aerosol fluxes
150	!rv
151	save flag_aer
152	c$OMP THREADPRIVATE(flag_aer)
153	data initialized/.false./
154	save initialized
155	c$OMP THREADPRIVATE(initialized)
156	cjq-end
157	if(.not.initialized) then
158	flag_aer=0.
159	initialized=.TRUE.
160	allocate(ZFSUPAD(KDLON,KFLEV+1))
161	allocate(ZFSDNAD(KDLON,KFLEV+1))
162	allocate(ZFSUPAI(KDLON,KFLEV+1))
163	allocate(ZFSDNAI(KDLON,KFLEV+1))
164	ZFSUPAD(:,:)=0.
165	ZFSDNAD(:,:)=0.
166	ZFSUPAI(:,:)=0.
167	ZFSDNAI(:,:)=0.
168
169	endif
170	!rv
171
172	c
173	IF (appel1er) THEN
174	PRINT*, 'SW calling frequency : ', swpas
175	PRINT*, " In general, it should be 1"
176	appel1er = .FALSE.
177	ENDIF
178	C ------------------------------------------------------------------
179	IF (MOD(itapsw,swpas).EQ.0) THEN
180	c
181	DO JK = 1 , KFLEV
182	DO JL = 1, KDLON
183	ZCLDSW0(JL,JK) = 0.0
184	ZOZ(JL,JK) = POZON(JL,JK) / dobson_u / 1e3 / RG * PDP(JL,JK)
185	$ * (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(KIND=8) PSCT
356	cIM ctes ds clesphys.h REAL(KIND=8) RCO2
357	#include "clesphys.h"
358	REAL(KIND=8) PCLDSW(KDLON,KFLEV)
359	REAL(KIND=8) PPMB(KDLON,KFLEV+1)
360	REAL(KIND=8) PPSOL(KDLON)
361	REAL(KIND=8) PRMU0(KDLON)
362	REAL(KIND=8) PFRAC(KDLON)
363	REAL(KIND=8) PTAVE(KDLON,KFLEV)
364	REAL(KIND=8) PWV(KDLON,KFLEV)
365	C
366	REAL(KIND=8) PAKI(KDLON,2)
367	REAL(KIND=8) PCLD(KDLON,KFLEV)
368	REAL(KIND=8) PCLEAR(KDLON)
369	REAL(KIND=8) PDSIG(KDLON,KFLEV)
370	REAL(KIND=8) PFACT(KDLON)
371	REAL(KIND=8) PRMU(KDLON)
372	REAL(KIND=8) PSEC(KDLON)
373	REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
374	C
375	C* LOCAL VARIABLES:
376	C
377	INTEGER IIND(2)
378	REAL(KIND=8) ZC1J(KDLON,KFLEV+1)
379	REAL(KIND=8) ZCLEAR(KDLON)
380	REAL(KIND=8) ZCLOUD(KDLON)
381	REAL(KIND=8) ZN175(KDLON)
382	REAL(KIND=8) ZN190(KDLON)
383	REAL(KIND=8) ZO175(KDLON)
384	REAL(KIND=8) ZO190(KDLON)
385	REAL(KIND=8) ZSIGN(KDLON)
386	REAL(KIND=8) ZR(KDLON,2)
387	REAL(KIND=8) ZSIGO(KDLON)
388	REAL(KIND=8) ZUD(KDLON,2)
389	REAL(KIND=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(KIND=8) ZPDH2O,ZPDUMG
395	SAVE ZPDH2O,ZPDUMG
396	c$OMP THREADPRIVATE(ZPDH2O,ZPDUMG)
397	REAL(KIND=8) ZPRH2O,ZPRUMG
398	SAVE ZPRH2O,ZPRUMG
399	c$OMP THREADPRIVATE(ZPRH2O,ZPRUMG)
400	REAL(KIND=8) RTDH2O,RTDUMG
401	SAVE RTDH2O,RTDUMG
402	c$OMP THREADPRIVATE(RTDH2O,RTDUMG)
403	REAL(KIND=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(kind=8) flag_aer
580	real(kind=8) tauae(kdlon,kflev,2)
581	real(kind=8) pizae(kdlon,kflev,2)
582	real(kind=8) cgae(kdlon,kflev,2)
583	REAL(KIND=8) PAER(KDLON,KFLEV,5)
584	REAL(KIND=8) PALBD(KDLON,2)
585	REAL(KIND=8) PALBP(KDLON,2)
586	REAL(KIND=8) PCG(KDLON,2,KFLEV)
587	REAL(KIND=8) PCLD(KDLON,KFLEV)
588	REAL(KIND=8) PCLDSW(KDLON,KFLEV)
589	REAL(KIND=8) PCLEAR(KDLON)
590	REAL(KIND=8) PDSIG(KDLON,KFLEV)
591	REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
592	REAL(KIND=8) POZ(KDLON,KFLEV)
593	REAL(KIND=8) PRMU(KDLON)
594	REAL(KIND=8) PSEC(KDLON)
595	REAL(KIND=8) PTAU(KDLON,2,KFLEV)
596	REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
597	C
598	REAL(KIND=8) PFD(KDLON,KFLEV+1)
599	REAL(KIND=8) PFU(KDLON,KFLEV+1)
600	C
601	C* LOCAL VARIABLES:
602	C
603	INTEGER IIND(4)
604	C
605	REAL(KIND=8) ZCGAZ(KDLON,KFLEV)
606	REAL(KIND=8) ZDIFF(KDLON)
607	REAL(KIND=8) ZDIRF(KDLON)
608	REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
609	REAL(KIND=8) ZRAYL(KDLON)
610	REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
611	REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
612	REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
613	REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
614	REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
615	REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
616	REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
617	REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
618	REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
619	REAL(KIND=8) ZR(KDLON,4)
620	REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
621	REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
622	REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
623	REAL(KIND=8) ZW(KDLON,4)
624	C
625	INTEGER jl, jk, k, jaj, ikm1, ikl
626	c
627	c Prescribed Data:
628	c
629	REAL(KIND=8) RSUN(2)
630	SAVE RSUN
631	c$OMP THREADPRIVATE(RSUN)
632	REAL(KIND=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(kind=8) flag_aer
828	real(kind=8) tauae(kdlon,kflev,2)
829	real(kind=8) pizae(kdlon,kflev,2)
830	real(kind=8) cgae(kdlon,kflev,2)
831	REAL(KIND=8) PAER(KDLON,KFLEV,5)
832	REAL(KIND=8) PAKI(KDLON,2)
833	REAL(KIND=8) PALBD(KDLON,2)
834	REAL(KIND=8) PALBP(KDLON,2)
835	REAL(KIND=8) PCG(KDLON,2,KFLEV)
836	REAL(KIND=8) PCLD(KDLON,KFLEV)
837	REAL(KIND=8) PCLDSW(KDLON,KFLEV)
838	REAL(KIND=8) PCLEAR(KDLON)
839	REAL(KIND=8) PDSIG(KDLON,KFLEV)
840	REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
841	REAL(KIND=8) POZ(KDLON,KFLEV)
842	REAL(KIND=8) PQS(KDLON,KFLEV)
843	REAL(KIND=8) PRMU(KDLON)
844	REAL(KIND=8) PSEC(KDLON)
845	REAL(KIND=8) PTAU(KDLON,2,KFLEV)
846	REAL(KIND=8) PUD(KDLON,5,KFLEV+1)
847	REAL(KIND=8) PWV(KDLON,KFLEV)
848	C
849	REAL(KIND=8) PFDOWN(KDLON,KFLEV+1)
850	REAL(KIND=8) PFUP(KDLON,KFLEV+1)
851	C
852	C* LOCAL VARIABLES:
853	C
854	INTEGER IIND2(2), IIND3(3)
855	REAL(KIND=8) ZCGAZ(KDLON,KFLEV)
856	REAL(KIND=8) ZFD(KDLON,KFLEV+1)
857	REAL(KIND=8) ZFU(KDLON,KFLEV+1)
858	REAL(KIND=8) ZG(KDLON)
859	REAL(KIND=8) ZGG(KDLON)
860	REAL(KIND=8) ZPIZAZ(KDLON,KFLEV)
861	REAL(KIND=8) ZRAYL(KDLON)
862	REAL(KIND=8) ZRAY1(KDLON,KFLEV+1)
863	REAL(KIND=8) ZRAY2(KDLON,KFLEV+1)
864	REAL(KIND=8) ZREF(KDLON)
865	REAL(KIND=8) ZREFZ(KDLON,2,KFLEV+1)
866	REAL(KIND=8) ZRE1(KDLON)
867	REAL(KIND=8) ZRE2(KDLON)
868	REAL(KIND=8) ZRJ(KDLON,6,KFLEV+1)
869	REAL(KIND=8) ZRJ0(KDLON,6,KFLEV+1)
870	REAL(KIND=8) ZRK(KDLON,6,KFLEV+1)
871	REAL(KIND=8) ZRK0(KDLON,6,KFLEV+1)
872	REAL(KIND=8) ZRL(KDLON,8)
873	REAL(KIND=8) ZRMUE(KDLON,KFLEV+1)
874	REAL(KIND=8) ZRMU0(KDLON,KFLEV+1)
875	REAL(KIND=8) ZRMUZ(KDLON)
876	REAL(KIND=8) ZRNEB(KDLON)
877	REAL(KIND=8) ZRUEF(KDLON,8)
878	REAL(KIND=8) ZR1(KDLON)
879	REAL(KIND=8) ZR2(KDLON,2)
880	REAL(KIND=8) ZR3(KDLON,3)
881	REAL(KIND=8) ZR4(KDLON)
882	REAL(KIND=8) ZR21(KDLON)
883	REAL(KIND=8) ZR22(KDLON)
884	REAL(KIND=8) ZS(KDLON)
885	REAL(KIND=8) ZTAUAZ(KDLON,KFLEV)
886	REAL(KIND=8) ZTO1(KDLON)
887	REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
888	REAL(KIND=8) ZTRA1(KDLON,KFLEV+1)
889	REAL(KIND=8) ZTRA2(KDLON,KFLEV+1)
890	REAL(KIND=8) ZTR1(KDLON)
891	REAL(KIND=8) ZTR2(KDLON)
892	REAL(KIND=8) ZW(KDLON)
893	REAL(KIND=8) ZW1(KDLON)
894	REAL(KIND=8) ZW2(KDLON,2)
895	REAL(KIND=8) ZW3(KDLON,3)
896	REAL(KIND=8) ZW4(KDLON)
897	REAL(KIND=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(KIND=8) ZRMUM1, ZWH2O, ZCNEB, ZAA, ZBB, ZRKI, ZRE11
902	C
903	C* Prescribed Data:
904	C
905	REAL(KIND=8) RSUN(2)
906	SAVE RSUN
907	c$OMP THREADPRIVATE(RSUN)
908	REAL(KIND=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(kind=8) flag_aer
1364	real(kind=8) tauae(kdlon,kflev,2)
1365	real(kind=8) pizae(kdlon,kflev,2)
1366	real(kind=8) cgae(kdlon,kflev,2)
1367	REAL(KIND=8) PAER(KDLON,KFLEV,5)
1368	REAL(KIND=8) PALBP(KDLON,2)
1369	REAL(KIND=8) PDSIG(KDLON,KFLEV)
1370	REAL(KIND=8) PRAYL(KDLON)
1371	REAL(KIND=8) PSEC(KDLON)
1372	C
1373	REAL(KIND=8) PCGAZ(KDLON,KFLEV)
1374	REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
1375	REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
1376	REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
1377	REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
1378	REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
1379	REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
1380	REAL(KIND=8) PRMU0(KDLON,KFLEV+1)
1381	REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
1382	REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
1383	REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
1384	C
1385	C* LOCAL VARIABLES:
1386	C
1387	REAL(KIND=8) ZC0I(KDLON,KFLEV+1)
1388	REAL(KIND=8) ZCLE0(KDLON,KFLEV)
1389	REAL(KIND=8) ZCLEAR(KDLON)
1390	REAL(KIND=8) ZR21(KDLON)
1391	REAL(KIND=8) ZR23(KDLON)
1392	REAL(KIND=8) ZSS0(KDLON)
1393	REAL(KIND=8) ZSCAT(KDLON)
1394	REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
1395	C
1396	INTEGER jl, jk, ja, jae, jkl, jklp1, jaj, jkm1, in
1397	REAL(KIND=8) ZTRAY, ZGAR, ZRATIO, ZFF, ZFACOA, ZCORAE
1398	REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZMU1, ZDEN1
1399	REAL(KIND=8) ZBMU0, ZBMU1, ZRE11
1400	C
1401	C* Prescribed Data for Aerosols:
1402	C
1403	REAL(KIND=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(KIND=8) PALBD(KDLON,2)
1731	REAL(KIND=8) PCG(KDLON,2,KFLEV)
1732	REAL(KIND=8) PCLD(KDLON,KFLEV)
1733	REAL(KIND=8) PDSIG(KDLON,KFLEV)
1734	REAL(KIND=8) POMEGA(KDLON,2,KFLEV)
1735	REAL(KIND=8) PRAYL(KDLON)
1736	REAL(KIND=8) PSEC(KDLON)
1737	REAL(KIND=8) PTAU(KDLON,2,KFLEV)
1738	C
1739	REAL(KIND=8) PRAY1(KDLON,KFLEV+1)
1740	REAL(KIND=8) PRAY2(KDLON,KFLEV+1)
1741	REAL(KIND=8) PREFZ(KDLON,2,KFLEV+1)
1742	REAL(KIND=8) PRJ(KDLON,6,KFLEV+1)
1743	REAL(KIND=8) PRK(KDLON,6,KFLEV+1)
1744	REAL(KIND=8) PRMUE(KDLON,KFLEV+1)
1745	REAL(KIND=8) PCGAZ(KDLON,KFLEV)
1746	REAL(KIND=8) PPIZAZ(KDLON,KFLEV)
1747	REAL(KIND=8) PTAUAZ(KDLON,KFLEV)
1748	REAL(KIND=8) PTRA1(KDLON,KFLEV+1)
1749	REAL(KIND=8) PTRA2(KDLON,KFLEV+1)
1750	C
1751	C* LOCAL VARIABLES:
1752	C
1753	REAL(KIND=8) ZC1I(KDLON,KFLEV+1)
1754	REAL(KIND=8) ZCLEQ(KDLON,KFLEV)
1755	REAL(KIND=8) ZCLEAR(KDLON)
1756	REAL(KIND=8) ZCLOUD(KDLON)
1757	REAL(KIND=8) ZGG(KDLON)
1758	REAL(KIND=8) ZREF(KDLON)
1759	REAL(KIND=8) ZRE1(KDLON)
1760	REAL(KIND=8) ZRE2(KDLON)
1761	REAL(KIND=8) ZRMUZ(KDLON)
1762	REAL(KIND=8) ZRNEB(KDLON)
1763	REAL(KIND=8) ZR21(KDLON)
1764	REAL(KIND=8) ZR22(KDLON)
1765	REAL(KIND=8) ZR23(KDLON)
1766	REAL(KIND=8) ZSS1(KDLON)
1767	REAL(KIND=8) ZTO1(KDLON)
1768	REAL(KIND=8) ZTR(KDLON,2,KFLEV+1)
1769	REAL(KIND=8) ZTR1(KDLON)
1770	REAL(KIND=8) ZTR2(KDLON)
1771	REAL(KIND=8) ZW(KDLON)
1772	C
1773	INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
1774	REAL(KIND=8) ZFACOA, ZFACOC, ZCORAE, ZCORCD
1775	REAL(KIND=8) ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
1776	REAL(KIND=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(KIND=8) PGG(KDLON) ! ASSYMETRY FACTOR
2084	REAL(KIND=8) PREF(KDLON) ! REFLECTIVITY OF THE UNDERLYING LAYER
2085	REAL(KIND=8) PRMUZ(KDLON) ! COSINE OF SOLAR ZENITH ANGLE
2086	REAL(KIND=8) PTO1(KDLON) ! OPTICAL THICKNESS
2087	REAL(KIND=8) PW(KDLON) ! SINGLE SCATTERING ALBEDO
2088	REAL(KIND=8) PRE1(KDLON) ! LAYER REFLECTIVITY (NO UNDERLYING-LAYER REFLECTION)
2089	REAL(KIND=8) PRE2(KDLON) ! LAYER REFLECTIVITY
2090	REAL(KIND=8) PTR1(KDLON) ! LAYER TRANSMISSIVITY (NO UNDERLYING-LAYER REFLECTION)
2091	REAL(KIND=8) PTR2(KDLON) ! LAYER TRANSMISSIVITY
2092	C
2093	C* LOCAL VARIABLES:
2094	C
2095	INTEGER jl
2096	REAL(KIND=8) ZFF, ZGP, ZTOP, ZWCP, ZDT, ZX1, ZWM
2097	REAL(KIND=8) ZRM2, ZRK, ZX2, ZRP, ZALPHA, ZBETA, ZARG
2098	REAL(KIND=8) ZEXMU0, ZARG2, ZEXKP, ZEXKM, ZXP2P, ZXM2P, ZAP2B,
2099	$ ZAM2B
2100	REAL(KIND=8) ZA11, ZA12, ZA13, ZA21, ZA22, ZA23
2101	REAL(KIND=8) ZDENA, ZC1A, ZC2A, ZRI0A, ZRI1A
2102	REAL(KIND=8) ZRI0B, ZRI1B
2103	REAL(KIND=8) ZB21, ZB22, ZB23, ZDENB, ZC1B, ZC2B
2104	REAL(KIND=8) ZRI0C, ZRI1C, ZRI0D, ZRI1D
2105	C ------------------------------------------------------------------
2106	C
2107	C* 1. DELTA-EDDINGTON CALCULATIONS
2108	C
2109	100 CONTINUE
2110	C
2111	DO 131 JL = 1, KDLON
2112	C
2113	C* 1.1 SET UP THE DELTA-MODIFIED PARAMETERS
2114	C
2115	110 CONTINUE
2116	C
2117	ZFF = PGG(JL)*PGG(JL)
2118	ZGP = PGG(JL)/(1.+PGG(JL))
2119	ZTOP = (1.- PW(JL) * ZFF) * PTO1(JL)
2120	ZWCP = (1-ZFF)* PW(JL) /(1.- PW(JL) * ZFF)
2121	ZDT = 2./3.
2122	ZX1 = 1.-ZWCP*ZGP
2123	ZWM = 1.-ZWCP
2124	ZRM2 = PRMUZ(JL) * PRMUZ(JL)
2125	ZRK = SQRT(3.ZWMZX1)
2126	ZX2 = 4.(1.-ZRKZRK*ZRM2)
2127	ZRP=ZRK/ZX1
2128	ZALPHA = 3.ZWCPZRM2(1.+ZGPZWM)/ZX2
2129	ZBETA = 3.ZWCP PRMUZ(JL) (1.+3.ZGPZRM2ZWM)/ZX2
2130	ZARG=MIN(ZTOP/PRMUZ(JL),200._8)
2131	ZEXMU0=EXP(-ZARG)
2132	ZARG2=MIN(ZRK*ZTOP,200._8)
2133	ZEXKP=EXP(ZARG2)
2134	ZEXKM = 1./ZEXKP
2135	ZXP2P = 1.+ZDT*ZRP
2136	ZXM2P = 1.-ZDT*ZRP
2137	ZAP2B = ZALPHA+ZDT*ZBETA
2138	ZAM2B = ZALPHA-ZDT*ZBETA
2139	C
2140	C* 1.2 WITHOUT REFLECTION FROM THE UNDERLYING LAYER
2141	C
2142	120 CONTINUE
2143	C
2144	ZA11 = ZXP2P
2145	ZA12 = ZXM2P
2146	ZA13 = ZAP2B
2147	ZA22 = ZXP2P*ZEXKP
2148	ZA21 = ZXM2P*ZEXKM
2149	ZA23 = ZAM2B*ZEXMU0
2150	ZDENA = ZA11 * ZA22 - ZA21 * ZA12
2151	ZC1A = (ZA22ZA13-ZA12ZA23)/ZDENA
2152	ZC2A = (ZA11ZA23-ZA21ZA13)/ZDENA
2153	ZRI0A = ZC1A+ZC2A-ZALPHA
2154	ZRI1A = ZRP*(ZC1A-ZC2A)-ZBETA
2155	PRE1(JL) = (ZRI0A-ZDT*ZRI1A)/ PRMUZ(JL)
2156	ZRI0B = ZC1AZEXKM+ZC2AZEXKP-ZALPHA*ZEXMU0
2157	ZRI1B = ZRP(ZC1AZEXKM-ZC2AZEXKP)-ZBETAZEXMU0
2158	PTR1(JL) = ZEXMU0+(ZRI0B+ZDT*ZRI1B)/ PRMUZ(JL)
2159	C
2160	C* 1.3 WITH REFLECTION FROM THE UNDERLYING LAYER
2161	C
2162	130 CONTINUE
2163	C
2164	ZB21 = ZA21- PREF(JL) ZXP2PZEXKM
2165	ZB22 = ZA22- PREF(JL) ZXM2PZEXKP
2166	ZB23 = ZA23- PREF(JL) ZEXMU0(ZAP2B - PRMUZ(JL) )
2167	ZDENB = ZA11 * ZB22 - ZB21 * ZA12
2168	ZC1B = (ZB22ZA13-ZA12ZB23)/ZDENB
2169	ZC2B = (ZA11ZB23-ZB21ZA13)/ZDENB
2170	ZRI0C = ZC1B+ZC2B-ZALPHA
2171	ZRI1C = ZRP*(ZC1B-ZC2B)-ZBETA
2172	PRE2(JL) = (ZRI0C-ZDT*ZRI1C) / PRMUZ(JL)
2173	ZRI0D = ZC1BZEXKM + ZC2BZEXKP - ZALPHA*ZEXMU0
2174	ZRI1D = ZRP * (ZC1BZEXKM - ZC2BZEXKP) - ZBETA*ZEXMU0
2175	PTR2(JL) = ZEXMU0 + (ZRI0D + ZDT*ZRI1D) / PRMUZ(JL)
2176	C
2177	131 CONTINUE
2178	RETURN
2179	END
2180	SUBROUTINE SWTT_LMDAR4 (KNU,KA,PU,PTR)
2181	USE dimphy
2182	IMPLICIT none
2183	cym#include "dimensions.h"
2184	cym#include "dimphy.h"
2185	cym#include "raddim.h"
2186	C
2187	C-----------------------------------------------------------------------
2188	C PURPOSE.
2189	C --------
2190	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2191	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2192	C INTERVALS.
2193	C
2194	C METHOD.
2195	C -------
2196	C
2197	C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2198	C AND HORNER'S ALGORITHM.
2199	C
2200	C REFERENCE.
2201	C ----------
2202	C
2203	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2204	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2205	C
2206	C AUTHOR.
2207	C -------
2208	C JEAN-JACQUES MORCRETTE ECMWF
2209	C
2210	C MODIFICATIONS.
2211	C --------------
2212	C ORIGINAL : 88-12-15
2213	C-----------------------------------------------------------------------
2214	C
2215	C* ARGUMENTS
2216	C
2217	INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2218	INTEGER KA ! INDEX OF THE ABSORBER
2219	REAL(KIND=8) PU(KDLON) ! ABSORBER AMOUNT
2220	C
2221	REAL(KIND=8) PTR(KDLON) ! TRANSMISSION FUNCTION
2222	C
2223	C* LOCAL VARIABLES:
2224	C
2225	REAL(KIND=8) ZR1(KDLON), ZR2(KDLON)
2226	INTEGER jl, i,j
2227	C
2228	C* Prescribed Data:
2229	C
2230	REAL(KIND=8) APAD(2,3,7), BPAD(2,3,7), D(2,3)
2231	SAVE APAD, BPAD, D
2232	c$OMP THREADPRIVATE(APAD, BPAD, D)
2233	DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2234	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2235	S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2236	S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2237	S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2238	S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2239	S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2240	S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2241	DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2242	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2243	S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2244	S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2245	S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2246	S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2247	S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2248	S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2249	C
2250	DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2251	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2252	S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2253	S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2254	S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2255	S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2256	S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2257	S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2258	DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2259	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2260	S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2261	S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2262	S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2263	S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2264	S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2265	S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2266	c
2267	DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2268	DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2269	C
2270	C-----------------------------------------------------------------------
2271	C
2272	C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2273	C
2274	100 CONTINUE
2275	C
2276	DO 201 JL = 1, KDLON
2277	ZR1(JL) = APAD(KNU,KA,1) + PU(JL) * (APAD(KNU,KA,2) + PU(JL)
2278	S * ( APAD(KNU,KA,3) + PU(JL) * (APAD(KNU,KA,4) + PU(JL)
2279	S * ( APAD(KNU,KA,5) + PU(JL) * (APAD(KNU,KA,6) + PU(JL)
2280	S * ( APAD(KNU,KA,7) ))))))
2281	C
2282	ZR2(JL) = BPAD(KNU,KA,1) + PU(JL) * (BPAD(KNU,KA,2) + PU(JL)
2283	S * ( BPAD(KNU,KA,3) + PU(JL) * (BPAD(KNU,KA,4) + PU(JL)
2284	S * ( BPAD(KNU,KA,5) + PU(JL) * (BPAD(KNU,KA,6) + PU(JL)
2285	S * ( BPAD(KNU,KA,7) ))))))
2286	C
2287	C
2288	C* 2. ADD THE BACKGROUND TRANSMISSION
2289	C
2290	200 CONTINUE
2291	C
2292	C
2293	PTR(JL) = (ZR1(JL) / ZR2(JL)) * (1. - D(KNU,KA)) + D(KNU,KA)
2294	201 CONTINUE
2295	C
2296	RETURN
2297	END
2298	SUBROUTINE SWTT1_LMDAR4(KNU,KABS,KIND, PU, PTR)
2299	USE dimphy
2300	IMPLICIT none
2301	cym#include "dimensions.h"
2302	cym#include "dimphy.h"
2303	cym#include "raddim.h"
2304	C
2305	C-----------------------------------------------------------------------
2306	C PURPOSE.
2307	C --------
2308	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
2309	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN THE TWO SPECTRAL
2310	C INTERVALS.
2311	C
2312	C METHOD.
2313	C -------
2314	C
2315	C TRANSMISSION FUNCTION ARE COMPUTED USING PADE APPROXIMANTS
2316	C AND HORNER'S ALGORITHM.
2317	C
2318	C REFERENCE.
2319	C ----------
2320	C
2321	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2322	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2323	C
2324	C AUTHOR.
2325	C -------
2326	C JEAN-JACQUES MORCRETTE ECMWF
2327	C
2328	C MODIFICATIONS.
2329	C --------------
2330	C ORIGINAL : 95-01-20
2331	C-----------------------------------------------------------------------
2332	C* ARGUMENTS:
2333	C
2334	INTEGER KNU ! INDEX OF THE SPECTRAL INTERVAL
2335	INTEGER KABS ! NUMBER OF ABSORBERS
2336	INTEGER KIND(KABS) ! INDICES OF THE ABSORBERS
2337	REAL(KIND=8) PU(KDLON,KABS) ! ABSORBER AMOUNT
2338	C
2339	REAL(KIND=8) PTR(KDLON,KABS) ! TRANSMISSION FUNCTION
2340	C
2341	C* LOCAL VARIABLES:
2342	C
2343	REAL(KIND=8) ZR1(KDLON)
2344	REAL(KIND=8) ZR2(KDLON)
2345	REAL(KIND=8) ZU(KDLON)
2346	INTEGER jl, ja, i, j, ia
2347	C
2348	C* Prescribed Data:
2349	C
2350	REAL(KIND=8) APAD(2,3,7), BPAD(2,3,7), D(2,3)
2351	SAVE APAD, BPAD, D
2352	c$OMP THREADPRIVATE(APAD, BPAD, D)
2353	DATA ((APAD(1,I,J),I=1,3),J=1,7) /
2354	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2355	S 0.723613782E+05, 0.000000000E-00, 0.129353723E-01,
2356	S 0.596037057E+04, 0.000000000E-00, 0.800821928E+00,
2357	S 0.000000000E-00, 0.000000000E-00, 0.242715973E+02,
2358	S 0.000000000E-00, 0.000000000E-00, 0.878331486E+02,
2359	S 0.000000000E-00, 0.000000000E-00, 0.191559725E+02,
2360	S 0.000000000E-00, 0.000000000E-00, 0.000000000E+00 /
2361	DATA ((APAD(2,I,J),I=1,3),J=1,7) /
2362	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2363	S 0.978576773E-04, 0.131849595E-03, 0.672595424E+02,
2364	S 0.387714006E+00, 0.437772681E+00, 0.000000000E-00,
2365	S 0.118461660E+03, 0.151345118E+03, 0.000000000E-00,
2366	S 0.119079797E+04, 0.233628890E+04, 0.000000000E-00,
2367	S 0.293353397E+03, 0.797219934E+03, 0.000000000E-00,
2368	S 0.000000000E+00, 0.000000000E+00, 0.000000000E+00 /
2369	C
2370	DATA ((BPAD(1,I,J),I=1,3),J=1,7) /
2371	S 0.912418292E+05, 0.000000000E-00, 0.925887084E-04,
2372	S 0.724555318E+05, 0.000000000E-00, 0.131812683E-01,
2373	S 0.602593328E+04, 0.000000000E-00, 0.812706117E+00,
2374	S 0.100000000E+01, 0.000000000E-00, 0.249863591E+02,
2375	S 0.000000000E-00, 0.000000000E-00, 0.931071925E+02,
2376	S 0.000000000E-00, 0.000000000E-00, 0.252233437E+02,
2377	S 0.000000000E-00, 0.000000000E-00, 0.100000000E+01 /
2378	DATA ((BPAD(2,I,J),I=1,3),J=1,7) /
2379	S 0.376655383E-08, 0.739646016E-08, 0.410177786E+03,
2380	S 0.979023421E-04, 0.131861712E-03, 0.731185438E+02,
2381	S 0.388611139E+00, 0.437949001E+00, 0.100000000E+01,
2382	S 0.120291383E+03, 0.151692730E+03, 0.000000000E+00,
2383	S 0.130531005E+04, 0.237071130E+04, 0.000000000E+00,
2384	S 0.415049409E+03, 0.867914360E+03, 0.000000000E+00,
2385	S 0.100000000E+01, 0.100000000E+01, 0.000000000E+00 /
2386	c
2387	DATA (D(1,I),I=1,3) / 0.00, 0.00, 0.00 /
2388	DATA (D(2,I),I=1,3) / 0.000000000, 0.000000000, 0.800000000 /
2389	C-----------------------------------------------------------------------
2390	C
2391	C* 1. HORNER'S ALGORITHM TO COMPUTE TRANSMISSION FUNCTION
2392	C
2393	100 CONTINUE
2394	C
2395	DO 202 JA = 1,KABS
2396	IA=KIND(JA)
2397	DO 201 JL = 1, KDLON
2398	ZU(JL) = PU(JL,JA)
2399	ZR1(JL) = APAD(KNU,IA,1) + ZU(JL) * (APAD(KNU,IA,2) + ZU(JL)
2400	S * ( APAD(KNU,IA,3) + ZU(JL) * (APAD(KNU,IA,4) + ZU(JL)
2401	S * ( APAD(KNU,IA,5) + ZU(JL) * (APAD(KNU,IA,6) + ZU(JL)
2402	S * ( APAD(KNU,IA,7) ))))))
2403	C
2404	ZR2(JL) = BPAD(KNU,IA,1) + ZU(JL) * (BPAD(KNU,IA,2) + ZU(JL)
2405	S * ( BPAD(KNU,IA,3) + ZU(JL) * (BPAD(KNU,IA,4) + ZU(JL)
2406	S * ( BPAD(KNU,IA,5) + ZU(JL) * (BPAD(KNU,IA,6) + ZU(JL)
2407	S * ( BPAD(KNU,IA,7) ))))))
2408	C
2409	C
2410	C* 2. ADD THE BACKGROUND TRANSMISSION
2411	C
2412	200 CONTINUE
2413	C
2414	PTR(JL,JA) = (ZR1(JL)/ZR2(JL)) * (1.-D(KNU,IA)) + D(KNU,IA)
2415	201 CONTINUE
2416	202 CONTINUE
2417	C
2418	RETURN
2419	END
2420	cIM ctes ds clesphys.h SUBROUTINE LW(RCO2,RCH4,RN2O,RCFC11,RCFC12,
2421	SUBROUTINE LW_LMDAR4(
2422	. PPMB, PDP,
2423	. PPSOL,PDT0,PEMIS,
2424	. PTL, PTAVE, PWV, POZON, PAER,
2425	. PCLDLD,PCLDLU,
2426	. PVIEW,
2427	. PCOLR, PCOLR0,
2428	. PTOPLW,PSOLLW,PTOPLW0,PSOLLW0,
2429	. psollwdown,
2430	cIM . psollwdown,psollwdownclr,
2431	cIM . ptoplwdown,ptoplwdownclr)
2432	. plwup, plwdn, plwup0, plwdn0)
2433	USE dimphy
2434	IMPLICIT none
2435	cym#include "dimensions.h"
2436	cym#include "dimphy.h"
2437	cym#include "raddim.h"
2438	#include "raddimlw.h"
2439	#include "YOMCST.h"
2440	C
2441	C-----------------------------------------------------------------------
2442	C METHOD.
2443	C -------
2444	C
2445	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2446	C ABSORBERS.
2447	C 2. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
2448	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
2449	C 3. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
2450	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
2451	C BOUNDARIES.
2452	C 4. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
2453	C 5. INTRODUCES THE EFFECTS OF THE CLOUDS ON THE FLUXES.
2454	C
2455	C
2456	C REFERENCE.
2457	C ----------
2458	C
2459	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2460	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2461	C
2462	C AUTHOR.
2463	C -------
2464	C JEAN-JACQUES MORCRETTE ECMWF
2465	C
2466	C MODIFICATIONS.
2467	C --------------
2468	C ORIGINAL : 89-07-14
2469	C-----------------------------------------------------------------------
2470	cIM ctes ds clesphys.h
2471	c REAL(KIND=8) RCO2 ! CO2 CONCENTRATION (IPCC:353.E-06* 44.011/28.97)
2472	c REAL(KIND=8) RCH4 ! CH4 CONCENTRATION (IPCC: 1.72E-06* 16.043/28.97)
2473	c REAL(KIND=8) RN2O ! N2O CONCENTRATION (IPCC: 310.E-09* 44.013/28.97)
2474	c REAL(KIND=8) RCFC11 ! CFC11 CONCENTRATION (IPCC: 280.E-12* 137.3686/28.97)
2475	c REAL(KIND=8) RCFC12 ! CFC12 CONCENTRATION (IPCC: 484.E-12* 120.9140/28.97)
2476	#include "clesphys.h"
2477	REAL(KIND=8) PCLDLD(KDLON,KFLEV) ! DOWNWARD EFFECTIVE CLOUD COVER
2478	REAL(KIND=8) PCLDLU(KDLON,KFLEV) ! UPWARD EFFECTIVE CLOUD COVER
2479	REAL(KIND=8) PDP(KDLON,KFLEV) ! LAYER PRESSURE THICKNESS (Pa)
2480	REAL(KIND=8) PDT0(KDLON) ! SURFACE TEMPERATURE DISCONTINUITY (K)
2481	REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
2482	REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF LEVEL PRESSURE (mb)
2483	REAL(KIND=8) PPSOL(KDLON) ! SURFACE PRESSURE (Pa)
2484	REAL(KIND=8) POZON(KDLON,KFLEV) ! O3 mass fraction
2485	REAL(KIND=8) PTL(KDLON,KFLEV+1) ! HALF LEVEL TEMPERATURE (K)
2486	REAL(KIND=8) PAER(KDLON,KFLEV,5) ! OPTICAL THICKNESS OF THE AEROSOLS
2487	REAL(KIND=8) PTAVE(KDLON,KFLEV) ! LAYER TEMPERATURE (K)
2488	REAL(KIND=8) PVIEW(KDLON) ! COSECANT OF VIEWING ANGLE
2489	REAL(KIND=8) PWV(KDLON,KFLEV) ! SPECIFIC HUMIDITY (kg/kg)
2490	C
2491	REAL(KIND=8) PCOLR(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day)
2492	REAL(KIND=8) PCOLR0(KDLON,KFLEV) ! LONG-WAVE TENDENCY (K/day) clear-sky
2493	REAL(KIND=8) PTOPLW(KDLON) ! LONGWAVE FLUX AT T.O.A.
2494	REAL(KIND=8) PSOLLW(KDLON) ! LONGWAVE FLUX AT SURFACE
2495	REAL(KIND=8) PTOPLW0(KDLON) ! LONGWAVE FLUX AT T.O.A. (CLEAR-SKY)
2496	REAL(KIND=8) PSOLLW0(KDLON) ! LONGWAVE FLUX AT SURFACE (CLEAR-SKY)
2497	c Rajout LF
2498	real(kind=8) psollwdown(kdlon) ! LONGWAVE downwards flux at surface
2499	c Rajout IM
2500	cIM real(kind=8) psollwdownclr(kdlon) ! LONGWAVE CS downwards flux at surface
2501	cIM real(kind=8) ptoplwdown(kdlon) ! LONGWAVE downwards flux at T.O.A.
2502	cIM real(kind=8) ptoplwdownclr(kdlon) ! LONGWAVE CS downwards flux at T.O.A.
2503	cIM
2504	REAL(KIND=8) plwup(KDLON,KFLEV+1) ! LW up total sky
2505	REAL(KIND=8) plwup0(KDLON,KFLEV+1) ! LW up clear sky
2506	REAL(KIND=8) plwdn(KDLON,KFLEV+1) ! LW down total sky
2507	REAL(KIND=8) plwdn0(KDLON,KFLEV+1) ! LW down clear sky
2508	C-------------------------------------------------------------------------
2509	REAL(KIND=8) ZABCU(KDLON,NUA,3*KFLEV+1)
2510
2511	REAL(KIND=8) ZOZ(KDLON,KFLEV)
2512	! equivalent pressure of ozone in a layer, in Pa
2513
2514	cym REAL(KIND=8) ZFLUX(KDLON,2,KFLEV+1) ! RADIATIVE FLUXES (1:up; 2:down)
2515	cym REAL(KIND=8) ZFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
2516	cym REAL(KIND=8) ZBINT(KDLON,KFLEV+1) ! Intermediate variable
2517	cym REAL(KIND=8) ZBSUI(KDLON) ! Intermediate variable
2518	cym REAL(KIND=8) ZCTS(KDLON,KFLEV) ! Intermediate variable
2519	cym REAL(KIND=8) ZCNTRB(KDLON,KFLEV+1,KFLEV+1) ! Intermediate variable
2520	cym SAVE ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB
2521	REAL(KIND=8),allocatable,save :: ZFLUX(:,:,:) ! RADIATIVE FLUXES (1:up; 2:down)
2522	REAL(KIND=8),allocatable,save :: ZFLUC(:,:,:) ! CLEAR-SKY RADIATIVE FLUXES
2523	REAL(KIND=8),allocatable,save :: ZBINT(:,:) ! Intermediate variable
2524	REAL(KIND=8),allocatable,save :: ZBSUI(:) ! Intermediate variable
2525	REAL(KIND=8),allocatable,save :: ZCTS(:,:) ! Intermediate variable
2526	REAL(KIND=8),allocatable,save :: ZCNTRB(:,:,:) ! Intermediate variable
2527	c$OMP THREADPRIVATE(ZFLUX, ZFLUC, ZBINT, ZBSUI, ZCTS, ZCNTRB)
2528	c
2529	INTEGER ilim, i, k, kpl1
2530	C
2531	INTEGER lw0pas ! Every lw0pas steps, clear-sky is done
2532	PARAMETER (lw0pas=1)
2533	INTEGER lwpas ! Every lwpas steps, cloudy-sky is done
2534	PARAMETER (lwpas=1)
2535	c
2536	INTEGER itaplw0, itaplw
2537	LOGICAL appel1er
2538	SAVE appel1er, itaplw0, itaplw
2539	c$OMP THREADPRIVATE(appel1er, itaplw0, itaplw)
2540	DATA appel1er /.TRUE./
2541	DATA itaplw0,itaplw /0,0/
2542
2543	C ------------------------------------------------------------------
2544	IF (appel1er) THEN
2545	PRINT*, "LW clear-sky calling frequency: ", lw0pas
2546	PRINT*, "LW cloudy-sky calling frequency: ", lwpas
2547	PRINT*, " In general, they should be 1"
2548	cym
2549	allocate(ZFLUX(KDLON,2,KFLEV+1) )
2550	allocate(ZFLUC(KDLON,2,KFLEV+1) )
2551	allocate(ZBINT(KDLON,KFLEV+1))
2552	allocate(ZBSUI(KDLON))
2553	allocate(ZCTS(KDLON,KFLEV))
2554	allocate(ZCNTRB(KDLON,KFLEV+1,KFLEV+1))
2555	appel1er=.FALSE.
2556	ENDIF
2557	C
2558	IF (MOD(itaplw0,lw0pas).EQ.0) THEN
2559	c Compute equivalent pressure of ozone from mass fraction:
2560	DO k = 1, KFLEV
2561	DO i = 1, KDLON
2562	ZOZ(i,k) = POZON(i,k)PDP(i,k) RMD/RMO3
2563	ENDDO
2564	ENDDO
2565	cIM ctes ds clesphys.h CALL LWU(RCO2,RCH4, RN2O, RCFC11, RCFC12,
2566	CALL LWU_LMDAR4(
2567	S PAER,PDP,PPMB,PPSOL,ZOZ,PTAVE,PVIEW,PWV,ZABCU)
2568	CALL LWBV_LMDAR4(ILIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,ZABCU,
2569	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB)
2570	itaplw0 = 0
2571	ENDIF
2572	itaplw0 = itaplw0 + 1
2573	C
2574	IF (MOD(itaplw,lwpas).EQ.0) THEN
2575	CALL LWC_LMDAR4(ILIM,PCLDLD,PCLDLU,PEMIS,
2576	S ZFLUC,ZBINT,ZBSUI,ZCTS,ZCNTRB,
2577	S ZFLUX)
2578	itaplw = 0
2579	ENDIF
2580	itaplw = itaplw + 1
2581	C
2582	DO k = 1, KFLEV
2583	kpl1 = k+1
2584	DO i = 1, KDLON
2585	PCOLR(i,k) = ZFLUX(i,1,kpl1)+ZFLUX(i,2,kpl1)
2586	. - ZFLUX(i,1,k)- ZFLUX(i,2,k)
2587	PCOLR(i,k) = PCOLR(i,k) * RDAY*RG/RCPD / PDP(i,k)
2588	PCOLR0(i,k) = ZFLUC(i,1,kpl1)+ZFLUC(i,2,kpl1)
2589	. - ZFLUC(i,1,k)- ZFLUC(i,2,k)
2590	PCOLR0(i,k) = PCOLR0(i,k) * RDAY*RG/RCPD / PDP(i,k)
2591	ENDDO
2592	ENDDO
2593	DO i = 1, KDLON
2594	PSOLLW(i) = -ZFLUX(i,1,1)-ZFLUX(i,2,1)
2595	PTOPLW(i) = ZFLUX(i,1,KFLEV+1) + ZFLUX(i,2,KFLEV+1)
2596	c
2597	PSOLLW0(i) = -ZFLUC(i,1,1)-ZFLUC(i,2,1)
2598	PTOPLW0(i) = ZFLUC(i,1,KFLEV+1) + ZFLUC(i,2,KFLEV+1)
2599	psollwdown(i) = -ZFLUX(i,2,1)
2600	c
2601	cIM attention aux signes !; LWtop >0, LWdn < 0
2602	DO k = 1, KFLEV+1
2603	plwup(i,k) = ZFLUX(i,1,k)
2604	plwup0(i,k) = ZFLUC(i,1,k)
2605	plwdn(i,k) = ZFLUX(i,2,k)
2606	plwdn0(i,k) = ZFLUC(i,2,k)
2607	ENDDO
2608	ENDDO
2609	C ------------------------------------------------------------------
2610	RETURN
2611	END
2612	cIM ctes ds clesphys.h SUBROUTINE LWU(RCO2, RCH4, RN2O, RCFC11, RCFC12,
2613	SUBROUTINE LWU_LMDAR4(
2614	S PAER,PDP,PPMB,PPSOL,POZ,PTAVE,PVIEW,PWV,
2615	S PABCU)
2616	USE dimphy
2617	IMPLICIT none
2618	cym#include "dimensions.h"
2619	cym#include "dimphy.h"
2620	cym#include "raddim.h"
2621	#include "raddimlw.h"
2622	#include "YOMCST.h"
2623	#include "radepsi.h"
2624	#include "radopt.h"
2625	C
2626	C PURPOSE.
2627	C --------
2628	C COMPUTES ABSORBER AMOUNTS INCLUDING PRESSURE AND
2629	C TEMPERATURE EFFECTS
2630	C
2631	C METHOD.
2632	C -------
2633	C
2634	C 1. COMPUTES THE PRESSURE AND TEMPERATURE WEIGHTED AMOUNTS OF
2635	C ABSORBERS.
2636	C
2637	C
2638	C REFERENCE.
2639	C ----------
2640	C
2641	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
2642	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
2643	C
2644	C AUTHOR.
2645	C -------
2646	C JEAN-JACQUES MORCRETTE ECMWF
2647	C
2648	C MODIFICATIONS.
2649	C --------------
2650	C ORIGINAL : 89-07-14
2651	C Voigt lines (loop 404 modified) - JJM & PhD - 01/96
2652	C-----------------------------------------------------------------------
2653	C* ARGUMENTS:
2654	cIM ctes ds clesphys.h
2655	c REAL(KIND=8) RCO2
2656	c REAL(KIND=8) RCH4, RN2O, RCFC11, RCFC12
2657	#include "clesphys.h"
2658	REAL(KIND=8) PAER(KDLON,KFLEV,5)
2659	REAL(KIND=8) PDP(KDLON,KFLEV)
2660	REAL(KIND=8) PPMB(KDLON,KFLEV+1)
2661	REAL(KIND=8) PPSOL(KDLON)
2662	REAL(KIND=8) POZ(KDLON,KFLEV)
2663	REAL(KIND=8) PTAVE(KDLON,KFLEV)
2664	REAL(KIND=8) PVIEW(KDLON)
2665	REAL(KIND=8) PWV(KDLON,KFLEV)
2666	C
2667	REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
2668	C
2669	C-----------------------------------------------------------------------
2670	C* LOCAL VARIABLES:
2671	REAL(KIND=8) ZABLY(KDLON,NUA,3*KFLEV+1)
2672	REAL(KIND=8) ZDUC(KDLON,3*KFLEV+1)
2673	REAL(KIND=8) ZPHIO(KDLON)
2674	REAL(KIND=8) ZPSC2(KDLON)
2675	REAL(KIND=8) ZPSC3(KDLON)
2676	REAL(KIND=8) ZPSH1(KDLON)
2677	REAL(KIND=8) ZPSH2(KDLON)
2678	REAL(KIND=8) ZPSH3(KDLON)
2679	REAL(KIND=8) ZPSH4(KDLON)
2680	REAL(KIND=8) ZPSH5(KDLON)
2681	REAL(KIND=8) ZPSH6(KDLON)
2682	REAL(KIND=8) ZPSIO(KDLON)
2683	REAL(KIND=8) ZTCON(KDLON)
2684	REAL(KIND=8) ZPHM6(KDLON)
2685	REAL(KIND=8) ZPSM6(KDLON)
2686	REAL(KIND=8) ZPHN6(KDLON)
2687	REAL(KIND=8) ZPSN6(KDLON)
2688	REAL(KIND=8) ZSSIG(KDLON,3*KFLEV+1)
2689	REAL(KIND=8) ZTAVI(KDLON)
2690	REAL(KIND=8) ZUAER(KDLON,Ninter)
2691	REAL(KIND=8) ZXOZ(KDLON)
2692	REAL(KIND=8) ZXWV(KDLON)
2693	C
2694	INTEGER jl, jk, jkj, jkjr, jkjp, ig1
2695	INTEGER jki, jkip1, ja, jj
2696	INTEGER jkl, jkp1, jkk, jkjpn
2697	INTEGER jae1, jae2, jae3, jae, jjpn
2698	INTEGER ir, jc, jcp1
2699	REAL(KIND=8) zdpm, zupm, zupmh2o, zupmco2, zupmo3, zu6, zup
2700	REAL(KIND=8) zfppw, ztx, ztx2, zzably
2701	REAL(KIND=8) zcah1, zcbh1, zcah2, zcbh2, zcah3, zcbh3
2702	REAL(KIND=8) zcah4, zcbh4, zcah5, zcbh5, zcah6, zcbh6
2703	REAL(KIND=8) zcac8, zcbc8
2704	REAL(KIND=8) zalup, zdiff
2705	c
2706	REAL(KIND=8) PVGCO2, PVGH2O, PVGO3
2707	C
2708	REAL(KIND=8) R10E ! DECIMAL/NATURAL LOG.FACTOR
2709	PARAMETER (R10E=0.4342945)
2710	c
2711	c Used Data Block:
2712	c
2713	REAL(KIND=8) TREF
2714	SAVE TREF
2715	c$OMP THREADPRIVATE(TREF)
2716	REAL(KIND=8) RT1(2)
2717	SAVE RT1
2718	c$OMP THREADPRIVATE(RT1)
2719	REAL(KIND=8) RAER(5,5)
2720	SAVE RAER
2721	c$OMP THREADPRIVATE(RAER)
2722	REAL(KIND=8) AT(8,3), BT(8,3)
2723	SAVE AT, BT
2724	c$OMP THREADPRIVATE(AT, BT)
2725	REAL(KIND=8) OCT(4)
2726	SAVE OCT
2727	c$OMP THREADPRIVATE(OCT)
2728	DATA TREF /250.0/
2729	DATA (RT1(IG1),IG1=1,2) / -0.577350269, +0.577350269 /
2730	DATA RAER / .038520, .037196, .040532, .054934, .038520
2731	1 , .12613 , .18313 , .10357 , .064106, .126130
2732	2 , .012579, .013649, .018652, .025181, .012579
2733	3 , .011890, .016142, .021105, .028908, .011890
2734	4 , .013792, .026810, .052203, .066338, .013792 /
2735	DATA (AT(1,IR),IR=1,3) /
2736	S 0.298199E-02,-.394023E-03,0.319566E-04 /
2737	DATA (BT(1,IR),IR=1,3) /
2738	S-0.106432E-04,0.660324E-06,0.174356E-06 /
2739	DATA (AT(2,IR),IR=1,3) /
2740	S 0.143676E-01,0.366501E-02,-.160822E-02 /
2741	DATA (BT(2,IR),IR=1,3) /
2742	S-0.553979E-04,-.101701E-04,0.920868E-05 /
2743	DATA (AT(3,IR),IR=1,3) /
2744	S 0.197861E-01,0.315541E-02,-.174547E-02 /
2745	DATA (BT(3,IR),IR=1,3) /
2746	S-0.877012E-04,0.513302E-04,0.523138E-06 /
2747	DATA (AT(4,IR),IR=1,3) /
2748	S 0.289560E-01,-.208807E-02,-.121943E-02 /
2749	DATA (BT(4,IR),IR=1,3) /
2750	S-0.165960E-03,0.157704E-03,-.146427E-04 /
2751	DATA (AT(5,IR),IR=1,3) /
2752	S 0.103800E-01,0.436296E-02,-.161431E-02 /
2753	DATA (BT(5,IR),IR=1,3) /
2754	S -.276744E-04,-.327381E-04,0.127646E-04 /
2755	DATA (AT(6,IR),IR=1,3) /
2756	S 0.868859E-02,-.972752E-03,0.000000E-00 /
2757	DATA (BT(6,IR),IR=1,3) /
2758	S -.278412E-04,-.713940E-06,0.117469E-05 /
2759	DATA (AT(7,IR),IR=1,3) /
2760	S 0.250073E-03,0.455875E-03,0.109242E-03 /
2761	DATA (BT(7,IR),IR=1,3) /
2762	S 0.199846E-05,-.216313E-05,0.175991E-06 /
2763	DATA (AT(8,IR),IR=1,3) /
2764	S 0.307423E-01,0.110879E-02,-.322172E-03 /
2765	DATA (BT(8,IR),IR=1,3) /
2766	S-0.108482E-03,0.258096E-05,-.814575E-06 /
2767	c
2768	DATA OCT /-.326E-03, -.102E-05, .137E-02, -.535E-05/
2769	C-----------------------------------------------------------------------
2770	c
2771	IF (LEVOIGT) THEN
2772	PVGCO2= 60.
2773	PVGH2O= 30.
2774	PVGO3 =400.
2775	ELSE
2776	PVGCO2= 0.
2777	PVGH2O= 0.
2778	PVGO3 = 0.
2779	ENDIF
2780	C
2781	C
2782	C* 2. PRESSURE OVER GAUSS SUB-LEVELS
2783	C ------------------------------
2784	C
2785	200 CONTINUE
2786	C
2787	DO 201 JL = 1, KDLON
2788	ZSSIG(JL, 1 ) = PPMB(JL,1) * 100.
2789	201 CONTINUE
2790	C
2791	DO 206 JK = 1 , KFLEV
2792	JKJ=(JK-1)*NG1P1+1
2793	JKJR = JKJ
2794	JKJP = JKJ + NG1P1
2795	DO 203 JL = 1, KDLON
2796	ZSSIG(JL,JKJP)=PPMB(JL,JK+1)* 100.
2797	203 CONTINUE
2798	DO 205 IG1=1,NG1
2799	JKJ=JKJ+1
2800	DO 204 JL = 1, KDLON
2801	ZSSIG(JL,JKJ)= (ZSSIG(JL,JKJR)+ZSSIG(JL,JKJP))*0.5
2802	S + RT1(IG1) * (ZSSIG(JL,JKJP) - ZSSIG(JL,JKJR)) * 0.5
2803	204 CONTINUE
2804	205 CONTINUE
2805	206 CONTINUE
2806	C
2807	C-----------------------------------------------------------------------
2808	C
2809	C
2810	C* 4. PRESSURE THICKNESS AND MEAN PRESSURE OF SUB-LAYERS
2811	C --------------------------------------------------
2812	C
2813	400 CONTINUE
2814	C
2815	DO 402 JKI=1,3*KFLEV
2816	JKIP1=JKI+1
2817	DO 401 JL = 1, KDLON
2818	ZABLY(JL,5,JKI)=(ZSSIG(JL,JKI)+ZSSIG(JL,JKIP1))*0.5
2819	ZABLY(JL,3,JKI)=(ZSSIG(JL,JKI)-ZSSIG(JL,JKIP1))
2820	S /(10.*RG)
2821	401 CONTINUE
2822	402 CONTINUE
2823	C
2824	DO 406 JK = 1 , KFLEV
2825	JKP1=JK+1
2826	JKL = KFLEV+1 - JK
2827	DO 403 JL = 1, KDLON
2828	ZXWV(JL) = MAX (PWV(JL,JK) , ZEPSCQ )
2829	ZXOZ(JL) = MAX (POZ(JL,JK) / PDP(JL,JK) , ZEPSCO )
2830	403 CONTINUE
2831	JKJ=(JK-1)*NG1P1+1
2832	JKJPN=JKJ+NG1
2833	DO 405 JKK=JKJ,JKJPN
2834	DO 404 JL = 1, KDLON
2835	ZDPM = ZABLY(JL,3,JKK)
2836	ZUPM = ZABLY(JL,5,JKK) * ZDPM / 101325.
2837	ZUPMCO2 = ( ZABLY(JL,5,JKK) + PVGCO2 ) * ZDPM / 101325.
2838	ZUPMH2O = ( ZABLY(JL,5,JKK) + PVGH2O ) * ZDPM / 101325.
2839	ZUPMO3 = ( ZABLY(JL,5,JKK) + PVGO3 ) * ZDPM / 101325.
2840	ZDUC(JL,JKK) = ZDPM
2841	ZABLY(JL,12,JKK) = ZXOZ(JL) * ZDPM
2842	ZABLY(JL,13,JKK) = ZXOZ(JL) * ZUPMO3
2843	ZU6 = ZXWV(JL) * ZUPM
2844	ZFPPW = 1.6078 * ZXWV(JL) / (1.+0.608*ZXWV(JL))
2845	ZABLY(JL,6,JKK) = ZXWV(JL) * ZUPMH2O
2846	ZABLY(JL,11,JKK) = ZU6 * ZFPPW
2847	ZABLY(JL,10,JKK) = ZU6 * (1.-ZFPPW)
2848	ZABLY(JL,9,JKK) = RCO2 * ZUPMCO2
2849	ZABLY(JL,8,JKK) = RCO2 * ZDPM
2850	404 CONTINUE
2851	405 CONTINUE
2852	406 CONTINUE
2853	C
2854	C-----------------------------------------------------------------------
2855	C
2856	C
2857	C* 5. CUMULATIVE ABSORBER AMOUNTS FROM TOP OF ATMOSPHERE
2858	C --------------------------------------------------
2859	C
2860	500 CONTINUE
2861	C
2862	DO 502 JA = 1, NUA
2863	DO 501 JL = 1, KDLON
2864	PABCU(JL,JA,3*KFLEV+1) = 0.
2865	501 CONTINUE
2866	502 CONTINUE
2867	C
2868	DO 529 JK = 1 , KFLEV
2869	JJ=(JK-1)*NG1P1+1
2870	JJPN=JJ+NG1
2871	JKL=KFLEV+1-JK
2872	C
2873	C
2874	C* 5.1 CUMULATIVE AEROSOL AMOUNTS FROM TOP OF ATMOSPHERE
2875	C --------------------------------------------------
2876	C
2877	510 CONTINUE
2878	C
2879	JAE1=3*KFLEV+1-JJ
2880	JAE2=3*KFLEV+1-(JJ+1)
2881	JAE3=3*KFLEV+1-JJPN
2882	DO 512 JAE=1,5
2883	DO 511 JL = 1, KDLON
2884	ZUAER(JL,JAE) = (RAER(JAE,1)*PAER(JL,JKL,1)
2885	S +RAER(JAE,2)PAER(JL,JKL,2)+RAER(JAE,3)PAER(JL,JKL,3)
2886	S +RAER(JAE,4)PAER(JL,JKL,4)+RAER(JAE,5)PAER(JL,JKL,5))
2887	S /(ZDUC(JL,JAE1)+ZDUC(JL,JAE2)+ZDUC(JL,JAE3))
2888	511 CONTINUE
2889	512 CONTINUE
2890	C
2891	C
2892	C
2893	C* 5.2 INTRODUCES TEMPERATURE EFFECTS ON ABSORBER AMOUNTS
2894	C --------------------------------------------------
2895	C
2896	520 CONTINUE
2897	C
2898	DO 521 JL = 1, KDLON
2899	ZTAVI(JL)=PTAVE(JL,JKL)
2900	ZTCON(JL)=EXP(6.08*(296./ZTAVI(JL)-1.))
2901	ZTX=ZTAVI(JL)-TREF
2902	ZTX2=ZTX*ZTX
2903	ZZABLY = ZABLY(JL,6,JAE1)+ZABLY(JL,6,JAE2)+ZABLY(JL,6,JAE3)
2904	ZUP=MIN( MAX( 0.5R10ELOG( ZZABLY ) + 5., 0._8), 6._8)
2905	ZCAH1=AT(1,1)+ZUP(AT(1,2)+ZUP(AT(1,3)))
2906	ZCBH1=BT(1,1)+ZUP(BT(1,2)+ZUP(BT(1,3)))
2907	ZPSH1(JL)=EXP( ZCAH1 * ZTX + ZCBH1 * ZTX2 )
2908	ZCAH2=AT(2,1)+ZUP(AT(2,2)+ZUP(AT(2,3)))
2909	ZCBH2=BT(2,1)+ZUP(BT(2,2)+ZUP(BT(2,3)))
2910	ZPSH2(JL)=EXP( ZCAH2 * ZTX + ZCBH2 * ZTX2 )
2911	ZCAH3=AT(3,1)+ZUP(AT(3,2)+ZUP(AT(3,3)))
2912	ZCBH3=BT(3,1)+ZUP(BT(3,2)+ZUP(BT(3,3)))
2913	ZPSH3(JL)=EXP( ZCAH3 * ZTX + ZCBH3 * ZTX2 )
2914	ZCAH4=AT(4,1)+ZUP(AT(4,2)+ZUP(AT(4,3)))
2915	ZCBH4=BT(4,1)+ZUP(BT(4,2)+ZUP(BT(4,3)))
2916	ZPSH4(JL)=EXP( ZCAH4 * ZTX + ZCBH4 * ZTX2 )
2917	ZCAH5=AT(5,1)+ZUP(AT(5,2)+ZUP(AT(5,3)))
2918	ZCBH5=BT(5,1)+ZUP(BT(5,2)+ZUP(BT(5,3)))
2919	ZPSH5(JL)=EXP( ZCAH5 * ZTX + ZCBH5 * ZTX2 )
2920	ZCAH6=AT(6,1)+ZUP(AT(6,2)+ZUP(AT(6,3)))
2921	ZCBH6=BT(6,1)+ZUP(BT(6,2)+ZUP(BT(6,3)))
2922	ZPSH6(JL)=EXP( ZCAH6 * ZTX + ZCBH6 * ZTX2 )
2923	ZPHM6(JL)=EXP(-5.81E-4 * ZTX - 1.13E-6 * ZTX2 )
2924	ZPSM6(JL)=EXP(-5.57E-4 * ZTX - 3.30E-6 * ZTX2 )
2925	ZPHN6(JL)=EXP(-3.46E-5 * ZTX + 2.05E-7 * ZTX2 )
2926	ZPSN6(JL)=EXP( 3.70E-3 * ZTX - 2.30E-6 * ZTX2 )
2927	521 CONTINUE
2928	C
2929	DO 522 JL = 1, KDLON
2930	ZTAVI(JL)=PTAVE(JL,JKL)
2931	ZTX=ZTAVI(JL)-TREF
2932	ZTX2=ZTX*ZTX
2933	ZZABLY = ZABLY(JL,9,JAE1)+ZABLY(JL,9,JAE2)+ZABLY(JL,9,JAE3)
2934	ZALUP = R10E * LOG ( ZZABLY )
2935	ZUP = MAX( 0._8, 5.0 + 0.5 * ZALUP )
2936	ZPSC2(JL) = (ZTAVI(JL)/TREF) ** ZUP
2937	ZCAC8=AT(8,1)+ZUP(AT(8,2)+ZUP(AT(8,3)))
2938	ZCBC8=BT(8,1)+ZUP(BT(8,2)+ZUP(BT(8,3)))
2939	ZPSC3(JL)=EXP( ZCAC8 * ZTX + ZCBC8 * ZTX2 )
2940	ZPHIO(JL) = EXP( OCT(1) * ZTX + OCT(2) * ZTX2)
2941	ZPSIO(JL) = EXP( 2.* (OCT(3)ZTX+OCT(4)ZTX2))
2942	522 CONTINUE
2943	C
2944	DO 524 JKK=JJ,JJPN
2945	JC=3*KFLEV+1-JKK
2946	JCP1=JC+1
2947	DO 523 JL = 1, KDLON
2948	ZDIFF = PVIEW(JL)
2949	PABCU(JL,10,JC)=PABCU(JL,10,JCP1)
2950	S +ZABLY(JL,10,JC) *ZDIFF
2951	PABCU(JL,11,JC)=PABCU(JL,11,JCP1)
2952	S +ZABLY(JL,11,JC)ZTCON(JL)ZDIFF
2953	C
2954	PABCU(JL,12,JC)=PABCU(JL,12,JCP1)
2955	S +ZABLY(JL,12,JC)ZPHIO(JL)ZDIFF
2956	PABCU(JL,13,JC)=PABCU(JL,13,JCP1)
2957	S +ZABLY(JL,13,JC)ZPSIO(JL)ZDIFF
2958	C
2959	PABCU(JL,7,JC)=PABCU(JL,7,JCP1)
2960	S +ZABLY(JL,9,JC)ZPSC2(JL)ZDIFF
2961	PABCU(JL,8,JC)=PABCU(JL,8,JCP1)
2962	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
2963	PABCU(JL,9,JC)=PABCU(JL,9,JCP1)
2964	S +ZABLY(JL,9,JC)ZPSC3(JL)ZDIFF
2965	C
2966	PABCU(JL,1,JC)=PABCU(JL,1,JCP1)
2967	S +ZABLY(JL,6,JC)ZPSH1(JL)ZDIFF
2968	PABCU(JL,2,JC)=PABCU(JL,2,JCP1)
2969	S +ZABLY(JL,6,JC)ZPSH2(JL)ZDIFF
2970	PABCU(JL,3,JC)=PABCU(JL,3,JCP1)
2971	S +ZABLY(JL,6,JC)ZPSH5(JL)ZDIFF
2972	PABCU(JL,4,JC)=PABCU(JL,4,JCP1)
2973	S +ZABLY(JL,6,JC)ZPSH3(JL)ZDIFF
2974	PABCU(JL,5,JC)=PABCU(JL,5,JCP1)
2975	S +ZABLY(JL,6,JC)ZPSH4(JL)ZDIFF
2976	PABCU(JL,6,JC)=PABCU(JL,6,JCP1)
2977	S +ZABLY(JL,6,JC)ZPSH6(JL)ZDIFF
2978	C
2979	PABCU(JL,14,JC)=PABCU(JL,14,JCP1)
2980	S +ZUAER(JL,1) ZDUC(JL,JC)ZDIFF
2981	PABCU(JL,15,JC)=PABCU(JL,15,JCP1)
2982	S +ZUAER(JL,2) ZDUC(JL,JC)ZDIFF
2983	PABCU(JL,16,JC)=PABCU(JL,16,JCP1)
2984	S +ZUAER(JL,3) ZDUC(JL,JC)ZDIFF
2985	PABCU(JL,17,JC)=PABCU(JL,17,JCP1)
2986	S +ZUAER(JL,4) ZDUC(JL,JC)ZDIFF
2987	PABCU(JL,18,JC)=PABCU(JL,18,JCP1)
2988	S +ZUAER(JL,5) ZDUC(JL,JC)ZDIFF
2989	C
2990	PABCU(JL,19,JC)=PABCU(JL,19,JCP1)
2991	S +ZABLY(JL,8,JC)RCH4/RCO2ZPHM6(JL)*ZDIFF
2992	PABCU(JL,20,JC)=PABCU(JL,20,JCP1)
2993	S +ZABLY(JL,9,JC)RCH4/RCO2ZPSM6(JL)*ZDIFF
2994	PABCU(JL,21,JC)=PABCU(JL,21,JCP1)
2995	S +ZABLY(JL,8,JC)RN2O/RCO2ZPHN6(JL)*ZDIFF
2996	PABCU(JL,22,JC)=PABCU(JL,22,JCP1)
2997	S +ZABLY(JL,9,JC)RN2O/RCO2ZPSN6(JL)*ZDIFF
2998	C
2999	PABCU(JL,23,JC)=PABCU(JL,23,JCP1)
3000	S +ZABLY(JL,8,JC)RCFC11/RCO2 ZDIFF
3001	PABCU(JL,24,JC)=PABCU(JL,24,JCP1)
3002	S +ZABLY(JL,8,JC)RCFC12/RCO2 ZDIFF
3003	523 CONTINUE
3004	524 CONTINUE
3005	C
3006	529 CONTINUE
3007	C
3008	C
3009	RETURN
3010	END
3011	SUBROUTINE LWBV_LMDAR4(KLIM,PDP,PDT0,PEMIS,PPMB,PTL,PTAVE,PABCU,
3012	S PFLUC,PBINT,PBSUI,PCTS,PCNTRB)
3013	USE dimphy
3014	IMPLICIT none
3015	cym#include "dimensions.h"
3016	cym#include "dimphy.h"
3017	cym#include "raddim.h"
3018	#include "raddimlw.h"
3019	#include "YOMCST.h"
3020	C
3021	C PURPOSE.
3022	C --------
3023	C TO COMPUTE THE PLANCK FUNCTION AND PERFORM THE
3024	C VERTICAL INTEGRATION. SPLIT OUT FROM LW FOR MEMORY
3025	C SAVING
3026	C
3027	C METHOD.
3028	C -------
3029	C
3030	C 1. COMPUTES THE PLANCK FUNCTIONS ON THE INTERFACES AND THE
3031	C GRADIENT OF PLANCK FUNCTIONS IN THE LAYERS.
3032	C 2. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING THE CON-
3033	C TRIBUTIONS OF THE ADJACENT AND DISTANT LAYERS AND THOSE FROM THE
3034	C BOUNDARIES.
3035	C 3. COMPUTES THE CLEAR-SKY COOLING RATES.
3036	C
3037	C REFERENCE.
3038	C ----------
3039	C
3040	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3041	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3042	C
3043	C AUTHOR.
3044	C -------
3045	C JEAN-JACQUES MORCRETTE ECMWF
3046	C
3047	C MODIFICATIONS.
3048	C --------------
3049	C ORIGINAL : 89-07-14
3050	C MODIFICATION : 93-10-15 M.HAMRUD (SPLIT OUT FROM LW TO SAVE
3051	C MEMORY)
3052	C-----------------------------------------------------------------------
3053	C* ARGUMENTS:
3054	INTEGER KLIM
3055	C
3056	REAL(KIND=8) PDP(KDLON,KFLEV)
3057	REAL(KIND=8) PDT0(KDLON)
3058	REAL(KIND=8) PEMIS(KDLON)
3059	REAL(KIND=8) PPMB(KDLON,KFLEV+1)
3060	REAL(KIND=8) PTL(KDLON,KFLEV+1)
3061	REAL(KIND=8) PTAVE(KDLON,KFLEV)
3062	C
3063	REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1)
3064	C
3065	REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1)
3066	REAL(KIND=8) PBINT(KDLON,KFLEV+1)
3067	REAL(KIND=8) PBSUI(KDLON)
3068	REAL(KIND=8) PCTS(KDLON,KFLEV)
3069	REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1)
3070	C
3071	C-------------------------------------------------------------------------
3072	C
3073	C* LOCAL VARIABLES:
3074	REAL(KIND=8) ZB(KDLON,Ninter,KFLEV+1)
3075	REAL(KIND=8) ZBSUR(KDLON,Ninter)
3076	REAL(KIND=8) ZBTOP(KDLON,Ninter)
3077	REAL(KIND=8) ZDBSL(KDLON,Ninter,KFLEV*2)
3078	REAL(KIND=8) ZGA(KDLON,8,2,KFLEV)
3079	REAL(KIND=8) ZGB(KDLON,8,2,KFLEV)
3080	REAL(KIND=8) ZGASUR(KDLON,8,2)
3081	REAL(KIND=8) ZGBSUR(KDLON,8,2)
3082	REAL(KIND=8) ZGATOP(KDLON,8,2)
3083	REAL(KIND=8) ZGBTOP(KDLON,8,2)
3084	C
3085	INTEGER nuaer, ntraer
3086	C ------------------------------------------------------------------
3087	C* COMPUTES PLANCK FUNCTIONS:
3088	CALL LWB_LMDAR4(PDT0,PTAVE,PTL,
3089	S ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,
3090	S ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP)
3091	C ------------------------------------------------------------------
3092	C* PERFORMS THE VERTICAL INTEGRATION:
3093	NUAER = NUA
3094	NTRAER = NTRA
3095	CALL LWV_LMDAR4(NUAER,NTRAER, KLIM
3096	R , PABCU,ZB,PBINT,PBSUI,ZBSUR,ZBTOP,ZDBSL,PEMIS,PPMB,PTAVE
3097	R , ZGA,ZGB,ZGASUR,ZGBSUR,ZGATOP,ZGBTOP
3098	S , PCNTRB,PCTS,PFLUC)
3099	C ------------------------------------------------------------------
3100	RETURN
3101	END
3102	SUBROUTINE LWC_LMDAR4(KLIM,PCLDLD,PCLDLU,PEMIS,PFLUC,
3103	R PBINT,PBSUIN,PCTS,PCNTRB,
3104	S PFLUX)
3105	USE dimphy
3106	IMPLICIT none
3107	cym#include "dimensions.h"
3108	cym#include "dimphy.h"
3109	cym#include "raddim.h"
3110	#include "radepsi.h"
3111	#include "radopt.h"
3112	C
3113	C PURPOSE.
3114	C --------
3115	C INTRODUCES CLOUD EFFECTS ON LONGWAVE FLUXES OR
3116	C RADIANCES
3117	C
3118	C EXPLICIT ARGUMENTS :
3119	C --------------------
3120	C ==== INPUTS ===
3121	C PBINT : (KDLON,0:KFLEV) ; HALF LEVEL PLANCK FUNCTION
3122	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3123	C PCLDLD : (KDLON,KFLEV) ; DOWNWARD EFFECTIVE CLOUD FRACTION
3124	C PCLDLU : (KDLON,KFLEV) ; UPWARD EFFECTIVE CLOUD FRACTION
3125	C PCNTRB : (KDLON,KFLEV+1,KFLEV+1); CLEAR-SKY ENERGY EXCHANGE
3126	C PCTS : (KDLON,KFLEV) ; CLEAR-SKY LAYER COOLING-TO-SPACE
3127	C PEMIS : (KDLON) ; SURFACE EMISSIVITY
3128	C PFLUC
3129	C ==== OUTPUTS ===
3130	C PFLUX(KDLON,2,KFLEV) ; RADIATIVE FLUXES :
3131	C 1 ==> UPWARD FLUX TOTAL
3132	C 2 ==> DOWNWARD FLUX TOTAL
3133	C
3134	C METHOD.
3135	C -------
3136	C
3137	C 1. INITIALIZES ALL FLUXES TO CLEAR-SKY VALUES
3138	C 2. EFFECT OF ONE OVERCAST UNITY EMISSIVITY CLOUD LAYER
3139	C 3. EFFECT OF SEMI-TRANSPARENT, PARTIAL OR MULTI-LAYERED
3140	C CLOUDS
3141	C
3142	C REFERENCE.
3143	C ----------
3144	C
3145	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3146	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
3147	C
3148	C AUTHOR.
3149	C -------
3150	C JEAN-JACQUES MORCRETTE ECMWF
3151	C
3152	C MODIFICATIONS.
3153	C --------------
3154	C ORIGINAL : 89-07-14
3155	C Voigt lines (loop 231 to 233) - JJM & PhD - 01/96
3156	C-----------------------------------------------------------------------
3157	C* ARGUMENTS:
3158	INTEGER klim
3159	REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
3160	REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3161	REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3162	REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) !CLEAR-SKY ENERGY EXCHANGE
3163	REAL(KIND=8) PCTS(KDLON,KFLEV) ! CLEAR-SKY LAYER COOLING-TO-SPACE
3164	c
3165	REAL(KIND=8) PCLDLD(KDLON,KFLEV)
3166	REAL(KIND=8) PCLDLU(KDLON,KFLEV)
3167	REAL(KIND=8) PEMIS(KDLON)
3168	C
3169	REAL(KIND=8) PFLUX(KDLON,2,KFLEV+1)
3170	C-----------------------------------------------------------------------
3171	C* LOCAL VARIABLES:
3172	INTEGER IMX(KDLON), IMXP(KDLON)
3173	C
3174	REAL(KIND=8) ZCLEAR(KDLON),ZCLOUD(KDLON),
3175	$ ZDNF(KDLON,KFLEV+1,KFLEV+1)
3176	S , ZFD(KDLON), ZFN10(KDLON), ZFU(KDLON)
3177	S , ZUPF(KDLON,KFLEV+1,KFLEV+1)
3178	REAL(KIND=8) ZCLM(KDLON,KFLEV+1,KFLEV+1)
3179	C
3180	INTEGER jk, jl, imaxc, imx1, imx2, jkj, jkp1, jkm1
3181	INTEGER jk1, jk2, jkc, jkcp1, jcloud
3182	INTEGER imxm1, imxp1
3183	REAL(KIND=8) zcfrac
3184	C ------------------------------------------------------------------
3185	C
3186	C* 1. INITIALIZATION
3187	C --------------
3188	C
3189	100 CONTINUE
3190	C
3191	IMAXC = 0
3192	C
3193	DO 101 JL = 1, KDLON
3194	IMX(JL)=0
3195	IMXP(JL)=0
3196	ZCLOUD(JL) = 0.
3197	101 CONTINUE
3198	C
3199	C* 1.1 SEARCH THE LAYER INDEX OF THE HIGHEST CLOUD
3200	C -------------------------------------------
3201	C
3202	110 CONTINUE
3203	C
3204	DO 112 JK = 1 , KFLEV
3205	DO 111 JL = 1, KDLON
3206	IMX1=IMX(JL)
3207	IMX2=JK
3208	IF (PCLDLU(JL,JK).GT.ZEPSC) THEN
3209	IMXP(JL)=IMX2
3210	ELSE
3211	IMXP(JL)=IMX1
3212	END IF
3213	IMAXC=MAX(IMXP(JL),IMAXC)
3214	IMX(JL)=IMXP(JL)
3215	111 CONTINUE
3216	112 CONTINUE
3217	CGM*******
3218	IMAXC=KFLEV
3219	CGM*******
3220	C
3221	DO 114 JK = 1 , KFLEV+1
3222	DO 113 JL = 1, KDLON
3223	PFLUX(JL,1,JK) = PFLUC(JL,1,JK)
3224	PFLUX(JL,2,JK) = PFLUC(JL,2,JK)
3225	113 CONTINUE
3226	114 CONTINUE
3227	C
3228	C ------------------------------------------------------------------
3229	C
3230	C* 2. EFFECT OF CLOUDINESS ON LONGWAVE FLUXES
3231	C ---------------------------------------
3232	C
3233	IF (IMAXC.GT.0) THEN
3234	C
3235	IMXP1 = IMAXC + 1
3236	IMXM1 = IMAXC - 1
3237	C
3238	C* 2.0 INITIALIZE TO CLEAR-SKY FLUXES
3239	C ------------------------------
3240	C
3241	200 CONTINUE
3242	C
3243	DO 203 JK1=1,KFLEV+1
3244	DO 202 JK2=1,KFLEV+1
3245	DO 201 JL = 1, KDLON
3246	ZUPF(JL,JK2,JK1)=PFLUC(JL,1,JK1)
3247	ZDNF(JL,JK2,JK1)=PFLUC(JL,2,JK1)
3248	201 CONTINUE
3249	202 CONTINUE
3250	203 CONTINUE
3251	C
3252	C* 2.1 FLUXES FOR ONE OVERCAST UNITY EMISSIVITY CLOUD
3253	C ----------------------------------------------
3254	C
3255	210 CONTINUE
3256	C
3257	DO 213 JKC = 1 , IMAXC
3258	JCLOUD=JKC
3259	JKCP1=JCLOUD+1
3260	C
3261	C* 2.1.1 ABOVE THE CLOUD
3262	C ---------------
3263	C
3264	2110 CONTINUE
3265	C
3266	DO 2115 JK=JKCP1,KFLEV+1
3267	JKM1=JK-1
3268	DO 2111 JL = 1, KDLON
3269	ZFU(JL)=0.
3270	2111 CONTINUE
3271	IF (JK .GT. JKCP1) THEN
3272	DO 2113 JKJ=JKCP1,JKM1
3273	DO 2112 JL = 1, KDLON
3274	ZFU(JL) = ZFU(JL) + PCNTRB(JL,JK,JKJ)
3275	2112 CONTINUE
3276	2113 CONTINUE
3277	END IF
3278	C
3279	DO 2114 JL = 1, KDLON
3280	ZUPF(JL,JKCP1,JK)=PBINT(JL,JK)-ZFU(JL)
3281	2114 CONTINUE
3282	2115 CONTINUE
3283	C
3284	C* 2.1.2 BELOW THE CLOUD
3285	C ---------------
3286	C
3287	2120 CONTINUE
3288	C
3289	DO 2125 JK=1,JCLOUD
3290	JKP1=JK+1
3291	DO 2121 JL = 1, KDLON
3292	ZFD(JL)=0.
3293	2121 CONTINUE
3294	C
3295	IF (JK .LT. JCLOUD) THEN
3296	DO 2123 JKJ=JKP1,JCLOUD
3297	DO 2122 JL = 1, KDLON
3298	ZFD(JL) = ZFD(JL) + PCNTRB(JL,JK,JKJ)
3299	2122 CONTINUE
3300	2123 CONTINUE
3301	END IF
3302	DO 2124 JL = 1, KDLON
3303	ZDNF(JL,JKCP1,JK)=-PBINT(JL,JK)-ZFD(JL)
3304	2124 CONTINUE
3305	2125 CONTINUE
3306	C
3307	213 CONTINUE
3308	C
3309	C
3310	C* 2.2 CLOUD COVER MATRIX
3311	C ------------------
3312	C
3313	C* ZCLM(JK1,JK2) IS THE OBSCURATION FACTOR BY CLOUD LAYERS BETWEEN
3314	C HALF-LEVELS JK1 AND JK2 AS SEEN FROM JK1
3315	C
3316	220 CONTINUE
3317	C
3318	DO 223 JK1 = 1 , KFLEV+1
3319	DO 222 JK2 = 1 , KFLEV+1
3320	DO 221 JL = 1, KDLON
3321	ZCLM(JL,JK1,JK2) = 0.
3322	221 CONTINUE
3323	222 CONTINUE
3324	223 CONTINUE
3325	C
3326	C
3327	C
3328	C* 2.4 CLOUD COVER BELOW THE LEVEL OF CALCULATION
3329	C ------------------------------------------
3330	C
3331	240 CONTINUE
3332	C
3333	DO 244 JK1 = 2 , KFLEV+1
3334	DO 241 JL = 1, KDLON
3335	ZCLEAR(JL)=1.
3336	ZCLOUD(JL)=0.
3337	241 CONTINUE
3338	DO 243 JK = JK1 - 1 , 1 , -1
3339	DO 242 JL = 1, KDLON
3340	IF (NOVLP.EQ.1) THEN
3341	c* maximum-random
3342	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLU(JL,JK),ZCLOUD(JL)))
3343	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3344	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3345	ZCLOUD(JL) = PCLDLU(JL,JK)
3346	ELSE IF (NOVLP.EQ.2) THEN
3347	c* maximum
3348	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLU(JL,JK))
3349	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3350	ELSE IF (NOVLP.EQ.3) THEN
3351	c* random
3352	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLU(JL,JK))
3353	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3354	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3355	END IF
3356	242 CONTINUE
3357	243 CONTINUE
3358	244 CONTINUE
3359	C
3360	C
3361	C* 2.5 CLOUD COVER ABOVE THE LEVEL OF CALCULATION
3362	C ------------------------------------------
3363	C
3364	250 CONTINUE
3365	C
3366	DO 254 JK1 = 1 , KFLEV
3367	DO 251 JL = 1, KDLON
3368	ZCLEAR(JL)=1.
3369	ZCLOUD(JL)=0.
3370	251 CONTINUE
3371	DO 253 JK = JK1 , KFLEV
3372	DO 252 JL = 1, KDLON
3373	IF (NOVLP.EQ.1) THEN
3374	c* maximum-random
3375	ZCLEAR(JL)=ZCLEAR(JL)*(1.0-MAX(PCLDLD(JL,JK),ZCLOUD(JL)))
3376	* /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
3377	ZCLM(JL,JK1,JK) = 1.0 - ZCLEAR(JL)
3378	ZCLOUD(JL) = PCLDLD(JL,JK)
3379	ELSE IF (NOVLP.EQ.2) THEN
3380	c* maximum
3381	ZCLOUD(JL) = MAX(ZCLOUD(JL) , PCLDLD(JL,JK))
3382	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3383	ELSE IF (NOVLP.EQ.3) THEN
3384	c* random
3385	ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - PCLDLD(JL,JK))
3386	ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
3387	ZCLM(JL,JK1,JK) = ZCLOUD(JL)
3388	END IF
3389	252 CONTINUE
3390	253 CONTINUE
3391	254 CONTINUE
3392	C
3393	C
3394	C
3395	C* 3. FLUXES FOR PARTIAL/MULTIPLE LAYERED CLOUDINESS
3396	C ----------------------------------------------
3397	C
3398	300 CONTINUE
3399	C
3400	C* 3.1 DOWNWARD FLUXES
3401	C ---------------
3402	C
3403	310 CONTINUE
3404	C
3405	DO 311 JL = 1, KDLON
3406	PFLUX(JL,2,KFLEV+1) = 0.
3407	311 CONTINUE
3408	C
3409	DO 317 JK1 = KFLEV , 1 , -1
3410	C
3411	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3412	C
3413	DO 312 JL = 1, KDLON
3414	ZFD (JL) = (1. - ZCLM(JL,JK1,KFLEV)) * ZDNF(JL,1,JK1)
3415	312 CONTINUE
3416	C
3417	C* CONTRIBUTION FROM ADJACENT CLOUD
3418	C
3419	DO 313 JL = 1, KDLON
3420	ZFD(JL) = ZFD(JL) + ZCLM(JL,JK1,JK1) * ZDNF(JL,JK1+1,JK1)
3421	313 CONTINUE
3422	C
3423	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3424	C
3425	DO 315 JK = KFLEV-1 , JK1 , -1
3426	DO 314 JL = 1, KDLON
3427	ZCFRAC = ZCLM(JL,JK1,JK+1) - ZCLM(JL,JK1,JK)
3428	ZFD(JL) = ZFD(JL) + ZCFRAC * ZDNF(JL,JK+2,JK1)
3429	314 CONTINUE
3430	315 CONTINUE
3431	C
3432	DO 316 JL = 1, KDLON
3433	PFLUX(JL,2,JK1) = ZFD (JL)
3434	316 CONTINUE
3435	C
3436	317 CONTINUE
3437	C
3438	C
3439	C
3440	C
3441	C* 3.2 UPWARD FLUX AT THE SURFACE
3442	C --------------------------
3443	C
3444	320 CONTINUE
3445	C
3446	DO 321 JL = 1, KDLON
3447	PFLUX(JL,1,1) = PEMIS(JL)PBSUIN(JL)-(1.-PEMIS(JL))PFLUX(JL,2,1)
3448	321 CONTINUE
3449	C
3450	C
3451	C
3452	C* 3.3 UPWARD FLUXES
3453	C -------------
3454	C
3455	330 CONTINUE
3456	C
3457	DO 337 JK1 = 2 , KFLEV+1
3458	C
3459	C* CONTRIBUTION FROM CLEAR-SKY FRACTION
3460	C
3461	DO 332 JL = 1, KDLON
3462	ZFU (JL) = (1. - ZCLM(JL,JK1,1)) * ZUPF(JL,1,JK1)
3463	332 CONTINUE
3464	C
3465	C* CONTRIBUTION FROM ADJACENT CLOUD
3466	C
3467	DO 333 JL = 1, KDLON
3468	ZFU(JL) = ZFU(JL) + ZCLM(JL,JK1,JK1-1) * ZUPF(JL,JK1,JK1)
3469	333 CONTINUE
3470	C
3471	C* CONTRIBUTION FROM OTHER CLOUDY FRACTIONS
3472	C
3473	DO 335 JK = 2 , JK1-1
3474	DO 334 JL = 1, KDLON
3475	ZCFRAC = ZCLM(JL,JK1,JK-1) - ZCLM(JL,JK1,JK)
3476	ZFU(JL) = ZFU(JL) + ZCFRAC * ZUPF(JL,JK ,JK1)
3477	334 CONTINUE
3478	335 CONTINUE
3479	C
3480	DO 336 JL = 1, KDLON
3481	PFLUX(JL,1,JK1) = ZFU (JL)
3482	336 CONTINUE
3483	C
3484	337 CONTINUE
3485	C
3486	C
3487	END IF
3488	C
3489	C
3490	C* 2.3 END OF CLOUD EFFECT COMPUTATIONS
3491	C
3492	230 CONTINUE
3493	C
3494	IF (.NOT.LEVOIGT) THEN
3495	DO 231 JL = 1, KDLON
3496	ZFN10(JL) = PFLUX(JL,1,KLIM) + PFLUX(JL,2,KLIM)
3497	231 CONTINUE
3498	DO 233 JK = KLIM+1 , KFLEV+1
3499	DO 232 JL = 1, KDLON
3500	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
3501	PFLUX(JL,1,JK) = ZFN10(JL)
3502	PFLUX(JL,2,JK) = 0.0
3503	232 CONTINUE
3504	233 CONTINUE
3505	ENDIF
3506	C
3507	RETURN
3508	END
3509	SUBROUTINE LWB_LMDAR4(PDT0,PTAVE,PTL
3510	S , PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL
3511	S , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP)
3512	USE dimphy
3513	IMPLICIT none
3514	cym#include "dimensions.h"
3515	cym#include "dimphy.h"
3516	cym#include "raddim.h"
3517	#include "raddimlw.h"
3518	C
3519	C-----------------------------------------------------------------------
3520	C PURPOSE.
3521	C --------
3522	C COMPUTES PLANCK FUNCTIONS
3523	C
3524	C EXPLICIT ARGUMENTS :
3525	C --------------------
3526	C ==== INPUTS ===
3527	C PDT0 : (KDLON) ; SURFACE TEMPERATURE DISCONTINUITY
3528	C PTAVE : (KDLON,KFLEV) ; TEMPERATURE
3529	C PTL : (KDLON,0:KFLEV) ; HALF LEVEL TEMPERATURE
3530	C ==== OUTPUTS ===
3531	C PB : (KDLON,Ninter,KFLEV+1); SPECTRAL HALF LEVEL PLANCK FUNCTION
3532	C PBINT : (KDLON,KFLEV+1) ; HALF LEVEL PLANCK FUNCTION
3533	C PBSUIN : (KDLON) ; SURFACE PLANCK FUNCTION
3534	C PBSUR : (KDLON,Ninter) ; SURFACE SPECTRAL PLANCK FUNCTION
3535	C PBTOP : (KDLON,Ninter) ; TOP SPECTRAL PLANCK FUNCTION
3536	C PDBSL : (KDLON,Ninter,KFLEV*2); SUB-LAYER PLANCK FUNCTION GRADIENT
3537	C PGA : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3538	C PGB : (KDLON,8,2,KFLEV); dB/dT-weighted LAYER PADE APPROXIMANTS
3539	C PGASUR, PGBSUR (KDLON,8,2) ; SURFACE PADE APPROXIMANTS
3540	C PGATOP, PGBTOP (KDLON,8,2) ; T.O.A. PADE APPROXIMANTS
3541	C
3542	C IMPLICIT ARGUMENTS : NONE
3543	C --------------------
3544	C
3545	C METHOD.
3546	C -------
3547	C
3548	C 1. COMPUTES THE PLANCK FUNCTION ON ALL LEVELS AND HALF LEVELS
3549	C FROM A POLYNOMIAL DEVELOPMENT OF PLANCK FUNCTION
3550	C
3551	C REFERENCE.
3552	C ----------
3553	C
3554	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
3555	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS "
3556	C
3557	C AUTHOR.
3558	C -------
3559	C JEAN-JACQUES MORCRETTE ECMWF
3560	C
3561	C MODIFICATIONS.
3562	C --------------
3563	C ORIGINAL : 89-07-14
3564	C
3565	C-----------------------------------------------------------------------
3566	C
3567	C ARGUMENTS:
3568	C
3569	REAL(KIND=8) PDT0(KDLON)
3570	REAL(KIND=8) PTAVE(KDLON,KFLEV)
3571	REAL(KIND=8) PTL(KDLON,KFLEV+1)
3572	C
3573	REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF LEVEL PLANCK FUNCTION
3574	REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF LEVEL PLANCK FUNCTION
3575	REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
3576	REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
3577	REAL(KIND=8) PBTOP(KDLON,Ninter) ! TOP SPECTRAL PLANCK FUNCTION
3578	REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
3579	REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3580	REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! dB/dT-weighted LAYER PADE APPROXIMANTS
3581	REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3582	REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
3583	REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3584	REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
3585	C
3586	C-------------------------------------------------------------------------
3587	C* LOCAL VARIABLES:
3588	INTEGER INDB(KDLON),INDS(KDLON)
3589	REAL(KIND=8) ZBLAY(KDLON,KFLEV),ZBLEV(KDLON,KFLEV+1)
3590	REAL(KIND=8) ZRES(KDLON),ZRES2(KDLON),ZTI(KDLON),ZTI2(KDLON)
3591	c
3592	INTEGER jk, jl, ic, jnu, jf, jg
3593	INTEGER jk1, jk2
3594	INTEGER k, j, ixtox, indto, ixtx, indt
3595	INTEGER indsu, indtp
3596	REAL(KIND=8) zdsto1, zdstox, zdst1, zdstx
3597	c
3598	C* Quelques parametres:
3599	REAL(KIND=8) TSTAND
3600	PARAMETER (TSTAND=250.0)
3601	REAL(KIND=8) TSTP
3602	PARAMETER (TSTP=12.5)
3603	INTEGER MXIXT
3604	PARAMETER (MXIXT=10)
3605	C
3606	C* Used Data Block:
3607	REAL(KIND=8) TINTP(11)
3608	SAVE TINTP
3609	c$OMP THREADPRIVATE(TINTP)
3610	REAL(KIND=8) GA(11,16,3), GB(11,16,3)
3611	SAVE GA, GB
3612	c$OMP THREADPRIVATE(GA, GB)
3613	REAL(KIND=8) XP(6,6)
3614	SAVE XP
3615	c$OMP THREADPRIVATE(XP)
3616	c
3617	DATA TINTP / 187.5, 200., 212.5, 225., 237.5, 250.,
3618	S 262.5, 275., 287.5, 300., 312.5 /
3619	C-----------------------------------------------------------------------
3620	C-- WATER VAPOR -- INT.1 -- 0- 500 CM-1 -- FROM ABS225 ----------------
3621	C
3622	C
3623	C
3624	C
3625	C-- R.D. -- G = - 0.2 SLA
3626	C
3627	C
3628	C----- INTERVAL = 1 ----- T = 187.5
3629	C
3630	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3631	DATA (GA( 1, 1,IC),IC=1,3) /
3632	S 0.63499072E-02,-0.99506586E-03, 0.00000000E+00/
3633	DATA (GB( 1, 1,IC),IC=1,3) /
3634	S 0.63499072E-02, 0.97222852E-01, 0.10000000E+01/
3635	DATA (GA( 1, 2,IC),IC=1,3) /
3636	S 0.77266491E-02,-0.11661515E-02, 0.00000000E+00/
3637	DATA (GB( 1, 2,IC),IC=1,3) /
3638	S 0.77266491E-02, 0.10681591E+00, 0.10000000E+01/
3639	C
3640	C----- INTERVAL = 1 ----- T = 200.0
3641	C
3642	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3643	DATA (GA( 2, 1,IC),IC=1,3) /
3644	S 0.65566348E-02,-0.10184169E-02, 0.00000000E+00/
3645	DATA (GB( 2, 1,IC),IC=1,3) /
3646	S 0.65566348E-02, 0.98862238E-01, 0.10000000E+01/
3647	DATA (GA( 2, 2,IC),IC=1,3) /
3648	S 0.81323287E-02,-0.11886130E-02, 0.00000000E+00/
3649	DATA (GB( 2, 2,IC),IC=1,3) /
3650	S 0.81323287E-02, 0.10921298E+00, 0.10000000E+01/
3651	C
3652	C----- INTERVAL = 1 ----- T = 212.5
3653	C
3654	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3655	DATA (GA( 3, 1,IC),IC=1,3) /
3656	S 0.67849730E-02,-0.10404730E-02, 0.00000000E+00/
3657	DATA (GB( 3, 1,IC),IC=1,3) /
3658	S 0.67849730E-02, 0.10061504E+00, 0.10000000E+01/
3659	DATA (GA( 3, 2,IC),IC=1,3) /
3660	S 0.86507620E-02,-0.12139929E-02, 0.00000000E+00/
3661	DATA (GB( 3, 2,IC),IC=1,3) /
3662	S 0.86507620E-02, 0.11198225E+00, 0.10000000E+01/
3663	C
3664	C----- INTERVAL = 1 ----- T = 225.0
3665	C
3666	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3667	DATA (GA( 4, 1,IC),IC=1,3) /
3668	S 0.70481947E-02,-0.10621792E-02, 0.00000000E+00/
3669	DATA (GB( 4, 1,IC),IC=1,3) /
3670	S 0.70481947E-02, 0.10256222E+00, 0.10000000E+01/
3671	DATA (GA( 4, 2,IC),IC=1,3) /
3672	S 0.92776391E-02,-0.12445811E-02, 0.00000000E+00/
3673	DATA (GB( 4, 2,IC),IC=1,3) /
3674	S 0.92776391E-02, 0.11487826E+00, 0.10000000E+01/
3675	C
3676	C----- INTERVAL = 1 ----- T = 237.5
3677	C
3678	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3679	DATA (GA( 5, 1,IC),IC=1,3) /
3680	S 0.73585943E-02,-0.10847662E-02, 0.00000000E+00/
3681	DATA (GB( 5, 1,IC),IC=1,3) /
3682	S 0.73585943E-02, 0.10475952E+00, 0.10000000E+01/
3683	DATA (GA( 5, 2,IC),IC=1,3) /
3684	S 0.99806312E-02,-0.12807672E-02, 0.00000000E+00/
3685	DATA (GB( 5, 2,IC),IC=1,3) /
3686	S 0.99806312E-02, 0.11751113E+00, 0.10000000E+01/
3687	C
3688	C----- INTERVAL = 1 ----- T = 250.0
3689	C
3690	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3691	DATA (GA( 6, 1,IC),IC=1,3) /
3692	S 0.77242818E-02,-0.11094726E-02, 0.00000000E+00/
3693	DATA (GB( 6, 1,IC),IC=1,3) /
3694	S 0.77242818E-02, 0.10720986E+00, 0.10000000E+01/
3695	DATA (GA( 6, 2,IC),IC=1,3) /
3696	S 0.10709803E-01,-0.13208251E-02, 0.00000000E+00/
3697	DATA (GB( 6, 2,IC),IC=1,3) /
3698	S 0.10709803E-01, 0.11951535E+00, 0.10000000E+01/
3699	C
3700	C----- INTERVAL = 1 ----- T = 262.5
3701	C
3702	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3703	DATA (GA( 7, 1,IC),IC=1,3) /
3704	S 0.81472693E-02,-0.11372949E-02, 0.00000000E+00/
3705	DATA (GB( 7, 1,IC),IC=1,3) /
3706	S 0.81472693E-02, 0.10985370E+00, 0.10000000E+01/
3707	DATA (GA( 7, 2,IC),IC=1,3) /
3708	S 0.11414739E-01,-0.13619034E-02, 0.00000000E+00/
3709	DATA (GB( 7, 2,IC),IC=1,3) /
3710	S 0.11414739E-01, 0.12069945E+00, 0.10000000E+01/
3711	C
3712	C----- INTERVAL = 1 ----- T = 275.0
3713	C
3714	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3715	DATA (GA( 8, 1,IC),IC=1,3) /
3716	S 0.86227527E-02,-0.11687683E-02, 0.00000000E+00/
3717	DATA (GB( 8, 1,IC),IC=1,3) /
3718	S 0.86227527E-02, 0.11257633E+00, 0.10000000E+01/
3719	DATA (GA( 8, 2,IC),IC=1,3) /
3720	S 0.12058772E-01,-0.14014165E-02, 0.00000000E+00/
3721	DATA (GB( 8, 2,IC),IC=1,3) /
3722	S 0.12058772E-01, 0.12108524E+00, 0.10000000E+01/
3723	C
3724	C----- INTERVAL = 1 ----- T = 287.5
3725	C
3726	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3727	DATA (GA( 9, 1,IC),IC=1,3) /
3728	S 0.91396814E-02,-0.12038314E-02, 0.00000000E+00/
3729	DATA (GB( 9, 1,IC),IC=1,3) /
3730	S 0.91396814E-02, 0.11522980E+00, 0.10000000E+01/
3731	DATA (GA( 9, 2,IC),IC=1,3) /
3732	S 0.12623992E-01,-0.14378639E-02, 0.00000000E+00/
3733	DATA (GB( 9, 2,IC),IC=1,3) /
3734	S 0.12623992E-01, 0.12084229E+00, 0.10000000E+01/
3735	C
3736	C----- INTERVAL = 1 ----- T = 300.0
3737	C
3738	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3739	DATA (GA(10, 1,IC),IC=1,3) /
3740	S 0.96825438E-02,-0.12418367E-02, 0.00000000E+00/
3741	DATA (GB(10, 1,IC),IC=1,3) /
3742	S 0.96825438E-02, 0.11766343E+00, 0.10000000E+01/
3743	DATA (GA(10, 2,IC),IC=1,3) /
3744	S 0.13108146E-01,-0.14708488E-02, 0.00000000E+00/
3745	DATA (GB(10, 2,IC),IC=1,3) /
3746	S 0.13108146E-01, 0.12019005E+00, 0.10000000E+01/
3747	C
3748	C----- INTERVAL = 1 ----- T = 312.5
3749	C
3750	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
3751	DATA (GA(11, 1,IC),IC=1,3) /
3752	S 0.10233955E-01,-0.12817135E-02, 0.00000000E+00/
3753	DATA (GB(11, 1,IC),IC=1,3) /
3754	S 0.10233955E-01, 0.11975320E+00, 0.10000000E+01/
3755	DATA (GA(11, 2,IC),IC=1,3) /
3756	S 0.13518390E-01,-0.15006791E-02, 0.00000000E+00/
3757	DATA (GB(11, 2,IC),IC=1,3) /
3758	S 0.13518390E-01, 0.11932684E+00, 0.10000000E+01/
3759	C
3760	C
3761	C
3762	C--- WATER VAPOR --- INTERVAL 2 -- 500-800 CM-1--- FROM ABS225 ---------
3763	C
3764	C
3765	C
3766	C
3767	C--- R.D. --- G = 0.02 + 0.50 / ( 1 + 4.5 U )
3768	C
3769	C
3770	C----- INTERVAL = 2 ----- T = 187.5
3771	C
3772	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3773	DATA (GA( 1, 3,IC),IC=1,3) /
3774	S 0.11644593E+01, 0.41243390E+00, 0.00000000E+00/
3775	DATA (GB( 1, 3,IC),IC=1,3) /
3776	S 0.11644593E+01, 0.10346097E+01, 0.10000000E+01/
3777	DATA (GA( 1, 4,IC),IC=1,3) /
3778	S 0.12006968E+01, 0.48318936E+00, 0.00000000E+00/
3779	DATA (GB( 1, 4,IC),IC=1,3) /
3780	S 0.12006968E+01, 0.10626130E+01, 0.10000000E+01/
3781	C
3782	C----- INTERVAL = 2 ----- T = 200.0
3783	C
3784	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3785	DATA (GA( 2, 3,IC),IC=1,3) /
3786	S 0.11747203E+01, 0.43407282E+00, 0.00000000E+00/
3787	DATA (GB( 2, 3,IC),IC=1,3) /
3788	S 0.11747203E+01, 0.10433655E+01, 0.10000000E+01/
3789	DATA (GA( 2, 4,IC),IC=1,3) /
3790	S 0.12108196E+01, 0.50501827E+00, 0.00000000E+00/
3791	DATA (GB( 2, 4,IC),IC=1,3) /
3792	S 0.12108196E+01, 0.10716026E+01, 0.10000000E+01/
3793	C
3794	C----- INTERVAL = 2 ----- T = 212.5
3795	C
3796	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3797	DATA (GA( 3, 3,IC),IC=1,3) /
3798	S 0.11837872E+01, 0.45331413E+00, 0.00000000E+00/
3799	DATA (GB( 3, 3,IC),IC=1,3) /
3800	S 0.11837872E+01, 0.10511933E+01, 0.10000000E+01/
3801	DATA (GA( 3, 4,IC),IC=1,3) /
3802	S 0.12196717E+01, 0.52409502E+00, 0.00000000E+00/
3803	DATA (GB( 3, 4,IC),IC=1,3) /
3804	S 0.12196717E+01, 0.10795108E+01, 0.10000000E+01/
3805	C
3806	C----- INTERVAL = 2 ----- T = 225.0
3807	C
3808	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3809	DATA (GA( 4, 3,IC),IC=1,3) /
3810	S 0.11918561E+01, 0.47048604E+00, 0.00000000E+00/
3811	DATA (GB( 4, 3,IC),IC=1,3) /
3812	S 0.11918561E+01, 0.10582150E+01, 0.10000000E+01/
3813	DATA (GA( 4, 4,IC),IC=1,3) /
3814	S 0.12274493E+01, 0.54085277E+00, 0.00000000E+00/
3815	DATA (GB( 4, 4,IC),IC=1,3) /
3816	S 0.12274493E+01, 0.10865006E+01, 0.10000000E+01/
3817	C
3818	C----- INTERVAL = 2 ----- T = 237.5
3819	C
3820	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3821	DATA (GA( 5, 3,IC),IC=1,3) /
3822	S 0.11990757E+01, 0.48586286E+00, 0.00000000E+00/
3823	DATA (GB( 5, 3,IC),IC=1,3) /
3824	S 0.11990757E+01, 0.10645317E+01, 0.10000000E+01/
3825	DATA (GA( 5, 4,IC),IC=1,3) /
3826	S 0.12343189E+01, 0.55565422E+00, 0.00000000E+00/
3827	DATA (GB( 5, 4,IC),IC=1,3) /
3828	S 0.12343189E+01, 0.10927103E+01, 0.10000000E+01/
3829	C
3830	C----- INTERVAL = 2 ----- T = 250.0
3831	C
3832	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3833	DATA (GA( 6, 3,IC),IC=1,3) /
3834	S 0.12055643E+01, 0.49968044E+00, 0.00000000E+00/
3835	DATA (GB( 6, 3,IC),IC=1,3) /
3836	S 0.12055643E+01, 0.10702313E+01, 0.10000000E+01/
3837	DATA (GA( 6, 4,IC),IC=1,3) /
3838	S 0.12404147E+01, 0.56878618E+00, 0.00000000E+00/
3839	DATA (GB( 6, 4,IC),IC=1,3) /
3840	S 0.12404147E+01, 0.10982489E+01, 0.10000000E+01/
3841	C
3842	C----- INTERVAL = 2 ----- T = 262.5
3843	C
3844	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3845	DATA (GA( 7, 3,IC),IC=1,3) /
3846	S 0.12114186E+01, 0.51214132E+00, 0.00000000E+00/
3847	DATA (GB( 7, 3,IC),IC=1,3) /
3848	S 0.12114186E+01, 0.10753907E+01, 0.10000000E+01/
3849	DATA (GA( 7, 4,IC),IC=1,3) /
3850	S 0.12458431E+01, 0.58047395E+00, 0.00000000E+00/
3851	DATA (GB( 7, 4,IC),IC=1,3) /
3852	S 0.12458431E+01, 0.11032019E+01, 0.10000000E+01/
3853	C
3854	C----- INTERVAL = 2 ----- T = 275.0
3855	C
3856	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3857	DATA (GA( 8, 3,IC),IC=1,3) /
3858	S 0.12167192E+01, 0.52341830E+00, 0.00000000E+00/
3859	DATA (GB( 8, 3,IC),IC=1,3) /
3860	S 0.12167192E+01, 0.10800762E+01, 0.10000000E+01/
3861	DATA (GA( 8, 4,IC),IC=1,3) /
3862	S 0.12506907E+01, 0.59089894E+00, 0.00000000E+00/
3863	DATA (GB( 8, 4,IC),IC=1,3) /
3864	S 0.12506907E+01, 0.11076379E+01, 0.10000000E+01/
3865	C
3866	C----- INTERVAL = 2 ----- T = 287.5
3867	C
3868	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3869	DATA (GA( 9, 3,IC),IC=1,3) /
3870	S 0.12215344E+01, 0.53365803E+00, 0.00000000E+00/
3871	DATA (GB( 9, 3,IC),IC=1,3) /
3872	S 0.12215344E+01, 0.10843446E+01, 0.10000000E+01/
3873	DATA (GA( 9, 4,IC),IC=1,3) /
3874	S 0.12550299E+01, 0.60021475E+00, 0.00000000E+00/
3875	DATA (GB( 9, 4,IC),IC=1,3) /
3876	S 0.12550299E+01, 0.11116160E+01, 0.10000000E+01/
3877	C
3878	C----- INTERVAL = 2 ----- T = 300.0
3879	C
3880	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3881	DATA (GA(10, 3,IC),IC=1,3) /
3882	S 0.12259226E+01, 0.54298448E+00, 0.00000000E+00/
3883	DATA (GB(10, 3,IC),IC=1,3) /
3884	S 0.12259226E+01, 0.10882439E+01, 0.10000000E+01/
3885	DATA (GA(10, 4,IC),IC=1,3) /
3886	S 0.12589256E+01, 0.60856112E+00, 0.00000000E+00/
3887	DATA (GB(10, 4,IC),IC=1,3) /
3888	S 0.12589256E+01, 0.11151910E+01, 0.10000000E+01/
3889	C
3890	C----- INTERVAL = 2 ----- T = 312.5
3891	C
3892	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3893	DATA (GA(11, 3,IC),IC=1,3) /
3894	S 0.12299344E+01, 0.55150227E+00, 0.00000000E+00/
3895	DATA (GB(11, 3,IC),IC=1,3) /
3896	S 0.12299344E+01, 0.10918144E+01, 0.10000000E+01/
3897	DATA (GA(11, 4,IC),IC=1,3) /
3898	S 0.12624402E+01, 0.61607594E+00, 0.00000000E+00/
3899	DATA (GB(11, 4,IC),IC=1,3) /
3900	S 0.12624402E+01, 0.11184188E+01, 0.10000000E+01/
3901	C
3902	C
3903	C
3904	C
3905	C
3906	C
3907	C- WATER VAPOR - INT. 3 -- 800-970 + 1110-1250 CM-1 -- FIT FROM 215 IS -
3908	C
3909	C
3910	C-- WATER VAPOR LINES IN THE WINDOW REGION (800-1250 CM-1)
3911	C
3912	C
3913	C
3914	C--- G = 3.875E-03 ---------------
3915	C
3916	C----- INTERVAL = 3 ----- T = 187.5
3917	C
3918	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3919	DATA (GA( 1, 7,IC),IC=1,3) /
3920	S 0.10192131E+02, 0.80737799E+01, 0.00000000E+00/
3921	DATA (GB( 1, 7,IC),IC=1,3) /
3922	S 0.10192131E+02, 0.82623280E+01, 0.10000000E+01/
3923	DATA (GA( 1, 8,IC),IC=1,3) /
3924	S 0.92439050E+01, 0.77425778E+01, 0.00000000E+00/
3925	DATA (GB( 1, 8,IC),IC=1,3) /
3926	S 0.92439050E+01, 0.79342219E+01, 0.10000000E+01/
3927	C
3928	C----- INTERVAL = 3 ----- T = 200.0
3929	C
3930	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3931	DATA (GA( 2, 7,IC),IC=1,3) /
3932	S 0.97258602E+01, 0.79171158E+01, 0.00000000E+00/
3933	DATA (GB( 2, 7,IC),IC=1,3) /
3934	S 0.97258602E+01, 0.81072291E+01, 0.10000000E+01/
3935	DATA (GA( 2, 8,IC),IC=1,3) /
3936	S 0.87567422E+01, 0.75443460E+01, 0.00000000E+00/
3937	DATA (GB( 2, 8,IC),IC=1,3) /
3938	S 0.87567422E+01, 0.77373458E+01, 0.10000000E+01/
3939	C
3940	C----- INTERVAL = 3 ----- T = 212.5
3941	C
3942	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3943	DATA (GA( 3, 7,IC),IC=1,3) /
3944	S 0.92992890E+01, 0.77609605E+01, 0.00000000E+00/
3945	DATA (GB( 3, 7,IC),IC=1,3) /
3946	S 0.92992890E+01, 0.79523834E+01, 0.10000000E+01/
3947	DATA (GA( 3, 8,IC),IC=1,3) /
3948	S 0.83270144E+01, 0.73526151E+01, 0.00000000E+00/
3949	DATA (GB( 3, 8,IC),IC=1,3) /
3950	S 0.83270144E+01, 0.75467334E+01, 0.10000000E+01/
3951	C
3952	C----- INTERVAL = 3 ----- T = 225.0
3953	C
3954	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3955	DATA (GA( 4, 7,IC),IC=1,3) /
3956	S 0.89154021E+01, 0.76087371E+01, 0.00000000E+00/
3957	DATA (GB( 4, 7,IC),IC=1,3) /
3958	S 0.89154021E+01, 0.78012527E+01, 0.10000000E+01/
3959	DATA (GA( 4, 8,IC),IC=1,3) /
3960	S 0.79528337E+01, 0.71711188E+01, 0.00000000E+00/
3961	DATA (GB( 4, 8,IC),IC=1,3) /
3962	S 0.79528337E+01, 0.73661786E+01, 0.10000000E+01/
3963	C
3964	C----- INTERVAL = 3 ----- T = 237.5
3965	C
3966	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3967	DATA (GA( 5, 7,IC),IC=1,3) /
3968	S 0.85730084E+01, 0.74627112E+01, 0.00000000E+00/
3969	DATA (GB( 5, 7,IC),IC=1,3) /
3970	S 0.85730084E+01, 0.76561458E+01, 0.10000000E+01/
3971	DATA (GA( 5, 8,IC),IC=1,3) /
3972	S 0.76286839E+01, 0.70015571E+01, 0.00000000E+00/
3973	DATA (GB( 5, 8,IC),IC=1,3) /
3974	S 0.76286839E+01, 0.71974319E+01, 0.10000000E+01/
3975	C
3976	C----- INTERVAL = 3 ----- T = 250.0
3977	C
3978	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3979	DATA (GA( 6, 7,IC),IC=1,3) /
3980	S 0.82685838E+01, 0.73239981E+01, 0.00000000E+00/
3981	DATA (GB( 6, 7,IC),IC=1,3) /
3982	S 0.82685838E+01, 0.75182174E+01, 0.10000000E+01/
3983	DATA (GA( 6, 8,IC),IC=1,3) /
3984	S 0.73477879E+01, 0.68442532E+01, 0.00000000E+00/
3985	DATA (GB( 6, 8,IC),IC=1,3) /
3986	S 0.73477879E+01, 0.70408543E+01, 0.10000000E+01/
3987	C
3988	C----- INTERVAL = 3 ----- T = 262.5
3989	C
3990	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
3991	DATA (GA( 7, 7,IC),IC=1,3) /
3992	S 0.79978921E+01, 0.71929934E+01, 0.00000000E+00/
3993	DATA (GB( 7, 7,IC),IC=1,3) /
3994	S 0.79978921E+01, 0.73878952E+01, 0.10000000E+01/
3995	DATA (GA( 7, 8,IC),IC=1,3) /
3996	S 0.71035818E+01, 0.66987996E+01, 0.00000000E+00/
3997	DATA (GB( 7, 8,IC),IC=1,3) /
3998	S 0.71035818E+01, 0.68960649E+01, 0.10000000E+01/
3999	C
4000	C----- INTERVAL = 3 ----- T = 275.0
4001	C
4002	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4003	DATA (GA( 8, 7,IC),IC=1,3) /
4004	S 0.77568055E+01, 0.70697065E+01, 0.00000000E+00/
4005	DATA (GB( 8, 7,IC),IC=1,3) /
4006	S 0.77568055E+01, 0.72652133E+01, 0.10000000E+01/
4007	DATA (GA( 8, 8,IC),IC=1,3) /
4008	S 0.68903312E+01, 0.65644820E+01, 0.00000000E+00/
4009	DATA (GB( 8, 8,IC),IC=1,3) /
4010	S 0.68903312E+01, 0.67623672E+01, 0.10000000E+01/
4011	C
4012	C----- INTERVAL = 3 ----- T = 287.5
4013	C
4014	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4015	DATA (GA( 9, 7,IC),IC=1,3) /
4016	S 0.75416266E+01, 0.69539626E+01, 0.00000000E+00/
4017	DATA (GB( 9, 7,IC),IC=1,3) /
4018	S 0.75416266E+01, 0.71500151E+01, 0.10000000E+01/
4019	DATA (GA( 9, 8,IC),IC=1,3) /
4020	S 0.67032875E+01, 0.64405267E+01, 0.00000000E+00/
4021	DATA (GB( 9, 8,IC),IC=1,3) /
4022	S 0.67032875E+01, 0.66389989E+01, 0.10000000E+01/
4023	C
4024	C----- INTERVAL = 3 ----- T = 300.0
4025	C
4026	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4027	DATA (GA(10, 7,IC),IC=1,3) /
4028	S 0.73491694E+01, 0.68455144E+01, 0.00000000E+00/
4029	DATA (GB(10, 7,IC),IC=1,3) /
4030	S 0.73491694E+01, 0.70420667E+01, 0.10000000E+01/
4031	DATA (GA(10, 8,IC),IC=1,3) /
4032	S 0.65386461E+01, 0.63262376E+01, 0.00000000E+00/
4033	DATA (GB(10, 8,IC),IC=1,3) /
4034	S 0.65386461E+01, 0.65252707E+01, 0.10000000E+01/
4035	C
4036	C----- INTERVAL = 3 ----- T = 312.5
4037	C
4038	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4039	DATA (GA(11, 7,IC),IC=1,3) /
4040	S 0.71767400E+01, 0.67441020E+01, 0.00000000E+00/
4041	DATA (GB(11, 7,IC),IC=1,3) /
4042	S 0.71767400E+01, 0.69411177E+01, 0.10000000E+01/
4043	DATA (GA(11, 8,IC),IC=1,3) /
4044	S 0.63934377E+01, 0.62210701E+01, 0.00000000E+00/
4045	DATA (GB(11, 8,IC),IC=1,3) /
4046	S 0.63934377E+01, 0.64206412E+01, 0.10000000E+01/
4047	C
4048	C
4049	C-- WATER VAPOR -- 970-1110 CM-1 ----------------------------------------
4050	C
4051	C-- G = 3.6E-03
4052	C
4053	C----- INTERVAL = 4 ----- T = 187.5
4054	C
4055	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4056	DATA (GA( 1, 9,IC),IC=1,3) /
4057	S 0.24870635E+02, 0.10542131E+02, 0.00000000E+00/
4058	DATA (GB( 1, 9,IC),IC=1,3) /
4059	S 0.24870635E+02, 0.10656640E+02, 0.10000000E+01/
4060	DATA (GA( 1,10,IC),IC=1,3) /
4061	S 0.24586283E+02, 0.10490353E+02, 0.00000000E+00/
4062	DATA (GB( 1,10,IC),IC=1,3) /
4063	S 0.24586283E+02, 0.10605856E+02, 0.10000000E+01/
4064	C
4065	C----- INTERVAL = 4 ----- T = 200.0
4066	C
4067	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4068	DATA (GA( 2, 9,IC),IC=1,3) /
4069	S 0.24725591E+02, 0.10515895E+02, 0.00000000E+00/
4070	DATA (GB( 2, 9,IC),IC=1,3) /
4071	S 0.24725591E+02, 0.10630910E+02, 0.10000000E+01/
4072	DATA (GA( 2,10,IC),IC=1,3) /
4073	S 0.24441465E+02, 0.10463512E+02, 0.00000000E+00/
4074	DATA (GB( 2,10,IC),IC=1,3) /
4075	S 0.24441465E+02, 0.10579514E+02, 0.10000000E+01/
4076	C
4077	C----- INTERVAL = 4 ----- T = 212.5
4078	C
4079	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4080	DATA (GA( 3, 9,IC),IC=1,3) /
4081	S 0.24600320E+02, 0.10492949E+02, 0.00000000E+00/
4082	DATA (GB( 3, 9,IC),IC=1,3) /
4083	S 0.24600320E+02, 0.10608399E+02, 0.10000000E+01/
4084	DATA (GA( 3,10,IC),IC=1,3) /
4085	S 0.24311657E+02, 0.10439183E+02, 0.00000000E+00/
4086	DATA (GB( 3,10,IC),IC=1,3) /
4087	S 0.24311657E+02, 0.10555632E+02, 0.10000000E+01/
4088	C
4089	C----- INTERVAL = 4 ----- T = 225.0
4090	C
4091	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4092	DATA (GA( 4, 9,IC),IC=1,3) /
4093	S 0.24487300E+02, 0.10472049E+02, 0.00000000E+00/
4094	DATA (GB( 4, 9,IC),IC=1,3) /
4095	S 0.24487300E+02, 0.10587891E+02, 0.10000000E+01/
4096	DATA (GA( 4,10,IC),IC=1,3) /
4097	S 0.24196167E+02, 0.10417324E+02, 0.00000000E+00/
4098	DATA (GB( 4,10,IC),IC=1,3) /
4099	S 0.24196167E+02, 0.10534169E+02, 0.10000000E+01/
4100	C
4101	C----- INTERVAL = 4 ----- T = 237.5
4102	C
4103	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4104	DATA (GA( 5, 9,IC),IC=1,3) /
4105	S 0.24384935E+02, 0.10452961E+02, 0.00000000E+00/
4106	DATA (GB( 5, 9,IC),IC=1,3) /
4107	S 0.24384935E+02, 0.10569156E+02, 0.10000000E+01/
4108	DATA (GA( 5,10,IC),IC=1,3) /
4109	S 0.24093406E+02, 0.10397704E+02, 0.00000000E+00/
4110	DATA (GB( 5,10,IC),IC=1,3) /
4111	S 0.24093406E+02, 0.10514900E+02, 0.10000000E+01/
4112	C
4113	C----- INTERVAL = 4 ----- T = 250.0
4114	C
4115	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4116	DATA (GA( 6, 9,IC),IC=1,3) /
4117	S 0.24292341E+02, 0.10435562E+02, 0.00000000E+00/
4118	DATA (GB( 6, 9,IC),IC=1,3) /
4119	S 0.24292341E+02, 0.10552075E+02, 0.10000000E+01/
4120	DATA (GA( 6,10,IC),IC=1,3) /
4121	S 0.24001597E+02, 0.10380038E+02, 0.00000000E+00/
4122	DATA (GB( 6,10,IC),IC=1,3) /
4123	S 0.24001597E+02, 0.10497547E+02, 0.10000000E+01/
4124	C
4125	C----- INTERVAL = 4 ----- T = 262.5
4126	C
4127	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4128	DATA (GA( 7, 9,IC),IC=1,3) /
4129	S 0.24208572E+02, 0.10419710E+02, 0.00000000E+00/
4130	DATA (GB( 7, 9,IC),IC=1,3) /
4131	S 0.24208572E+02, 0.10536510E+02, 0.10000000E+01/
4132	DATA (GA( 7,10,IC),IC=1,3) /
4133	S 0.23919098E+02, 0.10364052E+02, 0.00000000E+00/
4134	DATA (GB( 7,10,IC),IC=1,3) /
4135	S 0.23919098E+02, 0.10481842E+02, 0.10000000E+01/
4136	C
4137	C----- INTERVAL = 4 ----- T = 275.0
4138	C
4139	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4140	DATA (GA( 8, 9,IC),IC=1,3) /
4141	S 0.24132642E+02, 0.10405247E+02, 0.00000000E+00/
4142	DATA (GB( 8, 9,IC),IC=1,3) /
4143	S 0.24132642E+02, 0.10522307E+02, 0.10000000E+01/
4144	DATA (GA( 8,10,IC),IC=1,3) /
4145	S 0.23844511E+02, 0.10349509E+02, 0.00000000E+00/
4146	DATA (GB( 8,10,IC),IC=1,3) /
4147	S 0.23844511E+02, 0.10467553E+02, 0.10000000E+01/
4148	C
4149	C----- INTERVAL = 4 ----- T = 287.5
4150	C
4151	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4152	DATA (GA( 9, 9,IC),IC=1,3) /
4153	S 0.24063614E+02, 0.10392022E+02, 0.00000000E+00/
4154	DATA (GB( 9, 9,IC),IC=1,3) /
4155	S 0.24063614E+02, 0.10509317E+02, 0.10000000E+01/
4156	DATA (GA( 9,10,IC),IC=1,3) /
4157	S 0.23776708E+02, 0.10336215E+02, 0.00000000E+00/
4158	DATA (GB( 9,10,IC),IC=1,3) /
4159	S 0.23776708E+02, 0.10454488E+02, 0.10000000E+01/
4160	C
4161	C----- INTERVAL = 4 ----- T = 300.0
4162	C
4163	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4164	DATA (GA(10, 9,IC),IC=1,3) /
4165	S 0.24000649E+02, 0.10379892E+02, 0.00000000E+00/
4166	DATA (GB(10, 9,IC),IC=1,3) /
4167	S 0.24000649E+02, 0.10497402E+02, 0.10000000E+01/
4168	DATA (GA(10,10,IC),IC=1,3) /
4169	S 0.23714816E+02, 0.10324018E+02, 0.00000000E+00/
4170	DATA (GB(10,10,IC),IC=1,3) /
4171	S 0.23714816E+02, 0.10442501E+02, 0.10000000E+01/
4172	C
4173	C----- INTERVAL = 4 ----- T = 312.5
4174	C
4175	C-- INDICES FOR PADE APPROXIMATION 1 28 37 45
4176	DATA (GA(11, 9,IC),IC=1,3) /
4177	S 0.23943021E+02, 0.10368736E+02, 0.00000000E+00/
4178	DATA (GB(11, 9,IC),IC=1,3) /
4179	S 0.23943021E+02, 0.10486443E+02, 0.10000000E+01/
4180	DATA (GA(11,10,IC),IC=1,3) /
4181	S 0.23658197E+02, 0.10312808E+02, 0.00000000E+00/
4182	DATA (GB(11,10,IC),IC=1,3) /
4183	S 0.23658197E+02, 0.10431483E+02, 0.10000000E+01/
4184	C
4185	C
4186	C
4187	C-- H2O -- WEAKER PARTS OF THE STRONG BANDS -- FROM ABS225 ----
4188	C
4189	C-- WATER VAPOR --- 350 - 500 CM-1
4190	C
4191	C-- G = - 0.2*SLA, 0.0 +0.5/(1+0.5U)
4192	C
4193	C----- INTERVAL = 5 ----- T = 187.5
4194	C
4195	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4196	DATA (GA( 1, 5,IC),IC=1,3) /
4197	S 0.15750172E+00,-0.22159303E-01, 0.00000000E+00/
4198	DATA (GB( 1, 5,IC),IC=1,3) /
4199	S 0.15750172E+00, 0.38103212E+00, 0.10000000E+01/
4200	DATA (GA( 1, 6,IC),IC=1,3) /
4201	S 0.17770551E+00,-0.24972399E-01, 0.00000000E+00/
4202	DATA (GB( 1, 6,IC),IC=1,3) /
4203	S 0.17770551E+00, 0.41646579E+00, 0.10000000E+01/
4204	C
4205	C----- INTERVAL = 5 ----- T = 200.0
4206	C
4207	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4208	DATA (GA( 2, 5,IC),IC=1,3) /
4209	S 0.16174076E+00,-0.22748917E-01, 0.00000000E+00/
4210	DATA (GB( 2, 5,IC),IC=1,3) /
4211	S 0.16174076E+00, 0.38913800E+00, 0.10000000E+01/
4212	DATA (GA( 2, 6,IC),IC=1,3) /
4213	S 0.18176757E+00,-0.25537247E-01, 0.00000000E+00/
4214	DATA (GB( 2, 6,IC),IC=1,3) /
4215	S 0.18176757E+00, 0.42345095E+00, 0.10000000E+01/
4216	C
4217	C----- INTERVAL = 5 ----- T = 212.5
4218	C
4219	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4220	DATA (GA( 3, 5,IC),IC=1,3) /
4221	S 0.16548628E+00,-0.23269898E-01, 0.00000000E+00/
4222	DATA (GB( 3, 5,IC),IC=1,3) /
4223	S 0.16548628E+00, 0.39613651E+00, 0.10000000E+01/
4224	DATA (GA( 3, 6,IC),IC=1,3) /
4225	S 0.18527967E+00,-0.26025624E-01, 0.00000000E+00/
4226	DATA (GB( 3, 6,IC),IC=1,3) /
4227	S 0.18527967E+00, 0.42937476E+00, 0.10000000E+01/
4228	C
4229	C----- INTERVAL = 5 ----- T = 225.0
4230	C
4231	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4232	DATA (GA( 4, 5,IC),IC=1,3) /
4233	S 0.16881124E+00,-0.23732392E-01, 0.00000000E+00/
4234	DATA (GB( 4, 5,IC),IC=1,3) /
4235	S 0.16881124E+00, 0.40222421E+00, 0.10000000E+01/
4236	DATA (GA( 4, 6,IC),IC=1,3) /
4237	S 0.18833348E+00,-0.26450280E-01, 0.00000000E+00/
4238	DATA (GB( 4, 6,IC),IC=1,3) /
4239	S 0.18833348E+00, 0.43444062E+00, 0.10000000E+01/
4240	C
4241	C----- INTERVAL = 5 ----- T = 237.5
4242	C
4243	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4244	DATA (GA( 5, 5,IC),IC=1,3) /
4245	S 0.17177839E+00,-0.24145123E-01, 0.00000000E+00/
4246	DATA (GB( 5, 5,IC),IC=1,3) /
4247	S 0.17177839E+00, 0.40756010E+00, 0.10000000E+01/
4248	DATA (GA( 5, 6,IC),IC=1,3) /
4249	S 0.19100108E+00,-0.26821236E-01, 0.00000000E+00/
4250	DATA (GB( 5, 6,IC),IC=1,3) /
4251	S 0.19100108E+00, 0.43880316E+00, 0.10000000E+01/
4252	C
4253	C----- INTERVAL = 5 ----- T = 250.0
4254	C
4255	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4256	DATA (GA( 6, 5,IC),IC=1,3) /
4257	S 0.17443933E+00,-0.24515269E-01, 0.00000000E+00/
4258	DATA (GB( 6, 5,IC),IC=1,3) /
4259	S 0.17443933E+00, 0.41226954E+00, 0.10000000E+01/
4260	DATA (GA( 6, 6,IC),IC=1,3) /
4261	S 0.19334122E+00,-0.27146657E-01, 0.00000000E+00/
4262	DATA (GB( 6, 6,IC),IC=1,3) /
4263	S 0.19334122E+00, 0.44258354E+00, 0.10000000E+01/
4264	C
4265	C----- INTERVAL = 5 ----- T = 262.5
4266	C
4267	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4268	DATA (GA( 7, 5,IC),IC=1,3) /
4269	S 0.17683622E+00,-0.24848690E-01, 0.00000000E+00/
4270	DATA (GB( 7, 5,IC),IC=1,3) /
4271	S 0.17683622E+00, 0.41645142E+00, 0.10000000E+01/
4272	DATA (GA( 7, 6,IC),IC=1,3) /
4273	S 0.19540288E+00,-0.27433354E-01, 0.00000000E+00/
4274	DATA (GB( 7, 6,IC),IC=1,3) /
4275	S 0.19540288E+00, 0.44587882E+00, 0.10000000E+01/
4276	C
4277	C----- INTERVAL = 5 ----- T = 275.0
4278	C
4279	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4280	DATA (GA( 8, 5,IC),IC=1,3) /
4281	S 0.17900375E+00,-0.25150210E-01, 0.00000000E+00/
4282	DATA (GB( 8, 5,IC),IC=1,3) /
4283	S 0.17900375E+00, 0.42018474E+00, 0.10000000E+01/
4284	DATA (GA( 8, 6,IC),IC=1,3) /
4285	S 0.19722732E+00,-0.27687065E-01, 0.00000000E+00/
4286	DATA (GB( 8, 6,IC),IC=1,3) /
4287	S 0.19722732E+00, 0.44876776E+00, 0.10000000E+01/
4288	C
4289	C----- INTERVAL = 5 ----- T = 287.5
4290	C
4291	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4292	DATA (GA( 9, 5,IC),IC=1,3) /
4293	S 0.18097099E+00,-0.25423873E-01, 0.00000000E+00/
4294	DATA (GB( 9, 5,IC),IC=1,3) /
4295	S 0.18097099E+00, 0.42353379E+00, 0.10000000E+01/
4296	DATA (GA( 9, 6,IC),IC=1,3) /
4297	S 0.19884918E+00,-0.27912608E-01, 0.00000000E+00/
4298	DATA (GB( 9, 6,IC),IC=1,3) /
4299	S 0.19884918E+00, 0.45131451E+00, 0.10000000E+01/
4300	C
4301	C----- INTERVAL = 5 ----- T = 300.0
4302	C
4303	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4304	DATA (GA(10, 5,IC),IC=1,3) /
4305	S 0.18276283E+00,-0.25673139E-01, 0.00000000E+00/
4306	DATA (GB(10, 5,IC),IC=1,3) /
4307	S 0.18276283E+00, 0.42655211E+00, 0.10000000E+01/
4308	DATA (GA(10, 6,IC),IC=1,3) /
4309	S 0.20029696E+00,-0.28113944E-01, 0.00000000E+00/
4310	DATA (GB(10, 6,IC),IC=1,3) /
4311	S 0.20029696E+00, 0.45357095E+00, 0.10000000E+01/
4312	C
4313	C----- INTERVAL = 5 ----- T = 312.5
4314	C
4315	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4316	DATA (GA(11, 5,IC),IC=1,3) /
4317	S 0.18440117E+00,-0.25901055E-01, 0.00000000E+00/
4318	DATA (GB(11, 5,IC),IC=1,3) /
4319	S 0.18440117E+00, 0.42928533E+00, 0.10000000E+01/
4320	DATA (GA(11, 6,IC),IC=1,3) /
4321	S 0.20159300E+00,-0.28294180E-01, 0.00000000E+00/
4322	DATA (GB(11, 6,IC),IC=1,3) /
4323	S 0.20159300E+00, 0.45557797E+00, 0.10000000E+01/
4324	C
4325	C
4326	C
4327	C
4328	C- WATER VAPOR - WINGS OF VIBRATION-ROTATION BAND - 1250-1450+1880-2820 -
4329	C--- G = 0.0
4330	C
4331	C
4332	C----- INTERVAL = 6 ----- T = 187.5
4333	C
4334	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4335	DATA (GA( 1,11,IC),IC=1,3) /
4336	S 0.11990218E+02,-0.12823142E+01, 0.00000000E+00/
4337	DATA (GB( 1,11,IC),IC=1,3) /
4338	S 0.11990218E+02, 0.26681588E+02, 0.10000000E+01/
4339	DATA (GA( 1,12,IC),IC=1,3) /
4340	S 0.79709806E+01,-0.74805226E+00, 0.00000000E+00/
4341	DATA (GB( 1,12,IC),IC=1,3) /
4342	S 0.79709806E+01, 0.18377807E+02, 0.10000000E+01/
4343	C
4344	C----- INTERVAL = 6 ----- T = 200.0
4345	C
4346	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4347	DATA (GA( 2,11,IC),IC=1,3) /
4348	S 0.10904073E+02,-0.10571588E+01, 0.00000000E+00/
4349	DATA (GB( 2,11,IC),IC=1,3) /
4350	S 0.10904073E+02, 0.24728346E+02, 0.10000000E+01/
4351	DATA (GA( 2,12,IC),IC=1,3) /
4352	S 0.75400737E+01,-0.56252739E+00, 0.00000000E+00/
4353	DATA (GB( 2,12,IC),IC=1,3) /
4354	S 0.75400737E+01, 0.17643148E+02, 0.10000000E+01/
4355	C
4356	C----- INTERVAL = 6 ----- T = 212.5
4357	C
4358	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4359	DATA (GA( 3,11,IC),IC=1,3) /
4360	S 0.89126838E+01,-0.74864953E+00, 0.00000000E+00/
4361	DATA (GB( 3,11,IC),IC=1,3) /
4362	S 0.89126838E+01, 0.20551342E+02, 0.10000000E+01/
4363	DATA (GA( 3,12,IC),IC=1,3) /
4364	S 0.81804377E+01,-0.46188072E+00, 0.00000000E+00/
4365	DATA (GB( 3,12,IC),IC=1,3) /
4366	S 0.81804377E+01, 0.19296161E+02, 0.10000000E+01/
4367	C
4368	C----- INTERVAL = 6 ----- T = 225.0
4369	C
4370	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4371	DATA (GA( 4,11,IC),IC=1,3) /
4372	S 0.85622405E+01,-0.58705980E+00, 0.00000000E+00/
4373	DATA (GB( 4,11,IC),IC=1,3) /
4374	S 0.85622405E+01, 0.19955244E+02, 0.10000000E+01/
4375	DATA (GA( 4,12,IC),IC=1,3) /
4376	S 0.10564339E+02,-0.40712065E+00, 0.00000000E+00/
4377	DATA (GB( 4,12,IC),IC=1,3) /
4378	S 0.10564339E+02, 0.24951120E+02, 0.10000000E+01/
4379	C
4380	C----- INTERVAL = 6 ----- T = 237.5
4381	C
4382	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4383	DATA (GA( 5,11,IC),IC=1,3) /
4384	S 0.94892164E+01,-0.49305772E+00, 0.00000000E+00/
4385	DATA (GB( 5,11,IC),IC=1,3) /
4386	S 0.94892164E+01, 0.22227100E+02, 0.10000000E+01/
4387	DATA (GA( 5,12,IC),IC=1,3) /
4388	S 0.46896789E+02,-0.15295996E+01, 0.00000000E+00/
4389	DATA (GB( 5,12,IC),IC=1,3) /
4390	S 0.46896789E+02, 0.10957372E+03, 0.10000000E+01/
4391	C
4392	C----- INTERVAL = 6 ----- T = 250.0
4393	C
4394	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4395	DATA (GA( 6,11,IC),IC=1,3) /
4396	S 0.13580937E+02,-0.51461431E+00, 0.00000000E+00/
4397	DATA (GB( 6,11,IC),IC=1,3) /
4398	S 0.13580937E+02, 0.31770288E+02, 0.10000000E+01/
4399	DATA (GA( 6,12,IC),IC=1,3) /
4400	S-0.30926524E+01, 0.43555255E+00, 0.00000000E+00/
4401	DATA (GB( 6,12,IC),IC=1,3) /
4402	S-0.30926524E+01,-0.67432659E+01, 0.10000000E+01/
4403	C
4404	C----- INTERVAL = 6 ----- T = 262.5
4405	C
4406	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4407	DATA (GA( 7,11,IC),IC=1,3) /
4408	S-0.32050918E+03, 0.12373350E+02, 0.00000000E+00/
4409	DATA (GB( 7,11,IC),IC=1,3) /
4410	S-0.32050918E+03,-0.74061287E+03, 0.10000000E+01/
4411	DATA (GA( 7,12,IC),IC=1,3) /
4412	S 0.85742941E+00, 0.50380874E+00, 0.00000000E+00/
4413	DATA (GB( 7,12,IC),IC=1,3) /
4414	S 0.85742941E+00, 0.24550746E+01, 0.10000000E+01/
4415	C
4416	C----- INTERVAL = 6 ----- T = 275.0
4417	C
4418	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4419	DATA (GA( 8,11,IC),IC=1,3) /
4420	S-0.37133165E+01, 0.44809588E+00, 0.00000000E+00/
4421	DATA (GB( 8,11,IC),IC=1,3) /
4422	S-0.37133165E+01,-0.81329826E+01, 0.10000000E+01/
4423	DATA (GA( 8,12,IC),IC=1,3) /
4424	S 0.19164038E+01, 0.68537352E+00, 0.00000000E+00/
4425	DATA (GB( 8,12,IC),IC=1,3) /
4426	S 0.19164038E+01, 0.49089917E+01, 0.10000000E+01/
4427	C
4428	C----- INTERVAL = 6 ----- T = 287.5
4429	C
4430	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4431	DATA (GA( 9,11,IC),IC=1,3) /
4432	S 0.18890836E+00, 0.46548918E+00, 0.00000000E+00/
4433	DATA (GB( 9,11,IC),IC=1,3) /
4434	S 0.18890836E+00, 0.90279822E+00, 0.10000000E+01/
4435	DATA (GA( 9,12,IC),IC=1,3) /
4436	S 0.23513199E+01, 0.89437630E+00, 0.00000000E+00/
4437	DATA (GB( 9,12,IC),IC=1,3) /
4438	S 0.23513199E+01, 0.59008712E+01, 0.10000000E+01/
4439	C
4440	C----- INTERVAL = 6 ----- T = 300.0
4441	C
4442	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4443	DATA (GA(10,11,IC),IC=1,3) /
4444	S 0.14209226E+01, 0.59121475E+00, 0.00000000E+00/
4445	DATA (GB(10,11,IC),IC=1,3) /
4446	S 0.14209226E+01, 0.37532746E+01, 0.10000000E+01/
4447	DATA (GA(10,12,IC),IC=1,3) /
4448	S 0.25566644E+01, 0.11127003E+01, 0.00000000E+00/
4449	DATA (GB(10,12,IC),IC=1,3) /
4450	S 0.25566644E+01, 0.63532616E+01, 0.10000000E+01/
4451	C
4452	C----- INTERVAL = 6 ----- T = 312.5
4453	C
4454	C-- INDICES FOR PADE APPROXIMATION 1 35 40 45
4455	DATA (GA(11,11,IC),IC=1,3) /
4456	S 0.19817679E+01, 0.74676119E+00, 0.00000000E+00/
4457	DATA (GB(11,11,IC),IC=1,3) /
4458	S 0.19817679E+01, 0.50437916E+01, 0.10000000E+01/
4459	DATA (GA(11,12,IC),IC=1,3) /
4460	S 0.26555181E+01, 0.13329782E+01, 0.00000000E+00/
4461	DATA (GB(11,12,IC),IC=1,3) /
4462	S 0.26555181E+01, 0.65558627E+01, 0.10000000E+01/
4463	C
4464	C
4465	C
4466	C
4467	C
4468	C-- END WATER VAPOR
4469	C
4470	C
4471	C-- CO2 -- INT.2 -- 500-800 CM-1 --- FROM ABS225 ----------------------
4472	C
4473	C
4474	C
4475	C-- FIU = 0.8 + MAX(0.35,(7-IU)*0.9) , X/T, 9
4476	C
4477	C----- INTERVAL = 2 ----- T = 187.5
4478	C
4479	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4480	DATA (GA( 1,13,IC),IC=1,3) /
4481	S 0.87668459E-01, 0.13845511E+01, 0.00000000E+00/
4482	DATA (GB( 1,13,IC),IC=1,3) /
4483	S 0.87668459E-01, 0.23203798E+01, 0.10000000E+01/
4484	DATA (GA( 1,14,IC),IC=1,3) /
4485	S 0.74878820E-01, 0.11718758E+01, 0.00000000E+00/
4486	DATA (GB( 1,14,IC),IC=1,3) /
4487	S 0.74878820E-01, 0.20206726E+01, 0.10000000E+01/
4488	C
4489	C----- INTERVAL = 2 ----- T = 200.0
4490	C
4491	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4492	DATA (GA( 2,13,IC),IC=1,3) /
4493	S 0.83754276E-01, 0.13187042E+01, 0.00000000E+00/
4494	DATA (GB( 2,13,IC),IC=1,3) /
4495	S 0.83754276E-01, 0.22288925E+01, 0.10000000E+01/
4496	DATA (GA( 2,14,IC),IC=1,3) /
4497	S 0.71650966E-01, 0.11216131E+01, 0.00000000E+00/
4498	DATA (GB( 2,14,IC),IC=1,3) /
4499	S 0.71650966E-01, 0.19441824E+01, 0.10000000E+01/
4500	C
4501	C----- INTERVAL = 2 ----- T = 212.5
4502	C
4503	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4504	DATA (GA( 3,13,IC),IC=1,3) /
4505	S 0.80460283E-01, 0.12644396E+01, 0.00000000E+00/
4506	DATA (GB( 3,13,IC),IC=1,3) /
4507	S 0.80460283E-01, 0.21515593E+01, 0.10000000E+01/
4508	DATA (GA( 3,14,IC),IC=1,3) /
4509	S 0.68979615E-01, 0.10809473E+01, 0.00000000E+00/
4510	DATA (GB( 3,14,IC),IC=1,3) /
4511	S 0.68979615E-01, 0.18807257E+01, 0.10000000E+01/
4512	C
4513	C----- INTERVAL = 2 ----- T = 225.0
4514	C
4515	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4516	DATA (GA( 4,13,IC),IC=1,3) /
4517	S 0.77659686E-01, 0.12191543E+01, 0.00000000E+00/
4518	DATA (GB( 4,13,IC),IC=1,3) /
4519	S 0.77659686E-01, 0.20855896E+01, 0.10000000E+01/
4520	DATA (GA( 4,14,IC),IC=1,3) /
4521	S 0.66745345E-01, 0.10476396E+01, 0.00000000E+00/
4522	DATA (GB( 4,14,IC),IC=1,3) /
4523	S 0.66745345E-01, 0.18275618E+01, 0.10000000E+01/
4524	C
4525	C----- INTERVAL = 2 ----- T = 237.5
4526	C
4527	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4528	DATA (GA( 5,13,IC),IC=1,3) /
4529	S 0.75257056E-01, 0.11809511E+01, 0.00000000E+00/
4530	DATA (GB( 5,13,IC),IC=1,3) /
4531	S 0.75257056E-01, 0.20288489E+01, 0.10000000E+01/
4532	DATA (GA( 5,14,IC),IC=1,3) /
4533	S 0.64857571E-01, 0.10200373E+01, 0.00000000E+00/
4534	DATA (GB( 5,14,IC),IC=1,3) /
4535	S 0.64857571E-01, 0.17825910E+01, 0.10000000E+01/
4536	C
4537	C----- INTERVAL = 2 ----- T = 250.0
4538	C
4539	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4540	DATA (GA( 6,13,IC),IC=1,3) /
4541	S 0.73179175E-01, 0.11484154E+01, 0.00000000E+00/
4542	DATA (GB( 6,13,IC),IC=1,3) /
4543	S 0.73179175E-01, 0.19796791E+01, 0.10000000E+01/
4544	DATA (GA( 6,14,IC),IC=1,3) /
4545	S 0.63248495E-01, 0.99692726E+00, 0.00000000E+00/
4546	DATA (GB( 6,14,IC),IC=1,3) /
4547	S 0.63248495E-01, 0.17442308E+01, 0.10000000E+01/
4548	C
4549	C----- INTERVAL = 2 ----- T = 262.5
4550	C
4551	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4552	DATA (GA( 7,13,IC),IC=1,3) /
4553	S 0.71369063E-01, 0.11204723E+01, 0.00000000E+00/
4554	DATA (GB( 7,13,IC),IC=1,3) /
4555	S 0.71369063E-01, 0.19367778E+01, 0.10000000E+01/
4556	DATA (GA( 7,14,IC),IC=1,3) /
4557	S 0.61866970E-01, 0.97740923E+00, 0.00000000E+00/
4558	DATA (GB( 7,14,IC),IC=1,3) /
4559	S 0.61866970E-01, 0.17112809E+01, 0.10000000E+01/
4560	C
4561	C----- INTERVAL = 2 ----- T = 275.0
4562	C
4563	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4564	DATA (GA( 8,13,IC),IC=1,3) /
4565	S 0.69781812E-01, 0.10962918E+01, 0.00000000E+00/
4566	DATA (GB( 8,13,IC),IC=1,3) /
4567	S 0.69781812E-01, 0.18991112E+01, 0.10000000E+01/
4568	DATA (GA( 8,14,IC),IC=1,3) /
4569	S 0.60673632E-01, 0.96080188E+00, 0.00000000E+00/
4570	DATA (GB( 8,14,IC),IC=1,3) /
4571	S 0.60673632E-01, 0.16828137E+01, 0.10000000E+01/
4572	C
4573	C----- INTERVAL = 2 ----- T = 287.5
4574	C
4575	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4576	DATA (GA( 9,13,IC),IC=1,3) /
4577	S 0.68381606E-01, 0.10752229E+01, 0.00000000E+00/
4578	DATA (GB( 9,13,IC),IC=1,3) /
4579	S 0.68381606E-01, 0.18658501E+01, 0.10000000E+01/
4580	DATA (GA( 9,14,IC),IC=1,3) /
4581	S 0.59637277E-01, 0.94657562E+00, 0.00000000E+00/
4582	DATA (GB( 9,14,IC),IC=1,3) /
4583	S 0.59637277E-01, 0.16580908E+01, 0.10000000E+01/
4584	C
4585	C----- INTERVAL = 2 ----- T = 300.0
4586	C
4587	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4588	DATA (GA(10,13,IC),IC=1,3) /
4589	S 0.67139539E-01, 0.10567474E+01, 0.00000000E+00/
4590	DATA (GB(10,13,IC),IC=1,3) /
4591	S 0.67139539E-01, 0.18363226E+01, 0.10000000E+01/
4592	DATA (GA(10,14,IC),IC=1,3) /
4593	S 0.58732178E-01, 0.93430511E+00, 0.00000000E+00/
4594	DATA (GB(10,14,IC),IC=1,3) /
4595	S 0.58732178E-01, 0.16365014E+01, 0.10000000E+01/
4596	C
4597	C----- INTERVAL = 2 ----- T = 312.5
4598	C
4599	C-- INDICES FOR PADE APPROXIMATION 1 30 38 45
4600	DATA (GA(11,13,IC),IC=1,3) /
4601	S 0.66032012E-01, 0.10404465E+01, 0.00000000E+00/
4602	DATA (GB(11,13,IC),IC=1,3) /
4603	S 0.66032012E-01, 0.18099779E+01, 0.10000000E+01/
4604	DATA (GA(11,14,IC),IC=1,3) /
4605	S 0.57936092E-01, 0.92363528E+00, 0.00000000E+00/
4606	DATA (GB(11,14,IC),IC=1,3) /
4607	S 0.57936092E-01, 0.16175164E+01, 0.10000000E+01/
4608	C
4609	C
4610	C
4611	C
4612	C
4613	C
4614	C
4615	C
4616	C
4617	C
4618	C-- CARBON DIOXIDE LINES IN THE WINDOW REGION (800-1250 CM-1)
4619	C
4620	C
4621	C-- G = 0.0
4622	C
4623	C
4624	C----- INTERVAL = 4 ----- T = 187.5
4625	C
4626	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4627	DATA (GA( 1,15,IC),IC=1,3) /
4628	S 0.13230067E+02, 0.22042132E+02, 0.00000000E+00/
4629	DATA (GB( 1,15,IC),IC=1,3) /
4630	S 0.13230067E+02, 0.22051750E+02, 0.10000000E+01/
4631	DATA (GA( 1,16,IC),IC=1,3) /
4632	S 0.13183816E+02, 0.22169501E+02, 0.00000000E+00/
4633	DATA (GB( 1,16,IC),IC=1,3) /
4634	S 0.13183816E+02, 0.22178972E+02, 0.10000000E+01/
4635	C
4636	C----- INTERVAL = 4 ----- T = 200.0
4637	C
4638	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4639	DATA (GA( 2,15,IC),IC=1,3) /
4640	S 0.13213564E+02, 0.22107298E+02, 0.00000000E+00/
4641	DATA (GB( 2,15,IC),IC=1,3) /
4642	S 0.13213564E+02, 0.22116850E+02, 0.10000000E+01/
4643	DATA (GA( 2,16,IC),IC=1,3) /
4644	S 0.13189991E+02, 0.22270075E+02, 0.00000000E+00/
4645	DATA (GB( 2,16,IC),IC=1,3) /
4646	S 0.13189991E+02, 0.22279484E+02, 0.10000000E+01/
4647	C
4648	C----- INTERVAL = 4 ----- T = 212.5
4649	C
4650	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4651	DATA (GA( 3,15,IC),IC=1,3) /
4652	S 0.13209140E+02, 0.22180915E+02, 0.00000000E+00/
4653	DATA (GB( 3,15,IC),IC=1,3) /
4654	S 0.13209140E+02, 0.22190410E+02, 0.10000000E+01/
4655	DATA (GA( 3,16,IC),IC=1,3) /
4656	S 0.13209485E+02, 0.22379193E+02, 0.00000000E+00/
4657	DATA (GB( 3,16,IC),IC=1,3) /
4658	S 0.13209485E+02, 0.22388551E+02, 0.10000000E+01/
4659	C
4660	C----- INTERVAL = 4 ----- T = 225.0
4661	C
4662	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4663	DATA (GA( 4,15,IC),IC=1,3) /
4664	S 0.13213894E+02, 0.22259478E+02, 0.00000000E+00/
4665	DATA (GB( 4,15,IC),IC=1,3) /
4666	S 0.13213894E+02, 0.22268925E+02, 0.10000000E+01/
4667	DATA (GA( 4,16,IC),IC=1,3) /
4668	S 0.13238789E+02, 0.22492992E+02, 0.00000000E+00/
4669	DATA (GB( 4,16,IC),IC=1,3) /
4670	S 0.13238789E+02, 0.22502309E+02, 0.10000000E+01/
4671	C
4672	C----- INTERVAL = 4 ----- T = 237.5
4673	C
4674	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4675	DATA (GA( 5,15,IC),IC=1,3) /
4676	S 0.13225963E+02, 0.22341039E+02, 0.00000000E+00/
4677	DATA (GB( 5,15,IC),IC=1,3) /
4678	S 0.13225963E+02, 0.22350445E+02, 0.10000000E+01/
4679	DATA (GA( 5,16,IC),IC=1,3) /
4680	S 0.13275017E+02, 0.22608508E+02, 0.00000000E+00/
4681	DATA (GB( 5,16,IC),IC=1,3) /
4682	S 0.13275017E+02, 0.22617792E+02, 0.10000000E+01/
4683	C
4684	C----- INTERVAL = 4 ----- T = 250.0
4685	C
4686	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4687	DATA (GA( 6,15,IC),IC=1,3) /
4688	S 0.13243806E+02, 0.22424247E+02, 0.00000000E+00/
4689	DATA (GB( 6,15,IC),IC=1,3) /
4690	S 0.13243806E+02, 0.22433617E+02, 0.10000000E+01/
4691	DATA (GA( 6,16,IC),IC=1,3) /
4692	S 0.13316096E+02, 0.22723843E+02, 0.00000000E+00/
4693	DATA (GB( 6,16,IC),IC=1,3) /
4694	S 0.13316096E+02, 0.22733099E+02, 0.10000000E+01/
4695	C
4696	C----- INTERVAL = 4 ----- T = 262.5
4697	C
4698	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4699	DATA (GA( 7,15,IC),IC=1,3) /
4700	S 0.13266104E+02, 0.22508089E+02, 0.00000000E+00/
4701	DATA (GB( 7,15,IC),IC=1,3) /
4702	S 0.13266104E+02, 0.22517429E+02, 0.10000000E+01/
4703	DATA (GA( 7,16,IC),IC=1,3) /
4704	S 0.13360555E+02, 0.22837837E+02, 0.00000000E+00/
4705	DATA (GB( 7,16,IC),IC=1,3) /
4706	S 0.13360555E+02, 0.22847071E+02, 0.10000000E+01/
4707	C
4708	C----- INTERVAL = 4 ----- T = 275.0
4709	C
4710	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4711	DATA (GA( 8,15,IC),IC=1,3) /
4712	S 0.13291782E+02, 0.22591771E+02, 0.00000000E+00/
4713	DATA (GB( 8,15,IC),IC=1,3) /
4714	S 0.13291782E+02, 0.22601086E+02, 0.10000000E+01/
4715	DATA (GA( 8,16,IC),IC=1,3) /
4716	S 0.13407324E+02, 0.22949751E+02, 0.00000000E+00/
4717	DATA (GB( 8,16,IC),IC=1,3) /
4718	S 0.13407324E+02, 0.22958967E+02, 0.10000000E+01/
4719	C
4720	C----- INTERVAL = 4 ----- T = 287.5
4721	C
4722	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4723	DATA (GA( 9,15,IC),IC=1,3) /
4724	S 0.13319961E+02, 0.22674661E+02, 0.00000000E+00/
4725	DATA (GB( 9,15,IC),IC=1,3) /
4726	S 0.13319961E+02, 0.22683956E+02, 0.10000000E+01/
4727	DATA (GA( 9,16,IC),IC=1,3) /
4728	S 0.13455544E+02, 0.23059032E+02, 0.00000000E+00/
4729	DATA (GB( 9,16,IC),IC=1,3) /
4730	S 0.13455544E+02, 0.23068234E+02, 0.10000000E+01/
4731	C
4732	C----- INTERVAL = 4 ----- T = 300.0
4733	C
4734	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4735	DATA (GA(10,15,IC),IC=1,3) /
4736	S 0.13349927E+02, 0.22756246E+02, 0.00000000E+00/
4737	DATA (GB(10,15,IC),IC=1,3) /
4738	S 0.13349927E+02, 0.22765522E+02, 0.10000000E+01/
4739	DATA (GA(10,16,IC),IC=1,3) /
4740	S 0.13504450E+02, 0.23165146E+02, 0.00000000E+00/
4741	DATA (GB(10,16,IC),IC=1,3) /
4742	S 0.13504450E+02, 0.23174336E+02, 0.10000000E+01/
4743	C
4744	C----- INTERVAL = 4 ----- T = 312.5
4745	C
4746	C-- INDICES FOR PADE APPROXIMATION 1 15 29 45
4747	DATA (GA(11,15,IC),IC=1,3) /
4748	S 0.13381108E+02, 0.22836093E+02, 0.00000000E+00/
4749	DATA (GB(11,15,IC),IC=1,3) /
4750	S 0.13381108E+02, 0.22845354E+02, 0.10000000E+01/
4751	DATA (GA(11,16,IC),IC=1,3) /
4752	S 0.13553282E+02, 0.23267456E+02, 0.00000000E+00/
4753	DATA (GB(11,16,IC),IC=1,3) /
4754	S 0.13553282E+02, 0.23276638E+02, 0.10000000E+01/
4755
4756	C ------------------------------------------------------------------
4757	DATA (( XP( J,K),J=1,6), K=1,6) /
4758	S 0.46430621E+02, 0.12928299E+03, 0.20732648E+03,
4759	S 0.31398411E+03, 0.18373177E+03,-0.11412303E+03,
4760	S 0.73604774E+02, 0.27887914E+03, 0.27076947E+03,
4761	S-0.57322111E+02,-0.64742459E+02, 0.87238280E+02,
4762	S 0.37050866E+02, 0.20498759E+03, 0.37558029E+03,
4763	S 0.17401171E+03,-0.13350302E+03,-0.37651795E+02,
4764	S 0.14930141E+02, 0.89161160E+02, 0.17793062E+03,
4765	S 0.93433860E+02,-0.70646020E+02,-0.26373150E+02,
4766	S 0.40386780E+02, 0.10855270E+03, 0.50755010E+02,
4767	S-0.31496190E+02, 0.12791300E+00, 0.18017770E+01,
4768	S 0.90811926E+01, 0.75073923E+02, 0.24654438E+03,
4769	S 0.39332612E+03, 0.29385281E+03, 0.89107921E+02 /
4770	C
4771	C
4772	C* 1.0 PLANCK FUNCTIONS AND GRADIENTS
4773	C ------------------------------
4774	C
4775	100 CONTINUE
4776	C
4777	DO 102 JK = 1 , KFLEV+1
4778	DO 101 JL = 1, KDLON
4779	PBINT(JL,JK) = 0.
4780	101 CONTINUE
4781	102 CONTINUE
4782	DO 103 JL = 1, KDLON
4783	PBSUIN(JL) = 0.
4784	103 CONTINUE
4785	C
4786	DO 141 JNU=1,Ninter
4787	C
4788	C
4789	C* 1.1 LEVELS FROM SURFACE TO KFLEV
4790	C ----------------------------
4791	C
4792	110 CONTINUE
4793	C
4794	DO 112 JK = 1 , KFLEV
4795	DO 111 JL = 1, KDLON
4796	ZTI(JL)=(PTL(JL,JK)-TSTAND)/TSTAND
4797	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
4798	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
4799	S )))))
4800	PBINT(JL,JK)=PBINT(JL,JK)+ZRES(JL)
4801	PB(JL,JNU,JK)= ZRES(JL)
4802	ZBLEV(JL,JK) = ZRES(JL)
4803	ZTI2(JL)=(PTAVE(JL,JK)-TSTAND)/TSTAND
4804	ZRES2(JL)=XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
4805	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
4806	S )))))
4807	ZBLAY(JL,JK) = ZRES2(JL)
4808	111 CONTINUE
4809	112 CONTINUE
4810	C
4811	C
4812	C* 1.2 TOP OF THE ATMOSPHERE AND SURFACE
4813	C ---------------------------------
4814	C
4815	120 CONTINUE
4816	C
4817	DO 121 JL = 1, KDLON
4818	ZTI(JL)=(PTL(JL,KFLEV+1)-TSTAND)/TSTAND
4819	ZTI2(JL) = (PTL(JL,1) + PDT0(JL) - TSTAND) / TSTAND
4820	ZRES(JL) = XP(1,JNU)+ZTI(JL)(XP(2,JNU)+ZTI(JL)(XP(3,JNU)
4821	S +ZTI(JL)(XP(4,JNU)+ZTI(JL)(XP(5,JNU)+ZTI(JL)*(XP(6,JNU)
4822	S )))))
4823	ZRES2(JL) = XP(1,JNU)+ZTI2(JL)(XP(2,JNU)+ZTI2(JL)(XP(3,JNU)
4824	S +ZTI2(JL)(XP(4,JNU)+ZTI2(JL)(XP(5,JNU)+ZTI2(JL)*(XP(6,JNU)
4825	S )))))
4826	PBINT(JL,KFLEV+1) = PBINT(JL,KFLEV+1)+ZRES(JL)
4827	PB(JL,JNU,KFLEV+1)= ZRES(JL)
4828	ZBLEV(JL,KFLEV+1) = ZRES(JL)
4829	PBTOP(JL,JNU) = ZRES(JL)
4830	PBSUR(JL,JNU) = ZRES2(JL)
4831	PBSUIN(JL) = PBSUIN(JL) + ZRES2(JL)
4832	121 CONTINUE
4833	C
4834	C
4835	C* 1.3 GRADIENTS IN SUB-LAYERS
4836	C -----------------------
4837	C
4838	130 CONTINUE
4839	C
4840	DO 132 JK = 1 , KFLEV
4841	JK2 = 2 * JK
4842	JK1 = JK2 - 1
4843	DO 131 JL = 1, KDLON
4844	PDBSL(JL,JNU,JK1) = ZBLAY(JL,JK ) - ZBLEV(JL,JK)
4845	PDBSL(JL,JNU,JK2) = ZBLEV(JL,JK+1) - ZBLAY(JL,JK)
4846	131 CONTINUE
4847	132 CONTINUE
4848	C
4849	141 CONTINUE
4850	C
4851	C* 2.0 CHOOSE THE RELEVANT SETS OF PADE APPROXIMANTS
4852	C ---------------------------------------------
4853	C
4854	200 CONTINUE
4855	C
4856	C
4857	210 CONTINUE
4858	C
4859	DO 211 JL=1, KDLON
4860	ZDSTO1 = (PTL(JL,KFLEV+1)-TINTP(1)) / TSTP
4861	IXTOX = MAX( 1, MIN( MXIXT, INT( ZDSTO1 + 1. ) ) )
4862	ZDSTOX = (PTL(JL,KFLEV+1)-TINTP(IXTOX))/TSTP
4863	IF (ZDSTOX.LT.0.5) THEN
4864	INDTO=IXTOX
4865	ELSE
4866	INDTO=IXTOX+1
4867	END IF
4868	INDB(JL)=INDTO
4869	ZDST1 = (PTL(JL,1)-TINTP(1)) / TSTP
4870	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
4871	ZDSTX = (PTL(JL,1)-TINTP(IXTX))/TSTP
4872	IF (ZDSTX.LT.0.5) THEN
4873	INDT=IXTX
4874	ELSE
4875	INDT=IXTX+1
4876	END IF
4877	INDS(JL)=INDT
4878	211 CONTINUE
4879	C
4880	DO 214 JF=1,2
4881	DO 213 JG=1, 8
4882	DO 212 JL=1, KDLON
4883	INDSU=INDS(JL)
4884	PGASUR(JL,JG,JF)=GA(INDSU,2*JG-1,JF)
4885	PGBSUR(JL,JG,JF)=GB(INDSU,2*JG-1,JF)
4886	INDTP=INDB(JL)
4887	PGATOP(JL,JG,JF)=GA(INDTP,2*JG-1,JF)
4888	PGBTOP(JL,JG,JF)=GB(INDTP,2*JG-1,JF)
4889	212 CONTINUE
4890	213 CONTINUE
4891	214 CONTINUE
4892	C
4893	220 CONTINUE
4894	C
4895	DO 225 JK=1,KFLEV
4896	DO 221 JL=1, KDLON
4897	ZDST1 = (PTAVE(JL,JK)-TINTP(1)) / TSTP
4898	IXTX = MAX( 1, MIN( MXIXT, INT( ZDST1 + 1. ) ) )
4899	ZDSTX = (PTAVE(JL,JK)-TINTP(IXTX))/TSTP
4900	IF (ZDSTX.LT.0.5) THEN
4901	INDT=IXTX
4902	ELSE
4903	INDT=IXTX+1
4904	END IF
4905	INDB(JL)=INDT
4906	221 CONTINUE
4907	C
4908	DO 224 JF=1,2
4909	DO 223 JG=1, 8
4910	DO 222 JL=1, KDLON
4911	INDT=INDB(JL)
4912	PGA(JL,JG,JF,JK)=GA(INDT,2*JG,JF)
4913	PGB(JL,JG,JF,JK)=GB(INDT,2*JG,JF)
4914	222 CONTINUE
4915	223 CONTINUE
4916	224 CONTINUE
4917	225 CONTINUE
4918	C
4919	C ------------------------------------------------------------------
4920	C
4921	RETURN
4922	END
4923	SUBROUTINE LWV_LMDAR4(KUAER,KTRAER, KLIM
4924	R , PABCU,PB,PBINT,PBSUIN,PBSUR,PBTOP,PDBSL,PEMIS,PPMB,PTAVE
4925	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
4926	S , PCNTRB,PCTS,PFLUC)
4927	USE dimphy
4928	IMPLICIT none
4929	cym#include "dimensions.h"
4930	cym#include "dimphy.h"
4931	cym#include "raddim.h"
4932	#include "raddimlw.h"
4933	#include "YOMCST.h"
4934	C
4935	C-----------------------------------------------------------------------
4936	C PURPOSE.
4937	C --------
4938	C CARRIES OUT THE VERTICAL INTEGRATION TO GIVE LONGWAVE
4939	C FLUXES OR RADIANCES
4940	C
4941	C METHOD.
4942	C -------
4943	C
4944	C 1. PERFORMS THE VERTICAL INTEGRATION DISTINGUISHING BETWEEN
4945	C CONTRIBUTIONS BY - THE NEARBY LAYERS
4946	C - THE DISTANT LAYERS
4947	C - THE BOUNDARY TERMS
4948	C 2. COMPUTES THE CLEAR-SKY DOWNWARD AND UPWARD EMISSIVITIES.
4949	C
4950	C REFERENCE.
4951	C ----------
4952	C
4953	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
4954	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
4955	C
4956	C AUTHOR.
4957	C -------
4958	C JEAN-JACQUES MORCRETTE ECMWF
4959	C
4960	C MODIFICATIONS.
4961	C --------------
4962	C ORIGINAL : 89-07-14
4963	C-----------------------------------------------------------------------
4964	C
4965	C* ARGUMENTS:
4966	INTEGER KUAER,KTRAER, KLIM
4967	C
4968	REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! EFFECTIVE ABSORBER AMOUNTS
4969	REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
4970	REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
4971	REAL(KIND=8) PBSUR(KDLON,Ninter) ! SURFACE SPECTRAL PLANCK FUNCTION
4972	REAL(KIND=8) PBSUIN(KDLON) ! SURFACE PLANCK FUNCTION
4973	REAL(KIND=8) PBTOP(KDLON,Ninter) ! T.O.A. SPECTRAL PLANCK FUNCTION
4974	REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
4975	REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
4976	REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! HALF-LEVEL PRESSURE (MB)
4977	REAL(KIND=8) PTAVE(KDLON,KFLEV) ! TEMPERATURE
4978	REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
4979	REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
4980	REAL(KIND=8) PGASUR(KDLON,8,2) ! PADE APPROXIMANTS
4981	REAL(KIND=8) PGBSUR(KDLON,8,2) ! PADE APPROXIMANTS
4982	REAL(KIND=8) PGATOP(KDLON,8,2) ! PADE APPROXIMANTS
4983	REAL(KIND=8) PGBTOP(KDLON,8,2) ! PADE APPROXIMANTS
4984	C
4985	REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
4986	REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
4987	REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
4988	C-----------------------------------------------------------------------
4989	C LOCAL VARIABLES:
4990	REAL(KIND=8) ZADJD(KDLON,KFLEV+1)
4991	REAL(KIND=8) ZADJU(KDLON,KFLEV+1)
4992	REAL(KIND=8) ZDBDT(KDLON,Ninter,KFLEV)
4993	REAL(KIND=8) ZDISD(KDLON,KFLEV+1)
4994	REAL(KIND=8) ZDISU(KDLON,KFLEV+1)
4995	C
4996	INTEGER jk, jl
4997	C-----------------------------------------------------------------------
4998	C
4999	DO 112 JK=1,KFLEV+1
5000	DO 111 JL=1, KDLON
5001	ZADJD(JL,JK)=0.
5002	ZADJU(JL,JK)=0.
5003	ZDISD(JL,JK)=0.
5004	ZDISU(JL,JK)=0.
5005	111 CONTINUE
5006	112 CONTINUE
5007	C
5008	DO 114 JK=1,KFLEV
5009	DO 113 JL=1, KDLON
5010	PCTS(JL,JK)=0.
5011	113 CONTINUE
5012	114 CONTINUE
5013	C
5014	C* CONTRIBUTION FROM ADJACENT LAYERS
5015	C
5016	CALL LWVN_LMDAR4(KUAER,KTRAER
5017	R , PABCU,PDBSL,PGA,PGB
5018	S , ZADJD,ZADJU,PCNTRB,ZDBDT)
5019	C* CONTRIBUTION FROM DISTANT LAYERS
5020	C
5021	CALL LWVD_LMDAR4(KUAER,KTRAER
5022	R , PABCU,ZDBDT,PGA,PGB
5023	S , PCNTRB,ZDISD,ZDISU)
5024	C
5025	C* EXCHANGE WITH THE BOUNDARIES
5026	C
5027	CALL LWVB_LMDAR4(KUAER,KTRAER, KLIM
5028	R , PABCU,ZADJD,ZADJU,PB,PBINT,PBSUIN,PBSUR,PBTOP
5029	R , ZDISD,ZDISU,PEMIS,PPMB
5030	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5031	S , PCTS,PFLUC)
5032	C
5033	C
5034	RETURN
5035	END
5036	SUBROUTINE LWVB_LMDAR4(KUAER,KTRAER, KLIM
5037	R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
5038	R , PDISD,PDISU,PEMIS,PPMB
5039	R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5040	S , PCTS,PFLUC)
5041	USE dimphy
5042	IMPLICIT none
5043	cym#include "dimensions.h"
5044	cym#include "dimphy.h"
5045	cym#include "raddim.h"
5046	#include "raddimlw.h"
5047	#include "radopt.h"
5048	C
5049	C-----------------------------------------------------------------------
5050	C PURPOSE.
5051	C --------
5052	C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
5053	C INTEGRATION
5054	C
5055	C METHOD.
5056	C -------
5057	C
5058	C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
5059	C ATMOSPHERE
5060	C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
5061	C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
5062	C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
5063	C
5064	C REFERENCE.
5065	C ----------
5066	C
5067	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5068	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5069	C
5070	C AUTHOR.
5071	C -------
5072	C JEAN-JACQUES MORCRETTE ECMWF
5073	C
5074	C MODIFICATIONS.
5075	C --------------
5076	C ORIGINAL : 89-07-14
5077	C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
5078	C-----------------------------------------------------------------------
5079	C
5080	C* 0.1 ARGUMENTS
5081	C ---------
5082	C
5083	INTEGER KUAER,KTRAER, KLIM
5084	C
5085	REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
5086	REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5087	REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
5088	REAL(KIND=8) PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
5089	REAL(KIND=8) PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
5090	REAL(KIND=8) PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
5091	REAL(KIND=8) PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
5092	REAL(KIND=8) PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
5093	REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5094	REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5095	REAL(KIND=8) PEMIS(KDLON) ! SURFACE EMISSIVITY
5096	REAL(KIND=8) PPMB(KDLON,KFLEV+1) ! PRESSURE MB
5097	REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5098	REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5099	REAL(KIND=8) PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5100	REAL(KIND=8) PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
5101	REAL(KIND=8) PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5102	REAL(KIND=8) PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
5103	C
5104	REAL(KIND=8) PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
5105	REAL(KIND=8) PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
5106	C
5107	C* LOCAL VARIABLES:
5108	C
5109	REAL(KIND=8) ZBGND(KDLON)
5110	REAL(KIND=8) ZFD(KDLON)
5111	REAL(KIND=8) ZFN10(KDLON)
5112	REAL(KIND=8) ZFU(KDLON)
5113	REAL(KIND=8) ZTT(KDLON,NTRA)
5114	REAL(KIND=8) ZTT1(KDLON,NTRA)
5115	REAL(KIND=8) ZTT2(KDLON,NTRA)
5116	REAL(KIND=8) ZUU(KDLON,NUA)
5117	REAL(KIND=8) ZCNSOL(KDLON)
5118	REAL(KIND=8) ZCNTOP(KDLON)
5119	C
5120	INTEGER jk, jl, ja
5121	INTEGER jstra, jstru
5122	INTEGER ind1, ind2, ind3, ind4, in, jlim
5123	REAL(KIND=8) zctstr
5124	C-----------------------------------------------------------------------
5125	C
5126	C* 1. INITIALIZATION
5127	C --------------
5128	C
5129	100 CONTINUE
5130	C
5131	C
5132	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5133	C ---------------------------------
5134	C
5135	120 CONTINUE
5136	C
5137	DO 122 JA=1,NTRA
5138	DO 121 JL=1, KDLON
5139	ZTT (JL,JA)=1.0
5140	ZTT1(JL,JA)=1.0
5141	ZTT2(JL,JA)=1.0
5142	121 CONTINUE
5143	122 CONTINUE
5144	C
5145	DO 124 JA=1,NUA
5146	DO 123 JL=1, KDLON
5147	ZUU(JL,JA)=1.0
5148	123 CONTINUE
5149	124 CONTINUE
5150	C
5151	C ------------------------------------------------------------------
5152	C
5153	C* 2. VERTICAL INTEGRATION
5154	C --------------------
5155	C
5156	200 CONTINUE
5157	C
5158	IND1=0
5159	IND3=0
5160	IND4=1
5161	IND2=1
5162	C
5163	C
5164	C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
5165	C -----------------------------------
5166	C
5167	230 CONTINUE
5168	C
5169	DO 235 JK = 1 , KFLEV
5170	IN=(JK-1)*NG1P1+1
5171	C
5172	DO 232 JA=1,KUAER
5173	DO 231 JL=1, KDLON
5174	ZUU(JL,JA)=PABCU(JL,JA,IN)
5175	231 CONTINUE
5176	232 CONTINUE
5177	C
5178	C
5179	CALL LWTT_LMDAR4(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
5180	C
5181	DO 234 JL = 1, KDLON
5182	ZCNTOP(JL)=PBTOP(JL,1)ZTT(JL,1) ZTT(JL,10)
5183	2 +PBTOP(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5184	3 +PBTOP(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5185	4 +PBTOP(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5186	5 +PBTOP(JL,5)ZTT(JL,3) ZTT(JL,14)
5187	6 +PBTOP(JL,6)ZTT(JL,6) ZTT(JL,15)
5188	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5189	PFLUC(JL,2,JK)=ZFD(JL)
5190	234 CONTINUE
5191	C
5192	235 CONTINUE
5193	C
5194	JK = KFLEV+1
5195	IN=(JK-1)*NG1P1+1
5196	C
5197	DO 236 JL = 1, KDLON
5198	ZCNTOP(JL)= PBTOP(JL,1)
5199	1 + PBTOP(JL,2)
5200	2 + PBTOP(JL,3)
5201	3 + PBTOP(JL,4)
5202	4 + PBTOP(JL,5)
5203	5 + PBTOP(JL,6)
5204	ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
5205	PFLUC(JL,2,JK)=ZFD(JL)
5206	236 CONTINUE
5207	C
5208	C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
5209	C ---------------------------------------
5210	C
5211	240 CONTINUE
5212	C
5213	C
5214	C* 2.4.1 INITIALIZATION
5215	C --------------
5216	C
5217	2410 CONTINUE
5218	C
5219	JLIM = KFLEV
5220	C
5221	IF (.NOT.LEVOIGT) THEN
5222	DO 2412 JK = KFLEV,1,-1
5223	IF(PPMB(1,JK).LT.10.0) THEN
5224	JLIM=JK
5225	ENDIF
5226	2412 CONTINUE
5227	ENDIF
5228	KLIM=JLIM
5229	C
5230	IF (.NOT.LEVOIGT) THEN
5231	DO 2414 JA=1,KTRAER
5232	DO 2413 JL=1, KDLON
5233	ZTT1(JL,JA)=1.0
5234	2413 CONTINUE
5235	2414 CONTINUE
5236	C
5237	C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
5238	C -----------------------------
5239	C
5240	2420 CONTINUE
5241	C
5242	DO 2427 JSTRA = KFLEV,JLIM,-1
5243	JSTRU=(JSTRA-1)*NG1P1+1
5244	C
5245	DO 2423 JA=1,KUAER
5246	DO 2422 JL=1, KDLON
5247	ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
5248	2422 CONTINUE
5249	2423 CONTINUE
5250	C
5251	C
5252	CALL LWTT_LMDAR4(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
5253	C
5254	DO 2424 JL = 1, KDLON
5255	ZCTSTR =
5256	1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
5257	1 (ZTT1(JL,1) ZTT1(JL,10)
5258	1 - ZTT (JL,1) *ZTT (JL,10))
5259	2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
5260	2 (ZTT1(JL,2)ZTT1(JL,7)*ZTT1(JL,11)
5261	2 - ZTT (JL,2)ZTT (JL,7)ZTT (JL,11))
5262	3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
5263	3 (ZTT1(JL,4)ZTT1(JL,8)*ZTT1(JL,12)
5264	3 - ZTT (JL,4)ZTT (JL,8)ZTT (JL,12))
5265	4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
5266	4 (ZTT1(JL,5)ZTT1(JL,9)*ZTT1(JL,13)
5267	4 - ZTT (JL,5)ZTT (JL,9)ZTT (JL,13))
5268	5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
5269	5 (ZTT1(JL,3) ZTT1(JL,14)
5270	5 - ZTT (JL,3) *ZTT (JL,14))
5271	6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
5272	6 (ZTT1(JL,6) ZTT1(JL,15)
5273	6 - ZTT (JL,6) *ZTT (JL,15))
5274	PCTS(JL,JSTRA)=ZCTSTR*0.5
5275	2424 CONTINUE
5276	DO 2426 JA=1,KTRAER
5277	DO 2425 JL=1, KDLON
5278	ZTT1(JL,JA)=ZTT(JL,JA)
5279	2425 CONTINUE
5280	2426 CONTINUE
5281	2427 CONTINUE
5282	ENDIF
5283	C Mise a zero de securite pour PCTS en cas de LEVOIGT
5284	IF(LEVOIGT)THEN
5285	DO 2429 JSTRA = 1,KFLEV
5286	DO 2428 JL = 1, KDLON
5287	PCTS(JL,JSTRA)=0.
5288	2428 CONTINUE
5289	2429 CONTINUE
5290	ENDIF
5291	C
5292	C
5293	C* 2.5 EXCHANGE WITH LOWER LIMIT
5294	C -------------------------
5295	C
5296	250 CONTINUE
5297	C
5298	DO 251 JL = 1, KDLON
5299	ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
5300	S *PFLUC(JL,2,1)-PBINT(JL,1)
5301	251 CONTINUE
5302	C
5303	JK = 1
5304	IN=(JK-1)*NG1P1+1
5305	C
5306	DO 252 JL = 1, KDLON
5307	ZCNSOL(JL)=PBSUR(JL,1)
5308	1 +PBSUR(JL,2)
5309	2 +PBSUR(JL,3)
5310	3 +PBSUR(JL,4)
5311	4 +PBSUR(JL,5)
5312	5 +PBSUR(JL,6)
5313	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5314	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5315	PFLUC(JL,1,JK)=ZFU(JL)
5316	252 CONTINUE
5317	C
5318	DO 257 JK = 2 , KFLEV+1
5319	IN=(JK-1)*NG1P1+1
5320	C
5321	C
5322	DO 255 JA=1,KUAER
5323	DO 254 JL=1, KDLON
5324	ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
5325	254 CONTINUE
5326	255 CONTINUE
5327	C
5328	C
5329	CALL LWTT_LMDAR4(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
5330	C
5331	DO 256 JL = 1, KDLON
5332	ZCNSOL(JL)=PBSUR(JL,1)ZTT(JL,1) ZTT(JL,10)
5333	2 +PBSUR(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5334	3 +PBSUR(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5335	4 +PBSUR(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5336	5 +PBSUR(JL,5)ZTT(JL,3) ZTT(JL,14)
5337	6 +PBSUR(JL,6)ZTT(JL,6) ZTT(JL,15)
5338	ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
5339	ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
5340	PFLUC(JL,1,JK)=ZFU(JL)
5341	256 CONTINUE
5342	C
5343	C
5344	257 CONTINUE
5345	C
5346	C
5347	C
5348	C* 2.7 CLEAR-SKY FLUXES
5349	C ----------------
5350	C
5351	270 CONTINUE
5352	C
5353	IF (.NOT.LEVOIGT) THEN
5354	DO 271 JL = 1, KDLON
5355	ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
5356	271 CONTINUE
5357	DO 273 JK = JLIM+1,KFLEV+1
5358	DO 272 JL = 1, KDLON
5359	ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
5360	PFLUC(JL,1,JK) = ZFN10(JL)
5361	PFLUC(JL,2,JK) = 0.
5362	272 CONTINUE
5363	273 CONTINUE
5364	ENDIF
5365	C
5366	C ------------------------------------------------------------------
5367	C
5368	RETURN
5369	END
5370	SUBROUTINE LWVD_LMDAR4(KUAER,KTRAER
5371	S , PABCU,PDBDT
5372	R , PGA,PGB
5373	S , PCNTRB,PDISD,PDISU)
5374	USE dimphy
5375	IMPLICIT none
5376	cym#include "dimensions.h"
5377	cym#include "dimphy.h"
5378	cym#include "raddim.h"
5379	#include "raddimlw.h"
5380	C
5381	C-----------------------------------------------------------------------
5382	C PURPOSE.
5383	C --------
5384	C CARRIES OUT THE VERTICAL INTEGRATION ON THE DISTANT LAYERS
5385	C
5386	C METHOD.
5387	C -------
5388	C
5389	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5390	C CONTRIBUTIONS OF THE DISTANT LAYERS USING TRAPEZOIDAL RULE
5391	C
5392	C REFERENCE.
5393	C ----------
5394	C
5395	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5396	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5397	C
5398	C AUTHOR.
5399	C -------
5400	C JEAN-JACQUES MORCRETTE ECMWF
5401	C
5402	C MODIFICATIONS.
5403	C --------------
5404	C ORIGINAL : 89-07-14
5405	C-----------------------------------------------------------------------
5406	C* ARGUMENTS:
5407	C
5408	INTEGER KUAER,KTRAER
5409	C
5410	REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
5411	REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5412	REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5413	REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5414	C
5415	REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! ENERGY EXCHANGE MATRIX
5416	REAL(KIND=8) PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5417	REAL(KIND=8) PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
5418	C
5419	C* LOCAL VARIABLES:
5420	C
5421	REAL(KIND=8) ZGLAYD(KDLON)
5422	REAL(KIND=8) ZGLAYU(KDLON)
5423	REAL(KIND=8) ZTT(KDLON,NTRA)
5424	REAL(KIND=8) ZTT1(KDLON,NTRA)
5425	REAL(KIND=8) ZTT2(KDLON,NTRA)
5426	C
5427	INTEGER jl, jk, ja, ikp1, ikn, ikd1, jkj, ikd2
5428	INTEGER ikjp1, ikm1, ikj, jlk, iku1, ijkl, iku2
5429	INTEGER ind1, ind2, ind3, ind4, itt
5430	REAL(KIND=8) zww, zdzxdg, zdzxmg
5431	C
5432	C* 1. INITIALIZATION
5433	C --------------
5434	C
5435	100 CONTINUE
5436	C
5437	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5438	C ------------------------------
5439	C
5440	110 CONTINUE
5441	C
5442	DO 112 JK = 1, KFLEV+1
5443	DO 111 JL = 1, KDLON
5444	PDISD(JL,JK) = 0.
5445	PDISU(JL,JK) = 0.
5446	111 CONTINUE
5447	112 CONTINUE
5448	C
5449	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5450	C ---------------------------------
5451	C
5452	120 CONTINUE
5453	C
5454	C
5455	DO 122 JA = 1, NTRA
5456	DO 121 JL = 1, KDLON
5457	ZTT (JL,JA) = 1.0
5458	ZTT1(JL,JA) = 1.0
5459	ZTT2(JL,JA) = 1.0
5460	121 CONTINUE
5461	122 CONTINUE
5462	C
5463	C ------------------------------------------------------------------
5464	C
5465	C* 2. VERTICAL INTEGRATION
5466	C --------------------
5467	C
5468	200 CONTINUE
5469	C
5470	IND1=0
5471	IND3=0
5472	IND4=1
5473	IND2=1
5474	C
5475	C
5476	C* 2.2 CONTRIBUTION FROM DISTANT LAYERS
5477	C ---------------------------------
5478	C
5479	220 CONTINUE
5480	C
5481	C
5482	C* 2.2.1 DISTANT AND ABOVE LAYERS
5483	C ------------------------
5484	C
5485	2210 CONTINUE
5486	C
5487	C
5488	C
5489	C* 2.2.2 FIRST UPPER LEVEL
5490	C -----------------
5491	C
5492	2220 CONTINUE
5493	C
5494	DO 225 JK = 1 , KFLEV-1
5495	IKP1=JK+1
5496	IKN=(JK-1)*NG1P1+1
5497	IKD1= JK *NG1P1+1
5498	C
5499	CALL LWTTM_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK)
5500	2 , PABCU(1,1,IKN),PABCU(1,1,IKD1),ZTT1)
5501	C
5502	C
5503	C
5504	C* 2.2.3 HIGHER UP
5505	C ---------
5506	C
5507	2230 CONTINUE
5508	C
5509	ITT=1
5510	DO 224 JKJ=IKP1,KFLEV
5511	IF(ITT.EQ.1) THEN
5512	ITT=2
5513	ELSE
5514	ITT=1
5515	ENDIF
5516	IKJP1=JKJ+1
5517	IKD2= JKJ *NG1P1+1
5518	C
5519	IF(ITT.EQ.1) THEN
5520	CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5521	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT1)
5522	ELSE
5523	CALL LWTTM_LMDAR4(PGA(1,1,1,JKJ),PGB(1,1,1,JKJ)
5524	2 , PABCU(1,1,IKN),PABCU(1,1,IKD2),ZTT2)
5525	ENDIF
5526	C
5527	DO 2235 JA = 1, KTRAER
5528	DO 2234 JL = 1, KDLON
5529	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5530	2234 CONTINUE
5531	2235 CONTINUE
5532	C
5533	DO 2236 JL = 1, KDLON
5534	ZWW=PDBDT(JL,1,JKJ)ZTT(JL,1) ZTT(JL,10)
5535	S +PDBDT(JL,2,JKJ)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5536	S +PDBDT(JL,3,JKJ)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5537	S +PDBDT(JL,4,JKJ)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5538	S +PDBDT(JL,5,JKJ)ZTT(JL,3) ZTT(JL,14)
5539	S +PDBDT(JL,6,JKJ)ZTT(JL,6) ZTT(JL,15)
5540	ZGLAYD(JL)=ZWW
5541	ZDZXDG=ZGLAYD(JL)
5542	PDISD(JL,JK)=PDISD(JL,JK)+ZDZXDG
5543	PCNTRB(JL,JK,IKJP1)=ZDZXDG
5544	2236 CONTINUE
5545	C
5546	C
5547	224 CONTINUE
5548	225 CONTINUE
5549	C
5550	C
5551	C* 2.2.4 DISTANT AND BELOW LAYERS
5552	C ------------------------
5553	C
5554	2240 CONTINUE
5555	C
5556	C
5557	C
5558	C* 2.2.5 FIRST LOWER LEVEL
5559	C -----------------
5560	C
5561	2250 CONTINUE
5562	C
5563	DO 228 JK=3,KFLEV+1
5564	IKN=(JK-1)*NG1P1+1
5565	IKM1=JK-1
5566	IKJ=JK-2
5567	IKU1= IKJ *NG1P1+1
5568	C
5569	C
5570	CALL LWTTM_LMDAR4(PGA(1,1,1,IKJ),PGB(1,1,1,IKJ)
5571	2 , PABCU(1,1,IKU1),PABCU(1,1,IKN),ZTT1)
5572	C
5573	C
5574	C
5575	C* 2.2.6 DOWN BELOW
5576	C ----------
5577	C
5578	2260 CONTINUE
5579	C
5580	ITT=1
5581	DO 227 JLK=1,IKJ
5582	IF(ITT.EQ.1) THEN
5583	ITT=2
5584	ELSE
5585	ITT=1
5586	ENDIF
5587	IJKL=IKM1-JLK
5588	IKU2=(IJKL-1)*NG1P1+1
5589	C
5590	C
5591	IF(ITT.EQ.1) THEN
5592	CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5593	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT1)
5594	ELSE
5595	CALL LWTTM_LMDAR4(PGA(1,1,1,IJKL),PGB(1,1,1,IJKL)
5596	2 , PABCU(1,1,IKU2),PABCU(1,1,IKN),ZTT2)
5597	ENDIF
5598	C
5599	DO 2265 JA = 1, KTRAER
5600	DO 2264 JL = 1, KDLON
5601	ZTT(JL,JA) = (ZTT1(JL,JA)+ZTT2(JL,JA))*0.5
5602	2264 CONTINUE
5603	2265 CONTINUE
5604	C
5605	DO 2266 JL = 1, KDLON
5606	ZWW=PDBDT(JL,1,IJKL)ZTT(JL,1) ZTT(JL,10)
5607	S +PDBDT(JL,2,IJKL)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5608	S +PDBDT(JL,3,IJKL)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5609	S +PDBDT(JL,4,IJKL)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5610	S +PDBDT(JL,5,IJKL)ZTT(JL,3) ZTT(JL,14)
5611	S +PDBDT(JL,6,IJKL)ZTT(JL,6) ZTT(JL,15)
5612	ZGLAYU(JL)=ZWW
5613	ZDZXMG=ZGLAYU(JL)
5614	PDISU(JL,JK)=PDISU(JL,JK)+ZDZXMG
5615	PCNTRB(JL,JK,IJKL)=ZDZXMG
5616	2266 CONTINUE
5617	C
5618	C
5619	227 CONTINUE
5620	228 CONTINUE
5621	C
5622	RETURN
5623	END
5624	SUBROUTINE LWVN_LMDAR4(KUAER,KTRAER
5625	R , PABCU,PDBSL,PGA,PGB
5626	S , PADJD,PADJU,PCNTRB,PDBDT)
5627	USE dimphy
5628	IMPLICIT none
5629	cym#include "dimensions.h"
5630	cym#include "dimphy.h"
5631	cym#include "raddim.h"
5632	#include "raddimlw.h"
5633	C
5634	C-----------------------------------------------------------------------
5635	C PURPOSE.
5636	C --------
5637	C CARRIES OUT THE VERTICAL INTEGRATION ON NEARBY LAYERS
5638	C TO GIVE LONGWAVE FLUXES OR RADIANCES
5639	C
5640	C METHOD.
5641	C -------
5642	C
5643	C 1. PERFORMS THE VERTICAL INTEGRATION CORRESPONDING TO THE
5644	C CONTRIBUTIONS OF THE ADJACENT LAYERS USING A GAUSSIAN QUADRATURE
5645	C
5646	C REFERENCE.
5647	C ----------
5648	C
5649	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5650	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5651	C
5652	C AUTHOR.
5653	C -------
5654	C JEAN-JACQUES MORCRETTE ECMWF
5655	C
5656	C MODIFICATIONS.
5657	C --------------
5658	C ORIGINAL : 89-07-14
5659	C-----------------------------------------------------------------------
5660	C
5661	C* ARGUMENTS:
5662	C
5663	INTEGER KUAER,KTRAER
5664	C
5665	REAL(KIND=8) PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
5666	REAL(KIND=8) PDBSL(KDLON,Ninter,KFLEV*2) ! SUB-LAYER PLANCK FUNCTION GRADIENT
5667	REAL(KIND=8) PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5668	REAL(KIND=8) PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
5669	C
5670	REAL(KIND=8) PADJD(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5671	REAL(KIND=8) PADJU(KDLON,KFLEV+1) ! CONTRIBUTION OF ADJACENT LAYERS
5672	REAL(KIND=8) PCNTRB(KDLON,KFLEV+1,KFLEV+1) ! CLEAR-SKY ENERGY EXCHANGE MATRIX
5673	REAL(KIND=8) PDBDT(KDLON,Ninter,KFLEV) ! LAYER PLANCK FUNCTION GRADIENT
5674	C
5675	C* LOCAL ARRAYS:
5676	C
5677	REAL(KIND=8) ZGLAYD(KDLON)
5678	REAL(KIND=8) ZGLAYU(KDLON)
5679	REAL(KIND=8) ZTT(KDLON,NTRA)
5680	REAL(KIND=8) ZTT1(KDLON,NTRA)
5681	REAL(KIND=8) ZTT2(KDLON,NTRA)
5682	REAL(KIND=8) ZUU(KDLON,NUA)
5683	C
5684	INTEGER jk, jl, ja, im12, ind, inu, ixu, jg
5685	INTEGER ixd, ibs, idd, imu, jk1, jk2, jnu
5686	REAL(KIND=8) zwtr
5687	c
5688	C* Data Block:
5689	c
5690	REAL(KIND=8) WG1(2)
5691	SAVE WG1
5692	c$OMP THREADPRIVATE(WG1)
5693	DATA (WG1(jk),jk=1,2) /1.0, 1.0/
5694	C-----------------------------------------------------------------------
5695	C
5696	C* 1. INITIALIZATION
5697	C --------------
5698	C
5699	100 CONTINUE
5700	C
5701	C* 1.1 INITIALIZE LAYER CONTRIBUTIONS
5702	C ------------------------------
5703	C
5704	110 CONTINUE
5705	C
5706	DO 112 JK = 1 , KFLEV+1
5707	DO 111 JL = 1, KDLON
5708	PADJD(JL,JK) = 0.
5709	PADJU(JL,JK) = 0.
5710	111 CONTINUE
5711	112 CONTINUE
5712	C
5713	C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
5714	C ---------------------------------
5715	C
5716	120 CONTINUE
5717	C
5718	DO 122 JA = 1 , NTRA
5719	DO 121 JL = 1, KDLON
5720	ZTT (JL,JA) = 1.0
5721	ZTT1(JL,JA) = 1.0
5722	ZTT2(JL,JA) = 1.0
5723	121 CONTINUE
5724	122 CONTINUE
5725	C
5726	DO 124 JA = 1 , NUA
5727	DO 123 JL = 1, KDLON
5728	ZUU(JL,JA) = 0.
5729	123 CONTINUE
5730	124 CONTINUE
5731	C
5732	C ------------------------------------------------------------------
5733	C
5734	C* 2. VERTICAL INTEGRATION
5735	C --------------------
5736	C
5737	200 CONTINUE
5738	C
5739	C
5740	C* 2.1 CONTRIBUTION FROM ADJACENT LAYERS
5741	C ---------------------------------
5742	C
5743	210 CONTINUE
5744	C
5745	DO 215 JK = 1 , KFLEV
5746	C
5747	C* 2.1.1 DOWNWARD LAYERS
5748	C ---------------
5749	C
5750	2110 CONTINUE
5751	C
5752	IM12 = 2 * (JK - 1)
5753	IND = (JK - 1) * NG1P1 + 1
5754	IXD = IND
5755	INU = JK * NG1P1 + 1
5756	IXU = IND
5757	C
5758	DO 2111 JL = 1, KDLON
5759	ZGLAYD(JL) = 0.
5760	ZGLAYU(JL) = 0.
5761	2111 CONTINUE
5762	C
5763	DO 213 JG = 1 , NG1
5764	IBS = IM12 + JG
5765	IDD = IXD + JG
5766	DO 2113 JA = 1 , KUAER
5767	DO 2112 JL = 1, KDLON
5768	ZUU(JL,JA) = PABCU(JL,JA,IND) - PABCU(JL,JA,IDD)
5769	2112 CONTINUE
5770	2113 CONTINUE
5771	C
5772	C
5773	CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
5774	C
5775	DO 2114 JL = 1, KDLON
5776	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
5777	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5778	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5779	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5780	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
5781	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
5782	ZGLAYD(JL)=ZGLAYD(JL)+ZWTR*WG1(JG)
5783	2114 CONTINUE
5784	C
5785	C* 2.1.2 DOWNWARD LAYERS
5786	C ---------------
5787	C
5788	2120 CONTINUE
5789	C
5790	IMU = IXU + JG
5791	DO 2122 JA = 1 , KUAER
5792	DO 2121 JL = 1, KDLON
5793	ZUU(JL,JA) = PABCU(JL,JA,IMU) - PABCU(JL,JA,INU)
5794	2121 CONTINUE
5795	2122 CONTINUE
5796	C
5797	C
5798	CALL LWTT_LMDAR4(PGA(1,1,1,JK), PGB(1,1,1,JK), ZUU, ZTT)
5799	C
5800	DO 2123 JL = 1, KDLON
5801	ZWTR=PDBSL(JL,1,IBS)ZTT(JL,1) ZTT(JL,10)
5802	S +PDBSL(JL,2,IBS)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
5803	S +PDBSL(JL,3,IBS)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
5804	S +PDBSL(JL,4,IBS)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
5805	S +PDBSL(JL,5,IBS)ZTT(JL,3) ZTT(JL,14)
5806	S +PDBSL(JL,6,IBS)ZTT(JL,6) ZTT(JL,15)
5807	ZGLAYU(JL)=ZGLAYU(JL)+ZWTR*WG1(JG)
5808	2123 CONTINUE
5809	C
5810	213 CONTINUE
5811	C
5812	DO 214 JL = 1, KDLON
5813	PADJD(JL,JK) = ZGLAYD(JL)
5814	PCNTRB(JL,JK,JK+1) = ZGLAYD(JL)
5815	PADJU(JL,JK+1) = ZGLAYU(JL)
5816	PCNTRB(JL,JK+1,JK) = ZGLAYU(JL)
5817	PCNTRB(JL,JK ,JK) = 0.0
5818	214 CONTINUE
5819	C
5820	215 CONTINUE
5821	C
5822	DO 218 JK = 1 , KFLEV
5823	JK2 = 2 * JK
5824	JK1 = JK2 - 1
5825	DO 217 JNU = 1 , Ninter
5826	DO 216 JL = 1, KDLON
5827	PDBDT(JL,JNU,JK) = PDBSL(JL,JNU,JK1) + PDBSL(JL,JNU,JK2)
5828	216 CONTINUE
5829	217 CONTINUE
5830	218 CONTINUE
5831	C
5832	RETURN
5833	C
5834	END
5835	SUBROUTINE LWTT_LMDAR4(PGA,PGB,PUU, PTT)
5836	USE dimphy
5837	IMPLICIT none
5838	cym#include "dimensions.h"
5839	cym#include "dimphy.h"
5840	cym#include "raddim.h"
5841	#include "raddimlw.h"
5842	C
5843	C-----------------------------------------------------------------------
5844	C PURPOSE.
5845	C --------
5846	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
5847	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
5848	C INTERVALS.
5849	C
5850	C METHOD.
5851	C -------
5852	C
5853	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
5854	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
5855	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
5856	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
5857	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
5858	C
5859	C REFERENCE.
5860	C ----------
5861	C
5862	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
5863	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
5864	C
5865	C AUTHOR.
5866	C -------
5867	C JEAN-JACQUES MORCRETTE ECMWF
5868	C
5869	C MODIFICATIONS.
5870	C --------------
5871	C ORIGINAL : 88-12-15
5872	C
5873	C-----------------------------------------------------------------------
5874	REAL(KIND=8) O1H, O2H
5875	PARAMETER (O1H=2230.)
5876	PARAMETER (O2H=100.)
5877	REAL(KIND=8) RPIALF0
5878	PARAMETER (RPIALF0=2.0)
5879	C
5880	C* ARGUMENTS:
5881	C
5882	REAL(KIND=8) PUU(KDLON,NUA)
5883	REAL(KIND=8) PTT(KDLON,NTRA)
5884	REAL(KIND=8) PGA(KDLON,8,2)
5885	REAL(KIND=8) PGB(KDLON,8,2)
5886	C
5887	C* LOCAL VARIABLES:
5888	C
5889	REAL(KIND=8) zz, zxd, zxn
5890	REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
5891	REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
5892	REAL(KIND=8) zx, zy, zsq1, zsq2, zvxy, zuxy
5893	REAL(KIND=8) zaercn, zto1, zto2, zxch4, zych4, zxn2o, zyn2o
5894	REAL(KIND=8) zsqn21, zodn21, zsqh42, zodh42
5895	REAL(KIND=8) zsqh41, zodh41, zsqn22, zodn22, zttf11, zttf12
5896	REAL(KIND=8) zuu11, zuu12, za11, za12
5897	INTEGER jl, ja
5898	C ------------------------------------------------------------------
5899	C
5900	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
5901	C -----------------------------------------------
5902	C
5903	100 CONTINUE
5904	C
5905	C
5906	DO 130 JA = 1 , 8
5907	DO 120 JL = 1, KDLON
5908	ZZ =SQRT(PUU(JL,JA))
5909	c ZXD(JL,1)=PGB( JL, 1,1) + ZZ(JL, 1)*(PGB( JL, 1,2) + ZZ(JL, 1))
5910	c ZXN(JL,1)=PGA( JL, 1,1) + ZZ(JL, 1)*(PGA( JL, 1,2) )
5911	c PTT(JL,1)=ZXN(JL,1)/ZXD(JL,1)
5912	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
5913	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
5914	PTT(JL,JA)=ZXN /ZXD
5915	120 CONTINUE
5916	130 CONTINUE
5917	C
5918	C ------------------------------------------------------------------
5919	C
5920	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
5921	C ---------------------------------------------------
5922	C
5923	200 CONTINUE
5924	C
5925	DO 201 JL = 1, KDLON
5926	PTT(JL, 9) = PTT(JL, 8)
5927	C
5928	C- CONTINUUM ABSORPTION: E- AND P-TYPE
5929	C
5930	ZPU = 0.002 * PUU(JL,10)
5931	ZPU10 = 112. * ZPU
5932	ZPU11 = 6.25 * ZPU
5933	ZPU12 = 5.00 * ZPU
5934	ZPU13 = 80.0 * ZPU
5935	ZEU = PUU(JL,11)
5936	ZEU10 = 12. * ZEU
5937	ZEU11 = 6.25 * ZEU
5938	ZEU12 = 5.00 * ZEU
5939	ZEU13 = 80.0 * ZEU
5940	C
5941	C- OZONE ABSORPTION
5942	C
5943	ZX = PUU(JL,12)
5944	ZY = PUU(JL,13)
5945	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
5946	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
5947	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
5948	ZVXY = RPIALF0 * ZY / (2. * ZX)
5949	ZAERCN = PUU(JL,17) + ZEU12 + ZPU12
5950	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
5951	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
5952	C
5953	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
5954	C
5955	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
5956	C
5957	c NEXOTIC=1
5958	c IF (NEXOTIC.EQ.1) THEN
5959	ZXCH4 = PUU(JL,19)
5960	ZYCH4 = PUU(JL,20)
5961	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
5962	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
5963	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
5964	ZODH41 = ZVXY * ZSQH41
5965	C
5966	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
5967	C
5968	ZXN2O = PUU(JL,21)
5969	ZYN2O = PUU(JL,22)
5970	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
5971	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
5972	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
5973	ZODN21 = ZVXY * ZSQN21
5974	C
5975	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
5976	C
5977	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
5978	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
5979	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
5980	ZODH42 = ZVXY * ZSQH42
5981	C
5982	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
5983	C
5984	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
5985	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
5986	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
5987	ZODN22 = ZVXY * ZSQN22
5988	C
5989	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
5990	C
5991	ZA11 = 2. * PUU(JL,23) * 4.404E+05
5992	ZTTF11 = 1. - ZA11 * 0.003225
5993	C
5994	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
5995	C
5996	ZA12 = 2. * PUU(JL,24) * 6.7435E+05
5997	ZTTF12 = 1. - ZA12 * 0.003225
5998	C
5999	ZUU11 = - PUU(JL,15) - ZEU10 - ZPU10
6000	ZUU12 = - PUU(JL,16) - ZEU11 - ZPU11 - ZODH41 - ZODN21
6001	PTT(JL,10) = EXP( - PUU(JL,14) )
6002	PTT(JL,11) = EXP( ZUU11 )
6003	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6004	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6005	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6006	PTT(JL,15) = EXP ( - PUU(JL,14) - ZODH42 - ZODN22 )
6007	201 CONTINUE
6008	C
6009	RETURN
6010	END
6011	SUBROUTINE LWTTM_LMDAR4(PGA,PGB,PUU1,PUU2, PTT)
6012	USE dimphy
6013	IMPLICIT none
6014	cym#include "dimensions.h"
6015	cym#include "dimphy.h"
6016	cym#include "raddim.h"
6017	#include "raddimlw.h"
6018	C
6019	C ------------------------------------------------------------------
6020	C PURPOSE.
6021	C --------
6022	C THIS ROUTINE COMPUTES THE TRANSMISSION FUNCTIONS FOR ALL THE
6023	C ABSORBERS (H2O, UNIFORMLY MIXED GASES, AND O3) IN ALL SIX SPECTRAL
6024	C INTERVALS.
6025	C
6026	C METHOD.
6027	C -------
6028	C
6029	C 1. TRANSMISSION FUNCTION BY H2O AND UNIFORMLY MIXED GASES ARE
6030	C COMPUTED USING PADE APPROXIMANTS AND HORNER'S ALGORITHM.
6031	C 2. TRANSMISSION BY O3 IS EVALUATED WITH MALKMUS'S BAND MODEL.
6032	C 3. TRANSMISSION BY H2O CONTINUUM AND AEROSOLS FOLLOW AN
6033	C A SIMPLE EXPONENTIAL DECREASE WITH ABSORBER AMOUNT.
6034	C
6035	C REFERENCE.
6036	C ----------
6037	C
6038	C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
6039	C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
6040	C
6041	C AUTHOR.
6042	C -------
6043	C JEAN-JACQUES MORCRETTE ECMWF
6044	C
6045	C MODIFICATIONS.
6046	C --------------
6047	C ORIGINAL : 88-12-15
6048	C
6049	C-----------------------------------------------------------------------
6050	REAL(KIND=8) O1H, O2H
6051	PARAMETER (O1H=2230.)
6052	PARAMETER (O2H=100.)
6053	REAL(KIND=8) RPIALF0
6054	PARAMETER (RPIALF0=2.0)
6055	C
6056	C* ARGUMENTS:
6057	C
6058	REAL(KIND=8) PGA(KDLON,8,2) ! PADE APPROXIMANTS
6059	REAL(KIND=8) PGB(KDLON,8,2) ! PADE APPROXIMANTS
6060	REAL(KIND=8) PUU1(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 1
6061	REAL(KIND=8) PUU2(KDLON,NUA) ! ABSORBER AMOUNTS FROM TOP TO LEVEL 2
6062	REAL(KIND=8) PTT(KDLON,NTRA) ! TRANSMISSION FUNCTIONS
6063	C
6064	C* LOCAL VARIABLES:
6065	C
6066	INTEGER ja, jl
6067	REAL(KIND=8) zz, zxd, zxn
6068	REAL(KIND=8) zpu, zpu10, zpu11, zpu12, zpu13
6069	REAL(KIND=8) zeu, zeu10, zeu11, zeu12, zeu13
6070	REAL(KIND=8) zx, zy, zuxy, zsq1, zsq2, zvxy, zaercn, zto1, zto2
6071	REAL(KIND=8) zxch4, zych4, zsqh41, zodh41
6072	REAL(KIND=8) zxn2o, zyn2o, zsqn21, zodn21, zsqh42, zodh42
6073	REAL(KIND=8) zsqn22, zodn22, za11, zttf11, za12, zttf12
6074	REAL(KIND=8) zuu11, zuu12
6075	C ------------------------------------------------------------------
6076	C
6077	C* 1. HORNER'S ALGORITHM FOR H2O AND CO2 TRANSMISSION
6078	C -----------------------------------------------
6079	C
6080	100 CONTINUE
6081	C
6082	C
6083	DO 130 JA = 1 , 8
6084	DO 120 JL = 1, KDLON
6085	ZZ =SQRT(PUU1(JL,JA) - PUU2(JL,JA))
6086	ZXD =PGB( JL,JA,1) + ZZ *(PGB( JL,JA,2) + ZZ )
6087	ZXN =PGA( JL,JA,1) + ZZ *(PGA( JL,JA,2) )
6088	PTT(JL,JA)=ZXN /ZXD
6089	120 CONTINUE
6090	130 CONTINUE
6091	C
6092	C ------------------------------------------------------------------
6093	C
6094	C* 2. CONTINUUM, OZONE AND AEROSOL TRANSMISSION FUNCTIONS
6095	C ---------------------------------------------------
6096	C
6097	200 CONTINUE
6098	C
6099	DO 201 JL = 1, KDLON
6100	PTT(JL, 9) = PTT(JL, 8)
6101	C
6102	C- CONTINUUM ABSORPTION: E- AND P-TYPE
6103	C
6104	ZPU = 0.002 * (PUU1(JL,10) - PUU2(JL,10))
6105	ZPU10 = 112. * ZPU
6106	ZPU11 = 6.25 * ZPU
6107	ZPU12 = 5.00 * ZPU
6108	ZPU13 = 80.0 * ZPU
6109	ZEU = (PUU1(JL,11) - PUU2(JL,11))
6110	ZEU10 = 12. * ZEU
6111	ZEU11 = 6.25 * ZEU
6112	ZEU12 = 5.00 * ZEU
6113	ZEU13 = 80.0 * ZEU
6114	C
6115	C- OZONE ABSORPTION
6116	C
6117	ZX = (PUU1(JL,12) - PUU2(JL,12))
6118	ZY = (PUU1(JL,13) - PUU2(JL,13))
6119	ZUXY = 4. * ZX * ZX / (RPIALF0 * ZY)
6120	ZSQ1 = SQRT(1. + O1H * ZUXY ) - 1.
6121	ZSQ2 = SQRT(1. + O2H * ZUXY ) - 1.
6122	ZVXY = RPIALF0 * ZY / (2. * ZX)
6123	ZAERCN = (PUU1(JL,17) -PUU2(JL,17)) + ZEU12 + ZPU12
6124	ZTO1 = EXP( - ZVXY * ZSQ1 - ZAERCN )
6125	ZTO2 = EXP( - ZVXY * ZSQ2 - ZAERCN )
6126	C
6127	C-- TRACE GASES (CH4, N2O, CFC-11, CFC-12)
6128	C
6129	C* CH4 IN INTERVAL 800-970 + 1110-1250 CM-1
6130	C
6131	ZXCH4 = (PUU1(JL,19) - PUU2(JL,19))
6132	ZYCH4 = (PUU1(JL,20) - PUU2(JL,20))
6133	ZUXY = 4. * ZXCH4ZXCH4/(0.103ZYCH4)
6134	ZSQH41 = SQRT(1. + 33.7 * ZUXY) - 1.
6135	ZVXY = 0.103 * ZYCH4 / (2. * ZXCH4)
6136	ZODH41 = ZVXY * ZSQH41
6137	C
6138	C* N2O IN INTERVAL 800-970 + 1110-1250 CM-1
6139	C
6140	ZXN2O = (PUU1(JL,21) - PUU2(JL,21))
6141	ZYN2O = (PUU1(JL,22) - PUU2(JL,22))
6142	ZUXY = 4. * ZXN2OZXN2O/(0.416ZYN2O)
6143	ZSQN21 = SQRT(1. + 21.3 * ZUXY) - 1.
6144	ZVXY = 0.416 * ZYN2O / (2. * ZXN2O)
6145	ZODN21 = ZVXY * ZSQN21
6146	C
6147	C* CH4 IN INTERVAL 1250-1450 + 1880-2820 CM-1
6148	C
6149	ZUXY = 4. * ZXCH4ZXCH4/(0.113ZYCH4)
6150	ZSQH42 = SQRT(1. + 400. * ZUXY) - 1.
6151	ZVXY = 0.113 * ZYCH4 / (2. * ZXCH4)
6152	ZODH42 = ZVXY * ZSQH42
6153	C
6154	C* N2O IN INTERVAL 1250-1450 + 1880-2820 CM-1
6155	C
6156	ZUXY = 4. * ZXN2OZXN2O/(0.197ZYN2O)
6157	ZSQN22 = SQRT(1. + 2000. * ZUXY) - 1.
6158	ZVXY = 0.197 * ZYN2O / (2. * ZXN2O)
6159	ZODN22 = ZVXY * ZSQN22
6160	C
6161	C* CFC-11 IN INTERVAL 800-970 + 1110-1250 CM-1
6162	C
6163	ZA11 = (PUU1(JL,23) - PUU2(JL,23)) * 4.404E+05
6164	ZTTF11 = 1. - ZA11 * 0.003225
6165	C
6166	C* CFC-12 IN INTERVAL 800-970 + 1110-1250 CM-1
6167	C
6168	ZA12 = (PUU1(JL,24) - PUU2(JL,24)) * 6.7435E+05
6169	ZTTF12 = 1. - ZA12 * 0.003225
6170	C
6171	ZUU11 = - (PUU1(JL,15) - PUU2(JL,15)) - ZEU10 - ZPU10
6172	ZUU12 = - (PUU1(JL,16) - PUU2(JL,16)) - ZEU11 - ZPU11 -
6173	S ZODH41 - ZODN21
6174	PTT(JL,10) = EXP( - (PUU1(JL,14)- PUU2(JL,14)) )
6175	PTT(JL,11) = EXP( ZUU11 )
6176	PTT(JL,12) = EXP( ZUU12 ) * ZTTF11 * ZTTF12
6177	PTT(JL,13) = 0.7554 * ZTO1 + 0.2446 * ZTO2
6178	PTT(JL,14) = PTT(JL,10) * EXP( - ZEU13 - ZPU13 )
6179	PTT(JL,15) = EXP ( - (PUU1(JL,14) - PUU2(JL,14)) - ZODH42-ZODN22 )
6180	201 CONTINUE
6181	C
6182	RETURN
6183	END

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

Download in other formats:

Original Format