/[lmdze]/trunk/libf/phylmd/Radlwsw/sw1s.f
ViewVC logotype

Contents of /trunk/libf/phylmd/Radlwsw/sw1s.f

Parent Directory Parent Directory | Revision Log Revision Log


Revision 71 - (show annotations)
Mon Jul 8 18:12:18 2013 UTC (10 years, 9 months ago) by guez
File size: 6913 byte(s)
No reason to call inidissip in ce0l.

In inidissip, set random seed to 1 beacuse PGI compiler does not
accept all zeros.

dq was computed needlessly in caladvtrac. Arguments masse and dq of
calfis not used.

Replaced real*8 by double precision.

Pass arrays with inverted order of vertical levels to conflx instead
of creating local variables for this inside conflx.

1 SUBROUTINE SW1S ( KNU
2 S , PAER , flag_aer, tauae, pizae, cgae
3 S , PALBD , PALBP, PCG , PCLD , PCLEAR, PCLDSW
4 S , PDSIG , POMEGA, POZ , PRMU , PSEC , PTAU , PUD
5 S , PFD , PFU)
6 use dimens_m
7 use dimphy
8 use raddim
9 IMPLICIT none
10 C
11 C ------------------------------------------------------------------
12 C PURPOSE.
13 C --------
14 C
15 C THIS ROUTINE COMPUTES THE SHORTWAVE RADIATION FLUXES IN TWO
16 C SPECTRAL INTERVALS FOLLOWING FOUQUART AND BONNEL (1980).
17 C
18 C METHOD.
19 C -------
20 C
21 C 1. COMPUTES UPWARD AND DOWNWARD FLUXES CORRESPONDING TO
22 C CONTINUUM SCATTERING
23 C 2. MULTIPLY BY OZONE TRANSMISSION FUNCTION
24 C
25 C REFERENCE.
26 C ----------
27 C
28 C SEE RADIATION'S PART OF THE ECMWF RESEARCH DEPARTMENT
29 C DOCUMENTATION, AND FOUQUART AND BONNEL (1980)
30 C
31 C AUTHOR.
32 C -------
33 C JEAN-JACQUES MORCRETTE *ECMWF*
34 C
35 C MODIFICATIONS.
36 C --------------
37 C ORIGINAL : 89-07-14
38 C 94-11-15 J.-J. MORCRETTE DIRECT/DIFFUSE ALBEDO
39 C ------------------------------------------------------------------
40 C
41 C* ARGUMENTS:
42 C
43 INTEGER KNU
44 c-OB
45 double precision flag_aer
46 double precision tauae(kdlon,kflev,2)
47 double precision pizae(kdlon,kflev,2)
48 double precision cgae(kdlon,kflev,2)
49 DOUBLE PRECISION PAER(KDLON,KFLEV,5)
50 DOUBLE PRECISION PALBD(KDLON,2)
51 DOUBLE PRECISION PALBP(KDLON,2)
52 DOUBLE PRECISION PCG(KDLON,2,KFLEV)
53 DOUBLE PRECISION PCLD(KDLON,KFLEV)
54 DOUBLE PRECISION PCLDSW(KDLON,KFLEV)
55 DOUBLE PRECISION PCLEAR(KDLON)
56 DOUBLE PRECISION PDSIG(KDLON,KFLEV)
57 DOUBLE PRECISION POMEGA(KDLON,2,KFLEV)
58 DOUBLE PRECISION POZ(KDLON,KFLEV)
59 DOUBLE PRECISION PRMU(KDLON)
60 DOUBLE PRECISION PSEC(KDLON)
61 DOUBLE PRECISION PTAU(KDLON,2,KFLEV)
62 DOUBLE PRECISION PUD(KDLON,5,KFLEV+1)
63 C
64 DOUBLE PRECISION PFD(KDLON,KFLEV+1)
65 DOUBLE PRECISION PFU(KDLON,KFLEV+1)
66 C
67 C* LOCAL VARIABLES:
68 C
69 INTEGER IIND(4)
70 C
71 DOUBLE PRECISION ZCGAZ(KDLON,KFLEV)
72 DOUBLE PRECISION ZDIFF(KDLON)
73 DOUBLE PRECISION ZDIRF(KDLON)
74 DOUBLE PRECISION ZPIZAZ(KDLON,KFLEV)
75 DOUBLE PRECISION ZRAYL(KDLON)
76 DOUBLE PRECISION ZRAY1(KDLON,KFLEV+1)
77 DOUBLE PRECISION ZRAY2(KDLON,KFLEV+1)
78 DOUBLE PRECISION ZREFZ(KDLON,2,KFLEV+1)
79 DOUBLE PRECISION ZRJ(KDLON,6,KFLEV+1)
80 DOUBLE PRECISION ZRJ0(KDLON,6,KFLEV+1)
81 DOUBLE PRECISION ZRK(KDLON,6,KFLEV+1)
82 DOUBLE PRECISION ZRK0(KDLON,6,KFLEV+1)
83 DOUBLE PRECISION ZRMUE(KDLON,KFLEV+1)
84 DOUBLE PRECISION ZRMU0(KDLON,KFLEV+1)
85 DOUBLE PRECISION ZR(KDLON,4)
86 DOUBLE PRECISION ZTAUAZ(KDLON,KFLEV)
87 DOUBLE PRECISION ZTRA1(KDLON,KFLEV+1)
88 DOUBLE PRECISION ZTRA2(KDLON,KFLEV+1)
89 DOUBLE PRECISION ZW(KDLON,4)
90 C
91 INTEGER jl, jk, k, jaj, ikm1, ikl
92 c
93 c Prescribed Data:
94 c
95 DOUBLE PRECISION RSUN(2)
96 SAVE RSUN
97 DOUBLE PRECISION RRAY(2,6)
98 SAVE RRAY
99 DATA RSUN(1) / 0.441676 /
100 DATA RSUN(2) / 0.558324 /
101 DATA (RRAY(1,K),K=1,6) /
102 S .428937E-01, .890743E+00,-.288555E+01,
103 S .522744E+01,-.469173E+01, .161645E+01/
104 DATA (RRAY(2,K),K=1,6) /
105 S .697200E-02, .173297E-01,-.850903E-01,
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 ----------------------- ------------------
111 C
112 100 CONTINUE
113 C
114 C
115 C* 1.1 OPTICAL THICKNESS FOR RAYLEIGH SCATTERING
116 C -----------------------------------------
117 C
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)
123 S * (RRAY(KNU,5) + PRMU(JL) * RRAY(KNU,6) ))))
124 111 CONTINUE
125 C
126 C
127 C ------------------------------------------------------------------
128 C
129 C* 2. CONTINUUM SCATTERING CALCULATIONS
130 C ---------------------------------
131 C
132 200 CONTINUE
133 C
134 C* 2.1 CLEAR-SKY FRACTION OF THE COLUMN
135 C --------------------------------
136 C
137 210 CONTINUE
138 C
139 CALL SWCLR ( KNU
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
145 C
146 C* 2.2 CLOUDY FRACTION OF THE COLUMN
147 C -----------------------------
148 C
149 220 CONTINUE
150 C
151 CALL SWR ( KNU
152 S , PALBD ,PCG ,PCLD ,PDSIG ,POMEGA,ZRAYL
153 S , PSEC ,PTAU
154 S , ZCGAZ ,ZPIZAZ,ZRAY1 ,ZRAY2 ,ZREFZ ,ZRJ ,ZRK,ZRMUE
155 S , ZTAUAZ,ZTRA1 ,ZTRA2)
156 C
157 C
158 C ------------------------------------------------------------------
159 C
160 C* 3. OZONE ABSORPTION
161 C ----------------
162 C
163 300 CONTINUE
164 C
165 IIND(1)=1
166 IIND(2)=3
167 IIND(3)=1
168 IIND(4)=3
169 C
170 C
171 C* 3.1 DOWNWARD FLUXES
172 C ---------------
173 C
174 310 CONTINUE
175 C
176 JAJ = 2
177 C
178 DO 311 JL = 1, KDLON
179 ZW(JL,1)=0.
180 ZW(JL,2)=0.
181 ZW(JL,3)=0.
182 ZW(JL,4)=0.
183 PFD(JL,KFLEV+1)=((1.-PCLEAR(JL))*ZRJ(JL,JAJ,KFLEV+1)
184 S + PCLEAR(JL) *ZRJ0(JL,JAJ,KFLEV+1)) * RSUN(KNU)
185 311 CONTINUE
186 DO 314 JK = 1 , KFLEV
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)
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
194 C
195 CALL SWTT1(KNU, 4, IIND, ZW, ZR)
196 C
197 DO 313 JL = 1, KDLON
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)
200 PFD(JL,IKL) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
201 S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU)
202 313 CONTINUE
203 314 CONTINUE
204 C
205 C
206 C* 3.2 UPWARD FLUXES
207 C -------------
208 C
209 320 CONTINUE
210 C
211 DO 325 JL = 1, KDLON
212 PFU(JL,1) = ((1.-PCLEAR(JL))*ZDIFF(JL)*PALBD(JL,KNU)
213 S + PCLEAR(JL) *ZDIRF(JL)*PALBP(JL,KNU))
214 S * RSUN(KNU)
215 325 CONTINUE
216 C
217 DO 328 JK = 2 , KFLEV+1
218 IKM1=JK-1
219 DO 326 JL = 1, KDLON
220 ZW(JL,1)=ZW(JL,1)+PUD(JL,1,IKM1)*1.66
221 ZW(JL,2)=ZW(JL,2)+POZ(JL, IKM1)*1.66
222 ZW(JL,3)=ZW(JL,3)+PUD(JL,1,IKM1)*1.66
223 ZW(JL,4)=ZW(JL,4)+POZ(JL, IKM1)*1.66
224 326 CONTINUE
225 C
226 CALL SWTT1(KNU, 4, IIND, ZW, ZR)
227 C
228 DO 327 JL = 1, KDLON
229 ZDIFF(JL) = ZR(JL,1)*ZR(JL,2)*ZRK(JL,JAJ,JK)
230 ZDIRF(JL) = ZR(JL,3)*ZR(JL,4)*ZRK0(JL,JAJ,JK)
231 PFU(JL,JK) = ((1.-PCLEAR(JL)) * ZDIFF(JL)
232 S +PCLEAR(JL) * ZDIRF(JL)) * RSUN(KNU)
233 327 CONTINUE
234 328 CONTINUE
235 C
236 C ------------------------------------------------------------------
237 C
238 RETURN
239 END

  ViewVC Help
Powered by ViewVC 1.1.21