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