source: LMDZ.3.3/branches/LF/libf/phylmd/radlwsw.F @ 212

Last change on this file since 212 was 2, checked in by lmdz, 25 years ago

Initial revision

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