Context Navigation

radiation_AR4.F @ 1374

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

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

Download in other formats:

Original Format