/[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/phylmd/Radlwsw/sw1s.f90 revision 81 by guez, Wed Mar 5 14:38:41 2014 UTC
# Line 1  Line 1 
1        SUBROUTINE SW1S ( KNU  SUBROUTINE sw1s(knu, paer, flag_aer, tauae, pizae, cgae, palbd, palbp, pcg, &
2       S  ,  PAER  , flag_aer, tauae, pizae, cgae      pcld, pclear, pcldsw, pdsig, pomega, poz, prmu, psec, ptau, pud, pfd, &
3       S  ,  PALBD , PALBP, PCG  , PCLD , PCLEAR, PCLDSW      pfu)
4       S  ,  PDSIG , POMEGA, POZ  , PRMU , PSEC , PTAU  , PUD      USE dimens_m
5       S  ,  PFD   , PFU)    USE dimphy
6        use dimens_m    USE raddim
7        use dimphy    IMPLICIT NONE
8        use raddim  
9        IMPLICIT none    ! ------------------------------------------------------------------
10  C    ! PURPOSE.
11  C     ------------------------------------------------------------------    ! --------
12  C     PURPOSE.  
13  C     --------    ! THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
14  C    ! SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
15  C          THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO  
16  C     SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).    ! METHOD.
17  C    ! -------
18  C     METHOD.  
19  C     -------    ! 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
20  C    ! CONTINUUM SCATTERING
21  C          1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO    ! 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
22  C     CONTINUUM SCATTERING  
23  C          2. MULTIPLY BY OZONE TRANSMISSION FUNCTION    ! REFERENCE.
24  C    ! ----------
25  C     REFERENCE.  
26  C     ----------    ! SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
27  C    ! DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
28  C        SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT  
29  C        DOCUMENTATION, AND FOUQUART AND BONNEL (1980)    ! AUTHOR.
30  C    ! -------
31  C     AUTHOR.    ! JEAN-JACQUES MORCRETTE  *ECMWF*
32  C     -------  
33  C        JEAN-JACQUES MORCRETTE  *ECMWF*    ! MODIFICATIONS.
34  C    ! --------------
35  C     MODIFICATIONS.    ! ORIGINAL : 89-07-14
36  C     --------------    ! 94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO
37  C        ORIGINAL : 89-07-14    ! ------------------------------------------------------------------
38  C        94-11-15   J.-J. MORCRETTE    DIRECT/DIFFUSE ALBEDO  
39  C     ------------------------------------------------------------------    ! * ARGUMENTS:
40  C  
41  C* ARGUMENTS:    INTEGER knu
42  C    ! -OB
43        INTEGER KNU    DOUBLE PRECISION flag_aer
44  c-OB    DOUBLE PRECISION tauae(kdlon, kflev, 2)
45        double precision flag_aer    DOUBLE PRECISION pizae(kdlon, kflev, 2)
46        double precision tauae(kdlon,kflev,2)    DOUBLE PRECISION cgae(kdlon, kflev, 2)
47        double precision pizae(kdlon,kflev,2)    DOUBLE PRECISION paer(kdlon, kflev, 5)
48        double precision cgae(kdlon,kflev,2)    DOUBLE PRECISION palbd(kdlon, 2)
49        DOUBLE PRECISION PAER(KDLON,KFLEV,5)    DOUBLE PRECISION palbp(kdlon, 2)
50        DOUBLE PRECISION PALBD(KDLON,2)    DOUBLE PRECISION pcg(kdlon, 2, kflev)
51        DOUBLE PRECISION PALBP(KDLON,2)    DOUBLE PRECISION pcld(kdlon, kflev)
52        DOUBLE PRECISION PCG(KDLON,2,KFLEV)      DOUBLE PRECISION pcldsw(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.441676/
98        SAVE RRAY    DATA rsun(2)/0.558324/
99        DATA RSUN(1) / 0.441676 /    DATA (rray(1,k), k=1, 6)/.428937E-01, .890743E+00, -.288555E+01, &
100        DATA RSUN(2) / 0.558324 /      .522744E+01, -.469173E+01, .161645E+01/
101        DATA (RRAY(1,K),K=1,6) /    DATA (rray(2,k), k=1, 6)/.697200E-02, .173297E-01, -.850903E-01, &
102       S .428937E-01, .890743E+00,-.288555E+01,      .248261E+00, -.302031E+00, .129662E+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, paer, flag_aer, tauae, pizae, cgae, palbp, pdsig, zrayl, &
131  C      psec, zcgaz, zpizaz, zray1, zray2, zrefz, zrj0, zrk0, zrmu0, ztauaz, &
132   200  CONTINUE      ztra1, ztra2)
133  C  
134  C*         2.1   CLEAR-SKY FRACTION OF THE COLUMN  
135  C                --------------------------------    ! *         2.2   CLOUDY FRACTION OF THE COLUMN
136  C      ! -----------------------------
137   210  CONTINUE  
138  C  
139        CALL SWCLR ( KNU    CALL swr(knu, palbd, pcg, pcld, pdsig, pomega, zrayl, psec, ptau, zcgaz, &
140       S  , PAER   , flag_aer, tauae, pizae, cgae      zpizaz, zray1, zray2, zrefz, zrj, zrk, zrmue, ztauaz, ztra1, ztra2)
141       S  , PALBP  , PDSIG , ZRAYL, PSEC  
142       S  , ZCGAZ  , ZPIZAZ, ZRAY1 , ZRAY2, ZREFZ, ZRJ0  
143       S  , ZRK0   , ZRMU0 , ZTAUAZ, ZTRA1, ZTRA2)    ! ------------------------------------------------------------------
144  C  
145  C    ! *         3.    OZONE ABSORPTION
146  C*         2.2   CLOUDY FRACTION OF THE COLUMN    ! ----------------
147  C                -----------------------------  
148  C  
149   220  CONTINUE    iind(1) = 1
150  C    iind(2) = 3
151        CALL SWR ( KNU    iind(3) = 1
152       S  , PALBD ,PCG   ,PCLD  ,PDSIG ,POMEGA,ZRAYL    iind(4) = 3
153       S  , PSEC  ,PTAU  
154       S  , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ  ,ZRK,ZRMUE  
155       S  , ZTAUAZ,ZTRA1 ,ZTRA2)    ! *         3.1   DOWNWARD FLUXES
156  C    ! ---------------
157  C  
158  C     ------------------------------------------------------------------  
159  C    jaj = 2
160  C*         3.    OZONE ABSORPTION  
161  C                ----------------    DO jl = 1, kdlon
162  C      zw(jl, 1) = 0.
163   300  CONTINUE      zw(jl, 2) = 0.
164  C      zw(jl, 3) = 0.
165        IIND(1)=1      zw(jl, 4) = 0.
166        IIND(2)=3      pfd(jl, kflev+1) = ((1.-pclear(jl))*zrj(jl,jaj,kflev+1)+pclear(jl)*zrj0( &
167        IIND(3)=1        jl,jaj,kflev+1))*rsun(knu)
168        IIND(4)=3    END DO
169  C          DO jk = 1, kflev
170  C      ikl = kflev + 1 - jk
171  C*         3.1   DOWNWARD FLUXES      DO jl = 1, kdlon
172  C                ---------------        zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikl)/zrmue(jl, ikl)
173  C        zw(jl, 2) = zw(jl, 2) + poz(jl, ikl)/zrmue(jl, ikl)
174   310  CONTINUE        zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikl)/zrmu0(jl, ikl)
175  C        zw(jl, 4) = zw(jl, 4) + poz(jl, ikl)/zrmu0(jl, ikl)
176        JAJ = 2      END DO
177  C  
178        DO 311 JL = 1, KDLON      CALL swtt1(knu, 4, iind, zw, zr)
179        ZW(JL,1)=0.  
180        ZW(JL,2)=0.      DO jl = 1, kdlon
181        ZW(JL,3)=0.        zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrj(jl, jaj, ikl)
182        ZW(JL,4)=0.        zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrj0(jl, jaj, ikl)
183        PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)        pfd(jl, ikl) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
184       S     + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)          rsun(knu)
185   311  CONTINUE      END DO
186        DO 314 JK = 1 , KFLEV    END DO
187        IKL = KFLEV+1-JK  
188        DO 312 JL = 1, KDLON  
189        ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKL)/ZRMUE(JL,IKL)    ! *         3.2   UPWARD FLUXES
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)  
193   312  CONTINUE    DO jl = 1, kdlon
194  C      pfu(jl, 1) = ((1.-pclear(jl))*zdiff(jl)*palbd(jl,knu)+pclear(jl)*zdirf(jl &
195        CALL SWTT1(KNU, 4, IIND, ZW, ZR)        )*palbp(jl,knu))*rsun(knu)
196  C    END DO
197        DO 313 JL = 1, KDLON  
198        ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRJ(JL,JAJ,IKL)    DO jk = 2, kflev + 1
199        ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRJ0(JL,JAJ,IKL)      ikm1 = jk - 1
200        PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)      DO jl = 1, kdlon
201       S                  +PCLEAR(JL)  * ZDIRF(JL)) * RSUN(KNU)        zw(jl, 1) = zw(jl, 1) + pud(jl, 1, ikm1)*1.66
202   313  CONTINUE        zw(jl, 2) = zw(jl, 2) + poz(jl, ikm1)*1.66
203   314  CONTINUE        zw(jl, 3) = zw(jl, 3) + pud(jl, 1, ikm1)*1.66
204  C        zw(jl, 4) = zw(jl, 4) + poz(jl, ikm1)*1.66
205  C      END DO
206  C*         3.2   UPWARD FLUXES  
207  C                -------------      CALL swtt1(knu, 4, iind, zw, zr)
208  C  
209   320  CONTINUE      DO jl = 1, kdlon
210  C        zdiff(jl) = zr(jl, 1)*zr(jl, 2)*zrk(jl, jaj, jk)
211        DO 325 JL = 1, KDLON        zdirf(jl) = zr(jl, 3)*zr(jl, 4)*zrk0(jl, jaj, jk)
212        PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)        pfu(jl, jk) = ((1.-pclear(jl))*zdiff(jl)+pclear(jl)*zdirf(jl))* &
213       S               + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))          rsun(knu)
214       S          * RSUN(KNU)      END DO
215   325  CONTINUE    END DO
216  C  
217        DO 328 JK = 2 , KFLEV+1    ! ------------------------------------------------------------------
218        IKM1=JK-1  
219        DO 326 JL = 1, KDLON    RETURN
220        ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66  END SUBROUTINE sw1s
       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.76  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21