/[lmdze]/trunk/Sources/phylmd/Radlwsw/sw1s.f
ViewVC logotype

Diff of /trunk/Sources/phylmd/Radlwsw/sw1s.f

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

trunk/phylmd/Radlwsw/sw1s.f revision 82 by guez, Wed Mar 5 14:57:53 2014 UTC trunk/Sources/phylmd/Radlwsw/sw1s.f revision 219 by guez, Thu Mar 30 15:59:45 2017 UTC
# Line 1  Line 1 
1  SUBROUTINE sw1s(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, pcg, &  module sw1s_m
     pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, pfd, &  
     pfu)  
   USE dimens_m  
   USE dimphy  
   USE raddim  
   IMPLICIT NONE  
   
   ! ------------------------------------------------------------------  
   ! PURPOSE.  
   ! --------  
   
   ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO  
   ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).  
   
   ! METHOD.  
   ! -------  
   
   ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO  
   ! CONTINUUM SCATTERING  
   ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION  
   
   ! REFERENCE.  
   ! ----------  
   
   ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT  
   ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)  
   
   ! AUTHOR.  
   ! -------  
   ! JEAN-JACQUES MORCRETTE  *ECMWF*  
   
   ! MODIFICATIONS.  
   ! --------------  
   ! ORIGINAL : 89-07-14  
   ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO  
   ! ------------------------------------------------------------------  
   
   ! * ARGUMENTS:  
   
   INTEGER knu  
   ! -OB  
   DOUBLE PRECISION flag_aer  
   DOUBLE PRECISION tauae(kdlon, kflev, 2)  
   DOUBLE PRECISION pizae(kdlon, kflev, 2)  
   DOUBLE PRECISION cgae(kdlon, kflev, 2)  
   DOUBLE PRECISION paer(kdlon, kflev, 5)  
   DOUBLE PRECISION palbd(kdlon, 2)  
   DOUBLE PRECISION palbp(kdlon, 2)  
   DOUBLE PRECISION pcg(kdlon, 2, kflev)  
   DOUBLE PRECISION pcld(kdlon, kflev)  
   DOUBLE PRECISION pcldsw(kdlon, kflev)  
   DOUBLE PRECISION pclear(kdlon)  
   DOUBLE PRECISION pdsig(kdlon, kflev)  
   DOUBLE PRECISION pomega(kdlon, 2, kflev)  
   DOUBLE PRECISION poz(kdlon, kflev)  
   DOUBLE PRECISION prmu(kdlon)  
   DOUBLE PRECISION psec(kdlon)  
   DOUBLE PRECISION ptau(kdlon, 2, kflev)  
   DOUBLE PRECISION pud(kdlon, 5, kflev+1)  
   
   DOUBLE PRECISION pfd(kdlon, kflev+1)  
   DOUBLE PRECISION pfu(kdlon, kflev+1)  
   
   ! * LOCAL VARIABLES:  
2    
3    INTEGER iind(4)    IMPLICIT NONE
   
   DOUBLE PRECISION zcgaz(kdlon, kflev)  
   DOUBLE PRECISION zdiff(kdlon)  
   DOUBLE PRECISION zdirf(kdlon)  
   DOUBLE PRECISION zpizaz(kdlon, kflev)  
   DOUBLE PRECISION zrayl(kdlon)  
   DOUBLE PRECISION zray1(kdlon, kflev+1)  
   DOUBLE PRECISION zray2(kdlon, kflev+1)  
   DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)  
   DOUBLE PRECISION zrj(kdlon, 6, kflev+1)  
   DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)  
   DOUBLE PRECISION zrk(kdlon, 6, kflev+1)  
   DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)  
   DOUBLE PRECISION zrmue(kdlon, kflev+1)  
   DOUBLE PRECISION zrmu0(kdlon, kflev+1)  
   DOUBLE PRECISION zr(kdlon, 4)  
   DOUBLE PRECISION ztauaz(kdlon, kflev)  
   DOUBLE PRECISION ztra1(kdlon, kflev+1)  
   DOUBLE PRECISION ztra2(kdlon, kflev+1)  
   DOUBLE PRECISION zw(kdlon, 4)  
   
   INTEGER jl, jk, k, jaj, ikm1, ikl  
   
   ! Prescribed Data:  
