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