source: LMDZ5/branches/LMDZ5-DOFOCO/libf/phylmd/radiation_AR4.F @ 2904

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