/[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

revision 134 by guez, Wed Apr 29 15:47:56 2015 UTC revision 178 by guez, Fri Mar 11 18:47:26 2016 UTC
# Line 1  Line 1 
1  SUBROUTINE swr(knu, palbd, pcg, pcld, pdsig, pomega, prayl, psec, ptau, &  module swr_m
2      pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &  
     ptra2)  
   USE dimens_m  
   USE dimphy  
   USE raddim  
   USE radepsi  
   USE radopt  
3    IMPLICIT NONE    IMPLICIT NONE
4    
5    ! ------------------------------------------------------------------  contains
6    ! PURPOSE.  
7    ! --------    SUBROUTINE swr(knu, palbd, pcg, pcld, pomega, psec, ptau, &
8    ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF         pcgaz, ppizaz, pray1, pray2, prefz, prj, prk, prmue, ptauaz, ptra1, &
9    ! CONTINUUM SCATTERING         ptra2)
10        USE dimens_m
11    ! METHOD.      USE dimphy
12    ! -------      USE raddim
13        USE radepsi
14    ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL      USE radopt
15    ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)  
16        ! ------------------------------------------------------------------
17    ! REFERENCE.      ! PURPOSE.
18    ! ----------      ! --------
19        ! COMPUTES THE REFLECTIVITY AND TRANSMISSIVITY IN CASE OF
20    ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT      ! CONTINUUM SCATTERING
21    ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)  
22        ! METHOD.
23    ! AUTHOR.      ! -------
24    ! -------  
25    ! JEAN-JACQUES MORCRETTE  *ECMWF*      ! 1. COMPUTES CONTINUUM FLUXES CORRESPONDING TO AEROSOL
26        ! OR/AND RAYLEIGH SCATTERING (NO MOLECULAR GAS ABSORPTION)
27    ! MODIFICATIONS.  
28    ! --------------      ! REFERENCE.
29    ! ORIGINAL : 89-07-14      ! ----------
30    ! ------------------------------------------------------------------  
31    ! * ARGUMENTS:      ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
32        ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
33    INTEGER knu  
34    DOUBLE PRECISION palbd(kdlon, 2)      ! AUTHOR.
35    DOUBLE PRECISION pcg(kdlon, 2, kflev)      ! -------
36    DOUBLE PRECISION pcld(kdlon, kflev)      ! JEAN-JACQUES MORCRETTE  *ECMWF*
37    DOUBLE PRECISION pdsig(kdlon, kflev)  
38    DOUBLE PRECISION pomega(kdlon, 2, kflev)      ! MODIFICATIONS.
39    DOUBLE PRECISION prayl(kdlon)      ! --------------
40    DOUBLE PRECISION psec(kdlon)      ! ORIGINAL : 89-07-14
41    DOUBLE PRECISION ptau(kdlon, 2, kflev)      ! ------------------------------------------------------------------
42        ! * ARGUMENTS:
43    DOUBLE PRECISION pray1(kdlon, kflev+1)  
44    DOUBLE PRECISION pray2(kdlon, kflev+1)      INTEGER knu
45    DOUBLE PRECISION prefz(kdlon, 2, kflev+1)      DOUBLE PRECISION palbd(kdlon, 2)
46    DOUBLE PRECISION prj(kdlon, 6, kflev+1)      DOUBLE PRECISION pcg(kdlon, 2, kflev)
47    DOUBLE PRECISION prk(kdlon, 6, kflev+1)      DOUBLE PRECISION pcld(kdlon, kflev)
48    DOUBLE PRECISION prmue(kdlon, kflev+1)      DOUBLE PRECISION pomega(kdlon, 2, kflev)
49    DOUBLE PRECISION pcgaz(kdlon, kflev)      DOUBLE PRECISION psec(kdlon)
50    DOUBLE PRECISION ppizaz(kdlon, kflev)      DOUBLE PRECISION ptau(kdlon, 2, kflev)
51    DOUBLE PRECISION ptauaz(kdlon, kflev)  
52    DOUBLE PRECISION ptra1(kdlon, kflev+1)      DOUBLE PRECISION pray1(kdlon, kflev+1)
53    DOUBLE PRECISION ptra2(kdlon, kflev+1)      DOUBLE PRECISION pray2(kdlon, kflev+1)
54        DOUBLE PRECISION prefz(kdlon, 2, kflev+1)
55    ! * LOCAL VARIABLES:      DOUBLE PRECISION prj(kdlon, 6, kflev+1)
56        DOUBLE PRECISION prk(kdlon, 6, kflev+1)
57    DOUBLE PRECISION zc1i(kdlon, kflev+1)      DOUBLE PRECISION prmue(kdlon, kflev+1)
58    DOUBLE PRECISION zcleq(kdlon, kflev)      DOUBLE PRECISION pcgaz(kdlon, kflev)
59    DOUBLE PRECISION zclear(kdlon)      DOUBLE PRECISION ppizaz(kdlon, kflev)
60    DOUBLE PRECISION zcloud(kdlon)      DOUBLE PRECISION ptauaz(kdlon, kflev)
61    DOUBLE PRECISION zgg(kdlon)      DOUBLE PRECISION ptra1(kdlon, kflev+1)
62    DOUBLE PRECISION zref(kdlon)      DOUBLE PRECISION ptra2(kdlon, kflev+1)
63    DOUBLE PRECISION zre1(kdlon)  
64    DOUBLE PRECISION zre2(kdlon)      ! * LOCAL VARIABLES:
65    DOUBLE PRECISION zrmuz(kdlon)  
66    DOUBLE PRECISION zrneb(kdlon)      DOUBLE PRECISION zc1i(kdlon, kflev+1)
67    DOUBLE PRECISION zr21(kdlon)      DOUBLE PRECISION zclear(kdlon)
68    DOUBLE PRECISION zr22(kdlon)      DOUBLE PRECISION zcloud(kdlon)
69    DOUBLE PRECISION zr23(kdlon)      DOUBLE PRECISION zgg(kdlon)
70    DOUBLE PRECISION zss1(kdlon)      DOUBLE PRECISION zref(kdlon)
71    DOUBLE PRECISION zto1(kdlon)      DOUBLE PRECISION zre1(kdlon)
72    DOUBLE PRECISION ztr(kdlon, 2, kflev+1)      DOUBLE PRECISION zre2(kdlon)
73    DOUBLE PRECISION ztr1(kdlon)      DOUBLE PRECISION zrmuz(kdlon)
74    DOUBLE PRECISION ztr2(kdlon)      DOUBLE PRECISION zrneb(kdlon)
75    DOUBLE PRECISION zw(kdlon)      DOUBLE PRECISION zr21(kdlon)
76        DOUBLE PRECISION zr22(kdlon)
77    INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj      DOUBLE PRECISION zss1(kdlon)
78    DOUBLE PRECISION zfacoa, zfacoc, zcorae, zcorcd      DOUBLE PRECISION zto1(kdlon)
79    DOUBLE PRECISION zmue, zgap, zww, zto, zden, zden1      DOUBLE PRECISION ztr(kdlon, 2, kflev+1)
80    DOUBLE PRECISION zmu1, zre11, zbmu0, zbmu1      DOUBLE PRECISION ztr1(kdlon)
81        DOUBLE PRECISION ztr2(kdlon)
82    ! ------------------------------------------------------------------      DOUBLE PRECISION zw(kdlon)
83    
84    ! *         1.    INITIALIZATION      INTEGER jk, jl, ja, jkl, jklp1, jkm1, jaj
85    ! --------------      DOUBLE PRECISION zfacoa, zfacoc, zcorae, zcorcd
86        DOUBLE PRECISION zmue, zgap, zww, zto, zden, zden1
87        DOUBLE PRECISION zmu1, zre11, zbmu0, zbmu1
88    DO jk = 1, kflev + 1  
89      DO ja = 1, 6      ! ------------------------------------------------------------------
90        DO jl = 1, kdlon  
91          prj(jl, ja, jk) = 0.      ! *         1.    INITIALIZATION
92          prk(jl, ja, jk) = 0.      ! --------------
93        END DO  
94    
95        DO jk = 1, kflev + 1
96           DO ja = 1, 6
97              DO jl = 1, kdlon
98                 prj(jl, ja, jk) = 0.
99                 prk(jl, ja, jk) = 0.
100              END DO
101           END DO
102      END DO      END DO
   END DO  
