NCEPLIBS-sp 2.4.0
sptgps.f
Go to the documentation of this file.
1C> @file
2C> @brief Transform spectral scalar 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 scalar quantities
14C> to scalar fields on a pair of polar stereographic grids.
15C>
16C> The wave-space can be either triangular or rhomboidal.
17C>
18C> The wave and grid fields may have general indexing,
19C> but each wave field is in sequential 'IBM order',
20C> i.e. with zonal wavenumber as the slower index.
21C>
22C> The two square polar stereographic grids are centered
23C> on the respective poles, with the orientation longitude
24C> of the southern hemisphere grid 180 degrees opposite
25C> that of the northern hemisphere grid.
26C>
27C> The transform is made efficient
28C> by combining points in eight sectors
29C> of each polar stereographic grid,
30C> numbered as in the diagram below.
31C>
32C> The pole and the sector boundaries
33C> are treated specially in the code.
34C>
35C> Unfortunately, this approach induces
36C> some hairy indexing and code loquacity.
37C>
38C> <pre>
39C> \ 4 | 5 /
40C> \ | /
41C> 3 \ | / 6
42C> \|/
43C> ----+----
44C> /|\
45C> 2 / | \ 7
46C> / | \
47C> / 1 | 8 \
48C> </pre>
49C>
50C> The transforms are all multiprocessed over sector points.
51C>
52C> Transform several fields at a time to improve vectorization.
53C>
54C> Subprogram can be called from a multiprocessing environment.
55C>
56C> @param IROMB spectral domain shape
57C> (0 for triangular, 1 for rhomboidal)
58C> @param MAXWV spectral truncation
59C> @param KMAX number of fields to transform.
60C> @param NPS odd order of the polar stereographic grids.
61C> @param KWSKIP skip number between wave fields
62C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
63C> @param KGSKIP skip number between grid fields
64C> (defaults to NPS*NPS if KGSKIP=0)
65C> @param NISKIP skip number between grid i-points
66C> (defaults to 1 if NISKIP=0)
67C> @param NJSKIP skip number between grid j-points
68C> (defaults to NPS if NJSKIP=0)
69C> @param TRUE latitude at which ps grid is true (usually 60.)
70C> @param XMESH grid length at true latitude (m)
71C> @param ORIENT longitude at bottom of northern ps grid
72C> (southern ps grid will have opposite orientation.)
73C> @param WAVE wave fields
74C> @param GN northern polar stereographic fields
75C> @param GS southern polar stereographic fields
76C>
77C> @author Iredell @date 96-02-29
78 SUBROUTINE sptgps(IROMB,MAXWV,KMAX,NPS,
79 & KWSKIP,KGSKIP,NISKIP,NJSKIP,
80 & TRUE,XMESH,ORIENT,WAVE,GN,GS)
81
82 REAL WAVE(*),GN(*),GS(*)
83 REAL EPS((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EPSTOP(MAXWV+1)
84 REAL ENN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
85 REAL ELONN1((MAXWV+1)*((IROMB+1)*MAXWV+2)/2)
86 REAL EON((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),EONTOP(MAXWV+1)
87 INTEGER MP(KMAX)
88 REAL SLON(MAXWV,8),CLON(MAXWV,8),SROT(0:3),CROT(0:3)
89 REAL WTOP(2*(MAXWV+1),KMAX)
90 REAL PLN((MAXWV+1)*((IROMB+1)*MAXWV+2)/2),PLNTOP(MAXWV+1)
91 REAL F(2*MAXWV+3,2,KMAX)
92 DATA srot/0.,1.,0.,-1./,crot/1.,0.,-1.,0./
93 parameter(rerth=6.3712e6)
94 parameter(pi=3.14159265358979,dpr=180./pi)
95
96C CALCULATE PRELIMINARY CONSTANTS
97 CALL spwget(iromb,maxwv,eps,epstop,enn1,elonn1,eon,eontop)
98 mx=(maxwv+1)*((iromb+1)*maxwv+2)/2
99 mxtop=maxwv+1
100 idim=2*maxwv+3
101 kw=kwskip
102 kg=kgskip
103 ni=niskip
104 nj=njskip
105 IF(kw.EQ.0) kw=2*mx
106 IF(kg.EQ.0) kg=nps*nps
107 IF(ni.EQ.0) ni=1
108 IF(nj.EQ.0) nj=nps
109 mp=0
110 nph=(nps-1)/2
111 gq=((1.+sin(true/dpr))*rerth/xmesh)**2
112C$OMP PARALLEL DO
113 DO k=1,kmax
114 wtop(1:2*mxtop,k)=0
115 ENDDO
116
117C CALCULATE POLE POINT
118 i1=nph+1
119 j1=nph+1
120 ij1=(i1-1)*ni+(j1-1)*nj+1
121 slat1=1.
122 clat1=0.
123 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
124 & pln,plntop)
125 CALL spsynth(iromb,maxwv,2*maxwv,idim,kw,2*mxtop,kmax,
126 & clat1,pln,plntop,mp,wave,wtop,f)
127CDIR$ IVDEP
128 DO k=1,kmax
129 ijk1=ij1+(k-1)*kg
130 gn(ijk1)=f(1,1,k)
131 gs(ijk1)=f(1,2,k)
132 ENDDO
133
134C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE,
135C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
136C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
137C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
138C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
139C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
140C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI)
141 DO j1=1,nph
142 i1=nph+1
143 radlon=orient/dpr
144 j3=nps+1-i1
145 i3=j1
146 j5=nps+1-j1
147 i5=nps+1-i1
148 j7=i1
149 i7=nps+1-j1
150 ij1=(i1-1)*ni+(j1-1)*nj+1
151 ij3=(i3-1)*ni+(j3-1)*nj+1
152 ij5=(i5-1)*ni+(j5-1)*nj+1
153 ij7=(i7-1)*ni+(j7-1)*nj+1
154 di1=i1-nph-1
155 dj1=j1-nph-1
156 rq=di1**2+dj1**2
157 slat1=(gq-rq)/(gq+rq)
158 clat1=sqrt(1.-slat1**2)
159 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
160 & pln,plntop)
161 CALL spsynth(iromb,maxwv,2*maxwv,idim,kw,2*mxtop,kmax,
162 & clat1,pln,plntop,mp,wave,wtop,f)
163 DO l=1,maxwv
164 slon(l,1)=sin(l*radlon)
165 clon(l,1)=cos(l*radlon)
166 slon(l,3)=slon(l,1)*crot(mod(1*l,4))
167 & -clon(l,1)*srot(mod(1*l,4))
168 clon(l,3)=clon(l,1)*crot(mod(1*l,4))
169 & +slon(l,1)*srot(mod(1*l,4))
170 slon(l,5)=slon(l,1)*crot(mod(2*l,4))
171 & -clon(l,1)*srot(mod(2*l,4))
172 clon(l,5)=clon(l,1)*crot(mod(2*l,4))
173 & +slon(l,1)*srot(mod(2*l,4))
174 slon(l,7)=slon(l,1)*crot(mod(3*l,4))
175 & -clon(l,1)*srot(mod(3*l,4))
176 clon(l,7)=clon(l,1)*crot(mod(3*l,4))
177 & +slon(l,1)*srot(mod(3*l,4))
178 ENDDO
179CDIR$ IVDEP
180 DO k=1,kmax
181 ijk1=ij1+(k-1)*kg
182 ijk3=ij3+(k-1)*kg
183 ijk5=ij5+(k-1)*kg
184 ijk7=ij7+(k-1)*kg
185 gn(ijk1)=f(1,1,k)
186 gn(ijk3)=f(1,1,k)
187 gn(ijk5)=f(1,1,k)
188 gn(ijk7)=f(1,1,k)
189 gs(ijk1)=f(1,2,k)
190 gs(ijk3)=f(1,2,k)
191 gs(ijk5)=f(1,2,k)
192 gs(ijk7)=f(1,2,k)
193 ENDDO
194 IF(kmax.EQ.1) THEN
195 DO l=1,maxwv
196 lr=2*l+1
197 li=2*l+2
198 gn(ij1)=gn(ij1)+2*(f(lr,1,1)*clon(l,1)
199 & -f(li,1,1)*slon(l,1))
200 gn(ij3)=gn(ij3)+2*(f(lr,1,1)*clon(l,3)
201 & -f(li,1,1)*slon(l,3))
202 gn(ij5)=gn(ij5)+2*(f(lr,1,1)*clon(l,5)
203 & -f(li,1,1)*slon(l,5))
204 gn(ij7)=gn(ij7)+2*(f(lr,1,1)*clon(l,7)
205 & -f(li,1,1)*slon(l,7))
206 gs(ij1)=gs(ij1)+2*(f(lr,2,1)*clon(l,5)
207 & -f(li,2,1)*slon(l,5))
208 gs(ij3)=gs(ij3)+2*(f(lr,2,1)*clon(l,3)
209 & -f(li,2,1)*slon(l,3))
210 gs(ij5)=gs(ij5)+2*(f(lr,2,1)*clon(l,1)
211 & -f(li,2,1)*slon(l,1))
212 gs(ij7)=gs(ij7)+2*(f(lr,2,1)*clon(l,7)
213 & -f(li,2,1)*slon(l,7))
214 ENDDO
215 ELSE
216 DO l=1,maxwv
217 lr=2*l+1
218 li=2*l+2
219CDIR$ IVDEP
220 DO k=1,kmax
221 ijk1=ij1+(k-1)*kg
222 ijk3=ij3+(k-1)*kg
223 ijk5=ij5+(k-1)*kg
224 ijk7=ij7+(k-1)*kg
225 gn(ijk1)=gn(ijk1)+2*(f(lr,1,k)*clon(l,1)
226 & -f(li,1,k)*slon(l,1))
227 gn(ijk3)=gn(ijk3)+2*(f(lr,1,k)*clon(l,3)
228 & -f(li,1,k)*slon(l,3))
229 gn(ijk5)=gn(ijk5)+2*(f(lr,1,k)*clon(l,5)
230 & -f(li,1,k)*slon(l,5))
231 gn(ijk7)=gn(ijk7)+2*(f(lr,1,k)*clon(l,7)
232 & -f(li,1,k)*slon(l,7))
233 gs(ijk1)=gs(ijk1)+2*(f(lr,2,k)*clon(l,5)
234 & -f(li,2,k)*slon(l,5))
235 gs(ijk3)=gs(ijk3)+2*(f(lr,2,k)*clon(l,3)
236 & -f(li,2,k)*slon(l,3))
237 gs(ijk5)=gs(ijk5)+2*(f(lr,2,k)*clon(l,1)
238 & -f(li,2,k)*slon(l,1))
239 gs(ijk7)=gs(ijk7)+2*(f(lr,2,k)*clon(l,7)
240 & -f(li,2,k)*slon(l,7))
241 ENDDO
242 ENDDO
243 ENDIF
244 ENDDO
245
246C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE,
247C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
248C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
249C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
250C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
251C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
252C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI)
253 DO j1=1,nph
254 i1=j1
255 radlon=(orient-45)/dpr
256 j3=nps+1-i1
257 i3=j1
258 j5=nps+1-j1
259 i5=nps+1-i1
260 j7=i1
261 i7=nps+1-j1
262 ij1=(i1-1)*ni+(j1-1)*nj+1
263 ij3=(i3-1)*ni+(j3-1)*nj+1
264 ij5=(i5-1)*ni+(j5-1)*nj+1
265 ij7=(i7-1)*ni+(j7-1)*nj+1
266 di1=i1-nph-1
267 dj1=j1-nph-1
268 rq=di1**2+dj1**2
269 slat1=(gq-rq)/(gq+rq)
270 clat1=sqrt(1.-slat1**2)
271 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
272 & pln,plntop)
273 CALL spsynth(iromb,maxwv,2*maxwv,idim,kw,2*mxtop,kmax,
274 & clat1,pln,plntop,mp,wave,wtop,f)
275 DO l=1,maxwv
276 slon(l,1)=sin(l*radlon)
277 clon(l,1)=cos(l*radlon)
278 slon(l,3)=slon(l,1)*crot(mod(1*l,4))
279 & -clon(l,1)*srot(mod(1*l,4))
280 clon(l,3)=clon(l,1)*crot(mod(1*l,4))
281 & +slon(l,1)*srot(mod(1*l,4))
282 slon(l,5)=slon(l,1)*crot(mod(2*l,4))
283 & -clon(l,1)*srot(mod(2*l,4))
284 clon(l,5)=clon(l,1)*crot(mod(2*l,4))
285 & +slon(l,1)*srot(mod(2*l,4))
286 slon(l,7)=slon(l,1)*crot(mod(3*l,4))
287 & -clon(l,1)*srot(mod(3*l,4))
288 clon(l,7)=clon(l,1)*crot(mod(3*l,4))
289 & +slon(l,1)*srot(mod(3*l,4))
290 ENDDO
291CDIR$ IVDEP
292 DO k=1,kmax
293 ijk1=ij1+(k-1)*kg
294 ijk3=ij3+(k-1)*kg
295 ijk5=ij5+(k-1)*kg
296 ijk7=ij7+(k-1)*kg
297 gn(ijk1)=f(1,1,k)
298 gn(ijk3)=f(1,1,k)
299 gn(ijk5)=f(1,1,k)
300 gn(ijk7)=f(1,1,k)
301 gs(ijk1)=f(1,2,k)
302 gs(ijk3)=f(1,2,k)
303 gs(ijk5)=f(1,2,k)
304 gs(ijk7)=f(1,2,k)
305 ENDDO
306 IF(kmax.EQ.1) THEN
307 DO l=1,maxwv
308 lr=2*l+1
309 li=2*l+2
310 gn(ij1)=gn(ij1)+2*(f(lr,1,1)*clon(l,1)
311 & -f(li,1,1)*slon(l,1))
312 gn(ij3)=gn(ij3)+2*(f(lr,1,1)*clon(l,3)
313 & -f(li,1,1)*slon(l,3))
314 gn(ij5)=gn(ij5)+2*(f(lr,1,1)*clon(l,5)
315 & -f(li,1,1)*slon(l,5))
316 gn(ij7)=gn(ij7)+2*(f(lr,1,1)*clon(l,7)
317 & -f(li,1,1)*slon(l,7))
318 gs(ij1)=gs(ij1)+2*(f(lr,2,1)*clon(l,3)
319 & -f(li,2,1)*slon(l,3))
320 gs(ij3)=gs(ij3)+2*(f(lr,2,1)*clon(l,1)
321 & -f(li,2,1)*slon(l,1))
322 gs(ij5)=gs(ij5)+2*(f(lr,2,1)*clon(l,7)
323 & -f(li,2,1)*slon(l,7))
324 gs(ij7)=gs(ij7)+2*(f(lr,2,1)*clon(l,5)
325 & -f(li,2,1)*slon(l,5))
326 ENDDO
327 ELSE
328 DO l=1,maxwv
329 lr=2*l+1
330 li=2*l+2
331CDIR$ IVDEP
332 DO k=1,kmax
333 ijk1=ij1+(k-1)*kg
334 ijk3=ij3+(k-1)*kg
335 ijk5=ij5+(k-1)*kg
336 ijk7=ij7+(k-1)*kg
337 gn(ijk1)=gn(ijk1)+2*(f(lr,1,k)*clon(l,1)
338 & -f(li,1,k)*slon(l,1))
339 gn(ijk3)=gn(ijk3)+2*(f(lr,1,k)*clon(l,3)
340 & -f(li,1,k)*slon(l,3))
341 gn(ijk5)=gn(ijk5)+2*(f(lr,1,k)*clon(l,5)
342 & -f(li,1,k)*slon(l,5))
343 gn(ijk7)=gn(ijk7)+2*(f(lr,1,k)*clon(l,7)
344 & -f(li,1,k)*slon(l,7))
345 gs(ijk1)=gs(ijk1)+2*(f(lr,2,k)*clon(l,3)
346 & -f(li,2,k)*slon(l,3))
347 gs(ijk3)=gs(ijk3)+2*(f(lr,2,k)*clon(l,1)
348 & -f(li,2,k)*slon(l,1))
349 gs(ijk5)=gs(ijk5)+2*(f(lr,2,k)*clon(l,7)
350 & -f(li,2,k)*slon(l,7))
351 gs(ijk7)=gs(ijk7)+2*(f(lr,2,k)*clon(l,5)
352 & -f(li,2,k)*slon(l,5))
353 ENDDO
354 ENDDO
355 ENDIF
356 ENDDO
357
358C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN,
359C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE
360C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE.
361C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
362C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
363C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
364C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
365C$OMP& PRIVATE(PLN,PLNTOP,F,SLON,CLON,LR,LI)
366 DO j1=1,nph-1
367 DO i1=j1+1,nph
368 j2=i1
369 i2=j1
370 j3=nps+1-i1
371 i3=j1
372 j4=nps+1-j1
373 i4=i1
374 j5=nps+1-j1
375 i5=nps+1-i1
376 j6=nps+1-i1
377 i6=nps+1-j1
378 j7=i1
379 i7=nps+1-j1
380 j8=j1
381 i8=nps+1-i1
382 ij1=(i1-1)*ni+(j1-1)*nj+1
383 ij2=(i2-1)*ni+(j2-1)*nj+1
384 ij3=(i3-1)*ni+(j3-1)*nj+1
385 ij4=(i4-1)*ni+(j4-1)*nj+1
386 ij5=(i5-1)*ni+(j5-1)*nj+1
387 ij6=(i6-1)*ni+(j6-1)*nj+1
388 ij7=(i7-1)*ni+(j7-1)*nj+1
389 ij8=(i8-1)*ni+(j8-1)*nj+1
390 di1=i1-nph-1
391 dj1=j1-nph-1
392 rq=di1**2+dj1**2
393 slat1=(gq-rq)/(gq+rq)
394 clat1=sqrt(1.-slat1**2)
395 radlon1=orient/dpr+atan(-di1/dj1)
396 radlon2=(orient-45)/dpr*2-radlon1
397 CALL splegend(iromb,maxwv,slat1,clat1,eps,epstop,
398 & pln,plntop)
399 CALL spsynth(iromb,maxwv,2*maxwv,idim,kw,2*mxtop,kmax,
400 & clat1,pln,plntop,mp,wave,wtop,f)
401 DO l=1,maxwv
402 slon(l,1)=sin(l*radlon1)
403 clon(l,1)=cos(l*radlon1)
404 slon(l,2)=sin(l*radlon2)
405 clon(l,2)=cos(l*radlon2)
406 slon(l,3)=slon(l,1)*crot(mod(1*l,4))
407 & -clon(l,1)*srot(mod(1*l,4))
408 clon(l,3)=clon(l,1)*crot(mod(1*l,4))
409 & +slon(l,1)*srot(mod(1*l,4))
410 slon(l,4)=slon(l,2)*crot(mod(1*l,4))
411 & -clon(l,2)*srot(mod(1*l,4))
412 clon(l,4)=clon(l,2)*crot(mod(1*l,4))
413 & +slon(l,2)*srot(mod(1*l,4))
414 slon(l,5)=slon(l,1)*crot(mod(2*l,4))
415 & -clon(l,1)*srot(mod(2*l,4))
416 clon(l,5)=clon(l,1)*crot(mod(2*l,4))
417 & +slon(l,1)*srot(mod(2*l,4))
418 slon(l,6)=slon(l,2)*crot(mod(2*l,4))
419 & -clon(l,2)*srot(mod(2*l,4))
420 clon(l,6)=clon(l,2)*crot(mod(2*l,4))
421 & +slon(l,2)*srot(mod(2*l,4))
422 slon(l,7)=slon(l,1)*crot(mod(3*l,4))
423 & -clon(l,1)*srot(mod(3*l,4))
424 clon(l,7)=clon(l,1)*crot(mod(3*l,4))
425 & +slon(l,1)*srot(mod(3*l,4))
426 slon(l,8)=slon(l,2)*crot(mod(3*l,4))
427 & -clon(l,2)*srot(mod(3*l,4))
428 clon(l,8)=clon(l,2)*crot(mod(3*l,4))
429 & +slon(l,2)*srot(mod(3*l,4))
430 ENDDO
431CDIR$ IVDEP
432 DO k=1,kmax
433 ijk1=ij1+(k-1)*kg
434 ijk2=ij2+(k-1)*kg
435 ijk3=ij3+(k-1)*kg
436 ijk4=ij4+(k-1)*kg
437 ijk5=ij5+(k-1)*kg
438 ijk6=ij6+(k-1)*kg
439 ijk7=ij7+(k-1)*kg
440 ijk8=ij8+(k-1)*kg
441 gn(ijk1)=f(1,1,k)
442 gn(ijk2)=f(1,1,k)
443 gn(ijk3)=f(1,1,k)
444 gn(ijk4)=f(1,1,k)
445 gn(ijk5)=f(1,1,k)
446 gn(ijk6)=f(1,1,k)
447 gn(ijk7)=f(1,1,k)
448 gn(ijk8)=f(1,1,k)
449 gs(ijk1)=f(1,2,k)
450 gs(ijk2)=f(1,2,k)
451 gs(ijk3)=f(1,2,k)
452 gs(ijk4)=f(1,2,k)
453 gs(ijk5)=f(1,2,k)
454 gs(ijk6)=f(1,2,k)
455 gs(ijk7)=f(1,2,k)
456 gs(ijk8)=f(1,2,k)
457 ENDDO
458 IF(kmax.EQ.1) THEN
459 DO l=1,maxwv
460 lr=2*l+1
461 li=2*l+2
462 gn(ij1)=gn(ij1)+2*(f(lr,1,1)*clon(l,1)
463 & -f(li,1,1)*slon(l,1))
464 gn(ij2)=gn(ij2)+2*(f(lr,1,1)*clon(l,2)
465 & -f(li,1,1)*slon(l,2))
466 gn(ij3)=gn(ij3)+2*(f(lr,1,1)*clon(l,3)
467 & -f(li,1,1)*slon(l,3))
468 gn(ij4)=gn(ij4)+2*(f(lr,1,1)*clon(l,4)
469 & -f(li,1,1)*slon(l,4))
470 gn(ij5)=gn(ij5)+2*(f(lr,1,1)*clon(l,5)
471 & -f(li,1,1)*slon(l,5))
472 gn(ij6)=gn(ij6)+2*(f(lr,1,1)*clon(l,6)
473 & -f(li,1,1)*slon(l,6))
474 gn(ij7)=gn(ij7)+2*(f(lr,1,1)*clon(l,7)
475 & -f(li,1,1)*slon(l,7))
476 gn(ij8)=gn(ij8)+2*(f(lr,1,1)*clon(l,8)
477 & -f(li,1,1)*slon(l,8))
478 gs(ij1)=gs(ij1)+2*(f(lr,2,1)*clon(l,4)
479 & -f(li,2,1)*slon(l,4))
480 gs(ij2)=gs(ij2)+2*(f(lr,2,1)*clon(l,3)
481 & -f(li,2,1)*slon(l,3))
482 gs(ij3)=gs(ij3)+2*(f(lr,2,1)*clon(l,2)
483 & -f(li,2,1)*slon(l,2))
484 gs(ij4)=gs(ij4)+2*(f(lr,2,1)*clon(l,1)
485 & -f(li,2,1)*slon(l,1))
486 gs(ij5)=gs(ij5)+2*(f(lr,2,1)*clon(l,8)
487 & -f(li,2,1)*slon(l,8))
488 gs(ij6)=gs(ij6)+2*(f(lr,2,1)*clon(l,7)
489 & -f(li,2,1)*slon(l,7))
490 gs(ij7)=gs(ij7)+2*(f(lr,2,1)*clon(l,6)
491 & -f(li,2,1)*slon(l,6))
492 gs(ij8)=gs(ij8)+2*(f(lr,2,1)*clon(l,5)
493 & -f(li,2,1)*slon(l,5))
494 ENDDO
495 ELSE
496 DO l=1,maxwv
497 lr=2*l+1
498 li=2*l+2
499CDIR$ IVDEP
500 DO k=1,kmax
501 ijk1=ij1+(k-1)*kg
502 ijk2=ij2+(k-1)*kg
503 ijk3=ij3+(k-1)*kg
504 ijk4=ij4+(k-1)*kg
505 ijk5=ij5+(k-1)*kg
506 ijk6=ij6+(k-1)*kg
507 ijk7=ij7+(k-1)*kg
508 ijk8=ij8+(k-1)*kg
509 gn(ijk1)=gn(ijk1)+2*(f(lr,1,k)*clon(l,1)
510 & -f(li,1,k)*slon(l,1))
511 gn(ijk2)=gn(ijk2)+2*(f(lr,1,k)*clon(l,2)
512 & -f(li,1,k)*slon(l,2))
513 gn(ijk3)=gn(ijk3)+2*(f(lr,1,k)*clon(l,3)
514 & -f(li,1,k)*slon(l,3))
515 gn(ijk4)=gn(ijk4)+2*(f(lr,1,k)*clon(l,4)
516 & -f(li,1,k)*slon(l,4))
517 gn(ijk5)=gn(ijk5)+2*(f(lr,1,k)*clon(l,5)
518 & -f(li,1,k)*slon(l,5))
519 gn(ijk6)=gn(ijk6)+2*(f(lr,1,k)*clon(l,6)
520 & -f(li,1,k)*slon(l,6))
521 gn(ijk7)=gn(ijk7)+2*(f(lr,1,k)*clon(l,7)
522 & -f(li,1,k)*slon(l,7))
523 gn(ijk8)=gn(ijk8)+2*(f(lr,1,k)*clon(l,8)
524 & -f(li,1,k)*slon(l,8))
525 gs(ijk1)=gs(ijk1)+2*(f(lr,2,k)*clon(l,4)
526 & -f(li,2,k)*slon(l,4))
527 gs(ijk2)=gs(ijk2)+2*(f(lr,2,k)*clon(l,3)
528 & -f(li,2,k)*slon(l,3))
529 gs(ijk3)=gs(ijk3)+2*(f(lr,2,k)*clon(l,2)
530 & -f(li,2,k)*slon(l,2))
531 gs(ijk4)=gs(ijk4)+2*(f(lr,2,k)*clon(l,1)
532 & -f(li,2,k)*slon(l,1))
533 gs(ijk5)=gs(ijk5)+2*(f(lr,2,k)*clon(l,8)
534 & -f(li,2,k)*slon(l,8))
535 gs(ijk6)=gs(ijk6)+2*(f(lr,2,k)*clon(l,7)
536 & -f(li,2,k)*slon(l,7))
537 gs(ijk7)=gs(ijk7)+2*(f(lr,2,k)*clon(l,6)
538 & -f(li,2,k)*slon(l,6))
539 gs(ijk8)=gs(ijk8)+2*(f(lr,2,k)*clon(l,5)
540 & -f(li,2,k)*slon(l,5))
541 ENDDO
542 ENDDO
543 ENDIF
544 ENDDO
545 ENDDO
546
547 END
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
sptgps
subroutine sptgps(IROMB, MAXWV, KMAX, NPS, KWSKIP, KGSKIP, NISKIP, NJSKIP, TRUE, XMESH, ORIENT, WAVE, GN, GS)
This subprogram performs a spherical transform from spectral coefficients of scalar quantities to sca...
Definition: sptgps.f:81
spwget
subroutine spwget(IROMB, MAXWV, EPS, EPSTOP, ENN1, ELONN1, EON, EONTOP)
This subprogram gets wave-space constants.
Definition: spwget.f:18