phylmd/Radlwsw/swr.f

      SUBROUTINE SWR ( KNU
     S  , PALBD , PCG   , PCLD , PDSIG, POMEGA, PRAYL
     S  , PSEC  , PTAU
     S  , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ  , PRK , PRMUE
     S  , PTAUAZ, PTRA1 , PTRA2 )
      use dimens_m
      use dimphy
      use raddim
      use radepsi
      use radopt
      IMPLICIT none
C
C     ------------------------------------------------------------------
C     PURPOSE.
C     --------
C           COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
C     CONTINUUM SCATTERING
C
C     METHOD.
C     -------
C
C          1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
C     OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
C
C     REFERENCE.
C     ----------
C
C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
C
C     AUTHOR.
C     -------
C        JEAN-JACQUES MORCRETTE  *ECMWF*
C
C     MODIFICATIONS.
C     --------------
C        ORIGINAL : 89-07-14
C     ------------------------------------------------------------------
C* ARGUMENTS:
C
      INTEGER KNU
      REAL*8 PALBD(KDLON,2)
      REAL*8 PCG(KDLON,2,KFLEV)
      REAL*8 PCLD(KDLON,KFLEV)
      REAL*8 PDSIG(KDLON,KFLEV)
      REAL*8 POMEGA(KDLON,2,KFLEV)
      REAL*8 PRAYL(KDLON)
      REAL*8 PSEC(KDLON)
      REAL*8 PTAU(KDLON,2,KFLEV)
C
      REAL*8 PRAY1(KDLON,KFLEV+1)
      REAL*8 PRAY2(KDLON,KFLEV+1)
      REAL*8 PREFZ(KDLON,2,KFLEV+1)
      REAL*8 PRJ(KDLON,6,KFLEV+1)
      REAL*8 PRK(KDLON,6,KFLEV+1)
      REAL*8 PRMUE(KDLON,KFLEV+1)
      REAL*8 PCGAZ(KDLON,KFLEV)
      REAL*8 PPIZAZ(KDLON,KFLEV)
      REAL*8 PTAUAZ(KDLON,KFLEV)
      REAL*8 PTRA1(KDLON,KFLEV+1)
      REAL*8 PTRA2(KDLON,KFLEV+1)
C
C* LOCAL VARIABLES:
C
      REAL*8 ZC1I(KDLON,KFLEV+1)
      REAL*8 ZCLEQ(KDLON,KFLEV)
      REAL*8 ZCLEAR(KDLON)
      REAL*8 ZCLOUD(KDLON)
      REAL*8 ZGG(KDLON)
      REAL*8 ZREF(KDLON)
      REAL*8 ZRE1(KDLON)
      REAL*8 ZRE2(KDLON)
      REAL*8 ZRMUZ(KDLON)
      REAL*8 ZRNEB(KDLON)
      REAL*8 ZR21(KDLON)
      REAL*8 ZR22(KDLON)
      REAL*8 ZR23(KDLON)
      REAL*8 ZSS1(KDLON)
      REAL*8 ZTO1(KDLON)
      REAL*8 ZTR(KDLON,2,KFLEV+1)
      REAL*8 ZTR1(KDLON)
      REAL*8 ZTR2(KDLON)
      REAL*8 ZW(KDLON)
C
      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
      REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
      REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
      REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
C
C     ------------------------------------------------------------------
C
C*         1.    INITIALIZATION
C                --------------
C
 100  CONTINUE
C
      DO 103 JK = 1 , KFLEV+1
      DO 102 JA = 1 , 6
      DO 101 JL = 1, KDLON
      PRJ(JL,JA,JK) = 0.
      PRK(JL,JA,JK) = 0.
 101  CONTINUE
 102  CONTINUE
 103  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
C                ----------------------------------------------
C
 200  CONTINUE