103    
104    
105    ! ------------------------------------------------------------------      ! ------------------------------------------------------------------
106    
107    ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL      ! *         2.    TOTAL EFFECTIVE CLOUDINESS ABOVE A GIVEN LEVEL
108    ! ----------------------------------------------      ! ----------------------------------------------
109    
110    
111    DO jl = 1, kdlon      DO jl = 1, kdlon
112      zr23(jl) = 0.         zc1i(jl, kflev+1) = 0.
113      zc1i(jl, kflev+1) = 0.         zclear(jl) = 1.
114      zclear(jl) = 1.         zcloud(jl) = 0.
115      zcloud(jl) = 0.      END DO
   END DO  
   
   jk = 1  
   jkl = kflev + 1 - jk  
   jklp1 = jkl + 1  
   DO jl = 1, kdlon  
     zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)  
     zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)  
     zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)  
     zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)  
     zr21(jl) = exp(-zcorae)  
     zr22(jl) = exp(-zcorcd)  
     zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &  
       (1.0-pcld(jl,jkl))*(1.0-zr21(jl))  
     zcleq(jl, jkl) = zss1(jl)  
   
     IF (novlp==1) THEN  
       ! * maximum-random  
       zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &  
         (1.0-min(zcloud(jl),1.-zepsec))  
       zc1i(jl, jkl) = 1.0 - zclear(jl)  
       zcloud(jl) = zss1(jl)  
     ELSE IF (novlp==2) THEN  
       ! * maximum  
       zcloud(jl) = max(zss1(jl), zcloud(jl))  
       zc1i(jl, jkl) = zcloud(jl)  
     ELSE IF (novlp==3) THEN  
       ! * random  
       zclear(jl) = zclear(jl)*(1.0-zss1(jl))  
       zcloud(jl) = 1.0 - zclear(jl)  
       zc1i(jl, jkl) = zcloud(jl)  
     END IF  
   END DO  
