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

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

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

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