source: LMDZ4/trunk/libf/phylmd/radlwsw.F @ 862

Last change on this file since 862 was 776, checked in by Laurent Fairhead, 17 years ago

Suite du merge entre la version et la HEAD: quelques modifications
de Yann sur le

LF

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