116    
117    DO jk = 2, kflev      jk = 1
118      jkl = kflev + 1 - jk      jkl = kflev + 1 - jk
119      jklp1 = jkl + 1      jklp1 = jkl + 1
120      DO jl = 1, kdlon      DO jl = 1, kdlon
121        zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)         zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
122        zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)         zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)
123        zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)         zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
124        zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)         zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)
125        zr21(jl) = exp(-zcorae)         zr21(jl) = exp(-zcorae)
126        zr22(jl) = exp(-zcorcd)         zr22(jl) = exp(-zcorcd)
127        zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &         zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &
128          (1.0-pcld(jl,jkl))*(1.0-zr21(jl))              (1.0-pcld(jl,jkl))*(1.0-zr21(jl))
129        zcleq(jl, jkl) = zss1(jl)  
130           IF (novlp==1) THEN
131        IF (novlp==1) THEN            ! * maximum-random
132          ! * maximum-random            zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
133          zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &                 (1.0-min(zcloud(jl),1.-zepsec))
134            (1.0-min(zcloud(jl),1.-zepsec))            zc1i(jl, jkl) = 1.0 - zclear(jl)
135          zc1i(jl, jkl) = 1.0 - zclear(jl)            zcloud(jl) = zss1(jl)
136          zcloud(jl) = zss1(jl)         ELSE IF (novlp==2) THEN
137        ELSE IF (novlp==2) THEN            ! * maximum
138          ! * maximum            zcloud(jl) = max(zss1(jl), zcloud(jl))
139          zcloud(jl) = max(zss1(jl), zcloud(jl))            zc1i(jl, jkl) = zcloud(jl)
140          zc1i(jl, jkl) = zcloud(jl)         ELSE IF (novlp==3) THEN
141        ELSE IF (novlp==3) THEN            ! * random
142          ! * random            zclear(jl) = zclear(jl)*(1.0-zss1(jl))
143          zclear(jl) = zclear(jl)*(1.0-zss1(jl))            zcloud(jl) = 1.0 - zclear(jl)
144          zcloud(jl) = 1.0 - zclear(jl)            zc1i(jl, jkl) = zcloud(jl)
145          zc1i(jl, jkl) = zcloud(jl)         END IF
       END IF  
146      END DO      END DO
   END DO  