C
      DO 201 JL = 1, KDLON
      ZR23(JL) = 0.
      ZC1I(JL,KFLEV+1) = 0.
      ZCLEAR(JL) = 1.
      ZCLOUD(JL) = 0.
 201  CONTINUE
C
      JK = 1
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 202 JL = 1, KDLON
      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
     S                                 * PCG(JL,KNU,JKL)
      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
      ZR21(JL) = EXP(-ZCORAE   )
      ZR22(JL) = EXP(-ZCORCD   )
      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
      ZCLEQ(JL,JKL) = ZSS1(JL)
C
      IF (NOVLP.EQ.1) THEN
c* maximum-random
         ZCLEAR(JL) = ZCLEAR(JL)
     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
         ZCLOUD(JL) = ZSS1(JL)
      ELSE IF (NOVLP.EQ.2) THEN
C* maximum
         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
         ZC1I(JL,JKL) = ZCLOUD(JL)
      ELSE IF (NOVLP.EQ.3) THEN
c* random
         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
         ZC1I(JL,JKL) = ZCLOUD(JL)
      END IF
 202  CONTINUE
C
      DO 205 JK = 2 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 204 JL = 1, KDLON
      ZFACOA = 1. - PPIZAZ(JL,JKL)*PCGAZ(JL,JKL)*PCGAZ(JL,JKL)
      ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
     S                                 * PCG(JL,KNU,JKL)
      ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
      ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
      ZR21(JL) = EXP(-ZCORAE   )
      ZR22(JL) = EXP(-ZCORCD   )
      ZSS1(JL) = PCLD(JL,JKL)*(1.0-ZR21(JL)*ZR22(JL))
     S               + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
      ZCLEQ(JL,JKL) = ZSS1(JL)
c     
      IF (NOVLP.EQ.1) THEN
c* maximum-random
         ZCLEAR(JL) = ZCLEAR(JL)
     S                  *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
     S                  /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
         ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
         ZCLOUD(JL) = ZSS1(JL)
      ELSE IF (NOVLP.EQ.2) THEN
C* maximum
         ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
         ZC1I(JL,JKL) = ZCLOUD(JL)
      ELSE IF (NOVLP.EQ.3) THEN
c* random
         ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
         ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
         ZC1I(JL,JKL) = ZCLOUD(JL)
      END IF
 204  CONTINUE
 205  CONTINUE
C
C     ------------------------------------------------------------------
C
C*         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
C                -----------------------------------------------
C
 300  CONTINUE
C
      DO 301 JL = 1, KDLON
      PRAY1(JL,KFLEV+1) = 0.
      PRAY2(JL,KFLEV+1) = 0.
      PREFZ(JL,2,1) = PALBD(JL,KNU)
      PREFZ(JL,1,1) = PALBD(JL,KNU)
      PTRA1(JL,KFLEV+1) = 1.
      PTRA2(JL,KFLEV+1) = 1.
 301  CONTINUE
C
      DO 346 JK = 2 , KFLEV+1
      JKM1 = JK-1
      DO 342 JL = 1, KDLON
      ZRNEB(JL)= PCLD(JL,JKM1)
      ZRE1(JL)=0.
      ZTR1(JL)=0.
      ZRE2(JL)=0.
      ZTR2(JL)=0.
C
C
C     ------------------------------------------------------------------
C
C*         3.1  EQUIVALENT ZENITH ANGLE
C               -----------------------
C
 310  CONTINUE
C
      ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
     S            + ZC1I(JL,JK) * 1.66
      PRMUE(JL,JK) = 1./ZMUE
C
C
C     ------------------------------------------------------------------
C
C*         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
C               ----------------------------------------------------
C
 320  CONTINUE
C
      ZGAP = PCGAZ(JL,JKM1)
      ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
      ZWW = PPIZAZ(JL,JKM1)
      ZTO = PTAUAZ(JL,JKM1)
      ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU0*ZWW)*ZTO*ZTO*ZMUE*ZMUE
      PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
      PTRA1(JL,JKM1) = 1. / ZDEN
