phylmd/Radlwsw/lwvb.f

      SUBROUTINE LWVB(KUAER,KTRAER, KLIM
     R  , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
     R  , PDISD,PDISU,PEMIS,PPMB
     R  , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
     S  , PCTS,PFLUC)
      use dimens_m
      use dimphy
      use raddim
      use radopt
            use raddimlw
      IMPLICIT none
C
C-----------------------------------------------------------------------
C     PURPOSE.
C     --------
C           INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
C           INTEGRATION
C
C     METHOD.
C     -------
C
C          1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
C     ATMOSPHERE
C          2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
C     TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
C          3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
C
C     REFERENCE.
C     ----------
C
C        SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
C        ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
C
C     AUTHOR.
C     -------
C        JEAN-JACQUES MORCRETTE  *ECMWF*
C
C     MODIFICATIONS.
C     --------------
C        ORIGINAL : 89-07-14
C        Voigt lines (loop 2413 to 2427)  - JJM & PhD - 01/96
C-----------------------------------------------------------------------
C
C*       0.1   ARGUMENTS
C              ---------
C
      INTEGER KUAER,KTRAER, KLIM
C
      DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
      DOUBLE PRECISION PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
      DOUBLE PRECISION PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
      DOUBLE PRECISION PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
      DOUBLE PRECISION PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
      DOUBLE PRECISION PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
      DOUBLE PRECISION PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
      DOUBLE PRECISION PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
      DOUBLE PRECISION PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
      DOUBLE PRECISION PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
      DOUBLE PRECISION PEMIS(KDLON) ! SURFACE EMISSIVITY
      DOUBLE PRECISION PPMB(KDLON,KFLEV+1) ! PRESSURE MB
      DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      DOUBLE PRECISION PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
      DOUBLE PRECISION PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
      DOUBLE PRECISION PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
      DOUBLE PRECISION PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
C
      DOUBLE PRECISION PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
      DOUBLE PRECISION PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
C
C* LOCAL VARIABLES:
C
      DOUBLE PRECISION ZBGND(KDLON)
      DOUBLE PRECISION ZFD(KDLON)
      DOUBLE PRECISION  ZFN10(KDLON)
      DOUBLE PRECISION ZFU(KDLON)
      DOUBLE PRECISION  ZTT(KDLON,NTRA)
      DOUBLE PRECISION ZTT1(KDLON,NTRA)
      DOUBLE PRECISION ZTT2(KDLON,NTRA)
      DOUBLE PRECISION  ZUU(KDLON,NUA) 
      DOUBLE PRECISION ZCNSOL(KDLON)
      DOUBLE PRECISION ZCNTOP(KDLON)
C
      INTEGER jk, jl, ja
      INTEGER jstra, jstru
      INTEGER ind1, ind2, ind3, ind4, in, jlim
      DOUBLE PRECISION zctstr
C-----------------------------------------------------------------------
C
C*         1.    INITIALIZATION
C                --------------
C
 100  CONTINUE
C
C
C*         1.2     INITIALIZE TRANSMISSION FUNCTIONS
C                  ---------------------------------
C
 120  CONTINUE
C
      DO 122 JA=1,NTRA
      DO 121 JL=1, KDLON
      ZTT (JL,JA)=1.0
      ZTT1(JL,JA)=1.0
      ZTT2(JL,JA)=1.0
 121  CONTINUE
 122  CONTINUE
C
      DO 124 JA=1,NUA
      DO 123 JL=1, KDLON
      ZUU(JL,JA)=1.0
 123  CONTINUE
 124  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         2.      VERTICAL INTEGRATION
C                  --------------------
C
 200  CONTINUE
C
      IND1=0
      IND3=0
      IND4=1
      IND2=1
C
C
C*         2.3     EXCHANGE WITH TOP OF THE ATMOSPHERE
C                  -----------------------------------
C
 230  CONTINUE
C
      DO 235 JK = 1 , KFLEV
      IN=(JK-1)*NG1P1+1
C
      DO 232 JA=1,KUAER
      DO 231 JL=1, KDLON
      ZUU(JL,JA)=PABCU(JL,JA,IN)
 231  CONTINUE
 232  CONTINUE
C
C
      CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
