/[lmdze]/trunk/phylmd/Radlwsw/sw1s.f90
ViewVC logotype

Diff of /trunk/phylmd/Radlwsw/sw1s.f90

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/phylmd/Radlwsw/sw1s.f revision 254 by guez, Mon Feb 5 10:39:38 2018 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        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)      DOUBLE PRECISION palbd(kdlon, 2)
50        DOUBLE PRECISION PALBD(KDLON,2)      DOUBLE PRECISION palbp(kdlon, 2)
51        DOUBLE PRECISION PALBP(KDLON,2)      DOUBLE PRECISION pcg(kdlon, 2, kflev)
52        DOUBLE PRECISION PCG(KDLON,2,KFLEV)        DOUBLE PRECISION pcld(kdlon, kflev)
53        DOUBLE PRECISION PCLD(KDLON,KFLEV)      DOUBLE PRECISION pclear(kdlon)
54        DOUBLE PRECISION PCLDSW(KDLON,KFLEV)      DOUBLE PRECISION pdsig(kdlon, kflev)
55        DOUBLE PRECISION PCLEAR(KDLON)      DOUBLE PRECISION pomega(kdlon, 2, kflev)
56        DOUBLE PRECISION PDSIG(KDLON,KFLEV)      DOUBLE PRECISION poz(kdlon, kflev)
57        DOUBLE PRECISION POMEGA(KDLON,2,KFLEV)      DOUBLE PRECISION prmu(kdlon)
58        DOUBLE PRECISION POZ(KDLON,KFLEV)      DOUBLE PRECISION psec(kdlon)
59        DOUBLE PRECISION PRMU(KDLON)      DOUBLE PRECISION ptau(kdlon, 2, kflev)
60        DOUBLE PRECISION PSEC(KDLON)      DOUBLE PRECISION pud(kdlon, 5, kflev+1)
61        DOUBLE PRECISION PTAU(KDLON,2,KFLEV)  
62        DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)      DOUBLE PRECISION pfd(kdlon, kflev+1)
63  C      DOUBLE PRECISION pfu(kdlon, kflev+1)
64        DOUBLE PRECISION PFD(KDLON,KFLEV+1)  
65        DOUBLE PRECISION 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        DOUBLE PRECISION ZCGAZ(KDLON,KFLEV)      DOUBLE PRECISION zdirf(kdlon)
72        DOUBLE PRECISION ZDIFF(KDLON)      DOUBLE PRECISION zpizaz(kdlon, kflev)
73        DOUBLE PRECISION ZDIRF(KDLON)              DOUBLE PRECISION zrayl(kdlon)
74        DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV)      DOUBLE PRECISION zray1(kdlon, kflev+1)
75        DOUBLE PRECISION ZRAYL(KDLON)      DOUBLE PRECISION zray2(kdlon, kflev+1)
76        DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1)      DOUBLE PRECISION zrefz(kdlon, 2, kflev+1)
77        DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1)      DOUBLE PRECISION zrj(kdlon, 6, kflev+1)
78        DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1)      DOUBLE PRECISION zrj0(kdlon, 6, kflev+1)
79        DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk(kdlon, 6, kflev+1)
80        DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrk0(kdlon, 6, kflev+1)
81        DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrmue(kdlon, kflev+1)
82        DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1)      DOUBLE PRECISION zrmu0(kdlon, kflev+1)
83        DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1)      DOUBLE PRECISION zr(kdlon, 4)
84        DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1)      DOUBLE PRECISION ztauaz(kdlon, kflev)
85        DOUBLE PRECISION ZR(KDLON,4)      DOUBLE PRECISION ztra1(kdlon, kflev+1)
86        DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV)      DOUBLE PRECISION ztra2(kdlon, kflev+1)
87        DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1)      DOUBLE PRECISION zw(kdlon, 4)
88        DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1)  
89        DOUBLE PRECISION 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        DOUBLE PRECISION RSUN(2)      DOUBLE PRECISION rray(2, 6)
96        SAVE RSUN      SAVE rray
97        DOUBLE PRECISION 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.71  
changed lines
  Added in v.254
  ViewVC Help
Powered by ViewVC 1.1.21