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