c      PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
C
      ZMU1 = 0.5
      ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
      ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
     S       + (1-ZWW) * (1. - ZWW +2.*ZBMU1*ZWW)*ZTO*ZTO/ZMU1/ZMU1
      PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
      PTRA2(JL,JKM1) = 1. / ZDEN1
C
C
C     ------------------------------------------------------------------
C
C*         3.3  EFFECT OF CLOUD LAYER
C               ---------------------
C
 330  CONTINUE
C
      ZW(JL) = POMEGA(JL,KNU,JKM1)
      ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
     S         + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
      ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
      ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
      ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
     S              + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
C Modif PhD - JJM 19/03/96 pour erreurs arrondis
C machine
C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
      IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
         ZW(JL)=1.
      ELSE
         ZW(JL) = ZR21(JL) / ZTO1(JL)
      END IF
      ZREF(JL) = PREFZ(JL,1,JKM1)
      ZRMUZ(JL) = PRMUE(JL,JK)
 342  CONTINUE
C
      CALL SWDE(ZGG  , ZREF  , ZRMUZ , ZTO1 , ZW,
     S          ZRE1 , ZRE2  , ZTR1  , ZTR2)
C
      DO 345 JL = 1, KDLON
C
      PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
     S               + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
     S               * PTRA2(JL,JKM1)
     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
     S               + ZRNEB(JL) * ZRE2(JL)
C
      ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
     S               / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
     S               * (1.-ZRNEB(JL))
C
      PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
     S               + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
     S               * PTRA2(JL,JKM1) )
     S               + ZRNEB(JL) * ZRE1(JL)
C
      ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
     S               + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
C
 345  CONTINUE
 346  CONTINUE
      DO 347 JL = 1, KDLON
      ZMUE = (1.-ZC1I(JL,1))*PSEC(JL)+ZC1I(JL,1)*1.66
      PRMUE(JL,1)=1./ZMUE
 347  CONTINUE
C
C
C     ------------------------------------------------------------------
C
C*         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
C                 -------------------------------------------------
C
 350  CONTINUE
C
      IF (KNU.EQ.1) THEN
      JAJ = 2
      DO 351 JL = 1, KDLON
      PRJ(JL,JAJ,KFLEV+1) = 1.
      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
 351  CONTINUE
C
      DO 353 JK = 1 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 352 JL = 1, KDLON
      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,  1,JKL)
      PRJ(JL,JAJ,JKL) = ZRE11
      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,  1,JKL)
 352  CONTINUE
 353  CONTINUE
 354  CONTINUE
C
      ELSE
C
      DO 358 JAJ = 1 , 2
      DO 355 JL = 1, KDLON
      PRJ(JL,JAJ,KFLEV+1) = 1.
      PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
 355  CONTINUE
C
      DO 357 JK = 1 , KFLEV
      JKL = KFLEV+1 - JK
      JKLP1 = JKL + 1
      DO 356 JL = 1, KDLON
      ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
      PRJ(JL,JAJ,JKL) = ZRE11
      PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
 356  CONTINUE
 357  CONTINUE
 358  CONTINUE
C
      END IF
C
C     ------------------------------------------------------------------
C
      RETURN
      END