4    
5    DOUBLE PRECISION rsun(2)  contains
   SAVE rsun  
   DOUBLE PRECISION rray(2, 6)  
   SAVE rray  
   DATA rsun(1)/0.441676/  
   DATA rsun(2)/0.558324/  
   DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, &  
     .522744E+01, -.469173E+01, .161645E+01/  
   DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, &  
     .248261E+00, -.302031E+00, .129662E+00/  
   ! ------------------------------------------------------------------  
6    
7    ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)    SUBROUTINE sw1s(knu, palbd, palbp, pcg, pcld, pclear, pdsig, pomega, poz, &
8    ! ----------------------- ------------------         prmu, psec, ptau, pud, pfd, pfu)
9        
10        USE dimens_m
11        USE dimphy
12        USE raddim
13        use swclr_m, only: swclr
14        use swr_m, only: swr
15    
16        ! ------------------------------------------------------------------
17        ! PURPOSE.
18        ! --------
19    
20        ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
21        ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
22    
23        ! METHOD.
24        ! -------
25    
26        ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
27        ! CONTINUUM SCATTERING
28        ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
29    
30        ! REFERENCE.
31        ! ----------
32    
33        ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
34        ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
35    
36        ! AUTHOR.
37        ! -------
38        ! JEAN-JACQUES MORCRETTE  *ECMWF*
39    
40        ! MODIFICATIONS.
41        ! --------------
42        ! ORIGINAL : 89-07-14
43        ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
44        ! ------------------------------------------------------------------
45    
46        ! * ARGUMENTS:
47    
48        INTEGER knu
49        DOUBLE PRECISION palbd(kdlon, 2)
50        DOUBLE PRECISION palbp(kdlon, 2)
51        DOUBLE PRECISION pcg(kdlon, 2, kflev)
52        DOUBLE PRECISION pcld(kdlon, kflev)
53        DOUBLE PRECISION pclear(kdlon)
54        DOUBLE PRECISION pdsig(kdlon, kflev)
55        DOUBLE PRECISION pomega(kdlon, 2, kflev)
56        DOUBLE PRECISION poz(kdlon, kflev)
57        DOUBLE PRECISION prmu(kdlon)
58        DOUBLE PRECISION psec(kdlon)
59        DOUBLE PRECISION ptau(kdlon, 2, kflev)
60        DOUBLE PRECISION pud(kdlon, 5, kflev+1)
61    
62        DOUBLE PRECISION pfd(kdlon, kflev+1)
63        DOUBLE PRECISION pfu(kdlon, kflev+1)
64    
65        ! * LOCAL VARIABLES:
66    
67        INTEGER iind(4)
68    
69        DOUBLE PRECISION zcgaz(kdlon, kflev)
70        DOUBLE PRECISION zdiff(kdlon)
71        DOUBLE PRECISION zdirf(kdlon)
72        DOUBLE PRECISION zpizaz(kdlon, kflev)
73        DOUBLE PRECISION zrayl(kdlon)
74        DOUBLE PRECISION zray1(kdlon, kflev+1)
75        DOUBLE PRECISION zray2(kdlon, kflev+1)
76        DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
77        DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
78        DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
79        DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
80        DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
81        DOUBLE PRECISION zrmue(kdlon, kflev+1)
82        DOUBLE PRECISION zrmu0(kdlon, kflev+1)
83        DOUBLE PRECISION zr(kdlon, 4)
84        DOUBLE PRECISION ztauaz(kdlon, kflev)
85        DOUBLE PRECISION ztra1(kdlon, kflev+1)
86        DOUBLE PRECISION ztra2(kdlon, kflev+1)
87        DOUBLE PRECISION zw(kdlon, 4)
88    
89        INTEGER jl, jk, k, jaj, ikm1, ikl
90    
91        ! Prescribed Data:
92    
93        DOUBLE PRECISION rsun(2)
94        SAVE rsun
95        DOUBLE PRECISION rray(2, 6)
96        SAVE rray
97        DATA rsun(1)/0.441676d0/
98        DATA rsun(2)/0.558324d0/
99        DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
100             .522744d+01, -.469173d+01, .161645d+01/
101        DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
102             .248261d+00, -.302031d+00, .129662d+00/
103        ! ------------------------------------------------------------------
104    
105        ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
106        ! ----------------------- ------------------
107    
108    
   ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING  
   ! -----------------------------------------  
109    
110        ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
111        ! -----------------------------------------
112    
   DO jl = 1, kdlon  
     zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &  
       3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))  
   END DO  
113    
114        DO jl = 1, kdlon
115           zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &
116                3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))
117        END DO
118    
   ! ------------------------------------------------------------------  