C
      DO 234 JL = 1, KDLON
      ZCNTOP(JL)=PBTOP(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
     2      +PBTOP(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
     3      +PBTOP(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
     4      +PBTOP(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
     5      +PBTOP(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
     6      +PBTOP(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
      PFLUC(JL,2,JK)=ZFD(JL)
 234  CONTINUE
C
 235  CONTINUE
C
      JK = KFLEV+1
      IN=(JK-1)*NG1P1+1
C
      DO 236 JL = 1, KDLON
      ZCNTOP(JL)= PBTOP(JL,1)
     1   + PBTOP(JL,2)
     2   + PBTOP(JL,3)
     3   + PBTOP(JL,4)
     4   + PBTOP(JL,5)
     5   + PBTOP(JL,6)
      ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
      PFLUC(JL,2,JK)=ZFD(JL)
 236  CONTINUE
C
C*         2.4     COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
C                  ---------------------------------------
C
 240  CONTINUE
C
C
C*         2.4.1   INITIALIZATION
C                  --------------
C
 2410 CONTINUE
C
      JLIM = KFLEV
C
      IF (.NOT.LEVOIGT) THEN
      DO 2412 JK = KFLEV,1,-1
      IF(PPMB(1,JK).LT.10.0) THEN
         JLIM=JK
      ENDIF   
 2412 CONTINUE
      ENDIF
      KLIM=JLIM
C
      IF (.NOT.LEVOIGT) THEN
        DO 2414 JA=1,KTRAER
        DO 2413 JL=1, KDLON
        ZTT1(JL,JA)=1.0
 2413   CONTINUE
 2414   CONTINUE
C
C*         2.4.2   LOOP OVER LAYERS ABOVE 10 HPA
C                  -----------------------------
C
 2420   CONTINUE
C
        DO 2427 JSTRA = KFLEV,JLIM,-1
        JSTRU=(JSTRA-1)*NG1P1+1
C
        DO 2423 JA=1,KUAER
        DO 2422 JL=1, KDLON
        ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
 2422   CONTINUE
 2423   CONTINUE
C
C
        CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
C
        DO 2424 JL = 1, KDLON
        ZCTSTR =
     1   (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
     1       *(ZTT1(JL,1)           *ZTT1(JL,10)
     1       - ZTT (JL,1)           *ZTT (JL,10))
     2  +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
     2       *(ZTT1(JL,2)*ZTT1(JL,7)*ZTT1(JL,11)
     2       - ZTT (JL,2)*ZTT (JL,7)*ZTT (JL,11))
     3  +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
     3       *(ZTT1(JL,4)*ZTT1(JL,8)*ZTT1(JL,12)
     3       - ZTT (JL,4)*ZTT (JL,8)*ZTT (JL,12))
     4  +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
     4       *(ZTT1(JL,5)*ZTT1(JL,9)*ZTT1(JL,13)
     4       - ZTT (JL,5)*ZTT (JL,9)*ZTT (JL,13))
     5  +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
     5       *(ZTT1(JL,3)           *ZTT1(JL,14)
     5       - ZTT (JL,3)           *ZTT (JL,14))
     6  +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
     6       *(ZTT1(JL,6)           *ZTT1(JL,15)
     6       - ZTT (JL,6)           *ZTT (JL,15))
        PCTS(JL,JSTRA)=ZCTSTR*0.5
 2424   CONTINUE
        DO 2426 JA=1,KTRAER
        DO 2425 JL=1, KDLON
        ZTT1(JL,JA)=ZTT(JL,JA)
 2425   CONTINUE
 2426   CONTINUE
 2427   CONTINUE
      ENDIF
C Mise a zero de securite pour PCTS en cas de LEVOIGT
      IF(LEVOIGT)THEN
        DO 2429 JSTRA = 1,KFLEV
        DO 2428 JL = 1, KDLON
          PCTS(JL,JSTRA)=0.
 2428   CONTINUE
 2429   CONTINUE
      ENDIF
C
C
C*         2.5     EXCHANGE WITH LOWER LIMIT
C                  -------------------------
C
 250  CONTINUE
C
      DO 251 JL = 1, KDLON
      ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
     S               *PFLUC(JL,2,1)-PBINT(JL,1)
 251  CONTINUE
C
      JK = 1
      IN=(JK-1)*NG1P1+1
C
      DO 252 JL = 1, KDLON
      ZCNSOL(JL)=PBSUR(JL,1)
     1 +PBSUR(JL,2)
     2 +PBSUR(JL,3)
     3 +PBSUR(JL,4)
     4 +PBSUR(JL,5)
     5 +PBSUR(JL,6)
      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
      PFLUC(JL,1,JK)=ZFU(JL)
 252  CONTINUE
C
      DO 257 JK = 2 , KFLEV+1
      IN=(JK-1)*NG1P1+1
C
C
      DO 255 JA=1,KUAER
      DO 254 JL=1, KDLON
      ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
 254  CONTINUE
 255  CONTINUE
C
C
      CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
C
      DO 256 JL = 1, KDLON
      ZCNSOL(JL)=PBSUR(JL,1)*ZTT(JL,1)          *ZTT(JL,10)
     2      +PBSUR(JL,2)*ZTT(JL,2)*ZTT(JL,7)*ZTT(JL,11)
     3      +PBSUR(JL,3)*ZTT(JL,4)*ZTT(JL,8)*ZTT(JL,12)
     4      +PBSUR(JL,4)*ZTT(JL,5)*ZTT(JL,9)*ZTT(JL,13)
     5      +PBSUR(JL,5)*ZTT(JL,3)          *ZTT(JL,14)
     6      +PBSUR(JL,6)*ZTT(JL,6)          *ZTT(JL,15)
      ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
      ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
      PFLUC(JL,1,JK)=ZFU(JL)
 256  CONTINUE
C
C
 257  CONTINUE
C
C
C
C*         2.7     CLEAR-SKY FLUXES
C                  ----------------
C
 270  CONTINUE
C
      IF (.NOT.LEVOIGT) THEN
      DO 271 JL = 1, KDLON
      ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
 271  CONTINUE
      DO 273 JK = JLIM+1,KFLEV+1
      DO 272 JL = 1, KDLON
      ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
      PFLUC(JL,1,JK) = ZFN10(JL)
      PFLUC(JL,2,JK) = 0.
 272  CONTINUE
 273  CONTINUE
      ENDIF
C
C     ------------------------------------------------------------------
C
      RETURN
      END
1	guez	24	SUBROUTINE LWVB(KUAER,KTRAER, KLIM
2			R , PABCU,PADJD,PADJU,PB,PBINT,PBSUI,PBSUR,PBTOP
3			R , PDISD,PDISU,PEMIS,PPMB
4			R , PGA,PGB,PGASUR,PGBSUR,PGATOP,PGBTOP
5			S , PCTS,PFLUC)
6			use dimens_m
7			use dimphy
8			use raddim
9			use radopt
10			use raddimlw
11			IMPLICIT none
12			C
13			C-----------------------------------------------------------------------
14			C PURPOSE.
15			C --------
16			C INTRODUCES THE EFFECTS OF THE BOUNDARIES IN THE VERTICAL
17			C INTEGRATION
18			C
19			C METHOD.
20			C -------
21			C
22			C 1. COMPUTES THE ENERGY EXCHANGE WITH TOP AND SURFACE OF THE
23			C ATMOSPHERE
24			C 2. COMPUTES THE COOLING-TO-SPACE AND HEATING-FROM-GROUND
25			C TERMS FOR THE APPROXIMATE COOLING RATE ABOVE 10 HPA
26			C 3. ADDS UP ALL CONTRIBUTIONS TO GET THE CLEAR-SKY FLUXES
27			C
28			C REFERENCE.
29			C ----------
30			C
31			C SEE RADIATION'S PART OF THE MODEL'S DOCUMENTATION AND
32			C ECMWF RESEARCH DEPARTMENT DOCUMENTATION OF THE IFS
33			C
34			C AUTHOR.
35			C -------
36			C JEAN-JACQUES MORCRETTE ECMWF
37			C
38			C MODIFICATIONS.
39			C --------------
40			C ORIGINAL : 89-07-14
41			C Voigt lines (loop 2413 to 2427) - JJM & PhD - 01/96
42			C-----------------------------------------------------------------------
43			C
44			C* 0.1 ARGUMENTS
45			C ---------
46			C
47			INTEGER KUAER,KTRAER, KLIM
48			C
49	guez	71	DOUBLE PRECISION PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
50			DOUBLE PRECISION PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
51			DOUBLE PRECISION PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
52			DOUBLE PRECISION PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
53			DOUBLE PRECISION PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
54			DOUBLE PRECISION PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
55			DOUBLE PRECISION PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
56			DOUBLE PRECISION PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
57			DOUBLE PRECISION PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
58			DOUBLE PRECISION PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
59			DOUBLE PRECISION PEMIS(KDLON) ! SURFACE EMISSIVITY
60			DOUBLE PRECISION PPMB(KDLON,KFLEV+1) ! PRESSURE MB
61			DOUBLE PRECISION PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
62			DOUBLE PRECISION PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
63			DOUBLE PRECISION PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
64			DOUBLE PRECISION PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
65			DOUBLE PRECISION PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
66			DOUBLE PRECISION PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
67	guez	24	C
68	guez	71	DOUBLE PRECISION PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
69			DOUBLE PRECISION PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
70	guez	24	C
71			C* LOCAL VARIABLES:
72			C
73	guez	71	DOUBLE PRECISION ZBGND(KDLON)
74			DOUBLE PRECISION ZFD(KDLON)
75			DOUBLE PRECISION ZFN10(KDLON)
76			DOUBLE PRECISION ZFU(KDLON)
77			DOUBLE PRECISION ZTT(KDLON,NTRA)
78			DOUBLE PRECISION ZTT1(KDLON,NTRA)
79			DOUBLE PRECISION ZTT2(KDLON,NTRA)
80			DOUBLE PRECISION ZUU(KDLON,NUA)
81			DOUBLE PRECISION ZCNSOL(KDLON)
82			DOUBLE PRECISION ZCNTOP(KDLON)
83	guez	24	C
84			INTEGER jk, jl, ja
85			INTEGER jstra, jstru
86			INTEGER ind1, ind2, ind3, ind4, in, jlim
87	guez	71	DOUBLE PRECISION zctstr
88	guez	24	C-----------------------------------------------------------------------
89			C
90			C* 1. INITIALIZATION
91			C --------------
92			C
93			100 CONTINUE
94			C
95			C
96			C* 1.2 INITIALIZE TRANSMISSION FUNCTIONS
97			C ---------------------------------
98			C
99			120 CONTINUE
100			C
101			DO 122 JA=1,NTRA
102			DO 121 JL=1, KDLON
103			ZTT (JL,JA)=1.0
104			ZTT1(JL,JA)=1.0
105			ZTT2(JL,JA)=1.0
106			121 CONTINUE
107			122 CONTINUE
108			C
109			DO 124 JA=1,NUA
110			DO 123 JL=1, KDLON
111			ZUU(JL,JA)=1.0
112			123 CONTINUE
113			124 CONTINUE
114			C
115			C ------------------------------------------------------------------
116			C
117			C* 2. VERTICAL INTEGRATION
118			C --------------------
119			C
120			200 CONTINUE
121			C
122			IND1=0
123			IND3=0
124			IND4=1
125			IND2=1
126			C
127			C
128			C* 2.3 EXCHANGE WITH TOP OF THE ATMOSPHERE
129			C -----------------------------------
130			C
131			230 CONTINUE
132			C
133			DO 235 JK = 1 , KFLEV
134			IN=(JK-1)*NG1P1+1
135			C
136			DO 232 JA=1,KUAER
137			DO 231 JL=1, KDLON
138			ZUU(JL,JA)=PABCU(JL,JA,IN)
139			231 CONTINUE
140			232 CONTINUE
141			C
142			C
143			CALL LWTT(PGATOP(1,1,1), PGBTOP(1,1,1), ZUU, ZTT)
144			C
145			DO 234 JL = 1, KDLON
146			ZCNTOP(JL)=PBTOP(JL,1)ZTT(JL,1) ZTT(JL,10)
147			2 +PBTOP(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
148			3 +PBTOP(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
149			4 +PBTOP(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
150			5 +PBTOP(JL,5)ZTT(JL,3) ZTT(JL,14)
151			6 +PBTOP(JL,6)ZTT(JL,6) ZTT(JL,15)
152			ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
153			PFLUC(JL,2,JK)=ZFD(JL)
154			234 CONTINUE
155			C
156			235 CONTINUE
157			C
158			JK = KFLEV+1
159			IN=(JK-1)*NG1P1+1
160			C
161			DO 236 JL = 1, KDLON
162			ZCNTOP(JL)= PBTOP(JL,1)
163			1 + PBTOP(JL,2)
164			2 + PBTOP(JL,3)
165			3 + PBTOP(JL,4)
166			4 + PBTOP(JL,5)
167			5 + PBTOP(JL,6)
168			ZFD(JL)=ZCNTOP(JL)-PBINT(JL,JK)-PDISD(JL,JK)-PADJD(JL,JK)
169			PFLUC(JL,2,JK)=ZFD(JL)
170			236 CONTINUE
171			C
172			C* 2.4 COOLING-TO-SPACE OF LAYERS ABOVE 10 HPA
173			C ---------------------------------------
174			C
175			240 CONTINUE
176			C
177			C
178			C* 2.4.1 INITIALIZATION
179			C --------------
180			C
181			2410 CONTINUE
182			C
183			JLIM = KFLEV
184			C
185			IF (.NOT.LEVOIGT) THEN
186			DO 2412 JK = KFLEV,1,-1
187			IF(PPMB(1,JK).LT.10.0) THEN
188			JLIM=JK
189			ENDIF
190			2412 CONTINUE
191			ENDIF
192			KLIM=JLIM
193			C
194			IF (.NOT.LEVOIGT) THEN
195			DO 2414 JA=1,KTRAER
196			DO 2413 JL=1, KDLON
197			ZTT1(JL,JA)=1.0
198			2413 CONTINUE
199			2414 CONTINUE
200			C
201			C* 2.4.2 LOOP OVER LAYERS ABOVE 10 HPA
202			C -----------------------------
203			C
204			2420 CONTINUE
205			C
206			DO 2427 JSTRA = KFLEV,JLIM,-1
207			JSTRU=(JSTRA-1)*NG1P1+1
208			C
209			DO 2423 JA=1,KUAER
210			DO 2422 JL=1, KDLON
211			ZUU(JL,JA)=PABCU(JL,JA,JSTRU)
212			2422 CONTINUE
213			2423 CONTINUE
214			C
215			C
216			CALL LWTT(PGA(1,1,1,JSTRA), PGB(1,1,1,JSTRA), ZUU, ZTT)
217			C
218			DO 2424 JL = 1, KDLON
219			ZCTSTR =
220			1 (PB(JL,1,JSTRA)+PB(JL,1,JSTRA+1))
221			1 (ZTT1(JL,1) ZTT1(JL,10)
222			1 - ZTT (JL,1) *ZTT (JL,10))
223			2 +(PB(JL,2,JSTRA)+PB(JL,2,JSTRA+1))
224			2 (ZTT1(JL,2)ZTT1(JL,7)*ZTT1(JL,11)
225			2 - ZTT (JL,2)ZTT (JL,7)ZTT (JL,11))
226			3 +(PB(JL,3,JSTRA)+PB(JL,3,JSTRA+1))
227			3 (ZTT1(JL,4)ZTT1(JL,8)*ZTT1(JL,12)
228			3 - ZTT (JL,4)ZTT (JL,8)ZTT (JL,12))
229			4 +(PB(JL,4,JSTRA)+PB(JL,4,JSTRA+1))
230			4 (ZTT1(JL,5)ZTT1(JL,9)*ZTT1(JL,13)
231			4 - ZTT (JL,5)ZTT (JL,9)ZTT (JL,13))
232			5 +(PB(JL,5,JSTRA)+PB(JL,5,JSTRA+1))
233			5 (ZTT1(JL,3) ZTT1(JL,14)
234			5 - ZTT (JL,3) *ZTT (JL,14))
235			6 +(PB(JL,6,JSTRA)+PB(JL,6,JSTRA+1))
236			6 (ZTT1(JL,6) ZTT1(JL,15)
237			6 - ZTT (JL,6) *ZTT (JL,15))
238			PCTS(JL,JSTRA)=ZCTSTR*0.5
239			2424 CONTINUE
240			DO 2426 JA=1,KTRAER
241			DO 2425 JL=1, KDLON
242			ZTT1(JL,JA)=ZTT(JL,JA)
243			2425 CONTINUE
244			2426 CONTINUE
245			2427 CONTINUE
246			ENDIF
247			C Mise a zero de securite pour PCTS en cas de LEVOIGT
248			IF(LEVOIGT)THEN
249			DO 2429 JSTRA = 1,KFLEV
250			DO 2428 JL = 1, KDLON
251			PCTS(JL,JSTRA)=0.
252			2428 CONTINUE
253			2429 CONTINUE
254			ENDIF
255			C
256			C
257			C* 2.5 EXCHANGE WITH LOWER LIMIT
258			C -------------------------
259			C
260			250 CONTINUE
261			C
262			DO 251 JL = 1, KDLON
263			ZBGND(JL)=PBSUI(JL)*PEMIS(JL)-(1.-PEMIS(JL))
264			S *PFLUC(JL,2,1)-PBINT(JL,1)
265			251 CONTINUE
266			C
267			JK = 1
268			IN=(JK-1)*NG1P1+1
269			C
270			DO 252 JL = 1, KDLON
271			ZCNSOL(JL)=PBSUR(JL,1)
272			1 +PBSUR(JL,2)
273			2 +PBSUR(JL,3)
274			3 +PBSUR(JL,4)
275			4 +PBSUR(JL,5)
276			5 +PBSUR(JL,6)
277			ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
278			ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
279			PFLUC(JL,1,JK)=ZFU(JL)
280			252 CONTINUE
281			C
282			DO 257 JK = 2 , KFLEV+1
283			IN=(JK-1)*NG1P1+1
284			C
285			C
286			DO 255 JA=1,KUAER
287			DO 254 JL=1, KDLON
288			ZUU(JL,JA)=PABCU(JL,JA,1)-PABCU(JL,JA,IN)
289			254 CONTINUE
290			255 CONTINUE
291			C
292			C
293			CALL LWTT(PGASUR(1,1,1), PGBSUR(1,1,1), ZUU, ZTT)
294			C
295			DO 256 JL = 1, KDLON
296			ZCNSOL(JL)=PBSUR(JL,1)ZTT(JL,1) ZTT(JL,10)
297			2 +PBSUR(JL,2)ZTT(JL,2)ZTT(JL,7)*ZTT(JL,11)
298			3 +PBSUR(JL,3)ZTT(JL,4)ZTT(JL,8)*ZTT(JL,12)
299			4 +PBSUR(JL,4)ZTT(JL,5)ZTT(JL,9)*ZTT(JL,13)
300			5 +PBSUR(JL,5)ZTT(JL,3) ZTT(JL,14)
301			6 +PBSUR(JL,6)ZTT(JL,6) ZTT(JL,15)
302			ZCNSOL(JL)=ZCNSOL(JL)*ZBGND(JL)/PBSUI(JL)
303			ZFU(JL)=ZCNSOL(JL)+PBINT(JL,JK)-PDISU(JL,JK)-PADJU(JL,JK)
304			PFLUC(JL,1,JK)=ZFU(JL)
305			256 CONTINUE
306			C
307			C
308			257 CONTINUE
309			C
310			C
311			C
312			C* 2.7 CLEAR-SKY FLUXES
313			C ----------------
314			C
315			270 CONTINUE
316			C
317			IF (.NOT.LEVOIGT) THEN
318			DO 271 JL = 1, KDLON
319			ZFN10(JL) = PFLUC(JL,1,JLIM) + PFLUC(JL,2,JLIM)
320			271 CONTINUE
321			DO 273 JK = JLIM+1,KFLEV+1
322			DO 272 JL = 1, KDLON
323			ZFN10(JL) = ZFN10(JL) + PCTS(JL,JK-1)
324			PFLUC(JL,1,JK) = ZFN10(JL)
325			PFLUC(JL,2,JK) = 0.
326			272 CONTINUE
327			273 CONTINUE
328			ENDIF
329			C
330			C ------------------------------------------------------------------
331			C
332			RETURN
333			END