Context Navigation

radlwsw.F @ 1071

Last change on this file since 1071 was 868, checked in by Laurent Fairhead, 17 years ago
Preparation du remplacement de la physique utilisee pour l'exercice IPCC_AR4 par la version de la physique avec thermique. On garde le repertoire phylmd pour un petit moment pour que les utilisateurs ne soient pas trop perdus ... phy_IPCC_AR4 = phylmd LF
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 200.0 KB

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

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

Download in other formats:

Original Format