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