1	guez	24	SUBROUTINE SWR ( KNU
2			S , PALBD , PCG , PCLD , PDSIG, POMEGA, PRAYL
3			S , PSEC , PTAU
4			S , PCGAZ , PPIZAZ, PRAY1, PRAY2, PREFZ , PRJ , PRK , PRMUE
5			S , PTAUAZ, PTRA1 , PTRA2 )
6			use dimens_m
7			use dimphy
8			use raddim
9			use radepsi
10			use radopt
11			IMPLICIT none
12			C
13			C ------------------------------------------------------------------
14			C PURPOSE.
15			C --------
16			C COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
17			C CONTINUUM SCATTERING
18			C
19			C METHOD.
20			C -------
21			C
22			C 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
23			C OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
24			C
25			C REFERENCE.
26			C ----------
27			C
28			C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
29			C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
30			C
31			C AUTHOR.
32			C -------
33			C JEAN-JACQUES MORCRETTE ECMWF
34			C
35			C MODIFICATIONS.
36			C --------------
37			C ORIGINAL : 89-07-14
38			C ------------------------------------------------------------------
39			C* ARGUMENTS:
40			C
41			INTEGER KNU
42			REAL*8 PALBD(KDLON,2)
43			REAL*8 PCG(KDLON,2,KFLEV)
44			REAL*8 PCLD(KDLON,KFLEV)
45			REAL*8 PDSIG(KDLON,KFLEV)
46			REAL*8 POMEGA(KDLON,2,KFLEV)
47			REAL*8 PRAYL(KDLON)
48			REAL*8 PSEC(KDLON)
49			REAL*8 PTAU(KDLON,2,KFLEV)
50			C
51			REAL*8 PRAY1(KDLON,KFLEV+1)
52			REAL*8 PRAY2(KDLON,KFLEV+1)
53			REAL*8 PREFZ(KDLON,2,KFLEV+1)
54			REAL*8 PRJ(KDLON,6,KFLEV+1)
55			REAL*8 PRK(KDLON,6,KFLEV+1)
56			REAL*8 PRMUE(KDLON,KFLEV+1)
57			REAL*8 PCGAZ(KDLON,KFLEV)
58			REAL*8 PPIZAZ(KDLON,KFLEV)
59			REAL*8 PTAUAZ(KDLON,KFLEV)
60			REAL*8 PTRA1(KDLON,KFLEV+1)
61			REAL*8 PTRA2(KDLON,KFLEV+1)
62			C
63			C* LOCAL VARIABLES:
64			C
65			REAL*8 ZC1I(KDLON,KFLEV+1)
66			REAL*8 ZCLEQ(KDLON,KFLEV)
67			REAL*8 ZCLEAR(KDLON)
68			REAL*8 ZCLOUD(KDLON)
69			REAL*8 ZGG(KDLON)
70			REAL*8 ZREF(KDLON)
71			REAL*8 ZRE1(KDLON)
72			REAL*8 ZRE2(KDLON)
73			REAL*8 ZRMUZ(KDLON)
74			REAL*8 ZRNEB(KDLON)
75			REAL*8 ZR21(KDLON)
76			REAL*8 ZR22(KDLON)
77			REAL*8 ZR23(KDLON)
78			REAL*8 ZSS1(KDLON)
79			REAL*8 ZTO1(KDLON)
80			REAL*8 ZTR(KDLON,2,KFLEV+1)
81			REAL*8 ZTR1(KDLON)
82			REAL*8 ZTR2(KDLON)
83			REAL*8 ZW(KDLON)
84			C
85			INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
86			REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD
87			REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1
88			REAL*8 ZMU1, ZRE11, ZBMU0, ZBMU1
89			C
90			C ------------------------------------------------------------------
91			C
92			C* 1. INITIALIZATION
93			C --------------
94			C
95			100 CONTINUE
96			C
97			DO 103 JK = 1 , KFLEV+1
98			DO 102 JA = 1 , 6
99			DO 101 JL = 1, KDLON
100			PRJ(JL,JA,JK) = 0.
101			PRK(JL,JA,JK) = 0.
102			101 CONTINUE
103			102 CONTINUE
104			103 CONTINUE
105			C
106			C
107			C ------------------------------------------------------------------
108			C
109			C* 2. TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
110			C ----------------------------------------------
111			C
112			200 CONTINUE
113			C
114			DO 201 JL = 1, KDLON
115			ZR23(JL) = 0.
116			ZC1I(JL,KFLEV+1) = 0.
117			ZCLEAR(JL) = 1.
118			ZCLOUD(JL) = 0.
119			201 CONTINUE
120			C
121			JK = 1
122			JKL = KFLEV+1 - JK
123			JKLP1 = JKL + 1
124			DO 202 JL = 1, KDLON
125			ZFACOA = 1. - PPIZAZ(JL,JKL)PCGAZ(JL,JKL)PCGAZ(JL,JKL)
126			ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
127			S * PCG(JL,KNU,JKL)
128			ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
129			ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
130			ZR21(JL) = EXP(-ZCORAE )
131			ZR22(JL) = EXP(-ZCORCD )
132			ZSS1(JL) = PCLD(JL,JKL)(1.0-ZR21(JL)ZR22(JL))
133			S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
134			ZCLEQ(JL,JKL) = ZSS1(JL)
135			C
136			IF (NOVLP.EQ.1) THEN
137			c* maximum-random
138			ZCLEAR(JL) = ZCLEAR(JL)
139			S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
140			S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
141			ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
142			ZCLOUD(JL) = ZSS1(JL)
143			ELSE IF (NOVLP.EQ.2) THEN
144			C* maximum
145			ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
146			ZC1I(JL,JKL) = ZCLOUD(JL)
147			ELSE IF (NOVLP.EQ.3) THEN
148			c* random
149			ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
150			ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
151			ZC1I(JL,JKL) = ZCLOUD(JL)
152			END IF
153			202 CONTINUE
154			C
155			DO 205 JK = 2 , KFLEV
156			JKL = KFLEV+1 - JK
157			JKLP1 = JKL + 1
158			DO 204 JL = 1, KDLON
159			ZFACOA = 1. - PPIZAZ(JL,JKL)PCGAZ(JL,JKL)PCGAZ(JL,JKL)
160			ZFACOC = 1. - POMEGA(JL,KNU,JKL) * PCG(JL,KNU,JKL)
161			S * PCG(JL,KNU,JKL)
162			ZCORAE = ZFACOA * PTAUAZ(JL,JKL) * PSEC(JL)
163			ZCORCD = ZFACOC * PTAU(JL,KNU,JKL) * PSEC(JL)
164			ZR21(JL) = EXP(-ZCORAE )
165			ZR22(JL) = EXP(-ZCORCD )
166			ZSS1(JL) = PCLD(JL,JKL)(1.0-ZR21(JL)ZR22(JL))
167			S + (1.0-PCLD(JL,JKL))*(1.0-ZR21(JL))
168			ZCLEQ(JL,JKL) = ZSS1(JL)
169			c
170			IF (NOVLP.EQ.1) THEN
171			c* maximum-random
172			ZCLEAR(JL) = ZCLEAR(JL)
173			S *(1.0-MAX(ZSS1(JL),ZCLOUD(JL)))
174			S /(1.0-MIN(ZCLOUD(JL),1.-ZEPSEC))
175			ZC1I(JL,JKL) = 1.0 - ZCLEAR(JL)
176			ZCLOUD(JL) = ZSS1(JL)
177			ELSE IF (NOVLP.EQ.2) THEN
178			C* maximum
179			ZCLOUD(JL) = MAX( ZSS1(JL) , ZCLOUD(JL) )
180			ZC1I(JL,JKL) = ZCLOUD(JL)
181			ELSE IF (NOVLP.EQ.3) THEN
182			c* random
183			ZCLEAR(JL) = ZCLEAR(JL)*(1.0 - ZSS1(JL))
184			ZCLOUD(JL) = 1.0 - ZCLEAR(JL)
185			ZC1I(JL,JKL) = ZCLOUD(JL)
186			END IF
187			204 CONTINUE
188			205 CONTINUE
189			C
190			C ------------------------------------------------------------------
191			C
192			C* 3. REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
193			C -----------------------------------------------
194			C
195			300 CONTINUE
196			C
197			DO 301 JL = 1, KDLON
198			PRAY1(JL,KFLEV+1) = 0.
199			PRAY2(JL,KFLEV+1) = 0.
200			PREFZ(JL,2,1) = PALBD(JL,KNU)
201			PREFZ(JL,1,1) = PALBD(JL,KNU)
202			PTRA1(JL,KFLEV+1) = 1.
203			PTRA2(JL,KFLEV+1) = 1.
204			301 CONTINUE
205			C
206			DO 346 JK = 2 , KFLEV+1
207			JKM1 = JK-1
208			DO 342 JL = 1, KDLON
209			ZRNEB(JL)= PCLD(JL,JKM1)
210			ZRE1(JL)=0.
211			ZTR1(JL)=0.
212			ZRE2(JL)=0.
213			ZTR2(JL)=0.
214			C
215			C
216			C ------------------------------------------------------------------
217			C
218			C* 3.1 EQUIVALENT ZENITH ANGLE
219			C -----------------------
220			C
221			310 CONTINUE
222			C
223			ZMUE = (1.-ZC1I(JL,JK)) * PSEC(JL)
224			S + ZC1I(JL,JK) * 1.66
225			PRMUE(JL,JK) = 1./ZMUE
226			C
227			C
228			C ------------------------------------------------------------------
229			C
230			C* 3.2 REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
231			C ----------------------------------------------------
232			C
233			320 CONTINUE
234			C
235			ZGAP = PCGAZ(JL,JKM1)
236			ZBMU0 = 0.5 - 0.75 * ZGAP / ZMUE
237			ZWW = PPIZAZ(JL,JKM1)
238			ZTO = PTAUAZ(JL,JKM1)
239			ZDEN = 1. + (1. - ZWW + ZBMU0 * ZWW) * ZTO * ZMUE
240			S + (1-ZWW) * (1. - ZWW +2.ZBMU0ZWW)ZTOZTOZMUEZMUE
241			PRAY1(JL,JKM1) = ZBMU0 * ZWW * ZTO * ZMUE / ZDEN
242			PTRA1(JL,JKM1) = 1. / ZDEN
243			c PRINT ,' LOOP 342 * 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
244			C
245			ZMU1 = 0.5
246			ZBMU1 = 0.5 - 0.75 * ZGAP * ZMU1
247			ZDEN1= 1. + (1. - ZWW + ZBMU1 * ZWW) * ZTO / ZMU1
248			S + (1-ZWW) * (1. - ZWW +2.ZBMU1ZWW)ZTOZTO/ZMU1/ZMU1
249			PRAY2(JL,JKM1) = ZBMU1 * ZWW * ZTO / ZMU1 / ZDEN1
250			PTRA2(JL,JKM1) = 1. / ZDEN1
251			C
252			C
253			C ------------------------------------------------------------------
254			C
255			C* 3.3 EFFECT OF CLOUD LAYER
256			C ---------------------
257			C
258			330 CONTINUE
259			C
260			ZW(JL) = POMEGA(JL,KNU,JKM1)
261			ZTO1(JL) = PTAU(JL,KNU,JKM1)/ZW(JL)
262			S + PTAUAZ(JL,JKM1)/PPIZAZ(JL,JKM1)
263			ZR21(JL) = PTAU(JL,KNU,JKM1) + PTAUAZ(JL,JKM1)
264			ZR22(JL) = PTAU(JL,KNU,JKM1) / ZR21(JL)
265			ZGG(JL) = ZR22(JL) * PCG(JL,KNU,JKM1)
266			S + (1. - ZR22(JL)) * PCGAZ(JL,JKM1)
267			C Modif PhD - JJM 19/03/96 pour erreurs arrondis
268			C machine
269			C PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
270			IF (ZW(JL).EQ.1. .AND. PPIZAZ(JL,JKM1).EQ.1.) THEN
271			ZW(JL)=1.
272			ELSE
273			ZW(JL) = ZR21(JL) / ZTO1(JL)
274			END IF
275			ZREF(JL) = PREFZ(JL,1,JKM1)
276			ZRMUZ(JL) = PRMUE(JL,JK)
277			342 CONTINUE
278			C
279			CALL SWDE(ZGG , ZREF , ZRMUZ , ZTO1 , ZW,
280			S ZRE1 , ZRE2 , ZTR1 , ZTR2)
281			C
282			DO 345 JL = 1, KDLON
283			C
284			PREFZ(JL,1,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
285			S + PREFZ(JL,1,JKM1) * PTRA1(JL,JKM1)
286			S * PTRA2(JL,JKM1)
287			S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
288			S + ZRNEB(JL) * ZRE2(JL)
289			C
290			ZTR(JL,1,JKM1) = ZRNEB(JL) * ZTR2(JL) + (PTRA1(JL,JKM1)
291			S / (1.-PRAY2(JL,JKM1)*PREFZ(JL,1,JKM1)))
292			S * (1.-ZRNEB(JL))
293			C
294			PREFZ(JL,2,JK) = (1.-ZRNEB(JL)) * (PRAY1(JL,JKM1)
295			S + PREFZ(JL,2,JKM1) * PTRA1(JL,JKM1)
296			S * PTRA2(JL,JKM1) )
297			S + ZRNEB(JL) * ZRE1(JL)
298			C
299			ZTR(JL,2,JKM1) = ZRNEB(JL) * ZTR1(JL)
300			S + PTRA1(JL,JKM1) * (1.-ZRNEB(JL))
301			C
302			345 CONTINUE
303			346 CONTINUE
304			DO 347 JL = 1, KDLON
305			ZMUE = (1.-ZC1I(JL,1))PSEC(JL)+ZC1I(JL,1)1.66
306			PRMUE(JL,1)=1./ZMUE
307			347 CONTINUE
308			C
309			C
310			C ------------------------------------------------------------------
311			C
312			C* 3.5 REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
313			C -------------------------------------------------
314			C
315			350 CONTINUE
316			C
317			IF (KNU.EQ.1) THEN
318			JAJ = 2
319			DO 351 JL = 1, KDLON
320			PRJ(JL,JAJ,KFLEV+1) = 1.
321			PRK(JL,JAJ,KFLEV+1) = PREFZ(JL, 1,KFLEV+1)
322			351 CONTINUE
323			C
324			DO 353 JK = 1 , KFLEV
325			JKL = KFLEV+1 - JK
326			JKLP1 = JKL + 1
327			DO 352 JL = 1, KDLON
328			ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL, 1,JKL)
329			PRJ(JL,JAJ,JKL) = ZRE11
330			PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL, 1,JKL)
331			352 CONTINUE
332			353 CONTINUE
333			354 CONTINUE
334			C
335			ELSE
336			C
337			DO 358 JAJ = 1 , 2
338			DO 355 JL = 1, KDLON
339			PRJ(JL,JAJ,KFLEV+1) = 1.
340			PRK(JL,JAJ,KFLEV+1) = PREFZ(JL,JAJ,KFLEV+1)
341			355 CONTINUE
342			C
343			DO 357 JK = 1 , KFLEV
344			JKL = KFLEV+1 - JK
345			JKLP1 = JKL + 1
346			DO 356 JL = 1, KDLON
347			ZRE11= PRJ(JL,JAJ,JKLP1) * ZTR(JL,JAJ,JKL)
348			PRJ(JL,JAJ,JKL) = ZRE11
349			PRK(JL,JAJ,JKL) = ZRE11 * PREFZ(JL,JAJ,JKL)
350			356 CONTINUE
351			357 CONTINUE
352			358 CONTINUE
353			C
354			END IF
355			C
356			C ------------------------------------------------------------------
357			C
358			RETURN
359			END