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