source: LMDZ.3.3/branches/rel-LF/libf/phylmd/radlwsw.F @ 1546

Last change on this file since 1546 was 556, checked in by lmdzadmin, 20 years ago

Initialisations diverses necessaires au portage Prism AC
LF

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