source: LMDZ4/branches/LMDZ4V5.0-dev/libf/phylmd/radiation_AR4.F @ 1373

Last change on this file since 1373 was 1279, checked in by Laurent Fairhead, 15 years ago

Merged LMDZ4-dev branch changes r1241:1278 into the trunk
Running trunk and LMDZ4-dev in LMDZOR configuration on local
machine (sequential) and SX8 (4-proc) yields identical results
(restart and restartphy are identical binarily)
Log history from r1241 to r1278 is available by switching to
source:LMDZ4/branches/LMDZ4-dev-20091210

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