Context Navigation

radiation_AR4.F90 @ 2311

Last change on this file since 2311 was 2311, checked in by Ehouarn Millour, 9 years ago

Further modifications to enforce physics/dynamics separation:

moved iniprint.h and misc_mod back to dyn3d_common, as these should only be used by dynamics.
created print_control_mod in the physics to store flags prt_level, lunout, debug to be local to physics (should be used rather than iniprint.h)
created abort_physic.F90 , which does the same job as abort_gcm() did, but should be used instead when in physics.
reactivated inifis (turned it into a module, inifis_mod.F90) to initialize physical constants and print_control_mod flags.

Property copyright set to
Name of program: LMDZ
Creation date: 1984
Version: LMDZ5
License: CeCILL version 2
Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539
See the license file in the root directory
Property svn:eol-style set to native
Property svn:keywords set to Author Date Id Revision

File size: 171.7 KB

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

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

Download in other formats:

Original Format