NCEPLIBS-sp  2.5.0
sptgps.f
Go to the documentation of this file.
1 C> @file
2 C> @brief Transform spectral scalar to polar stereo.
3 C>
4 C> ### Program History Log
5 C> Date | Programmer | Comments
6 C> -----|------------|---------
7 C> 96-02-29 | Iredell | Initial.
8 C> 1998-12-15 | Iredell | Openmp directives inserted.
9 C>
10 C> @author Iredell @date 96-02-29
11 
12 C> This subprogram performs a spherical transform
13 C> from spectral coefficients of scalar quantities
14 C> to scalar fields on a pair of polar stereographic grids.
15 C>
16 C> The wave-space can be either triangular or rhomboidal.
17 C>
18 C> The wave and grid fields may have general indexing,
19 C> but each wave field is in sequential 'IBM order',
20 C> i.e. with zonal wavenumber as the slower index.
21 C>
22 C> The two square polar stereographic grids are centered
23 C> on the respective poles, with the orientation longitude
24 C> of the southern hemisphere grid 180 degrees opposite
25 C> that of the northern hemisphere grid.
26 C>
27 C> The transform is made efficient
28 C> by combining points in eight sectors
29 C> of each polar stereographic grid,
30 C> numbered as in the diagram below.
31 C>
32 C> The pole and the sector boundaries
33 C> are treated specially in the code.
34 C>
35 C> Unfortunately, this approach induces
36 C> some hairy indexing and code loquacity.
37 C>
38 C> <pre>
39 C> \ 4 | 5 /
40 C> \ | /
41 C> 3 \ | / 6
42 C> \|/
43 C> ----+----
44 C> /|\
45 C> 2 / | \ 7
46 C> / | \
47 C> / 1 | 8 \
48 C> </pre>
49 C>
50 C> The transforms are all multiprocessed over sector points.
51 C>
52 C> Transform several fields at a time to improve vectorization.
53 C>
54 C> Subprogram can be called from a multiprocessing environment.
55 C>
56 C> @param IROMB spectral domain shape
57 C> (0 for triangular, 1 for rhomboidal)
58 C> @param MAXWV spectral truncation
59 C> @param KMAX number of fields to transform.
60 C> @param NPS odd order of the polar stereographic grids.
61 C> @param KWSKIP skip number between wave fields
62 C> (defaults to (MAXWV+1)*((IROMB+1)*MAXWV+2) if KWSKIP=0)
63 C> @param KGSKIP skip number between grid fields
64 C> (defaults to NPS*NPS if KGSKIP=0)
65 C> @param NISKIP skip number between grid i-points
66 C> (defaults to 1 if NISKIP=0)
67 C> @param NJSKIP skip number between grid j-points
68 C> (defaults to NPS if NJSKIP=0)
69 C> @param TRUE latitude at which ps grid is true (usually 60.)
70 C> @param XMESH grid length at true latitude (m)
71 C> @param ORIENT longitude at bottom of northern ps grid
72 C> (southern ps grid will have opposite orientation.)
73 C> @param WAVE wave fields
74 C> @param GN northern polar stereographic fields
75 C> @param GS southern polar stereographic fields
76 C>
77 C> @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 
96 C 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
112 C$OMP PARALLEL DO
113  DO k=1,kmax
114  wtop(1:2*mxtop,k)=0
115  ENDDO
116 
117 C 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)
127 CDIR$ 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 
134 C CALCULATE POINTS ALONG THE ROW AND COLUMN OF THE POLE,
135 C STARTING AT THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
136 C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
137 C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
138 C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
139 C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
140 C$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
179 CDIR$ 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
219 CDIR$ 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 
246 C CALCULATE POINTS ON THE MAIN DIAGONALS THROUGH THE POLE,
247 C STARTING CLOCKWISE OF THE ORIENTATION LONGITUDE AND GOING CLOCKWISE.
248 C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
249 C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
250 C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
251 C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
252 C$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
291 CDIR$ 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
331 CDIR$ 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 
358 C CALCULATE THE REMAINDER OF THE POLAR STEREOGRAPHIC DOMAIN,
359 C STARTING AT THE SECTOR JUST CLOCKWISE OF THE ORIENTATION LONGITUDE
360 C AND GOING CLOCKWISE UNTIL ALL EIGHT SECTORS ARE DONE.
361 C$OMP PARALLEL DO PRIVATE(I1,J2,I2,J3,I3,J4,I4,J5,I5,J6,I6,J7,I7,J8,I8)
362 C$OMP& PRIVATE(IJ1,IJ2,IJ3,IJ4,IJ5,IJ6,IJ7,IJ8)
363 C$OMP& PRIVATE(IJK1,IJK2,IJK3,IJK4,IJK5,IJK6,IJK7,IJK8)
364 C$OMP& PRIVATE(DJ1,DI1,RQ,RADLON,RADLON1,RADLON2,SLAT1,CLAT1)
365 C$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
431 CDIR$ 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
499 CDIR$ 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