1 |
heimbach |
1.1 |
|
2 |
|
|
#include "CPP_OPTIONS.h" |
3 |
|
|
|
4 |
|
|
c ================================================================== |
5 |
|
|
c |
6 |
|
|
c shpere.F: Routines that handle the projection onto sherical |
7 |
|
|
c harmonics. |
8 |
|
|
c |
9 |
|
|
c Routines: |
10 |
|
|
c |
11 |
|
|
c o adfsc4dat - Adjoint routine of fsc4dat. |
12 |
|
|
c o shc2grid - Evaluate a spherical harmonics model on a |
13 |
|
|
c regular grid. |
14 |
|
|
c o shc4grid - Evaluate a spherical harmonics model on a |
15 |
|
|
c regular grid. |
16 |
|
|
c |
17 |
|
|
c o shcrotate - s/r used for the sph analysis ... |
18 |
|
|
c o shc2zone - s/r used for the sph analysis ... |
19 |
|
|
c o shc4zone - s/r used for the sph analysis ... |
20 |
|
|
c o fsc2dat - s/r used for the sph analysis ... |
21 |
|
|
c o frsbase - s/r used for the sph analysis ... |
22 |
|
|
c o helmholtz - s/r used for the sph analysis ... |
23 |
|
|
c o recur_z - s/r used for the sph analysis ... |
24 |
|
|
c |
25 |
|
|
c o shcError - Print error message and stop program (see below). |
26 |
|
|
c |
27 |
|
|
c IMSL Routines: |
28 |
|
|
c |
29 |
|
|
c o fftrb - Compute the real periodic sequence from its Fourier |
30 |
|
|
c coefficients. |
31 |
|
|
c --> replace by NAGLIB routine. C06... |
32 |
|
|
c |
33 |
|
|
c Platform-specific: |
34 |
|
|
c |
35 |
|
|
c M abort - FORTRAN intrinsic on SUN and, presumably, on CRAY to |
36 |
|
|
c exit the program if an error condition is met. |
37 |
|
|
c |
38 |
|
|
c --> Replaced ABORT by shcError ( Christian Eckert MIT 22-Mar-2000 ) |
39 |
|
|
c |
40 |
|
|
c Note: |
41 |
|
|
c ===== |
42 |
|
|
c |
43 |
|
|
c Where code is written in lower case letters, changes were |
44 |
|
|
c introduced. The changes are mainly related to F90 syntax. |
45 |
|
|
c Additionally, I replaced the call to the intrinsic *AMOD* |
46 |
|
|
c by its generic name *MOD*. ( Ch.E. 25-May-1999 ) |
47 |
|
|
c |
48 |
|
|
c |
49 |
|
|
c Documentation: |
50 |
|
|
c |
51 |
|
|
c |
52 |
|
|
c ================================================================== |
53 |
|
|
|
54 |
|
|
SUBROUTINE FSC4DAT(N,FSC) |
55 |
|
|
|
56 |
|
|
IMPLICIT NONE |
57 |
|
|
|
58 |
|
|
INTEGER N |
59 |
|
|
REAL FSC(N) |
60 |
|
|
REAL SCALE |
61 |
|
|
integer i |
62 |
|
|
|
63 |
|
|
#ifdef USE_SPH_PROJECTION |
64 |
|
|
CALL FFTRF(N,FSC,FSC) |
65 |
|
|
#else |
66 |
|
|
do i=1,n |
67 |
|
|
fsc(i) = 0.0 |
68 |
|
|
enddo |
69 |
|
|
#endif |
70 |
|
|
|
71 |
|
|
SCALE = 2.0/FLOAT(N) |
72 |
|
|
FSC(1) = FSC(1)/FLOAT(N) |
73 |
|
|
|
74 |
|
|
CE FSC(2:N-1:2) = FSC(2:N-1:2)*SCALE |
75 |
|
|
CE FSC(3:N :2) =-FSC(3:N: 2)*SCALE ! change sign of SINE coeffs. |
76 |
|
|
|
77 |
|
|
do i = 2,n-1,2 |
78 |
|
|
fsc( i ) = fsc( i )*scale |
79 |
|
|
enddo |
80 |
|
|
do i = 3,n,2 |
81 |
|
|
fsc( i ) = -fsc( i )*scale ! change sign of sine coeffs. |
82 |
|
|
enddo |
83 |
|
|
|
84 |
|
|
IF (MOD(N,2).EQ.0) THEN |
85 |
|
|
FSC(N) = FSC(N)/FLOAT(N) |
86 |
|
|
ENDIF |
87 |
|
|
|
88 |
|
|
RETURN |
89 |
|
|
END |
90 |
|
|
|
91 |
|
|
c ================================================================== |
92 |
|
|
|
93 |
|
|
subroutine adfsc4dat(n,adfsc) |
94 |
|
|
|
95 |
|
|
implicit none |
96 |
|
|
|
97 |
|
|
integer n |
98 |
|
|
real adfsc(n) |
99 |
|
|
|
100 |
|
|
integer i |
101 |
|
|
|
102 |
|
|
#ifdef USE_SPH_PROJECTION |
103 |
|
|
call fftrb(n,adfsc,adfsc) |
104 |
|
|
#else |
105 |
|
|
do i=1,n |
106 |
|
|
adfsc(i) = 0.0 |
107 |
|
|
enddo |
108 |
|
|
#endif |
109 |
|
|
|
110 |
|
|
do i=1,n |
111 |
|
|
adfsc(i) = adfsc(i)/float(n) |
112 |
|
|
enddo |
113 |
|
|
|
114 |
|
|
end |
115 |
|
|
|
116 |
|
|
c ================================================================== |
117 |
|
|
|
118 |
|
|
SUBROUTINE SHC2GRID( LMAX, SHC, NLON, NLAT, GRID, P ) |
119 |
|
|
C |
120 |
|
|
C --- Evaluate a spherical harmonics model on a regular grid. |
121 |
|
|
C |
122 |
|
|
C SHC ! spherical harmonic coefficients in the order of |
123 |
|
|
C ! |
124 |
|
|
C ! C00 : SHC(1) |
125 |
|
|
C ! S11 C10 C11 : SHC(2) SHC(3) SHC(4) |
126 |
|
|
C ! S22 S21 C20 C21 C22 : SHC(5) SHC(6) SHC(7) SHC(8) SHC(9) |
127 |
|
|
C ! |
128 |
|
|
C ! i.e., C(L,M) = SHC(L*L+L+1+M) |
129 |
|
|
C ! S(L,M) = SHC(L*L+L+1-M) |
130 |
|
|
C NLAT ! number of latitude (zonal) lines. |
131 |
|
|
C NLON ! number of longitude (meridional) lines. |
132 |
|
|
C ! |
133 |
|
|
C GRID ! grid values in the order of |
134 |
|
|
C ! ((west to east),south to north) |
135 |
|
|
C ! ((LON=1,NLON),LAT=1,NLAT) |
136 |
|
|
C ! grid values are defined on the "centers" |
137 |
|
|
C ! of geographically regular equi-angular blocks. |
138 |
|
|
C |
139 |
|
|
C --- Coded by Dr. Myung-Chan Kim, Center for Space Research, 1997 |
140 |
|
|
C University of Texas at Austin, Austin, Texas, 78712 |
141 |
|
|
C |
142 |
|
|
IMPLICIT NONE |
143 |
|
|
|
144 |
|
|
INTEGER LMAX ! INPUT max. degree |
145 |
|
|
REAL SHC((1+LMAX)*(1+LMAX)) ! INPUT spherical harmonics |
146 |
|
|
INTEGER NLAT ! INPUT number of latitude lines. |
147 |
|
|
INTEGER NLON ! INPUT number of longitude lines. |
148 |
|
|
REAL GRID(NLON,NLAT) ! OUTPUT grid values |
149 |
|
|
REAL P((LMAX+1)*(LMAX+2)/2) ! work space |
150 |
|
|
|
151 |
|
|
INTEGER NLONLMT |
152 |
|
|
PARAMETER (NLONLMT=10000) |
153 |
|
|
REAL HS (NLONLMT) |
154 |
|
|
REAL HN (NLONLMT) |
155 |
|
|
|
156 |
|
|
REAL DLAT, ANGLE, XLAT1, XLAT2 |
157 |
|
|
INTEGER LATS, LATN |
158 |
|
|
|
159 |
|
|
ce integer js, jn |
160 |
|
|
|
161 |
|
|
integer i |
162 |
|
|
|
163 |
|
|
ce IF(NLON.GT.NLONLMT) CALL ABORT('NLON.GT.NLONLMT') |
164 |
|
|
ce IF(NLON.LT.LMAX*2 ) CALL ABORT('NLON.LT.LMAX*2 ') |
165 |
|
|
IF(NLON.GT.NLONLMT) CALL shcError('NLON.GT.NLONLMT',1) |
166 |
|
|
IF(NLON.LT.LMAX*2 ) CALL shcError('NLON.LT.LMAX*2 ',1) |
167 |
|
|
|
168 |
|
|
DLAT = 180.0/FLOAT(NLAT) |
169 |
|
|
ANGLE = 180.0/FLOAT(NLON) |
170 |
|
|
|
171 |
|
|
CALL SHCROTATE(LMAX,SHC,ANGLE) |
172 |
|
|
DO LATS = 1,(NLAT+1)/2 |
173 |
|
|
LATN = NLAT-(LATS-1) |
174 |
|
|
XLAT2 =-90.0 + FLOAT(LATS)*DLAT |
175 |
|
|
XLAT1 = XLAT2-DLAT |
176 |
|
|
do i=1,nlon |
177 |
|
|
hs(i) = 0.0 |
178 |
|
|
hn(i) = 0.0 |
179 |
|
|
enddo |
180 |
|
|
CALL SHC2ZONE( LMAX, SHC, XLAT1, XLAT2, HS, HN, P ) |
181 |
|
|
CALL FSC2DAT( NLON, HS ) |
182 |
|
|
CALL FSC2DAT( NLON, HN ) |
183 |
|
|
do i=1,nlon |
184 |
|
|
grid(i,lats) = hs(i) |
185 |
|
|
grid(i,latn) = hn(i) |
186 |
|
|
enddo |
187 |
|
|
ENDDO |
188 |
|
|
CALL SHCROTATE(LMAX,SHC,-ANGLE) |
189 |
|
|
RETURN |
190 |
|
|
END |
191 |
|
|
|
192 |
|
|
c ================================================================== |
193 |
|
|
|
194 |
|
|
SUBROUTINE SHC4GRID( LMAX, SHC, NLON, NLAT, GRID, P ) |
195 |
|
|
|
196 |
|
|
IMPLICIT NONE |
197 |
|
|
|
198 |
|
|
INTEGER LMAX ! INPUT max. degree |
199 |
|
|
REAL SHC((1+LMAX)*(1+LMAX)) ! OUTPUT spherical harmonics |
200 |
|
|
INTEGER NLAT ! INPUT number of latitude lines. |
201 |
|
|
INTEGER NLON ! INPUT number of longitude lines. |
202 |
|
|
REAL GRID(NLON,NLAT) ! INPUT grid values |
203 |
|
|
REAL P((LMAX+1)*(LMAX+2)/2) ! work space |
204 |
|
|
|
205 |
|
|
INTEGER NLONLMT |
206 |
|
|
PARAMETER (NLONLMT=10000) |
207 |
|
|
REAL HS (NLONLMT) |
208 |
|
|
REAL HN (NLONLMT) |
209 |
|
|
|
210 |
|
|
REAL DLAT, ANGLE, XLAT1, XLAT2 |
211 |
|
|
INTEGER LATS, LATN |
212 |
|
|
|
213 |
|
|
ce integer js, jn |
214 |
|
|
|
215 |
|
|
integer i |
216 |
|
|
|
217 |
|
|
IF(NLON.GT.NLONLMT) THEN |
218 |
|
|
PRINT *, 'NLON = ', NLON |
219 |
|
|
PRINT *, 'NLONLMT = ', NLONLMT |
220 |
|
|
ce CALL ABORT('NLON.GT.NLONLMT') |
221 |
|
|
CALL shcError('NLON.GT.NLONLMT',1) |
222 |
|
|
END IF |
223 |
|
|
|
224 |
|
|
IF(NLON.LT.LMAX*2 ) THEN |
225 |
|
|
PRINT *, 'NLON = ', NLON |
226 |
|
|
PRINT *, 'LMAX = ', LMAX |
227 |
|
|
ce CALL ABORT('NLON.LT.LMAX*2') |
228 |
|
|
CALL shcError('NLON.LT.LMAX*2',1) |
229 |
|
|
END IF |
230 |
|
|
|
231 |
|
|
DLAT = 180.0/FLOAT(NLAT) |
232 |
|
|
ANGLE = 180.0/FLOAT(NLON) |
233 |
|
|
DO LATS = 1,(NLAT+1)/2 |
234 |
|
|
LATN = NLAT-(LATS-1) |
235 |
|
|
do i = 1,nlon |
236 |
|
|
hs(i) = grid(i,lats) |
237 |
|
|
hn(i) = grid(i,latn) |
238 |
|
|
enddo |
239 |
|
|
CALL FSC4DAT(NLON,HS) |
240 |
|
|
CALL FSC4DAT(NLON,HN) |
241 |
|
|
XLAT2 =-90.0 + FLOAT(LATS)*DLAT |
242 |
|
|
XLAT1 = XLAT2-DLAT |
243 |
|
|
CALL SHC4ZONE(LMAX,SHC,XLAT1,XLAT2,HS,HN,P) |
244 |
|
|
ENDDO |
245 |
|
|
CALL SHCROTATE(LMAX,SHC,-ANGLE) |
246 |
|
|
|
247 |
|
|
RETURN |
248 |
|
|
END |
249 |
|
|
|
250 |
|
|
c ================================================================== |
251 |
|
|
|
252 |
|
|
SUBROUTINE SHCROTATE(LMAX,SHC,ANGLE) |
253 |
|
|
|
254 |
|
|
IMPLICIT NONE |
255 |
|
|
|
256 |
|
|
INTEGER LMAX ! max. degree of spherical harmonics. |
257 |
|
|
REAL SHC((1+LMAX)*(1+LMAX)) ! spherical harmonic coeffs. |
258 |
|
|
REAL ANGLE ! in degree. |
259 |
|
|
|
260 |
|
|
INTEGER LMAXLMT |
261 |
|
|
PARAMETER (LMAXLMT=10000) |
262 |
|
|
|
263 |
|
|
REAL H(LMAXLMT*2+1) |
264 |
|
|
INTEGER K, L, M |
265 |
|
|
REAL SINA, COSA, C, S |
266 |
|
|
|
267 |
|
|
if (mod(angle,360.0) .ne. 0.0) then |
268 |
|
|
|
269 |
|
|
CALL FRSBASE(ANGLE,H,1,1+LMAX+LMAX) |
270 |
|
|
|
271 |
|
|
DO M = 0,LMAX |
272 |
|
|
IF(M.EQ.0) THEN |
273 |
|
|
SINA = 0.0 |
274 |
|
|
COSA = 1.0 |
275 |
|
|
ELSE |
276 |
|
|
COSA = H(M+M) |
277 |
|
|
SINA = H(M+M+1) |
278 |
|
|
ENDIF |
279 |
|
|
DO L = M,LMAX |
280 |
|
|
K = L*L+L+1 |
281 |
|
|
C = SHC(K+M) |
282 |
|
|
S = SHC(K-M) |
283 |
|
|
SHC(K+M) = COSA*C + SINA*S |
284 |
|
|
SHC(K-M) =-SINA*C + COSA*S |
285 |
|
|
ENDDO |
286 |
|
|
ENDDO |
287 |
|
|
|
288 |
|
|
ENDIF |
289 |
|
|
|
290 |
|
|
RETURN |
291 |
|
|
END |
292 |
|
|
|
293 |
|
|
c ================================================================== |
294 |
|
|
|
295 |
|
|
SUBROUTINE SHC2ZONE(LMAX,SHC,XLAT1,XLAT2,HS,HN,P) |
296 |
|
|
|
297 |
|
|
IMPLICIT NONE |
298 |
|
|
|
299 |
|
|
INTEGER LMAX ! INPUT max. degree of spher. harmonics. |
300 |
|
|
REAL SHC((1+LMAX)*(1+LMAX)) ! INPUT spherical harmonic coeffs. |
301 |
|
|
REAL XLAT1 ! INPUT latitude. |
302 |
|
|
REAL XLAT2 ! INPUT latitude. |
303 |
|
|
REAL HS(1+LMAX+LMAX) ! OUTPUT |
304 |
|
|
REAL HN(1+LMAX+LMAX) ! OUTPUT |
305 |
|
|
REAL P((LMAX+1)*(LMAX+2)/2) ! INPUT |
306 |
|
|
|
307 |
|
|
INTEGER LMAXLMT |
308 |
|
|
PARAMETER (LMAXLMT=5000) |
309 |
|
|
|
310 |
|
|
REAL FACT(0:LMAXLMT) ! |
311 |
|
|
INTEGER LMAX1, J, K, L, M |
312 |
|
|
REAL DEG2RAD, SLAT |
313 |
|
|
REAL A, B, E, F, Q, DA, DB, XLAT |
314 |
|
|
|
315 |
|
|
ce IF (LMAX.GT.LMAXLMT) CALL ABORT('LMAX.GT.LMAXLMT') |
316 |
|
|
IF (LMAX.GT.LMAXLMT) CALL shcError('LMAX.GT.LMAXLMT',1) |
317 |
|
|
|
318 |
|
|
DEG2RAD = ACOS(-1.0)/180.0 |
319 |
|
|
XLAT = 0.5*(XLAT1+XLAT2) |
320 |
|
|
do k = 1,lmax |
321 |
|
|
fact(k) = 1.0 |
322 |
|
|
enddo |
323 |
|
|
SLAT = SIN(XLAT*DEG2RAD) |
324 |
|
|
|
325 |
|
|
CALL HELMHOLTZ(LMAX,SLAT,P) |
326 |
|
|
LMAX1 = LMAX+1 |
327 |
|
|
K = 0 |
328 |
|
|
DO M = 0,LMAX |
329 |
|
|
A = 0.0 |
330 |
|
|
B = 0.0 |
331 |
|
|
E = 0.0 |
332 |
|
|
F = 0.0 |
333 |
|
|
DO L = M,LMAX-1,2 |
334 |
|
|
K = K+1 |
335 |
|
|
J = L*L+L+1 |
336 |
|
|
Q = FACT(L)*P(K) |
337 |
|
|
DA = Q*SHC(J+M) |
338 |
|
|
DB = Q*SHC(J-M) |
339 |
|
|
A = A+DA |
340 |
|
|
B = B+DB |
341 |
|
|
E = E+DA |
342 |
|
|
F = F+DB |
343 |
|
|
K = K+1 |
344 |
|
|
J = J+L+L+2 |
345 |
|
|
Q = FACT(L+1)*P(K) |
346 |
|
|
DA = Q*SHC(J+M) |
347 |
|
|
DB = Q*SHC(J-M) |
348 |
|
|
A = A+DA |
349 |
|
|
B = B+DB |
350 |
|
|
E = E-DA |
351 |
|
|
F = F-DB |
352 |
|
|
ENDDO |
353 |
|
|
IF(MOD(LMAX-L,2).EQ.0) THEN |
354 |
|
|
K = K+1 |
355 |
|
|
J = LMAX*LMAX+LMAX+1 |
356 |
|
|
Q = FACT(LMAX)*P(K) |
357 |
|
|
DA = Q*SHC(J+M) |
358 |
|
|
DB = Q*SHC(J-M) |
359 |
|
|
A = A+DA |
360 |
|
|
B = B+DB |
361 |
|
|
E = E+DA |
362 |
|
|
F = F+DB |
363 |
|
|
ENDIF |
364 |
|
|
IF(M.EQ.0) THEN |
365 |
|
|
HS(1) = A |
366 |
|
|
HN(1) = E |
367 |
|
|
ELSE |
368 |
|
|
HS(M+M ) = A |
369 |
|
|
HS(M+M+1) = B |
370 |
|
|
HN(M+M ) = E |
371 |
|
|
HN(M+M+1) = F |
372 |
|
|
ENDIF |
373 |
|
|
ENDDO |
374 |
|
|
|
375 |
|
|
RETURN |
376 |
|
|
END |
377 |
|
|
|
378 |
|
|
c ================================================================== |
379 |
|
|
|
380 |
|
|
SUBROUTINE SHC4ZONE(LMAX,SHC,XLAT1,XLAT2,HS,HN,P) |
381 |
|
|
|
382 |
|
|
IMPLICIT NONE |
383 |
|
|
|
384 |
|
|
INTEGER LMAX |
385 |
|
|
REAL SHC((1+LMAX)*(1+LMAX)) ! spherical harmonic coeffs. |
386 |
|
|
REAL XLAT1 ! latitude. |
387 |
|
|
REAL XLAT2 ! latitude. |
388 |
|
|
REAL P((LMAX+1)*(LMAX+2)/2) |
389 |
|
|
C |
390 |
|
|
C - output - |
391 |
|
|
C |
392 |
|
|
REAL HS(1+LMAX+LMAX) |
393 |
|
|
REAL HN(1+LMAX+LMAX) |
394 |
|
|
C |
395 |
|
|
C - work space - |
396 |
|
|
C |
397 |
|
|
INTEGER LMAXLMT |
398 |
|
|
PARAMETER (LMAXLMT=5000) |
399 |
|
|
|
400 |
|
|
REAL XLAT, SIN0, SIN1, SIN2, SCALE |
401 |
|
|
REAL DEG2RAD, CE, CO, SE, SO |
402 |
|
|
INTEGER I, J, K, L, M |
403 |
|
|
INTEGER JP, I1, I2 |
404 |
|
|
|
405 |
|
|
ce IF(LMAX.GT.LMAXLMT) CALL ABORT('LMAX.GT.LMAXLMT') |
406 |
|
|
IF(LMAX.GT.LMAXLMT) CALL shcError('LMAX.GT.LMAXLMT',1) |
407 |
|
|
|
408 |
|
|
IF(XLAT1 .LT. -90.0+1.E-10) THEN |
409 |
|
|
do i = 1,(1+lmax)*(1+lmax) |
410 |
|
|
shc(i) = 0.0 |
411 |
|
|
enddo |
412 |
|
|
ENDIF |
413 |
|
|
|
414 |
|
|
XLAT = 0.5*(XLAT1+XLAT2) |
415 |
|
|
DEG2RAD = ACOS(-1.0)/180.0 |
416 |
|
|
SIN0 = SIN(XLAT *DEG2RAD) |
417 |
|
|
SIN1 = SIN(AMAX1(-90.0,XLAT1)*DEG2RAD) |
418 |
|
|
SIN2 = SIN(AMIN1( 0.0,XLAT2)*DEG2RAD) |
419 |
|
|
SCALE = (SIN2 - SIN1)*0.25 |
420 |
|
|
do i = 1,lmax+lmax+1 |
421 |
|
|
hs(i) = hs(i)*scale |
422 |
|
|
hn(i) = hn(i)*scale |
423 |
|
|
enddo |
424 |
|
|
|
425 |
|
|
CALL HELMHOLTZ(LMAX,SIN0,P) |
426 |
|
|
I = 0 |
427 |
|
|
cadj loop = parallel |
428 |
|
|
DO M = 0,LMAX |
429 |
|
|
IF (M .EQ. 0) THEN |
430 |
|
|
J = 1 |
431 |
|
|
JP = 1 |
432 |
|
|
ELSE |
433 |
|
|
J = 2*M |
434 |
|
|
JP = J+1 |
435 |
|
|
ENDIF |
436 |
|
|
CE = HS(J)+HN(J) |
437 |
|
|
CO = HS(J)-HN(J) |
438 |
|
|
SE = HS(J)+HN(JP) |
439 |
|
|
SO = HS(J)-HN(JP) |
440 |
|
|
I1 = I+1 |
441 |
|
|
I2 = I+2 |
442 |
|
|
cadj loop = parallel |
443 |
|
|
DO L = M,LMAX-1,2 |
444 |
|
|
K = L*L+L+1 |
445 |
|
|
SHC(K+M) = SHC(K+M) + P(I1) * CE |
446 |
|
|
SHC(K-M) = SHC(K-M) + P(I1) * SE |
447 |
|
|
K = K+L+L+2 |
448 |
|
|
SHC(K+M) = SHC(K+M) + P(I2) * CO |
449 |
|
|
SHC(K-M) = SHC(K-M) + P(I2) * SO |
450 |
|
|
ENDDO |
451 |
|
|
I = I + 2 |
452 |
|
|
IF(MOD(LMAX-M,2).NE.1) THEN |
453 |
|
|
I = I+1 |
454 |
|
|
K = LMAX*LMAX+LMAX+1 |
455 |
|
|
SHC(K+M) = SHC(K+M) + P(I) * CE |
456 |
|
|
SHC(K-M) = SHC(K-M) + P(I) * SE |
457 |
|
|
ENDIF |
458 |
|
|
ENDDO |
459 |
|
|
RETURN |
460 |
|
|
END |
461 |
|
|
|
462 |
|
|
c ================================================================== |
463 |
|
|
|
464 |
|
|
subroutine fsc2dat(n,fsc) |
465 |
|
|
c |
466 |
|
|
c --- this routine are coded to clarify the imsl's fftrf/fftrb. |
467 |
|
|
c |
468 |
|
|
implicit none |
469 |
|
|
|
470 |
|
|
integer n |
471 |
|
|
real fsc(n) |
472 |
|
|
|
473 |
|
|
integer i |
474 |
|
|
|
475 |
|
|
do i = 2,n-1,2 |
476 |
|
|
fsc(i ) = fsc(i )*0.5 |
477 |
|
|
fsc(i+1) = -fsc(i+1)*0.5 ! change sign of sine coeffs. |
478 |
|
|
enddo |
479 |
|
|
|
480 |
|
|
#ifdef USE_SPH_PROJECTION |
481 |
|
|
call fftrb(n,fsc,fsc) |
482 |
|
|
#else |
483 |
|
|
do i = 1,n |
484 |
|
|
fsc( i ) = 0.0 |
485 |
|
|
enddo |
486 |
|
|
#endif |
487 |
|
|
|
488 |
|
|
return |
489 |
|
|
end |
490 |
|
|
|
491 |
|
|
c ================================================================== |
492 |
|
|
|
493 |
|
|
SUBROUTINE FRSBASE(A,H,I,J) |
494 |
|
|
C |
495 |
|
|
C --- Given A (in degree), return H(I:J) = 1,COS(A),SIN(A)..... |
496 |
|
|
C |
497 |
|
|
IMPLICIT NONE |
498 |
|
|
|
499 |
|
|
REAL A |
500 |
|
|
REAL H(1) |
501 |
|
|
INTEGER I, J |
502 |
|
|
|
503 |
|
|
REAL DEG2RAD, T, ARG |
504 |
|
|
INTEGER N, L |
505 |
|
|
|
506 |
|
|
DEG2RAD = ACOS(-1.0)/180.0 |
507 |
|
|
|
508 |
|
|
N = J-I+1 |
509 |
|
|
IF(N.LE.0) RETURN |
510 |
|
|
H(I) = 1.0 |
511 |
|
|
IF(N.EQ.1) RETURN |
512 |
|
|
ARG = A * DEG2RAD |
513 |
|
|
H(I+1) = COS(ARG) |
514 |
|
|
IF(N.EQ.2) RETURN |
515 |
|
|
H(I+2) = SIN(ARG) |
516 |
|
|
IF(N.EQ.3) RETURN |
517 |
|
|
T = H(I+1)+H(I+1) |
518 |
|
|
H(I+3) = T*H(I+1) - 1.0 |
519 |
|
|
IF(N.EQ.4) RETURN |
520 |
|
|
H(I+4) = T*H(I+2) |
521 |
|
|
IF(N.EQ.5) RETURN |
522 |
|
|
DO L = I+5,J |
523 |
|
|
H(L) = T*H(L-2)-H(L-4) |
524 |
|
|
END DO |
525 |
|
|
|
526 |
|
|
RETURN |
527 |
|
|
END |
528 |
|
|
|
529 |
|
|
c ================================================================== |
530 |
|
|
|
531 |
|
|
SUBROUTINE HELMHOLTZ(LMAX,S,P) |
532 |
|
|
C |
533 |
|
|
C --- compute the fully normalized associated legendre polynomials. |
534 |
|
|
C |
535 |
|
|
IMPLICIT NONE |
536 |
|
|
|
537 |
|
|
INTEGER LMAX ! INPUT max. degree. |
538 |
|
|
REAL S ! INPUT sin(latitude). |
539 |
|
|
REAL P(1) ! OUTPUT assoc. legendre polynomials. |
540 |
|
|
|
541 |
|
|
INTEGER LMAXLMT |
542 |
|
|
PARAMETER(LMAXLMT=10800) |
543 |
|
|
|
544 |
|
|
REAL A(0:LMAXLMT) |
545 |
|
|
REAL ISECT(0:LMAXLMT) |
546 |
|
|
REAL X(LMAXLMT) |
547 |
|
|
REAL Y(LMAXLMT+LMAXLMT) |
548 |
|
|
REAL Z(LMAXLMT) |
549 |
|
|
|
550 |
|
|
INTEGER LMAXOLD |
551 |
|
|
DATA LMAXOLD/-1/ |
552 |
|
|
SAVE LMAXOLD, ISECT, X, Y, Z |
553 |
|
|
|
554 |
|
|
REAL C, CM, AK |
555 |
|
|
INTEGER K, L, N, M |
556 |
|
|
|
557 |
|
|
IF(LMAX.NE.LMAXOLD) THEN |
558 |
|
|
ISECT(0) = 1 |
559 |
|
|
DO L = 1,LMAX |
560 |
|
|
X(L) = SNGL(1.0D0/DSQRT(DBLE(FLOAT(4*L*L-1)))) |
561 |
|
|
Y(L) = SNGL(DSQRT(DBLE(FLOAT(L)))) |
562 |
|
|
Y(L+LMAX) = SNGL(DSQRT(DBLE(FLOAT(L+LMAX)))) |
563 |
|
|
ISECT(L) = L*LMAX-L*(L-3)/2+1 |
564 |
|
|
ENDDO |
565 |
|
|
CALL RECUR_Z(Z,LMAX) |
566 |
|
|
LMAXOLD = LMAX |
567 |
|
|
ENDIF |
568 |
|
|
|
569 |
|
|
C = SNGL(DSQRT(1.0D0-DBLE(S)*DBLE(S))) |
570 |
|
|
CM = 1.0 |
571 |
|
|
P(1) = 1.0 |
572 |
|
|
DO M = 1,LMAX |
573 |
|
|
K = ISECT(M) |
574 |
|
|
CM = C * CM |
575 |
|
|
P(K) = Z(M) * CM |
576 |
|
|
ENDDO |
577 |
|
|
N = 1 |
578 |
|
|
DO M = 0,LMAX-N |
579 |
|
|
K = ISECT(M)+N |
580 |
|
|
L = N+M |
581 |
|
|
AK = X(L)*Y(L+M)*Y(N) |
582 |
|
|
P(K) = S*P(K-1)/AK |
583 |
|
|
A(M) = AK |
584 |
|
|
ENDDO |
585 |
|
|
DO N = 2,LMAX |
586 |
|
|
DO M = 0,LMAX-N |
587 |
|
|
K = ISECT(M)+N |
588 |
|
|
L = N+M |
589 |
|
|
AK = X(L)*Y(L+M)*Y(N) |
590 |
|
|
P(K) =(S*P(K-1)-P(K-2)*A(M))/AK |
591 |
|
|
A(M) = AK |
592 |
|
|
ENDDO |
593 |
|
|
ENDDO |
594 |
|
|
RETURN |
595 |
|
|
END |
596 |
|
|
|
597 |
|
|
c ================================================================== |
598 |
|
|
|
599 |
|
|
SUBROUTINE RECUR_Z(Z,LMAX) |
600 |
|
|
C |
601 |
|
|
C --- Coefficients for fully normalized sectorial Legendre polynomials. |
602 |
|
|
C |
603 |
|
|
IMPLICIT NONE |
604 |
|
|
|
605 |
|
|
INTEGER LMAX |
606 |
|
|
REAL Z(LMAX) |
607 |
|
|
|
608 |
|
|
DOUBLE PRECISION ZZ |
609 |
|
|
INTEGER L |
610 |
|
|
|
611 |
|
|
ZZ = 2.0D0 |
612 |
|
|
DO L = 1,LMAX |
613 |
|
|
ZZ = ZZ * DBLE(FLOAT(L+L+1))/DBLE(FLOAT(L+L)) |
614 |
|
|
Z(L) = SNGL(DSQRT(ZZ)) |
615 |
|
|
ENDDO |
616 |
|
|
|
617 |
|
|
RETURN |
618 |
|
|
END |
619 |
|
|
|
620 |
|
|
c ================================================================== |
621 |
|
|
|
622 |
|
|
subroutine shcError( errstring, ierr ) |
623 |
|
|
c |
624 |
|
|
c --- Print an error message and exit. Written in order to replace |
625 |
|
|
c the machine specific routine ABORT. |
626 |
|
|
c ( Christian Eckert MIT 22-Mar-2000 ) |
627 |
|
|
c |
628 |
|
|
implicit none |
629 |
|
|
|
630 |
|
|
integer ierr |
631 |
|
|
character*(*) errstring |
632 |
|
|
|
633 |
|
|
if ( ierr .ne. 0 ) then |
634 |
|
|
print* |
635 |
|
|
print*,' sphere: ',errstring |
636 |
|
|
print* |
637 |
|
|
stop ' ... program stopped.' |
638 |
|
|
endif |
639 |
|
|
|
640 |
|
|
return |
641 |
|
|
end |
642 |
|
|
|
643 |
|
|
c ================================================================== |