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

revision 177 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 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)  
2    
3    ! * LOCAL VARIABLES:    IMPLICIT NONE
   
   INTEGER iind(4)  
   
   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  
4    
5    ! Prescribed Data:  contains
6    
7    DOUBLE PRECISION rsun(2)    SUBROUTINE sw1s(knu, flag_aer, tauae, pizae, cgae, palbd, palbp, pcg, &
8    SAVE rsun         pcld, pclear, pdsig, pomega, poz, prmu, psec, ptau, pud, pfd, &
9    DOUBLE PRECISION rray(2, 6)         pfu)
10    SAVE rray      USE dimens_m
11    DATA rsun(1)/0.441676/      USE dimphy
12    DATA rsun(2)/0.558324/      USE raddim
13    DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, &      use swclr_m, only: swclr
14      .522744E+01, -.469173E+01, .161645E+01/      use swr_m, only: swr
15    DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, &  
16      .248261E+00, -.302031E+00, .129662E+00/      ! ------------------------------------------------------------------
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        ! -OB
50        DOUBLE PRECISION flag_aer
51        DOUBLE PRECISION tauae(kdlon, kflev, 2)
52        DOUBLE PRECISION pizae(kdlon, kflev, 2)
53        DOUBLE PRECISION cgae(kdlon, kflev, 2)
54        DOUBLE PRECISION palbd(kdlon, 2)
55        DOUBLE PRECISION palbp(kdlon, 2)
56        DOUBLE PRECISION pcg(kdlon, 2, kflev)
57        DOUBLE PRECISION pcld(kdlon, kflev)
58        DOUBLE PRECISION pclear(kdlon)
59        DOUBLE PRECISION pdsig(kdlon, kflev)
60        DOUBLE PRECISION pomega(kdlon, 2, kflev)
61        DOUBLE PRECISION poz(kdlon, kflev)
62        DOUBLE PRECISION prmu(kdlon)
63        DOUBLE PRECISION psec(kdlon)
64        DOUBLE PRECISION ptau(kdlon, 2, kflev)
65        DOUBLE PRECISION pud(kdlon, 5, kflev+1)
66    
67        DOUBLE PRECISION pfd(kdlon, kflev+1)
68        DOUBLE PRECISION pfu(kdlon, kflev+1)
69    
70        ! * LOCAL VARIABLES:
71    
72        INTEGER iind(4)
73    
74        DOUBLE PRECISION zcgaz(kdlon, kflev)
75        DOUBLE PRECISION zdiff(kdlon)
76        DOUBLE PRECISION zdirf(kdlon)
77        DOUBLE PRECISION zpizaz(kdlon, kflev)
78        DOUBLE PRECISION zrayl(kdlon)
79        DOUBLE PRECISION zray1(kdlon, kflev+1)
80        DOUBLE PRECISION zray2(kdlon, kflev+1)
81        DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
82        DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
83        DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
84        DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
85        DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
86        DOUBLE PRECISION zrmue(kdlon, kflev+1)
87        DOUBLE PRECISION zrmu0(kdlon, kflev+1)
88        DOUBLE PRECISION zr(kdlon, 4)
89        DOUBLE PRECISION ztauaz(kdlon, kflev)
90        DOUBLE PRECISION ztra1(kdlon, kflev+1)
91        DOUBLE PRECISION ztra2(kdlon, kflev+1)
92        DOUBLE PRECISION zw(kdlon, 4)
93    
94        INTEGER jl, jk, k, jaj, ikm1, ikl
95    
96        ! Prescribed Data:
97    
98        DOUBLE PRECISION rsun(2)
99        SAVE rsun
100        DOUBLE PRECISION rray(2, 6)
101        SAVE rray
102        DATA rsun(1)/0.441676d0/
103        DATA rsun(2)/0.558324d0/
104        DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
105             .522744d+01, -.469173d+01, .161645d+01/
106        DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
107             .248261d+00, -.302031d+00, .129662d+00/
108        ! ------------------------------------------------------------------
109    
110    ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)      ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
111    ! ----------------------- ------------------      ! ----------------------- ------------------
112    
113    
114    
115    ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING      ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
116    ! -----------------------------------------      ! -----------------------------------------
117    
118    
119    DO jl = 1, kdlon      DO jl = 1, kdlon
120      zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &         zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &
121        3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))              3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))
122    END DO      END DO
123    
124    
125    ! ------------------------------------------------------------------      ! ------------------------------------------------------------------
126    
127    ! *         2.    CONTINUUM SCATTERING CALCULATIONS      ! *         2.    CONTINUUM SCATTERING CALCULATIONS
128    ! ---------------------------------      ! ---------------------------------
129    
130    
131    ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN      ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
132    ! --------------------------------      ! --------------------------------
133    
134    
135    CALL swclr(knu, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &      CALL swclr(knu, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
136      psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &           psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
137      ztra1, ztra2)           ztra1, ztra2)
138    
139    
140    ! *         2.2   CLOUDY FRACTION OF THE COLUMN      ! *         2.2   CLOUDY FRACTION OF THE COLUMN
141    ! -----------------------------      ! -----------------------------
142    
143    
144    CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, &      CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
145      zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)           zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
146    
147    
148    ! ------------------------------------------------------------------      ! ------------------------------------------------------------------
149    
150    ! *         3.    OZONE ABSORPTION      ! *         3.    OZONE ABSORPTION
151    ! ----------------      ! ----------------
152    
153    
154    iind(1) = 1      iind(1) = 1
155    iind(2) = 3      iind(2) = 3
156    iind(3) = 1      iind(3) = 1
157    iind(4) = 3      iind(4) = 3
158    
159    
160    ! *         3.1   DOWNWARD FLUXES      ! *         3.1   DOWNWARD FLUXES
161    ! ---------------      ! ---------------
162    
163    
164    jaj = 2      jaj = 2
165    
   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  