119    
120    ! *         2.    CONTINUUM SCATTERING CALCULATIONS      ! ------------------------------------------------------------------
   ! ---------------------------------  
121    
122        ! *         2.    CONTINUUM SCATTERING CALCULATIONS
123        ! ---------------------------------
124    
   ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN  
   ! --------------------------------  
125    
126        ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
127        ! --------------------------------
128    
   CALL swclr(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &  
     psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &  
     ztra1, ztra2)  
129    
130        CALL swclr(knu, palbp, pdsig, zrayl, psec, zpizaz, zray1, zray2, zrefz, &
131             zrj0, zrk0, zrmu0, ztauaz, ztra1, ztra2)
132    
   ! *         2.2   CLOUDY FRACTION OF THE COLUMN  
   ! -----------------------------  
133    
134        ! *         2.2   CLOUDY FRACTION OF THE COLUMN
135        ! -----------------------------
136    
137    CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, &      zcgaz = 0d0
138      zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)      CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
139             zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
140    
141    
142    ! ------------------------------------------------------------------      ! ------------------------------------------------------------------
143    
144    ! *         3.    OZONE ABSORPTION      ! *         3.    OZONE ABSORPTION
145    ! ----------------      ! ----------------
146    
147    
148    iind(1) = 1      iind(1) = 1
149    iind(2) = 3      iind(2) = 3
150    iind(3) = 1      iind(3) = 1
151    iind(4) = 3      iind(4) = 3
152    
153    
154    ! *         3.1   DOWNWARD FLUXES      ! *         3.1   DOWNWARD FLUXES
155    ! ---------------      ! ---------------
156    
157    
158    jaj = 2      jaj = 2
159    
   DO jl = 1, kdlon  
     zw(jl, 1) = 0.  
     zw(jl, 2) = 0.  
     zw(jl, 3) = 0.  
     zw(jl, 4) = 0.  
     pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &  
       jl,jaj,kflev+1))*rsun(knu)  
   END DO  
   DO jk = 1, kflev  
     ikl = kflev + 1 - jk  
160      DO jl = 1, kdlon      DO jl = 1, kdlon
161        zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)         zw(jl, 1) = 0.
162        zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)         zw(jl, 2) = 0.
163        zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)         zw(jl, 3) = 0.
164        zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)         zw(jl, 4) = 0.
165           pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
166                jl,jaj,kflev+1))*rsun(knu)
167      END DO      END DO
168        DO jk = 1, kflev
169      CALL swtt1(knu, 4, iind, zw, zr)         ikl = kflev + 1 - jk
170           DO jl = 1, kdlon
171      DO jl = 1, kdlon            zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
172        zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)            zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
173        zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)            zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
174        pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &            zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
175          rsun(knu)         END DO
176    
177           CALL swtt1(knu, 4, iind, zw, zr)
178    
179           DO jl = 1, kdlon
180              zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
181              zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
182              pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
183                   rsun(knu)
184           END DO
185      END DO      END DO
   END DO  
186    
187    
188    ! *         3.2   UPWARD FLUXES      ! *         3.2   UPWARD FLUXES
189    ! -------------      ! -------------
190    
191    
   DO jl = 1, kdlon  
     pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &  
       )*palbp(jl,knu))*rsun(knu)  
   END DO  
   
   DO jk = 2, kflev + 1  
     ikm1 = jk - 1  
192      DO jl = 1, kdlon      DO jl = 1, kdlon
193        zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66         pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &
194        zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66              )*palbp(jl,knu))*rsun(knu)
       zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66  
       zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66  
195      END DO      END DO
196    
197      CALL swtt1(knu, 4, iind, zw, zr)      DO jk = 2, kflev + 1
198           ikm1 = jk - 1
199      DO jl = 1, kdlon         DO jl = 1, kdlon
200        zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)            zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
201        zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)            zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
202        pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &            zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
203          rsun(knu)            zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
204           END DO
205    
206           CALL swtt1(knu, 4, iind, zw, zr)
207    
208           DO jl = 1, kdlon
209              zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
210              zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
211              pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
212                   rsun(knu)
213           END DO
214      END DO      END DO
   END DO  
215    
216    ! ------------------------------------------------------------------    END SUBROUTINE sw1s
217    
218    RETURN  end module sw1s_m
 END SUBROUTINE sw1s  
Legend:
Removed from v.82  
changed lines
  Added in v.219
  ViewVC Help
Powered by ViewVC 1.1.21