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