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