Context Navigation

radiation_AR4.F90 @ 5213

Last change on this file since 5213 was 4389, checked in by dcugnet, 22 months ago
revert to original "type_trac" management: 4 characters keyword (lmdz, Inca, repr, co2i, into, aeNP, coag no longer a list of component with "\|" separator the parsed (with "\|" separator) version "types_trac" is no longer used the sole routine using a list of component is readTracFiles fix for INCA and CO2Aer modes: setGeneration is now a function, index corrections for had/vadv.
Property copyright set to Name of program: LMDZ Creation date: 1984 Version: LMDZ5 License: CeCILL version 2 Holder: Laboratoire de m\'et\'eorologie dynamique, CNRS, UMR 8539 See the license file in the root directory Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 170.2 KB

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

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

Download in other formats:

Original Format