/[lmdze]/trunk/Sources/phylmd/Radlwsw/swr.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/swr.f

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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