/[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/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        real*8 flag_aer    DOUBLE PRECISION pizae(kdlon, kflev, 2)
46        real*8 tauae(kdlon,kflev,2)    DOUBLE PRECISION cgae(kdlon, kflev, 2)
47        real*8 pizae(kdlon,kflev,2)    DOUBLE PRECISION paer(kdlon, kflev, 5)
48        real*8 cgae(kdlon,kflev,2)    DOUBLE PRECISION palbd(kdlon, 2)
49        REAL*8 PAER(KDLON,KFLEV,5)    DOUBLE PRECISION palbp(kdlon, 2)
50        REAL*8 PALBD(KDLON,2)    DOUBLE PRECISION pcg(kdlon, 2, kflev)
51        REAL*8 PALBP(KDLON,2)    DOUBLE PRECISION pcld(kdlon, kflev)
52        REAL*8 PCG(KDLON,2,KFLEV)      DOUBLE PRECISION pcldsw(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.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.24  
changed lines
  Added in v.81
  ViewVC Help
Powered by ViewVC 1.1.21