166      DO jl = 1, kdlon      DO jl = 1, kdlon
167        zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)         zw(jl, 1) = 0.
168        zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)         zw(jl, 2) = 0.
169        zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)         zw(jl, 3) = 0.
170        zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)         zw(jl, 4) = 0.
171           pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
172                jl,jaj,kflev+1))*rsun(knu)
173      END DO      END DO
174        DO jk = 1, kflev
175      CALL swtt1(knu, 4, iind, zw, zr)         ikl = kflev + 1 - jk
176           DO jl = 1, kdlon
177      DO jl = 1, kdlon            zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
178        zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)            zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
179        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)
180        pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &            zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
181          rsun(knu)         END DO
182    
183           CALL swtt1(knu, 4, iind, zw, zr)
184    
185           DO jl = 1, kdlon
186              zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
187              zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
188              pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
189                   rsun(knu)
190           END DO
191      END DO      END DO
   END DO  
192    
193    
194    ! *         3.2   UPWARD FLUXES      ! *         3.2   UPWARD FLUXES
195    ! -------------      ! -------------
196    
197    
   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  
198      DO jl = 1, kdlon      DO jl = 1, kdlon
199        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 &
200        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  
201      END DO      END DO
202    
203      CALL swtt1(knu, 4, iind, zw, zr)      DO jk = 2, kflev + 1
204           ikm1 = jk - 1
205      DO jl = 1, kdlon         DO jl = 1, kdlon
206        zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)            zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
207        zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)            zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
208        pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &            zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
209          rsun(knu)            zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
210           END DO
211    
212           CALL swtt1(knu, 4, iind, zw, zr)
213    
214           DO jl = 1, kdlon
215              zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
216              zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
217              pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
218                   rsun(knu)
219           END DO
220      END DO      END DO
   END DO  
221    
222    ! ------------------------------------------------------------------    END SUBROUTINE sw1s
223    
224    RETURN  end module sw1s_m
 END SUBROUTINE sw1s  
Legend:
Removed from v.177  
changed lines
  Added in v.178
  ViewVC Help
Powered by ViewVC 1.1.21