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