Context Navigation

radiation_AR4.F90 @ 4771

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

Physics/dynamics separation:

remove all references to dimensions.h from physics. nbp_lon (==iim) , nbp_lat (==jjm+1) and nbp_lev (==llm) from mod_grid_phy_lmdz should be used instead.
added module regular_lonlat_mod in phy_common to store information about the global (lon-lat) grid cell boundaries and centers.

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

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

Download in other formats:

Original Format