147    
148    ! ------------------------------------------------------------------      DO jk = 2, kflev
149           jkl = kflev + 1 - jk
150           jklp1 = jkl + 1
151           DO jl = 1, kdlon
152              zfacoa = 1. - ppizaz(jl, jkl)*pcgaz(jl, jkl)*pcgaz(jl, jkl)
153              zfacoc = 1. - pomega(jl, knu, jkl)*pcg(jl, knu, jkl)*pcg(jl, knu, jkl)
154              zcorae = zfacoa*ptauaz(jl, jkl)*psec(jl)
155              zcorcd = zfacoc*ptau(jl, knu, jkl)*psec(jl)
156              zr21(jl) = exp(-zcorae)
157              zr22(jl) = exp(-zcorcd)
158              zss1(jl) = pcld(jl, jkl)*(1.0-zr21(jl)*zr22(jl)) + &
159                   (1.0-pcld(jl,jkl))*(1.0-zr21(jl))
160    
161              IF (novlp==1) THEN
162                 ! * maximum-random
163                 zclear(jl) = zclear(jl)*(1.0-max(zss1(jl),zcloud(jl)))/ &
164                      (1.0-min(zcloud(jl),1.-zepsec))
165                 zc1i(jl, jkl) = 1.0 - zclear(jl)
166                 zcloud(jl) = zss1(jl)
167              ELSE IF (novlp==2) THEN
168                 ! * maximum
169                 zcloud(jl) = max(zss1(jl), zcloud(jl))
170                 zc1i(jl, jkl) = zcloud(jl)
171              ELSE IF (novlp==3) THEN
172                 ! * random
173                 zclear(jl) = zclear(jl)*(1.0-zss1(jl))
174                 zcloud(jl) = 1.0 - zclear(jl)
175                 zc1i(jl, jkl) = zcloud(jl)
176              END IF
177           END DO
178        END DO
179    
180    ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING      ! ------------------------------------------------------------------
   ! -----------------------------------------------  
181    
182        ! *         3.    REFLECTIVITY/TRANSMISSIVITY FOR PURE SCATTERING
183        ! -----------------------------------------------
184    
   DO jl = 1, kdlon  
     pray1(jl, kflev+1) = 0.  
     pray2(jl, kflev+1) = 0.  
     prefz(jl, 2, 1) = palbd(jl, knu)  
     prefz(jl, 1, 1) = palbd(jl, knu)  
     ptra1(jl, kflev+1) = 1.  
     ptra2(jl, kflev+1) = 1.  
   END DO  
185    
   DO jk = 2, kflev + 1  
     jkm1 = jk - 1  
186      DO jl = 1, kdlon      DO jl = 1, kdlon
187        zrneb(jl) = pcld(jl, jkm1)         pray1(jl, kflev+1) = 0.
188        zre1(jl) = 0.         pray2(jl, kflev+1) = 0.
189        ztr1(jl) = 0.         prefz(jl, 2, 1) = palbd(jl, knu)
190        zre2(jl) = 0.         prefz(jl, 1, 1) = palbd(jl, knu)
191        ztr2(jl) = 0.         ptra1(jl, kflev+1) = 1.
192           ptra2(jl, kflev+1) = 1.
193        END DO
       ! ------------------------------------------------------------------  
   
       ! *         3.1  EQUIVALENT ZENITH ANGLE  
       ! -----------------------  
   
194    
195        zmue = (1.-zc1i(jl,jk))*psec(jl) + zc1i(jl, jk)*1.66      DO jk = 2, kflev + 1
196        prmue(jl, jk) = 1./zmue         jkm1 = jk - 1
197           DO jl = 1, kdlon
198              zrneb(jl) = pcld(jl, jkm1)
199              zre1(jl) = 0.
200              ztr1(jl) = 0.
201              zre2(jl) = 0.
202              ztr2(jl) = 0.
203    
204    
205        ! ------------------------------------------------------------------            ! ------------------------------------------------------------------
206    
207        ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS            ! *         3.1  EQUIVALENT ZENITH ANGLE
208        ! ----------------------------------------------------            ! -----------------------
209    
210    
211        zgap = pcgaz(jl, jkm1)            zmue = (1.-zc1i(jl,jk))*psec(jl) + zc1i(jl, jk)*1.66
212        zbmu0 = 0.5 - 0.75*zgap/zmue            prmue(jl, jk) = 1./zmue
       zww = ppizaz(jl, jkm1)  
       zto = ptauaz(jl, jkm1)  
       zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &  
         *zto*zto*zmue*zmue  
       pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden  
       ptra1(jl, jkm1) = 1./zden  
       ! PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)  
