NCEPLIBS-sp 2.4.0
spsynth.f
Go to the documentation of this file.
1C> @file
2C> @brief Synthesize Fourier coefficients from spectral coefficients.
3C>
4C> ### Program History Log
5C> Date | Programmer | Comments
6C> -----|------------|---------
7C> 91-10-31 | Mark Iredell | Initial.
8C> 1998-12-18 | Mark Iredell | Include scalar and gradient option.
9C>
10C> @author Iredell @date 92-10-31
11
12C> Synthesizes Fourier coefficients from spectral coefficients
13C> for a latitude pair (Northern and Southern hemispheres).
14C>
15C> Vector components are divided by cosine of latitude.
16C>
17C> @param I spectral domain shape
18C> (0 for triangular, 1 for rhomboidal)
19C> @param M spectral truncation
20C> @param IM even number of Fourier coefficients
21C> @param IX dimension of Fourier coefficients (IX>=IM+2)
22C> @param NC dimension of spectral coefficients
23C> (NC>=(M+1)*((I+1)*M+2))
24C> @param NCTOP dimension of spectral coefficients over top
25C> (NCTOP>=2*(M+1))
26C> @param KM number of fields
27C> @param CLAT cosine of latitude
28C> @param PLN ((M+1)*((I+1)*M+2)/2) Legendre polynomial
29C> @param PLNTOP Legendre polynomial over top
30C> @param SPC spectral coefficients
31C> @param SPCTOP spectral coefficients over top
32C> @param MP identifiers (0 for scalar, 1 for vector,
33C> or 10 for scalar and gradient)
34C> @param F Fourier coefficients for latitude pair
35C>
36C> @author Iredell @date 92-10-31
37 SUBROUTINE spsynth(I,M,IM,IX,NC,NCTOP,KM,CLAT,PLN,PLNTOP,MP,
38 & SPC,SPCTOP,F)
39
40 REAL PLN((M+1)*((I+1)*M+2)/2),PLNTOP(M+1)
41 INTEGER MP(KM)
42 REAL SPC(NC,KM),SPCTOP(NCTOP,KM)
43 REAL F(IX,2,KM)
44
45C ZERO OUT FOURIER COEFFICIENTS.
46 DO k=1,km
47 DO l=0,im/2
48 f(2*l+1,1,k)=0.
49 f(2*l+2,1,k)=0.
50 f(2*l+1,2,k)=0.
51 f(2*l+2,2,k)=0.
52 ENDDO
53 ENDDO
54
55C SYNTHESIS OVER POLE.
56C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM.
57C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
58 IF(clat.EQ.0) THEN
59 ltope=mod(m+1+i,2)
60!C$OMP PARALLEL DO PRIVATE(LB,LE,L,KS,KP,N,F1R,F1I)
61 DO k=1,km
62 lb=mp(k)
63 le=mp(k)
64 IF(mp(k).EQ.10) THEN
65 lb=0
66 le=1
67 ENDIF
68 l=lb
69 IF(l.EQ.1) THEN
70 IF(l.EQ.ltope) THEN
71 f(2*l+1,1,k)=plntop(l+1)*spctop(2*l+1,k)
72 f(2*l+2,1,k)=plntop(l+1)*spctop(2*l+2,k)
73 ELSE
74 f(2*l+1,2,k)=plntop(l+1)*spctop(2*l+1,k)
75 f(2*l+2,2,k)=plntop(l+1)*spctop(2*l+2,k)
76 ENDIF
77 ENDIF
78C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER.
79C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
80 DO l=lb,le
81 ks=l*(2*m+(i-1)*(l-1))
82 kp=ks/2+1
83 DO n=l,i*l+m,2
84 f(2*l+1,1,k)=f(2*l+1,1,k)+pln(kp+n)*spc(ks+2*n+1,k)
85 f(2*l+2,1,k)=f(2*l+2,1,k)+pln(kp+n)*spc(ks+2*n+2,k)
86 ENDDO
87 DO n=l+1,i*l+m,2
88 f(2*l+1,2,k)=f(2*l+1,2,k)+pln(kp+n)*spc(ks+2*n+1,k)
89 f(2*l+2,2,k)=f(2*l+2,2,k)+pln(kp+n)*spc(ks+2*n+2,k)
90 ENDDO
91C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE.
92C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE.
93 f1r=f(2*l+1,1,k)
94 f1i=f(2*l+2,1,k)
95 f(2*l+1,1,k)=f1r+f(2*l+1,2,k)
96 f(2*l+2,1,k)=f1i+f(2*l+2,2,k)
97 f(2*l+1,2,k)=f1r-f(2*l+1,2,k)
98 f(2*l+2,2,k)=f1i-f(2*l+2,2,k)
99 ENDDO
100 ENDDO
101
102C SYNTHESIS OVER FINITE LATITUDE.
103C INITIALIZE FOURIER COEFFICIENTS WITH TERMS OVER TOP OF THE SPECTRUM.
104C INITIALIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
105 ELSE
106 lx=min(m,im/2)
107 ltope=mod(m+1,2)
108 ltopo=1-ltope
109 le=1+i*ltope
110 lo=2-i*ltopo
111!C$OMP PARALLEL DO PRIVATE(L,KS,KP,N,F1R,F1I)
112 DO k=1,km
113 IF(mp(k).EQ.1) THEN
114 DO l=ltope,lx,2
115 f(2*l+1,le,k)=plntop(l+1)*spctop(2*l+1,k)
116 f(2*l+2,le,k)=plntop(l+1)*spctop(2*l+2,k)
117 ENDDO
118 DO l=ltopo,lx,2
119 f(2*l+1,lo,k)=plntop(l+1)*spctop(2*l+1,k)
120 f(2*l+2,lo,k)=plntop(l+1)*spctop(2*l+2,k)
121 ENDDO
122 ENDIF
123C FOR EACH ZONAL WAVENUMBER, SYNTHESIZE TERMS OVER TOTAL WAVENUMBER.
124C SYNTHESIZE EVEN AND ODD POLYNOMIALS SEPARATELY.
125 DO l=0,lx
126 ks=l*(2*m+(i-1)*(l-1))
127 kp=ks/2+1
128 DO n=l,i*l+m,2
129 f(2*l+1,1,k)=f(2*l+1,1,k)+pln(kp+n)*spc(ks+2*n+1,k)
130 f(2*l+2,1,k)=f(2*l+2,1,k)+pln(kp+n)*spc(ks+2*n+2,k)
131 ENDDO
132 DO n=l+1,i*l+m,2
133 f(2*l+1,2,k)=f(2*l+1,2,k)+pln(kp+n)*spc(ks+2*n+1,k)
134 f(2*l+2,2,k)=f(2*l+2,2,k)+pln(kp+n)*spc(ks+2*n+2,k)
135 ENDDO
136 ENDDO
137C SEPARATE FOURIER COEFFICIENTS FROM EACH HEMISPHERE.
138C ODD POLYNOMIALS CONTRIBUTE NEGATIVELY TO THE SOUTHERN HEMISPHERE.
139C DIVIDE VECTOR COMPONENTS BY COSINE LATITUDE.
140 DO l=0,lx
141 f1r=f(2*l+1,1,k)
142 f1i=f(2*l+2,1,k)
143 f(2*l+1,1,k)=f1r+f(2*l+1,2,k)
144 f(2*l+2,1,k)=f1i+f(2*l+2,2,k)
145 f(2*l+1,2,k)=f1r-f(2*l+1,2,k)
146 f(2*l+2,2,k)=f1i-f(2*l+2,2,k)
147 ENDDO
148 IF(mp(k).EQ.1) THEN
149 DO l=0,lx
150 f(2*l+1,1,k)=f(2*l+1,1,k)/clat
151 f(2*l+2,1,k)=f(2*l+2,1,k)/clat
152 f(2*l+1,2,k)=f(2*l+1,2,k)/clat
153 f(2*l+2,2,k)=f(2*l+2,2,k)/clat
154 ENDDO
155 ENDIF
156 ENDDO
157 ENDIF
158 END
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