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
      REAL*8 PABCU(KDLON,NUA,3*KFLEV+1) ! ABSORBER AMOUNTS
      REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
      REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
      REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
      REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
      REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
      REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
      REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
      REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
      REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
      REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
      REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
      REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
      REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
      REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
      REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
      REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
C
      REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
      REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
C
C* LOCAL VARIABLES:
C
      REAL*8 ZBGND(KDLON)
      REAL*8 ZFD(KDLON)
      REAL*8  ZFN10(KDLON)
      REAL*8 ZFU(KDLON)
      REAL*8  ZTT(KDLON,NTRA)
      REAL*8 ZTT1(KDLON,NTRA)
      REAL*8 ZTT2(KDLON,NTRA)
      REAL*8  ZUU(KDLON,NUA) 
      REAL*8 ZCNSOL(KDLON)
      REAL*8 ZCNTOP(KDLON)
C
      INTEGER jk, jl, ja
      INTEGER jstra, jstru
      INTEGER ind1, ind2, ind3, ind4, in, jlim
      REAL*8 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			REAL8 PABCU(KDLON,NUA,3KFLEV+1) ! ABSORBER AMOUNTS
50			REAL*8 PADJD(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
51			REAL*8 PADJU(KDLON,KFLEV+1) ! CONTRIBUTION BY ADJACENT LAYERS
52			REAL*8 PB(KDLON,Ninter,KFLEV+1) ! SPECTRAL HALF-LEVEL PLANCK FUNCTIONS
53			REAL*8 PBINT(KDLON,KFLEV+1) ! HALF-LEVEL PLANCK FUNCTIONS
54			REAL*8 PBSUR(KDLON,Ninter) ! SPECTRAL SURFACE PLANCK FUNCTION
55			REAL*8 PBSUI(KDLON) ! SURFACE PLANCK FUNCTION
56			REAL*8 PBTOP(KDLON,Ninter) ! SPECTRAL T.O.A. PLANCK FUNCTION
57			REAL*8 PDISD(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
58			REAL*8 PDISU(KDLON,KFLEV+1) ! CONTRIBUTION BY DISTANT LAYERS
59			REAL*8 PEMIS(KDLON) ! SURFACE EMISSIVITY
60			REAL*8 PPMB(KDLON,KFLEV+1) ! PRESSURE MB
61			REAL*8 PGA(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
62			REAL*8 PGB(KDLON,8,2,KFLEV) ! PADE APPROXIMANTS
63			REAL*8 PGASUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
64			REAL*8 PGBSUR(KDLON,8,2) ! SURFACE PADE APPROXIMANTS
65			REAL*8 PGATOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
66			REAL*8 PGBTOP(KDLON,8,2) ! T.O.A. PADE APPROXIMANTS
67			C
68			REAL*8 PFLUC(KDLON,2,KFLEV+1) ! CLEAR-SKY RADIATIVE FLUXES
69			REAL*8 PCTS(KDLON,KFLEV) ! COOLING-TO-SPACE TERM
70			C
71			C* LOCAL VARIABLES:
72			C
73			REAL*8 ZBGND(KDLON)
74			REAL*8 ZFD(KDLON)
75			REAL*8 ZFN10(KDLON)
76			REAL*8 ZFU(KDLON)
77			REAL*8 ZTT(KDLON,NTRA)
78			REAL*8 ZTT1(KDLON,NTRA)
79			REAL*8 ZTT2(KDLON,NTRA)
80			REAL*8 ZUU(KDLON,NUA)
81			REAL*8 ZCNSOL(KDLON)
82			REAL*8 ZCNTOP(KDLON)
83			C
84			INTEGER jk, jl, ja
85			INTEGER jstra, jstru
86			INTEGER ind1, ind2, ind3, ind4, in, jlim
87			REAL*8 zctstr
88			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