213    
       zmu1 = 0.5  
       zbmu1 = 0.5 - 0.75*zgap*zmu1  
       zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &  
         )*zto*zto/zmu1/zmu1  
       pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1  
       ptra2(jl, jkm1) = 1./zden1  
214    
215              ! ------------------------------------------------------------------
216    
217        ! ------------------------------------------------------------------            ! *         3.2  REFLECT./TRANSMISSIVITY DUE TO RAYLEIGH AND AEROSOLS
218              ! ----------------------------------------------------
219    
       ! *         3.3  EFFECT OF CLOUD LAYER  
       ! ---------------------  
220    
221              zgap = pcgaz(jl, jkm1)
222              zbmu0 = 0.5 - 0.75*zgap/zmue
223              zww = ppizaz(jl, jkm1)
224              zto = ptauaz(jl, jkm1)
225              zden = 1. + (1.-zww+zbmu0*zww)*zto*zmue + (1-zww)*(1.-zww+2.*zbmu0*zww) &
226                   *zto*zto*zmue*zmue
227              pray1(jl, jkm1) = zbmu0*zww*zto*zmue/zden
228              ptra1(jl, jkm1) = 1./zden
229              ! PRINT *,' LOOP 342 ** 3 ** JL=',JL,PRAY1(JL,JKM1),PTRA1(JL,JKM1)
230    
231        zw(jl) = pomega(jl, knu, jkm1)            zmu1 = 0.5
232        zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, &            zbmu1 = 0.5 - 0.75*zgap*zmu1
233          jkm1)            zden1 = 1. + (1.-zww+zbmu1*zww)*zto/zmu1 + (1-zww)*(1.-zww+2.*zbmu1*zww &
234        zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1)                 )*zto*zto/zmu1/zmu1
235        zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)            pray2(jl, jkm1) = zbmu1*zww*zto/zmu1/zden1
236        zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*pcgaz(jl, jkm1)            ptra2(jl, jkm1) = 1./zden1
       ! Modif PhD - JJM 19/03/96 pour erreurs arrondis  
       ! machine  
       ! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)  
       IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN  
         zw(jl) = 1.  
       ELSE  
         zw(jl) = zr21(jl)/zto1(jl)  
       END IF  
       zref(jl) = prefz(jl, 1, jkm1)  
       zrmuz(jl) = prmue(jl, jk)  
     END DO  
237    
     CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)  
238    
239      DO jl = 1, kdlon            ! ------------------------------------------------------------------
240    
241        prefz(jl, 1, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,1,jkm1)* &            ! *         3.3  EFFECT OF CLOUD LAYER
242          ptra1(jl,jkm1)*ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &            ! ---------------------
         jkm1))) + zrneb(jl)*zre2(jl)  
243    
       ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &  
         jkm1)*prefz(jl,1,jkm1)))*(1.-zrneb(jl))  
244    
245        prefz(jl, 2, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,2,jkm1)* &            zw(jl) = pomega(jl, knu, jkm1)
246          ptra1(jl,jkm1)*ptra2(jl,jkm1)) + zrneb(jl)*zre1(jl)            zto1(jl) = ptau(jl, knu, jkm1)/zw(jl) + ptauaz(jl, jkm1)/ppizaz(jl, &
247                   jkm1)
248              zr21(jl) = ptau(jl, knu, jkm1) + ptauaz(jl, jkm1)
249              zr22(jl) = ptau(jl, knu, jkm1)/zr21(jl)
250              zgg(jl) = zr22(jl)*pcg(jl, knu, jkm1) + (1.-zr22(jl))*pcgaz(jl, jkm1)
251              ! Modif PhD - JJM 19/03/96 pour erreurs arrondis
252              ! machine
253              ! PHD PROTECTION ZW(JL) = ZR21(JL) / ZTO1(JL)
254              IF (zw(jl)==1. .AND. ppizaz(jl,jkm1)==1.) THEN
255                 zw(jl) = 1.
256              ELSE
257                 zw(jl) = zr21(jl)/zto1(jl)
258              END IF
259              zref(jl) = prefz(jl, 1, jkm1)
260              zrmuz(jl) = prmue(jl, jk)
261           END DO
262    
263        ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + ptra1(jl, jkm1)*(1.-zrneb(jl))         CALL swde(zgg, zref, zrmuz, zto1, zw, zre1, zre2, ztr1, ztr2)
264    
265      END DO         DO jl = 1, kdlon
   END DO  
   DO jl = 1, kdlon  
     zmue = (1.-zc1i(jl,1))*psec(jl) + zc1i(jl, 1)*1.66  
     prmue(jl, 1) = 1./zmue  
   END DO  
