/[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/libf/phylmd/Radlwsw/sw1s.f revision 71 by guez, Mon Jul 8 18:12:18 2013 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  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, palbd, palbp, pcg, pcld, pclear, pdsig, &
8        use raddim         pomega, poz, prmu, psec, ptau, pud, pfd, pfu)
9        IMPLICIT none      
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)      logical, intent(in):: flag_aer
51        DOUBLE PRECISION PALBP(KDLON,2)      DOUBLE PRECISION palbd(kdlon, 2)
52        DOUBLE PRECISION PCG(KDLON,2,KFLEV)        DOUBLE PRECISION palbp(kdlon, 2)
53        DOUBLE PRECISION PCLD(KDLON,KFLEV)      DOUBLE PRECISION pcg(kdlon, 2, kflev)
54        DOUBLE PRECISION PCLDSW(KDLON,KFLEV)      DOUBLE PRECISION pcld(kdlon, kflev)
55        DOUBLE PRECISION PCLEAR(KDLON)      DOUBLE PRECISION pclear(kdlon)
56        DOUBLE PRECISION PDSIG(KDLON,KFLEV)      DOUBLE PRECISION pdsig(kdlon, kflev)
57        DOUBLE PRECISION POMEGA(KDLON,2,KFLEV)      DOUBLE PRECISION pomega(kdlon, 2, kflev)
58        DOUBLE PRECISION POZ(KDLON,KFLEV)      DOUBLE PRECISION poz(kdlon, kflev)
59        DOUBLE PRECISION PRMU(KDLON)      DOUBLE PRECISION prmu(kdlon)
60        DOUBLE PRECISION PSEC(KDLON)      DOUBLE PRECISION psec(kdlon)
61        DOUBLE PRECISION PTAU(KDLON,2,KFLEV)      DOUBLE PRECISION ptau(kdlon, 2, kflev)
62        DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)      DOUBLE PRECISION pud(kdlon, 5, kflev+1)
63  C  
64        DOUBLE PRECISION PFD(KDLON,KFLEV+1)      DOUBLE PRECISION pfd(kdlon, kflev+1)
65        DOUBLE PRECISION PFU(KDLON,KFLEV+1)      DOUBLE PRECISION pfu(kdlon, kflev+1)
66  C  
67  C* LOCAL VARIABLES:      ! * LOCAL VARIABLES:
68  C  
69        INTEGER IIND(4)      INTEGER iind(4)
70  C        
71        DOUBLE PRECISION ZCGAZ(KDLON,KFLEV)      DOUBLE PRECISION zcgaz(kdlon, kflev)
72        DOUBLE PRECISION ZDIFF(KDLON)      DOUBLE PRECISION zdiff(kdlon)
73        DOUBLE PRECISION ZDIRF(KDLON)              DOUBLE PRECISION zdirf(kdlon)
74        DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION zpizaz(kdlon, kflev)
75        DOUBLE PRECISION ZRAYL(KDLON)      DOUBLE PRECISION zrayl(kdlon)
76        DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION zray1(kdlon, kflev+1)
77        DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION zray2(kdlon, kflev+1)
78        DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
79        DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
80        DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
81        DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
82        DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
83        DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1)      DOUBLE PRECISION zrmue(kdlon, kflev+1)
84        DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION zrmu0(kdlon, kflev+1)
85        DOUBLE PRECISION ZR(KDLON,4)      DOUBLE PRECISION zr(kdlon, 4)
86        DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION ztauaz(kdlon, kflev)
87        DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION ztra1(kdlon, kflev+1)
88        DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1)      DOUBLE PRECISION ztra2(kdlon, kflev+1)
89        DOUBLE PRECISION ZW(KDLON,4)      DOUBLE PRECISION zw(kdlon, 4)
90  C  
91        INTEGER jl, jk, k, jaj, ikm1, ikl      INTEGER jl, jk, k, jaj, ikm1, ikl
92  c  
93  c Prescribed Data:      ! Prescribed Data:
94  c  
95        DOUBLE PRECISION RSUN(2)      DOUBLE PRECISION rsun(2)
96        SAVE RSUN      SAVE rsun
97        DOUBLE PRECISION RRAY(2,6)      DOUBLE PRECISION rray(2, 6)
98        SAVE RRAY      SAVE rray
99        DATA RSUN(1) / 0.441676 /      DATA rsun(1)/0.441676d0/
100        DATA RSUN(2) / 0.558324 /      DATA rsun(2)/0.558324d0/
101        DATA (RRAY(1,K),K=1,6) /      DATA (rray(1,k), k=1, 6)/.428937d-01, .890743d+00, -.288555d+01, &
102       S .428937E-01, .890743E+00,-.288555E+01,           .522744d+01, -.469173d+01, .161645d+01/
103       S .522744E+01,-.469173E+01, .161645E+01/      DATA (rray(2,k), k=1, 6)/.697200d-02, .173297d-01, -.850903d-01, &
104        DATA (RRAY(2,K),K=1,6) /           .248261d+00, -.302031d+00, .129662d+00/
105       S .697200E-02, .173297E-01,-.850903E-01,      ! ------------------------------------------------------------------
106       S .248261E+00,-.302031E+00, .129662E+00/  
107  C     ------------------------------------------------------------------      ! *         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)
108  C      ! ----------------------- ------------------
109  C*         1.     FIRST SPECTRAL INTERVAL (0.25-0.68 MICRON)  
110  C                 ----------------------- ------------------  
111  C  
112   100  CONTINUE      ! *         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
113  C      ! -----------------------------------------
114  C  
115  C*         1.1    OPTICAL THICKNESS FOR RAYLEIGH SCATTERING  
116  C                 -----------------------------------------      DO jl = 1, kdlon
117  C         zrayl(jl) = rray(knu, 1) + prmu(jl)*(rray(knu,2)+prmu(jl)*(rray(knu, &
118   110  CONTINUE              3)+prmu(jl)*(rray(knu,4)+prmu(jl)*(rray(knu,5)+prmu(jl)*rray(knu,6)))))
119  C      END DO
120        DO 111 JL = 1, KDLON  
121        ZRAYL(JL) =  RRAY(KNU,1) + PRMU(JL) * (RRAY(KNU,2) + PRMU(JL)  
122       S          * (RRAY(KNU,3) + PRMU(JL) * (RRAY(KNU,4) + PRMU(JL)      ! ------------------------------------------------------------------
123       S          * (RRAY(KNU,5) + PRMU(JL) *  RRAY(KNU,6)       ))))  
124   111  CONTINUE      ! *         2.    CONTINUUM SCATTERING CALCULATIONS
125  C      ! ---------------------------------
126  C  
127  C     ------------------------------------------------------------------  
128  C      ! *         2.1   CLEAR-SKY FRACTION OF THE COLUMN
129  C*         2.    CONTINUUM SCATTERING CALCULATIONS      ! --------------------------------
130  C                ---------------------------------  
131  C  
132   200  CONTINUE      CALL swclr(knu, flag_aer, palbp, pdsig, zrayl, psec, zcgaz, zpizaz, &
133  C           zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, ztra1, ztra2)
134  C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN  
135  C                --------------------------------  
136  C        ! *         2.2   CLOUDY FRACTION OF THE COLUMN
137   210  CONTINUE      ! -----------------------------
138  C  
139        CALL SWCLR ( KNU  
140       S  , PAER   , flag_aer, tauae, pizae, cgae      CALL swr(knu, palbd, pcg, pcld, pomega, psec, ptau, zcgaz, &
141       S  , PALBP  , PDSIG , ZRAYL, PSEC           zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
142       S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0  
143       S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)  
144  C      ! ------------------------------------------------------------------
145  C  
146  C*         2.2   CLOUDY FRACTION OF THE COLUMN      ! *         3.    OZONE ABSORPTION
147  C                -----------------------------      ! ----------------
148  C  
149   220  CONTINUE  
150  C      iind(1) = 1
151        CALL SWR ( KNU      iind(2) = 3
152       S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL      iind(3) = 1
153       S  , PSEC  ,PTAU      iind(4) = 3
154       S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE  
155       S  , ZTAUAZ,ZTRA1 ,ZTRA2)  
156  C      ! *         3.1   DOWNWARD FLUXES
157  C      ! ---------------
158  C     ------------------------------------------------------------------  
159  C  
160  C*         3.    OZONE ABSORPTION      jaj = 2
161  C                ----------------  
162  C      DO jl = 1, kdlon
163   300  CONTINUE         zw(jl, 1) = 0.
164  C         zw(jl, 2) = 0.
165        IIND(1)=1         zw(jl, 3) = 0.
166        IIND(2)=3         zw(jl, 4) = 0.
167        IIND(3)=1         pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
168        IIND(4)=3              jl,jaj,kflev+1))*rsun(knu)
169  C            END DO
170  C      DO jk = 1, kflev
171  C*         3.1   DOWNWARD FLUXES         ikl = kflev + 1 - jk
172  C                ---------------         DO jl = 1, kdlon
173  C            zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
174   310  CONTINUE            zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
175  C            zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
176        JAJ = 2            zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
177  C         END DO
178        DO 311 JL = 1, KDLON  
179        ZW(JL,1)=0.         CALL swtt1(knu, 4, iind, zw, zr)
180        ZW(JL,2)=0.  
181        ZW(JL,3)=0.         DO jl = 1, kdlon
182        ZW(JL,4)=0.            zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
183        PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)            zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
184       S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)            pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
185   311  CONTINUE                 rsun(knu)
186        DO 314 JK = 1 , KFLEV         END DO
187        IKL = KFLEV+1-JK      END DO
188        DO 312 JL = 1, KDLON  
189        ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)  
190        ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKL)/ZRMUE(JL,IKL)      ! *         3.2   UPWARD FLUXES
191        ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKL)/ZRMU0(JL,IKL)      ! -------------
192        ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKL)/ZRMU0(JL,IKL)  
193   312  CONTINUE  
194  C      DO jl = 1, kdlon
195        CALL SWTT1(KNU, 4, IIND, ZW, ZR)         pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &
196  C              )*palbp(jl,knu))*rsun(knu)
197        DO 313 JL = 1, KDLON      END DO
198        ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)  
199        ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)      DO jk = 2, kflev + 1
200        PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)         ikm1 = jk - 1
201       S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)         DO jl = 1, kdlon
202   313  CONTINUE            zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
203   314  CONTINUE            zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
204  C            zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
205  C            zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
206  C*         3.2   UPWARD FLUXES         END DO
207  C                -------------  
208  C         CALL swtt1(knu, 4, iind, zw, zr)
209   320  CONTINUE  
210  C         DO jl = 1, kdlon
211        DO 325 JL = 1, KDLON            zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
212        PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)            zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
213       S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))            pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
214       S          * RSUN(KNU)                 rsun(knu)
215   325  CONTINUE         END DO
216  C      END DO
217        DO 328 JK = 2 , KFLEV+1  
218        IKM1=JK-1    END SUBROUTINE sw1s
219        DO 326 JL = 1, KDLON  
220        ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66  end module sw1s_m
       ZW(JL,2)=ZW(JL,2)+POZ(JL,  IKM1)*1.66  
       ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66  
       ZW(JL,4)=ZW(JL,4)+POZ(JL,  IKM1)*1.66  
  326  CONTINUE  
 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.71  
changed lines
  Added in v.217
  ViewVC Help
Powered by ViewVC 1.1.21