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