266    
267              prefz(jl, 1, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,1,jkm1)* &
268                   ptra1(jl,jkm1)*ptra2(jl,jkm1)/(1.-pray2(jl,jkm1)*prefz(jl,1, &
269                   jkm1))) + zrneb(jl)*zre2(jl)
270    
271    ! ------------------------------------------------------------------            ztr(jl, 1, jkm1) = zrneb(jl)*ztr2(jl) + (ptra1(jl,jkm1)/(1.-pray2(jl, &
272                   jkm1)*prefz(jl,1,jkm1)))*(1.-zrneb(jl))
273    
274    ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL            prefz(jl, 2, jk) = (1.-zrneb(jl))*(pray1(jl,jkm1)+prefz(jl,2,jkm1)* &
275    ! -------------------------------------------------                 ptra1(jl,jkm1)*ptra2(jl,jkm1)) + zrneb(jl)*zre1(jl)
276    
277              ztr(jl, 2, jkm1) = zrneb(jl)*ztr1(jl) + ptra1(jl, jkm1)*(1.-zrneb(jl))
278    
279    IF (knu==1) THEN         END DO
280      jaj = 2      END DO
281      DO jl = 1, kdlon      DO jl = 1, kdlon
282        prj(jl, jaj, kflev+1) = 1.         zmue = (1.-zc1i(jl,1))*psec(jl) + zc1i(jl, 1)*1.66
283        prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)         prmue(jl, 1) = 1./zmue
284      END DO      END DO
285    
     DO jk = 1, kflev  
       jkl = kflev + 1 - jk  
       jklp1 = jkl + 1  
       DO jl = 1, kdlon  
         zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)  
         prj(jl, jaj, jkl) = zre11  
         prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)  
       END DO  
     END DO  
286    
287    ELSE      ! ------------------------------------------------------------------
288    
289        ! *         3.5    REFLECT./TRANSMISSIVITY BETWEEN SURFACE AND LEVEL
290        ! -------------------------------------------------
291    
     DO jaj = 1, 2  
       DO jl = 1, kdlon  
         prj(jl, jaj, kflev+1) = 1.  
         prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)  
       END DO  
   
       DO jk = 1, kflev  
         jkl = kflev + 1 - jk  
         jklp1 = jkl + 1  
         DO 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)  
         END DO  
       END DO  
     END DO  
292    
293    END IF      IF (knu==1) THEN
294           jaj = 2
295           DO jl = 1, kdlon
296              prj(jl, jaj, kflev+1) = 1.
297              prk(jl, jaj, kflev+1) = prefz(jl, 1, kflev+1)
298           END DO
299    
300           DO jk = 1, kflev
301              jkl = kflev + 1 - jk
302              jklp1 = jkl + 1
303              DO jl = 1, kdlon
304                 zre11 = prj(jl, jaj, jklp1)*ztr(jl, 1, jkl)
305                 prj(jl, jaj, jkl) = zre11
306                 prk(jl, jaj, jkl) = zre11*prefz(jl, 1, jkl)
307              END DO
308           END DO
309    
310        ELSE
311    
312           DO jaj = 1, 2
313              DO jl = 1, kdlon
314                 prj(jl, jaj, kflev+1) = 1.
315                 prk(jl, jaj, kflev+1) = prefz(jl, jaj, kflev+1)
316              END DO
317    
318              DO jk = 1, kflev
319                 jkl = kflev + 1 - jk
320                 jklp1 = jkl + 1
321                 DO jl = 1, kdlon
322                    zre11 = prj(jl, jaj, jklp1)*ztr(jl, jaj, jkl)
323                    prj(jl, jaj, jkl) = zre11
324                    prk(jl, jaj, jkl) = zre11*prefz(jl, jaj, jkl)
325                 END DO
326              END DO
327           END DO
328    
329        END IF
330    
331    ! ------------------------------------------------------------------    END SUBROUTINE swr
332    
333    RETURN  end module swr_m
 END SUBROUTINE swr  
Legend:
Removed from v.134  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21