NCEPLIBS-sp 2.4.0
sptgpsv.f
Go to the documentation of this file.
1C> @file
2C> @brief Transform spectral vector to polar stereo.
3C>
4C> ### Program History Log
5C> Date | Programmer | Comments
6C> -----|------------|---------
7C> 96-02-29 | Iredell | Initial.
8C> 1998-12-15 | Iredell | Openmp directives inserted.
9C>
10C> @author Iredell @date 96-02-29
11
12C> This subprogram performs a spherical transform
13C> from spectral coefficients of divergences and curls
14C> to vector fields on a pair of polar stereographic grids.
15C> The wave-space can be either triangular or rhomboidal.
16C>
17C> The wave and grid fields may have general indexing,
18C> but each wave field is in sequential 'IBM order',
19C> i.e. with zonal wavenumber as the slower index.
20C>
21C> The two square polar stereographic grids are centered
22C> on the respective poles, with the orientation longitude
23C> of the southern hemisphere grid 180 degrees opposite
24C> that of the northern hemisphere grid.
25C>
26C> The vectors are automatically rotated to be resolved
27C> relative to the respective polar stereographic grids.
28C>
29C> The transform is made efficient
30C> by combining points in eight sectors
31C> of each polar stereographic grid,
32C> numbered as in the diagram below.
33C> The pole and the sector boundaries
34C> are treated specially in the code.
35C> Unfortunately, this approach induces
36C> some hairy indexing and code loquacity,
37C> for which the developer apologizes.
38C>
39C> <pre>
40C> \ 4 | 5 /
41C> \ | /
42C> 3 \ | / 6
43C> \|/
44C> ----+----
45C> /|\
46C> 2 / | \ 7
47C> / | \
48C> / 1 | 8 \
49C> </pre>
50C>
51C> The transforms are all multiprocessed over sector points.
52C> transform several fields at a time to improve vectorization.
53C> subprogram can be called from a multiprocessing environment.
54C>
55C> @param IROMB spectral domain shape
56C> (0 for triangular, 1 for rhomboidal)
57C> @param MAXWV spectral truncation
58C> @param KMAX number of fields to transform.
59C> @param NPS odd order of the polar stereographic grids
60C> @param KWSKIP skip number between wave fields
61C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
62C> @param KGSKIP skip number between grid fields
63C> (defaults to NPS*NPS if KGSKIP=0)
64C> @param NISKIP skip number between grid i-points
65C> (defaults to 1 if NISKIP=0)
66C> @param NJSKIP skip number between grid j-points
67C> (defaults to NPS if NJSKIP=0)
68C> @param TRUE latitude at which ps grid is true (usually 60.)
69C> @param XMESH grid length at true latitude (m)
70C> @param ORIENT longitude at bottom of northern ps grid
71C> (southern ps grid will have opposite orientation.)
72C> @param WAVED wave divergence fields
73C> @param WAVEZ wave vorticity fields
74C> @param UN northern polar stereographic u-winds
75C> @param VN northern polar stereographic v-winds
76C> @param US southern polar stereographic u-winds
77C> @param VS southern polar stereographic v-winds
78C>
79C> @author Iredell @date 96-02-29
80 SUBROUTINE sptgpsv(IROMB,MAXWV,KMAX,NPS,
81 & KWSKIP,KGSKIP,NISKIP,NJSKIP,
82 & TRUE,XMESH,ORIENT,WAVED,WAVEZ,UN,VN,US,VS)
83
84 REAL WAVED(*),WAVEZ(*),UN(*),VN(*),US(*),VS(*)
85 REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
86 REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
87 REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
88 REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
89 INTEGER MP(2*KMAX)
90 REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3)
91 REAL W((MAXWV+1)*((IROMB+1)*MAXWV+2)/2*2+1,2*KMAX)
92 REAL WTOP(2*(MAXWV+1),2*KMAX)
93 REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
94 REAL F(2*MAXWV+3,2,2*KMAX)
95 DATA srot/0.,1.,0.,-1./,crot/1.,0.,-1.,0./
96 parameter(rerth=6.3712e6)
97 parameter(pi=3.14159265358979,dpr=180./pi)
98
99C CALCULATE PRELIMINARY CONSTANTS
100 CALL spwget(iromb,maxwv,eps,epstop,enn1,elonn1,eon,eontop)
101 mx=(maxwv+1)*((iromb+1)*maxwv+2)/2
102 mxtop=maxwv+1
103 mdim=2*mx+1
104 idim=2*maxwv+3
105 kw=kwskip
106 kg=kgskip
107 ni=niskip
108 nj=njskip
109 IF(kw.EQ.0) kw=2*mx
110 IF(kg.EQ.0) kg=nps*nps
111 IF(ni.EQ.0) ni=1
112 IF(nj.EQ.0) nj=nps
113 mp=1
114 nph=(nps-1)/2
115 gq=((1.+sin(true/dpr))*rerth/xmesh)**2
116 srh=sqrt(0.5)
117
118C CALCULATE SPECTRAL WINDS
119C$OMP PARALLEL DO PRIVATE(KWS)
120 DO k=1,kmax
121 kws=(k-1)*kw
122 CALL spdz2uv(iromb,maxwv,enn1,elonn1,eon,eontop,
123 & waved(kws+1),wavez(kws+1),
124 & w(1,k),w(1,kmax+k),wtop(1,k),wtop(1,kmax+k))
125 ENDDO
126
127C CALCULATE POLE POINT
128 i1=nph+1
129 j1=nph+1
130 ij1=(i1-1)*ni+(j1-1)*nj+1
131 slat1=1.
132 clat1=0.
133 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
134 & pln,plntop)
135 CALL spsynth(iromb,maxwv,2*maxwv,idim,mdim,2*mxtop,2*kmax,
136 & clat1,pln,plntop,mp,w,wtop,f)
137 coso=cos(orient/dpr)
138 sino=sin(orient/dpr)
139CDIR$ IVDEP
140 DO k=1,kmax
141 ku=k
142 kv=k+kmax
143 ijk1=ij1+(k-1)*kg
144 un(ijk1)=2*( coso*f(3,1,ku)+sino*f(3,1,kv))
145 vn(ijk1)=2*(-sino*f(3,1,ku)+coso*f(3,1,kv))
146 us(ijk1)=2*( coso*f(3,2,ku)-sino*f(3,2,kv))
147 vs(ijk1)=2*( sino*f(3,2,ku)+coso*f(3,2,kv))
148 ENDDO
149
150C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE,
151C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
152C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
153C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
154C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
155C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
156C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
157 DO j1=1,nph
158 i1=nph+1
159 radlon=orient/dpr
160 j3=nps+1-i1
161 i3=j1
162 j5=nps+1-j1
163 i5=nps+1-i1
164 j7=i1
165 i7=nps+1-j1
166 ij1=(i1-1)*ni+(j1-1)*nj+1
167 ij3=(i3-1)*ni+(j3-1)*nj+1
168 ij5=(i5-1)*ni+(j5-1)*nj+1
169 ij7=(i7-1)*ni+(j7-1)*nj+1
170 di1=i1-nph-1
171 dj1=j1-nph-1
172 rq=di1**2+dj1**2
173 slat1=(gq-rq)/(gq+rq)
174 clat1=sqrt(1.-slat1**2)
175 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
176 & pln,plntop)
177 CALL spsynth(iromb,maxwv,2*maxwv,idim,mdim,2*mxtop,2*kmax,
178 & clat1,pln,plntop,mp,w,wtop,f)
179 DO l=1,maxwv
180 slon(l,1)=sin(l*radlon)
181 clon(l,1)=cos(l*radlon)
182 slon(l,3)=slon(l,1)*crot(mod(1*l,4))
183 & -clon(l,1)*srot(mod(1*l,4))
184 clon(l,3)=clon(l,1)*crot(mod(1*l,4))
185 & +slon(l,1)*srot(mod(1*l,4))
186 slon(l,5)=slon(l,1)*crot(mod(2*l,4))
187 & -clon(l,1)*srot(mod(2*l,4))
188 clon(l,5)=clon(l,1)*crot(mod(2*l,4))
189 & +slon(l,1)*srot(mod(2*l,4))
190 slon(l,7)=slon(l,1)*crot(mod(3*l,4))
191 & -clon(l,1)*srot(mod(3*l,4))
192 clon(l,7)=clon(l,1)*crot(mod(3*l,4))
193 & +slon(l,1)*srot(mod(3*l,4))
194 ENDDO
195CDIR$ IVDEP
196 DO k=1,kmax
197 ku=k
198 kv=k+kmax
199 ijk1=ij1+(k-1)*kg
200 ijk3=ij3+(k-1)*kg
201 ijk5=ij5+(k-1)*kg
202 ijk7=ij7+(k-1)*kg
203 un(ijk1)= f(1,1,ku)
204 vn(ijk1)= f(1,1,kv)
205 un(ijk3)= f(1,1,kv)
206 vn(ijk3)=-f(1,1,ku)
207 un(ijk5)=-f(1,1,ku)
208 vn(ijk5)=-f(1,1,kv)
209 un(ijk7)=-f(1,1,kv)
210 vn(ijk7)= f(1,1,ku)
211 us(ijk1)=-f(1,2,ku)
212 vs(ijk1)=-f(1,2,kv)
213 us(ijk3)=-f(1,2,kv)
214 vs(ijk3)= f(1,2,ku)
215 us(ijk5)= f(1,2,ku)
216 vs(ijk5)= f(1,2,kv)
217 us(ijk7)= f(1,2,kv)
218 vs(ijk7)=-f(1,2,ku)
219 ENDDO
220 IF(kmax.EQ.1) THEN
221 ku=1
222 kv=2
223 DO l=1,maxwv
224 lr=2*l+1
225 li=2*l+2
226 un(ij1)=un(ij1)+2*(f(lr,1,ku)*clon(l,1)
227 & -f(li,1,ku)*slon(l,1))
228 vn(ij1)=vn(ij1)+2*(f(lr,1,kv)*clon(l,1)
229 & -f(li,1,kv)*slon(l,1))
230 un(ij3)=un(ij3)+2*(f(lr,1,kv)*clon(l,3)
231 & -f(li,1,kv)*slon(l,3))
232 vn(ij3)=vn(ij3)-2*(f(lr,1,ku)*clon(l,3)
233 & -f(li,1,ku)*slon(l,3))
234 un(ij5)=un(ij5)-2*(f(lr,1,ku)*clon(l,5)
235 & -f(li,1,ku)*slon(l,5))
236 vn(ij5)=vn(ij5)-2*(f(lr,1,kv)*clon(l,5)
237 & -f(li,1,kv)*slon(l,5))
238 un(ij7)=un(ij7)-2*(f(lr,1,kv)*clon(l,7)
239 & -f(li,1,kv)*slon(l,7))
240 vn(ij7)=vn(ij7)+2*(f(lr,1,ku)*clon(l,7)
241 & -f(li,1,ku)*slon(l,7))
242 us(ij1)=us(ij1)-2*(f(lr,2,ku)*clon(l,5)
243 & -f(li,2,ku)*slon(l,5))
244 vs(ij1)=vs(ij1)-2*(f(lr,2,kv)*clon(l,5)
245 & -f(li,2,kv)*slon(l,5))
246 us(ij3)=us(ij3)-2*(f(lr,2,kv)*clon(l,3)
247 & -f(li,2,kv)*slon(l,3))
248 vs(ij3)=vs(ij3)+2*(f(lr,2,ku)*clon(l,3)
249 & -f(li,2,ku)*slon(l,3))
250 us(ij5)=us(ij5)+2*(f(lr,2,ku)*clon(l,1)
251 & -f(li,2,ku)*slon(l,1))
252 vs(ij5)=vs(ij5)+2*(f(lr,2,kv)*clon(l,1)
253 & -f(li,2,kv)*slon(l,1))
254 us(ij7)=us(ij7)+2*(f(lr,2,kv)*clon(l,7)
255 & -f(li,2,kv)*slon(l,7))
256 vs(ij7)=vs(ij7)-2*(f(lr,2,ku)*clon(l,7)
257 & -f(li,2,ku)*slon(l,7))
258 ENDDO
259 ELSE
260 DO l=1,maxwv
261 lr=2*l+1
262 li=2*l+2
263CDIR$ IVDEP
264 DO k=1,kmax
265 ku=k
266 kv=k+kmax
267 ijk1=ij1+(k-1)*kg
268 ijk3=ij3+(k-1)*kg
269 ijk5=ij5+(k-1)*kg
270 ijk7=ij7+(k-1)*kg
271 un(ijk1)=un(ijk1)+2*(f(lr,1,ku)*clon(l,1)
272 & -f(li,1,ku)*slon(l,1))
273 vn(ijk1)=vn(ijk1)+2*(f(lr,1,kv)*clon(l,1)
274 & -f(li,1,kv)*slon(l,1))
275 un(ijk3)=un(ijk3)+2*(f(lr,1,kv)*clon(l,3)
276 & -f(li,1,kv)*slon(l,3))
277 vn(ijk3)=vn(ijk3)-2*(f(lr,1,ku)*clon(l,3)
278 & -f(li,1,ku)*slon(l,3))
279 un(ijk5)=un(ijk5)-2*(f(lr,1,ku)*clon(l,5)
280 & -f(li,1,ku)*slon(l,5))
281 vn(ijk5)=vn(ijk5)-2*(f(lr,1,kv)*clon(l,5)
282 & -f(li,1,kv)*slon(l,5))
283 un(ijk7)=un(ijk7)-2*(f(lr,1,kv)*clon(l,7)
284 & -f(li,1,kv)*slon(l,7))
285 vn(ijk7)=vn(ijk7)+2*(f(lr,1,ku)*clon(l,7)
286 & -f(li,1,ku)*slon(l,7))
287 us(ijk1)=us(ijk1)-2*(f(lr,2,ku)*clon(l,5)
288 & -f(li,2,ku)*slon(l,5))
289 vs(ijk1)=vs(ijk1)-2*(f(lr,2,kv)*clon(l,5)
290 & -f(li,2,kv)*slon(l,5))
291 us(ijk3)=us(ijk3)-2*(f(lr,2,kv)*clon(l,3)
292 & -f(li,2,kv)*slon(l,3))
293 vs(ijk3)=vs(ijk3)+2*(f(lr,2,ku)*clon(l,3)
294 & -f(li,2,ku)*slon(l,3))
295 us(ijk5)=us(ijk5)+2*(f(lr,2,ku)*clon(l,1)
296 & -f(li,2,ku)*slon(l,1))
297 vs(ijk5)=vs(ijk5)+2*(f(lr,2,kv)*clon(l,1)
298 & -f(li,2,kv)*slon(l,1))
299 us(ijk7)=us(ijk7)+2*(f(lr,2,kv)*clon(l,7)
300 & -f(li,2,kv)*slon(l,7))
301 vs(ijk7)=vs(ijk7)-2*(f(lr,2,ku)*clon(l,7)
302 & -f(li,2,ku)*slon(l,7))
303 ENDDO
304 ENDDO
305 ENDIF
306 ENDDO
307
308C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE,
309C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
310C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
311C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
312C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
313C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
314C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
315 DO j1=1,nph
316 i1=j1
317 radlon=(orient-45)/dpr
318 j3=nps+1-i1
319 i3=j1
320 j5=nps+1-j1
321 i5=nps+1-i1
322 j7=i1
323 i7=nps+1-j1
324 ij1=(i1-1)*ni+(j1-1)*nj+1
325 ij3=(i3-1)*ni+(j3-1)*nj+1
326 ij5=(i5-1)*ni+(j5-1)*nj+1
327 ij7=(i7-1)*ni+(j7-1)*nj+1
328 di1=i1-nph-1
329 dj1=j1-nph-1
330 rq=di1**2+dj1**2
331 slat1=(gq-rq)/(gq+rq)
332 clat1=sqrt(1.-slat1**2)
333 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
334 & pln,plntop)
335 CALL spsynth(iromb,maxwv,2*maxwv,idim,mdim,2*mxtop,2*kmax,
336 & clat1,pln,plntop,mp,w,wtop,f)
337 DO l=1,maxwv
338 slon(l,1)=sin(l*radlon)
339 clon(l,1)=cos(l*radlon)
340 slon(l,3)=slon(l,1)*crot(mod(1*l,4))
341 & -clon(l,1)*srot(mod(1*l,4))
342 clon(l,3)=clon(l,1)*crot(mod(1*l,4))
343 & +slon(l,1)*srot(mod(1*l,4))
344 slon(l,5)=slon(l,1)*crot(mod(2*l,4))
345 & -clon(l,1)*srot(mod(2*l,4))
346 clon(l,5)=clon(l,1)*crot(mod(2*l,4))
347 & +slon(l,1)*srot(mod(2*l,4))
348 slon(l,7)=slon(l,1)*crot(mod(3*l,4))
349 & -clon(l,1)*srot(mod(3*l,4))
350 clon(l,7)=clon(l,1)*crot(mod(3*l,4))
351 & +slon(l,1)*srot(mod(3*l,4))
352 ENDDO
353CDIR$ IVDEP
354 DO k=1,kmax
355 ku=k
356 kv=k+kmax
357 ijk1=ij1+(k-1)*kg
358 ijk3=ij3+(k-1)*kg
359 ijk5=ij5+(k-1)*kg
360 ijk7=ij7+(k-1)*kg
361 un(ijk1)=srh*( f(1,1,ku)+f(1,1,kv))
362 vn(ijk1)=srh*(-f(1,1,ku)+f(1,1,kv))
363 un(ijk3)=srh*(-f(1,1,ku)+f(1,1,kv))
364 vn(ijk3)=srh*(-f(1,1,ku)-f(1,1,kv))
365 un(ijk5)=srh*(-f(1,1,ku)-f(1,1,kv))
366 vn(ijk5)=srh*( f(1,1,ku)-f(1,1,kv))
367 un(ijk7)=srh*( f(1,1,ku)-f(1,1,kv))
368 vn(ijk7)=srh*( f(1,1,ku)+f(1,1,kv))
369 us(ijk1)=srh*(-f(1,2,ku)-f(1,2,kv))
370 vs(ijk1)=srh*( f(1,2,ku)-f(1,2,kv))
371 us(ijk3)=srh*( f(1,2,ku)-f(1,2,kv))
372 vs(ijk3)=srh*( f(1,2,ku)+f(1,2,kv))
373 us(ijk5)=srh*( f(1,2,ku)+f(1,2,kv))
374 vs(ijk5)=srh*(-f(1,2,ku)+f(1,2,kv))
375 us(ijk7)=srh*(-f(1,2,ku)+f(1,2,kv))
376 vs(ijk7)=srh*(-f(1,2,ku)-f(1,2,kv))
377 ENDDO
378 IF(kmax.EQ.1) THEN
379 ku=1
380 kv=2
381 DO l=1,maxwv
382 lr=2*l+1
383 li=2*l+2
384 un(ij1)=un(ij1)+2*srh*(( f(lr,1,ku)+f(lr,1,kv))
385 & *clon(l,1)
386 & -( f(li,1,ku)+f(li,1,kv))
387 & *slon(l,1))
388 vn(ij1)=vn(ij1)+2*srh*((-f(lr,1,ku)+f(lr,1,kv))
389 & *clon(l,1)
390 & -(-f(li,1,ku)+f(li,1,kv))
391 & *slon(l,1))
392 un(ij3)=un(ij3)+2*srh*((-f(lr,1,ku)+f(lr,1,kv))
393 & *clon(l,3)
394 & -(-f(li,1,ku)+f(li,1,kv))
395 & *slon(l,3))
396 vn(ij3)=vn(ij3)+2*srh*((-f(lr,1,ku)-f(lr,1,kv))
397 & *clon(l,3)
398 & -(-f(li,1,ku)-f(li,1,kv))
399 & *slon(l,3))
400 un(ij5)=un(ij5)+2*srh*((-f(lr,1,ku)-f(lr,1,kv))
401 & *clon(l,5)
402 & -(-f(li,1,ku)-f(li,1,kv))
403 & *slon(l,5))
404 vn(ij5)=vn(ij5)+2*srh*(( f(lr,1,ku)-f(lr,1,kv))
405 & *clon(l,5)
406 & -( f(li,1,ku)-f(li,1,kv))
407 & *slon(l,5))
408 un(ij7)=un(ij7)+2*srh*(( f(lr,1,ku)-f(lr,1,kv))
409 & *clon(l,7)
410 & -( f(li,1,ku)-f(li,1,kv))
411 & *slon(l,7))
412 vn(ij7)=vn(ij7)+2*srh*(( f(lr,1,ku)+f(lr,1,kv))
413 & *clon(l,7)
414 & -( f(li,1,ku)+f(li,1,kv))
415 & *slon(l,7))
416 us(ij1)=us(ij1)+2*srh*((-f(lr,2,ku)-f(lr,2,kv))
417 & *clon(l,3)
418 & -(-f(li,2,ku)-f(li,2,kv))
419 & *slon(l,3))
420 vs(ij1)=vs(ij1)+2*srh*(( f(lr,2,ku)-f(lr,2,kv))
421 & *clon(l,3)
422 & -( f(li,2,ku)-f(li,2,kv))
423 & *slon(l,3))
424 us(ij3)=us(ij3)+2*srh*(( f(lr,2,ku)-f(lr,2,kv))
425 & *clon(l,1)
426 & -( f(li,2,ku)-f(li,2,kv))
427 & *slon(l,1))
428 vs(ij3)=vs(ij3)+2*srh*(( f(lr,2,ku)+f(lr,2,kv))
429 & *clon(l,1)
430 & -( f(li,2,ku)+f(li,2,kv))
431 & *slon(l,1))
432 us(ij5)=us(ij5)+2*srh*(( f(lr,2,ku)+f(lr,2,kv))
433 & *clon(l,7)
434 & -( f(li,2,ku)+f(li,2,kv))
435 & *slon(l,7))
436 vs(ij5)=vs(ij5)+2*srh*((-f(lr,2,ku)+f(lr,2,kv))
437 & *clon(l,7)
438 & -(-f(li,2,ku)+f(li,2,kv))
439 & *slon(l,7))
440 us(ij7)=us(ij7)+2*srh*((-f(lr,2,ku)+f(lr,2,kv))
441 & *clon(l,5)
442 & -(-f(li,2,ku)+f(li,2,kv))
443 & *slon(l,5))
444 vs(ij7)=vs(ij7)+2*srh*((-f(lr,2,ku)-f(lr,2,kv))
445 & *clon(l,5)
446 & -(-f(li,2,ku)-f(li,2,kv))
447 & *slon(l,5))
448 ENDDO
449 ELSE
450 DO l=1,maxwv
451 lr=2*l+1
452 li=2*l+2
453CDIR$ IVDEP
454 DO k=1,kmax
455 ku=k
456 kv=k+kmax
457 ijk1=ij1+(k-1)*kg
458 ijk3=ij3+(k-1)*kg
459 ijk5=ij5+(k-1)*kg
460 ijk7=ij7+(k-1)*kg
461 un(ijk1)=un(ijk1)+2*srh*(( f(lr,1,ku)+f(lr,1,kv))
462 & *clon(l,1)
463 & -( f(li,1,ku)+f(li,1,kv))
464 & *slon(l,1))
465 vn(ijk1)=vn(ijk1)+2*srh*((-f(lr,1,ku)+f(lr,1,kv))
466 & *clon(l,1)
467 & -(-f(li,1,ku)+f(li,1,kv))
468 & *slon(l,1))
469 un(ijk3)=un(ijk3)+2*srh*((-f(lr,1,ku)+f(lr,1,kv))
470 & *clon(l,3)
471 & -(-f(li,1,ku)+f(li,1,kv))
472 & *slon(l,3))
473 vn(ijk3)=vn(ijk3)+2*srh*((-f(lr,1,ku)-f(lr,1,kv))
474 & *clon(l,3)
475 & -(-f(li,1,ku)-f(li,1,kv))
476 & *slon(l,3))
477 un(ijk5)=un(ijk5)+2*srh*((-f(lr,1,ku)-f(lr,1,kv))
478 & *clon(l,5)
479 & -(-f(li,1,ku)-f(li,1,kv))
480 & *slon(l,5))
481 vn(ijk5)=vn(ijk5)+2*srh*(( f(lr,1,ku)-f(lr,1,kv))
482 & *clon(l,5)
483 & -( f(li,1,ku)-f(li,1,kv))
484 & *slon(l,5))
485 un(ijk7)=un(ijk7)+2*srh*(( f(lr,1,ku)-f(lr,1,kv))
486 & *clon(l,7)
487 & -( f(li,1,ku)-f(li,1,kv))
488 & *slon(l,7))
489 vn(ijk7)=vn(ijk7)+2*srh*(( f(lr,1,ku)+f(lr,1,kv))
490 & *clon(l,7)
491 & -( f(li,1,ku)+f(li,1,kv))
492 & *slon(l,7))
493 us(ijk1)=us(ijk1)+2*srh*((-f(lr,2,ku)-f(lr,2,kv))
494 & *clon(l,3)
495 & -(-f(li,2,ku)-f(li,2,kv))
496 & *slon(l,3))
497 vs(ijk1)=vs(ijk1)+2*srh*(( f(lr,2,ku)-f(lr,2,kv))
498 & *clon(l,3)
499 & -( f(li,2,ku)-f(li,2,kv))
500 & *slon(l,3))
501 us(ijk3)=us(ijk3)+2*srh*(( f(lr,2,ku)-f(lr,2,kv))
502 & *clon(l,1)
503 & -( f(li,2,ku)-f(li,2,kv))
504 & *slon(l,1))
505 vs(ijk3)=vs(ijk3)+2*srh*(( f(lr,2,ku)+f(lr,2,kv))
506 & *clon(l,1)
507 & -( f(li,2,ku)+f(li,2,kv))
508 & *slon(l,1))
509 us(ijk5)=us(ijk5)+2*srh*(( f(lr,2,ku)+f(lr,2,kv))
510 & *clon(l,7)
511 & -( f(li,2,ku)+f(li,2,kv))
512 & *slon(l,7))
513 vs(ijk5)=vs(ijk5)+2*srh*((-f(lr,2,ku)+f(lr,2,kv))
514 & *clon(l,7)
515 & -(-f(li,2,ku)+f(li,2,kv))
516 & *slon(l,7))
517 us(ijk7)=us(ijk7)+2*srh*((-f(lr,2,ku)+f(lr,2,kv))
518 & *clon(l,5)
519 & -(-f(li,2,ku)+f(li,2,kv))
520 & *slon(l,5))
521 vs(ijk7)=vs(ijk7)+2*srh*((-f(lr,2,ku)-f(lr,2,kv))
522 & *clon(l,5)
523 & -(-f(li,2,ku)-f(li,2,kv))
524 & *slon(l,5))
525 ENDDO
526 ENDDO
527 ENDIF
528 ENDDO
529
530C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN,
531C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE
532C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE.
533C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
534C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
535C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
536C$OMP& PRIVATE(DJ1,DI1,RQ,RR,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
537C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,KU,KV,LR,LI)
538 DO j1=1,nph-1
539 DO i1=j1+1,nph
540 j2=i1
541 i2=j1
542 j3=nps+1-i1
543 i3=j1
544 j4=nps+1-j1
545 i4=i1
546 j5=nps+1-j1
547 i5=nps+1-i1
548 j6=nps+1-i1
549 i6=nps+1-j1
550 j7=i1
551 i7=nps+1-j1
552 j8=j1
553 i8=nps+1-i1
554 ij1=(i1-1)*ni+(j1-1)*nj+1
555 ij2=(i2-1)*ni+(j2-1)*nj+1
556 ij3=(i3-1)*ni+(j3-1)*nj+1
557 ij4=(i4-1)*ni+(j4-1)*nj+1
558 ij5=(i5-1)*ni+(j5-1)*nj+1
559 ij6=(i6-1)*ni+(j6-1)*nj+1
560 ij7=(i7-1)*ni+(j7-1)*nj+1
561 ij8=(i8-1)*ni+(j8-1)*nj+1
562 di1=i1-nph-1
563 dj1=j1-nph-1
564 rq=di1**2+dj1**2
565 rr=sqrt(1/rq)
566 slat1=(gq-rq)/(gq+rq)
567 clat1=sqrt(1.-slat1**2)
568 radlon1=orient/dpr+atan(-di1/dj1)
569 radlon2=(orient-45)/dpr*2-radlon1
570 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
571 & pln,plntop)
572 CALL spsynth(iromb,maxwv,2*maxwv,idim,mdim,2*mxtop,2*kmax,
573 & clat1,pln,plntop,mp,w,wtop,f)
574 DO l=1,maxwv
575 slon(l,1)=sin(l*radlon1)
576 clon(l,1)=cos(l*radlon1)
577 slon(l,2)=sin(l*radlon2)
578 clon(l,2)=cos(l*radlon2)
579 slon(l,3)=slon(l,1)*crot(mod(1*l,4))
580 & -clon(l,1)*srot(mod(1*l,4))
581 clon(l,3)=clon(l,1)*crot(mod(1*l,4))
582 & +slon(l,1)*srot(mod(1*l,4))
583 slon(l,4)=slon(l,2)*crot(mod(1*l,4))
584 & -clon(l,2)*srot(mod(1*l,4))
585 clon(l,4)=clon(l,2)*crot(mod(1*l,4))
586 & +slon(l,2)*srot(mod(1*l,4))
587 slon(l,5)=slon(l,1)*crot(mod(2*l,4))
588 & -clon(l,1)*srot(mod(2*l,4))
589 clon(l,5)=clon(l,1)*crot(mod(2*l,4))
590 & +slon(l,1)*srot(mod(2*l,4))
591 slon(l,6)=slon(l,2)*crot(mod(2*l,4))
592 & -clon(l,2)*srot(mod(2*l,4))
593 clon(l,6)=clon(l,2)*crot(mod(2*l,4))
594 & +slon(l,2)*srot(mod(2*l,4))
595 slon(l,7)=slon(l,1)*crot(mod(3*l,4))
596 & -clon(l,1)*srot(mod(3*l,4))
597 clon(l,7)=clon(l,1)*crot(mod(3*l,4))
598 & +slon(l,1)*srot(mod(3*l,4))
599 slon(l,8)=slon(l,2)*crot(mod(3*l,4))
600 & -clon(l,2)*srot(mod(3*l,4))
601 clon(l,8)=clon(l,2)*crot(mod(3*l,4))
602 & +slon(l,2)*srot(mod(3*l,4))
603 ENDDO
604CDIR$ IVDEP
605 DO k=1,kmax
606 ku=k
607 kv=k+kmax
608 ijk1=ij1+(k-1)*kg
609 ijk2=ij2+(k-1)*kg
610 ijk3=ij3+(k-1)*kg
611 ijk4=ij4+(k-1)*kg
612 ijk5=ij5+(k-1)*kg
613 ijk6=ij6+(k-1)*kg
614 ijk7=ij7+(k-1)*kg
615 ijk8=ij8+(k-1)*kg
616 un(ijk1)=rr*(-dj1*f(1,1,ku)-di1*f(1,1,kv))
617 vn(ijk1)=rr*( di1*f(1,1,ku)-dj1*f(1,1,kv))
618 un(ijk2)=rr*(-di1*f(1,1,ku)-dj1*f(1,1,kv))
619 vn(ijk2)=rr*( dj1*f(1,1,ku)-di1*f(1,1,kv))
620 un(ijk3)=rr*( di1*f(1,1,ku)-dj1*f(1,1,kv))
621 vn(ijk3)=rr*( dj1*f(1,1,ku)+di1*f(1,1,kv))
622 un(ijk4)=rr*( dj1*f(1,1,ku)-di1*f(1,1,kv))
623 vn(ijk4)=rr*( di1*f(1,1,ku)+dj1*f(1,1,kv))
624 un(ijk5)=rr*( dj1*f(1,1,ku)+di1*f(1,1,kv))
625 vn(ijk5)=rr*(-di1*f(1,1,ku)+dj1*f(1,1,kv))
626 un(ijk6)=rr*( di1*f(1,1,ku)+dj1*f(1,1,kv))
627 vn(ijk6)=rr*(-dj1*f(1,1,ku)+di1*f(1,1,kv))
628 un(ijk7)=rr*(-di1*f(1,1,ku)+dj1*f(1,1,kv))
629 vn(ijk7)=rr*(-dj1*f(1,1,ku)-di1*f(1,1,kv))
630 un(ijk8)=rr*(-dj1*f(1,1,ku)+di1*f(1,1,kv))
631 vn(ijk8)=rr*(-di1*f(1,1,ku)-dj1*f(1,1,kv))
632 us(ijk1)=rr*( dj1*f(1,2,ku)+di1*f(1,2,kv))
633 vs(ijk1)=rr*(-di1*f(1,2,ku)+dj1*f(1,2,kv))
634 us(ijk2)=rr*( di1*f(1,2,ku)+dj1*f(1,2,kv))
635 vs(ijk2)=rr*(-dj1*f(1,2,ku)+di1*f(1,2,kv))
636 us(ijk3)=rr*(-di1*f(1,2,ku)+dj1*f(1,2,kv))
637 vs(ijk3)=rr*(-dj1*f(1,2,ku)-di1*f(1,2,kv))
638 us(ijk4)=rr*(-dj1*f(1,2,ku)+di1*f(1,2,kv))
639 vs(ijk4)=rr*(-di1*f(1,2,ku)-dj1*f(1,2,kv))
640 us(ijk5)=rr*(-dj1*f(1,2,ku)-di1*f(1,2,kv))
641 vs(ijk5)=rr*( di1*f(1,2,ku)-dj1*f(1,2,kv))
642 us(ijk6)=rr*(-di1*f(1,2,ku)-dj1*f(1,2,kv))
643 vs(ijk6)=rr*( dj1*f(1,2,ku)-di1*f(1,2,kv))
644 us(ijk7)=rr*( di1*f(1,2,ku)-dj1*f(1,2,kv))
645 vs(ijk7)=rr*( dj1*f(1,2,ku)+di1*f(1,2,kv))
646 us(ijk8)=rr*( dj1*f(1,2,ku)-di1*f(1,2,kv))
647 vs(ijk8)=rr*( di1*f(1,2,ku)+dj1*f(1,2,kv))
648 ENDDO
649 IF(kmax.EQ.1) THEN
650 ku=1
651 kv=2
652 DO l=1,maxwv
653 lr=2*l+1
654 li=2*l+2
655 un(ij1)=un(ij1)+2*rr*((-dj1*f(lr,1,ku)-di1*f(lr,1,kv))
656 & *clon(l,1)
657 & -(-dj1*f(li,1,ku)-di1*f(li,1,kv))
658 & *slon(l,1))
659 vn(ij1)=vn(ij1)+2*rr*(( di1*f(lr,1,ku)-dj1*f(lr,1,kv))
660 & *clon(l,1)
661 & -( di1*f(li,1,ku)-dj1*f(li,1,kv))
662 & *slon(l,1))
663 un(ij2)=un(ij2)+2*rr*((-di1*f(lr,1,ku)-dj1*f(lr,1,kv))
664 & *clon(l,2)
665 & -(-di1*f(li,1,ku)-dj1*f(li,1,kv))
666 & *slon(l,2))
667 vn(ij2)=vn(ij2)+2*rr*(( dj1*f(lr,1,ku)-di1*f(lr,1,kv))
668 & *clon(l,2)
669 & -( dj1*f(li,1,ku)-di1*f(li,1,kv))
670 & *slon(l,2))
671 un(ij3)=un(ij3)+2*rr*(( di1*f(lr,1,ku)-dj1*f(lr,1,kv))
672 & *clon(l,3)
673 & -( di1*f(li,1,ku)-dj1*f(li,1,kv))
674 & *slon(l,3))
675 vn(ij3)=vn(ij3)+2*rr*(( dj1*f(lr,1,ku)+di1*f(lr,1,kv))
676 & *clon(l,3)
677 & -( dj1*f(li,1,ku)+di1*f(li,1,kv))
678 & *slon(l,3))
679 un(ij4)=un(ij4)+2*rr*(( dj1*f(lr,1,ku)-di1*f(lr,1,kv))
680 & *clon(l,4)
681 & -( dj1*f(li,1,ku)-di1*f(li,1,kv))
682 & *slon(l,4))
683 vn(ij4)=vn(ij4)+2*rr*(( di1*f(lr,1,ku)+dj1*f(lr,1,kv))
684 & *clon(l,4)
685 & -( di1*f(li,1,ku)+dj1*f(li,1,kv))
686 & *slon(l,4))
687 un(ij5)=un(ij5)+2*rr*(( dj1*f(lr,1,ku)+di1*f(lr,1,kv))
688 & *clon(l,5)
689 & -( dj1*f(li,1,ku)+di1*f(li,1,kv))
690 & *slon(l,5))
691 vn(ij5)=vn(ij5)+2*rr*((-di1*f(lr,1,ku)+dj1*f(lr,1,kv))
692 & *clon(l,5)
693 & -(-di1*f(li,1,ku)+dj1*f(li,1,kv))
694 & *slon(l,5))
695 un(ij6)=un(ij6)+2*rr*(( di1*f(lr,1,ku)+dj1*f(lr,1,kv))
696 & *clon(l,6)
697 & -( di1*f(li,1,ku)+dj1*f(li,1,kv))
698 & *slon(l,6))
699 vn(ij6)=vn(ij6)+2*rr*((-dj1*f(lr,1,ku)+di1*f(lr,1,kv))
700 & *clon(l,6)
701 & -(-dj1*f(li,1,ku)+di1*f(li,1,kv))
702 & *slon(l,6))
703 un(ij7)=un(ij7)+2*rr*((-di1*f(lr,1,ku)+dj1*f(lr,1,kv))
704 & *clon(l,7)
705 & -(-di1*f(li,1,ku)+dj1*f(li,1,kv))
706 & *slon(l,7))
707 vn(ij7)=vn(ij7)+2*rr*((-dj1*f(lr,1,ku)-di1*f(lr,1,kv))
708 & *clon(l,7)
709 & -(-dj1*f(li,1,ku)-di1*f(li,1,kv))
710 & *slon(l,7))
711 un(ij8)=un(ij8)+2*rr*((-dj1*f(lr,1,ku)+di1*f(lr,1,kv))
712 & *clon(l,8)
713 & -(-dj1*f(li,1,ku)+di1*f(li,1,kv))
714 & *slon(l,8))
715 vn(ij8)=vn(ij8)+2*rr*((-di1*f(lr,1,ku)-dj1*f(lr,1,kv))
716 & *clon(l,8)
717 & -(-di1*f(li,1,ku)-dj1*f(li,1,kv))
718 & *slon(l,8))
719 us(ij1)=us(ij1)+2*rr*(( dj1*f(lr,2,ku)+di1*f(lr,2,kv))
720 & *clon(l,4)
721 & -( dj1*f(li,2,ku)+di1*f(li,2,kv))
722 & *slon(l,4))
723 vs(ij1)=vs(ij1)+2*rr*((-di1*f(lr,2,ku)+dj1*f(lr,2,kv))
724 & *clon(l,4)
725 & -(-di1*f(li,2,ku)+dj1*f(li,2,kv))
726 & *slon(l,4))
727 us(ij2)=us(ij2)+2*rr*(( di1*f(lr,2,ku)+dj1*f(lr,2,kv))
728 & *clon(l,3)
729 & -( di1*f(li,2,ku)+dj1*f(li,2,kv))
730 & *slon(l,3))
731 vs(ij2)=vs(ij2)+2*rr*((-dj1*f(lr,2,ku)+di1*f(lr,2,kv))
732 & *clon(l,3)
733 & -(-dj1*f(li,2,ku)+di1*f(li,2,kv))
734 & *slon(l,3))
735 us(ij3)=us(ij3)+2*rr*((-di1*f(lr,2,ku)+dj1*f(lr,2,kv))
736 & *clon(l,2)
737 & -(-di1*f(li,2,ku)+dj1*f(li,2,kv))
738 & *slon(l,2))
739 vs(ij3)=vs(ij3)+2*rr*((-dj1*f(lr,2,ku)-di1*f(lr,2,kv))
740 & *clon(l,2)
741 & -(-dj1*f(li,2,ku)-di1*f(li,2,kv))
742 & *slon(l,2))
743 us(ij4)=us(ij4)+2*rr*((-dj1*f(lr,2,ku)+di1*f(lr,2,kv))
744 & *clon(l,1)
745 & -(-dj1*f(li,2,ku)+di1*f(li,2,kv))
746 & *slon(l,1))
747 vs(ij4)=vs(ij4)+2*rr*((-di1*f(lr,2,ku)-dj1*f(lr,2,kv))
748 & *clon(l,1)
749 & -(-di1*f(li,2,ku)-dj1*f(li,2,kv))
750 & *slon(l,1))
751 us(ij5)=us(ij5)+2*rr*((-dj1*f(lr,2,ku)-di1*f(lr,2,kv))
752 & *clon(l,8)
753 & -(-dj1*f(li,2,ku)-di1*f(li,2,kv))
754 & *slon(l,8))
755 vs(ij5)=vs(ij5)+2*rr*(( di1*f(lr,2,ku)-dj1*f(lr,2,kv))
756 & *clon(l,8)
757 & -( di1*f(li,2,ku)-dj1*f(li,2,kv))
758 & *slon(l,8))
759 us(ij6)=us(ij6)+2*rr*((-di1*f(lr,2,ku)-dj1*f(lr,2,kv))
760 & *clon(l,7)
761 & -(-di1*f(li,2,ku)-dj1*f(li,2,kv))
762 & *slon(l,7))
763 vs(ij6)=vs(ij6)+2*rr*(( dj1*f(lr,2,ku)-di1*f(lr,2,kv))
764 & *clon(l,7)
765 & -( dj1*f(li,2,ku)-di1*f(li,2,kv))
766 & *slon(l,7))
767 us(ij7)=us(ij7)+2*rr*(( di1*f(lr,2,ku)-dj1*f(lr,2,kv))
768 & *clon(l,6)
769 & -( di1*f(li,2,ku)-dj1*f(li,2,kv))
770 & *slon(l,6))
771 vs(ij7)=vs(ij7)+2*rr*(( dj1*f(lr,2,ku)+di1*f(lr,2,kv))
772 & *clon(l,6)
773 & -( dj1*f(li,2,ku)+di1*f(li,2,kv))
774 & *slon(l,6))
775 us(ij8)=us(ij8)+2*rr*(( dj1*f(lr,2,ku)-di1*f(lr,2,kv))
776 & *clon(l,5)
777 & -( dj1*f(li,2,ku)-di1*f(li,2,kv))
778 & *slon(l,5))
779 vs(ij8)=vs(ij8)+2*rr*(( di1*f(lr,2,ku)+dj1*f(lr,2,kv))
780 & *clon(l,5)
781 & -( di1*f(li,2,ku)+dj1*f(li,2,kv))
782 & *slon(l,5))
783 ENDDO
784 ELSE
785 DO l=1,maxwv
786 lr=2*l+1
787 li=2*l+2
788CDIR$ IVDEP
789 DO k=1,kmax
790 ku=k
791 kv=k+kmax
792 ijk1=ij1+(k-1)*kg
793 ijk2=ij2+(k-1)*kg
794 ijk3=ij3+(k-1)*kg
795 ijk4=ij4+(k-1)*kg
796 ijk5=ij5+(k-1)*kg
797 ijk6=ij6+(k-1)*kg
798 ijk7=ij7+(k-1)*kg
799 ijk8=ij8+(k-1)*kg
800 un(ijk1)=un(ijk1)+2*rr*((-dj1*f(lr,1,ku)-di1*f(lr,1,kv))
801 & *clon(l,1)
802 & -(-dj1*f(li,1,ku)-di1*f(li,1,kv))
803 & *slon(l,1))
804 vn(ijk1)=vn(ijk1)+2*rr*(( di1*f(lr,1,ku)-dj1*f(lr,1,kv))
805 & *clon(l,1)
806 & -( di1*f(li,1,ku)-dj1*f(li,1,kv))
807 & *slon(l,1))
808 un(ijk2)=un(ijk2)+2*rr*((-di1*f(lr,1,ku)-dj1*f(lr,1,kv))
809 & *clon(l,2)
810 & -(-di1*f(li,1,ku)-dj1*f(li,1,kv))
811 & *slon(l,2))
812 vn(ijk2)=vn(ijk2)+2*rr*(( dj1*f(lr,1,ku)-di1*f(lr,1,kv))
813 & *clon(l,2)
814 & -( dj1*f(li,1,ku)-di1*f(li,1,kv))
815 & *slon(l,2))
816 un(ijk3)=un(ijk3)+2*rr*(( di1*f(lr,1,ku)-dj1*f(lr,1,kv))
817 & *clon(l,3)
818 & -( di1*f(li,1,ku)-dj1*f(li,1,kv))
819 & *slon(l,3))
820 vn(ijk3)=vn(ijk3)+2*rr*(( dj1*f(lr,1,ku)+di1*f(lr,1,kv))
821 & *clon(l,3)
822 & -( dj1*f(li,1,ku)+di1*f(li,1,kv))
823 & *slon(l,3))
824 un(ijk4)=un(ijk4)+2*rr*(( dj1*f(lr,1,ku)-di1*f(lr,1,kv))
825 & *clon(l,4)
826 & -( dj1*f(li,1,ku)-di1*f(li,1,kv))
827 & *slon(l,4))
828 vn(ijk4)=vn(ijk4)+2*rr*(( di1*f(lr,1,ku)+dj1*f(lr,1,kv))
829 & *clon(l,4)
830 & -( di1*f(li,1,ku)+dj1*f(li,1,kv))
831 & *slon(l,4))
832 un(ijk5)=un(ijk5)+2*rr*(( dj1*f(lr,1,ku)+di1*f(lr,1,kv))
833 & *clon(l,5)
834 & -( dj1*f(li,1,ku)+di1*f(li,1,kv))
835 & *slon(l,5))
836 vn(ijk5)=vn(ijk5)+2*rr*((-di1*f(lr,1,ku)+dj1*f(lr,1,kv))
837 & *clon(l,5)
838 & -(-di1*f(li,1,ku)+dj1*f(li,1,kv))
839 & *slon(l,5))
840 un(ijk6)=un(ijk6)+2*rr*(( di1*f(lr,1,ku)+dj1*f(lr,1,kv))
841 & *clon(l,6)
842 & -( di1*f(li,1,ku)+dj1*f(li,1,kv))
843 & *slon(l,6))
844 vn(ijk6)=vn(ijk6)+2*rr*((-dj1*f(lr,1,ku)+di1*f(lr,1,kv))
845 & *clon(l,6)
846 & -(-dj1*f(li,1,ku)+di1*f(li,1,kv))
847 & *slon(l,6))
848 un(ijk7)=un(ijk7)+2*rr*((-di1*f(lr,1,ku)+dj1*f(lr,1,kv))
849 & *clon(l,7)
850 & -(-di1*f(li,1,ku)+dj1*f(li,1,kv))
851 & *slon(l,7))
852 vn(ijk7)=vn(ijk7)+2*rr*((-dj1*f(lr,1,ku)-di1*f(lr,1,kv))
853 & *clon(l,7)
854 & -(-dj1*f(li,1,ku)-di1*f(li,1,kv))
855 & *slon(l,7))
856 un(ijk8)=un(ijk8)+2*rr*((-dj1*f(lr,1,ku)+di1*f(lr,1,kv))
857 & *clon(l,8)
858 & -(-dj1*f(li,1,ku)+di1*f(li,1,kv))
859 & *slon(l,8))
860 vn(ijk8)=vn(ijk8)+2*rr*((-di1*f(lr,1,ku)-dj1*f(lr,1,kv))
861 & *clon(l,8)
862 & -(-di1*f(li,1,ku)-dj1*f(li,1,kv))
863 & *slon(l,8))
864 us(ijk1)=us(ijk1)+2*rr*(( dj1*f(lr,2,ku)+di1*f(lr,2,kv))
865 & *clon(l,4)
866 & -( dj1*f(li,2,ku)+di1*f(li,2,kv))
867 & *slon(l,4))
868 vs(ijk1)=vs(ijk1)+2*rr*((-di1*f(lr,2,ku)+dj1*f(lr,2,kv))
869 & *clon(l,4)
870 & -(-di1*f(li,2,ku)+dj1*f(li,2,kv))
871 & *slon(l,4))
872 us(ijk2)=us(ijk2)+2*rr*(( di1*f(lr,2,ku)+dj1*f(lr,2,kv))
873 & *clon(l,3)
874 & -( di1*f(li,2,ku)+dj1*f(li,2,kv))
875 & *slon(l,3))
876 vs(ijk2)=vs(ijk2)+2*rr*((-dj1*f(lr,2,ku)+di1*f(lr,2,kv))
877 & *clon(l,3)
878 & -(-dj1*f(li,2,ku)+di1*f(li,2,kv))
879 & *slon(l,3))
880 us(ijk3)=us(ijk3)+2*rr*((-di1*f(lr,2,ku)+dj1*f(lr,2,kv))
881 & *clon(l,2)
882 & -(-di1*f(li,2,ku)+dj1*f(li,2,kv))
883 & *slon(l,2))
884 vs(ijk3)=vs(ijk3)+2*rr*((-dj1*f(lr,2,ku)-di1*f(lr,2,kv))
885 & *clon(l,2)
886 & -(-dj1*f(li,2,ku)-di1*f(li,2,kv))
887 & *slon(l,2))
888 us(ijk4)=us(ijk4)+2*rr*((-dj1*f(lr,2,ku)+di1*f(lr,2,kv))
889 & *clon(l,1)
890 & -(-dj1*f(li,2,ku)+di1*f(li,2,kv))
891 & *slon(l,1))
892 vs(ijk4)=vs(ijk4)+2*rr*((-di1*f(lr,2,ku)-dj1*f(lr,2,kv))
893 & *clon(l,1)
894 & -(-di1*f(li,2,ku)-dj1*f(li,2,kv))
895 & *slon(l,1))
896 us(ijk5)=us(ijk5)+2*rr*((-dj1*f(lr,2,ku)-di1*f(lr,2,kv))
897 & *clon(l,8)
898 & -(-dj1*f(li,2,ku)-di1*f(li,2,kv))
899 & *slon(l,8))
900 vs(ijk5)=vs(ijk5)+2*rr*(( di1*f(lr,2,ku)-dj1*f(lr,2,kv))
901 & *clon(l,8)
902 & -( di1*f(li,2,ku)-dj1*f(li,2,kv))
903 & *slon(l,8))
904 us(ijk6)=us(ijk6)+2*rr*((-di1*f(lr,2,ku)-dj1*f(lr,2,kv))
905 & *clon(l,7)
906 & -(-di1*f(li,2,ku)-dj1*f(li,2,kv))
907 & *slon(l,7))
908 vs(ijk6)=vs(ijk6)+2*rr*(( dj1*f(lr,2,ku)-di1*f(lr,2,kv))
909 & *clon(l,7)
910 & -( dj1*f(li,2,ku)-di1*f(li,2,kv))
911 & *slon(l,7))
912 us(ijk7)=us(ijk7)+2*rr*(( di1*f(lr,2,ku)-dj1*f(lr,2,kv))
913 & *clon(l,6)
914 & -( di1*f(li,2,ku)-dj1*f(li,2,kv))
915 & *slon(l,6))
916 vs(ijk7)=vs(ijk7)+2*rr*(( dj1*f(lr,2,ku)+di1*f(lr,2,kv))
917 & *clon(l,6)
918 & -( dj1*f(li,2,ku)+di1*f(li,2,kv))
919 & *slon(l,6))
920 us(ijk8)=us(ijk8)+2*rr*(( dj1*f(lr,2,ku)-di1*f(lr,2,kv))
921 & *clon(l,5)
922 & -( dj1*f(li,2,ku)-di1*f(li,2,kv))
923 & *slon(l,5))
924 vs(ijk8)=vs(ijk8)+2*rr*(( di1*f(lr,2,ku)+dj1*f(lr,2,kv))
925 & *clon(l,5)
926 & -( di1*f(li,2,ku)+dj1*f(li,2,kv))
927 & *slon(l,5))
928 ENDDO
929 ENDDO
930 ENDIF
931 ENDDO
932 ENDDO
933
934 END
spdz2uv
subroutine spdz2uv(I, M, ENN1, ELONN1, EON, EONTOP, D, Z, U, V, UTOP, VTOP)
Computes the wind components from divergence and vorticity in spectral space.
Definition: spdz2uv.f:49
splegend
subroutine splegend(I, M, SLAT, CLAT, EPS, EPSTOP, PLN, PLNTOP)
Evaluates the orthonormal associated Legendre polynomials in the spectral domain at a given latitude.
Definition: splegend.f:45
spsynth
subroutine spsynth(I, M, IM, IX, NC, NCTOP, KM, CLAT, PLN, PLNTOP, MP, SPC, SPCTOP, F)
Synthesizes Fourier coefficients from spectral coefficients for a latitude pair (Northern and Souther...
Definition: spsynth.f:39
sptgpsv
subroutine sptgpsv(IROMB, MAXWV, KMAX, NPS, KWSKIP, KGSKIP, NISKIP, NJSKIP, TRUE, XMESH, ORIENT, WAVED, WAVEZ, UN, VN, US, VS)
This subprogram performs a spherical transform from spectral coefficients of divergences and curls to...
Definition: sptgpsv.f:83
spwget
subroutine spwget(IROMB, MAXWV, EPS, EPSTOP, ENN1, ELONN1, EON, EONTOP)
This subprogram gets wave-space constants.
Definition: spwget.f:18