/[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 24 by guez, Wed Mar 3 13:23:49 2010 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        REAL*8 PALBD(KDLON,2)    DOUBLE PRECISION pcld(kdlon, kflev)
43        REAL*8 PCG(KDLON,2,KFLEV)    DOUBLE PRECISION pdsig(kdlon, kflev)
44        REAL*8 PCLD(KDLON,KFLEV)    DOUBLE PRECISION pomega(kdlon, 2, kflev)
45        REAL*8 PDSIG(KDLON,KFLEV)    DOUBLE PRECISION prayl(kdlon)
46        REAL*8 POMEGA(KDLON,2,KFLEV)    DOUBLE PRECISION psec(kdlon)
47        REAL*8 PRAYL(KDLON)    DOUBLE PRECISION ptau(kdlon, 2, kflev)
48        REAL*8 PSEC(KDLON)  
49        REAL*8 PTAU(KDLON,2,KFLEV)    DOUBLE PRECISION pray1(kdlon, kflev+1)
50  C    DOUBLE PRECISION pray2(kdlon, kflev+1)
51        REAL*8 PRAY1(KDLON,KFLEV+1)    DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
52        REAL*8 PRAY2(KDLON,KFLEV+1)    DOUBLE PRECISION prj(kdlon, 6, kflev+1)
53        REAL*8 PREFZ(KDLON,2,KFLEV+1)    DOUBLE PRECISION prk(kdlon, 6, kflev+1)
54        REAL*8 PRJ(KDLON,6,KFLEV+1)    DOUBLE PRECISION prmue(kdlon, kflev+1)
55        REAL*8 PRK(KDLON,6,KFLEV+1)    DOUBLE PRECISION pcgaz(kdlon, kflev)
56        REAL*8 PRMUE(KDLON,KFLEV+1)    DOUBLE PRECISION ppizaz(kdlon, kflev)
57        REAL*8 PCGAZ(KDLON,KFLEV)    DOUBLE PRECISION ptauaz(kdlon, kflev)
58        REAL*8 PPIZAZ(KDLON,KFLEV)    DOUBLE PRECISION ptra1(kdlon, kflev+1)
59        REAL*8 PTAUAZ(KDLON,KFLEV)    DOUBLE PRECISION ptra2(kdlon, kflev+1)
60        REAL*8 PTRA1(KDLON,KFLEV+1)  
61        REAL*8 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        REAL*8 ZC1I(KDLON,KFLEV+1)    DOUBLE PRECISION zclear(kdlon)
66        REAL*8 ZCLEQ(KDLON,KFLEV)    DOUBLE PRECISION zcloud(kdlon)
67        REAL*8 ZCLEAR(KDLON)    DOUBLE PRECISION zgg(kdlon)
68        REAL*8 ZCLOUD(KDLON)    DOUBLE PRECISION zref(kdlon)
69        REAL*8 ZGG(KDLON)    DOUBLE PRECISION zre1(kdlon)
70        REAL*8 ZREF(KDLON)    DOUBLE PRECISION zre2(kdlon)
71        REAL*8 ZRE1(KDLON)    DOUBLE PRECISION zrmuz(kdlon)
72        REAL*8 ZRE2(KDLON)    DOUBLE PRECISION zrneb(kdlon)
73        REAL*8 ZRMUZ(KDLON)    DOUBLE PRECISION zr21(kdlon)
74        REAL*8 ZRNEB(KDLON)    DOUBLE PRECISION zr22(kdlon)
75        REAL*8 ZR21(KDLON)    DOUBLE PRECISION zr23(kdlon)
76        REAL*8 ZR22(KDLON)    DOUBLE PRECISION zss1(kdlon)
77        REAL*8 ZR23(KDLON)    DOUBLE PRECISION zto1(kdlon)
78        REAL*8 ZSS1(KDLON)    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
79        REAL*8 ZTO1(KDLON)    DOUBLE PRECISION ztr1(kdlon)
80        REAL*8 ZTR(KDLON,2,KFLEV+1)    DOUBLE PRECISION ztr2(kdlon)
81        REAL*8 ZTR1(KDLON)    DOUBLE PRECISION zw(kdlon)
82        REAL*8 ZTR2(KDLON)  
83        REAL*8 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        REAL*8 ZFACOA, ZFACOC, ZCORAE, ZCORCD    DOUBLE PRECISION zmu1, zre11, zbmu0, zbmu1
87        REAL*8 ZMUE, ZGAP, ZWW, ZTO, ZDEN, ZDEN1  
88        REAL*8 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.24  
changed lines
  Added in v.134
  ViewVC Help
Powered by ViewVC 1.1.21