PLaSK library
Loading...
Searching...
No Matches
c1fgkf.c
Go to the documentation of this file.
1/* c1fgkf.f -- translated by f2c (version 20100827).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11*/
12
13#include "f2c.h"
14
15/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
16/* * * */
17/* * copyright (c) 2011 by UCAR * */
18/* * * */
19/* * University Corporation for Atmospheric Research * */
20/* * * */
21/* * all rights reserved * */
22/* * * */
23/* * FFTPACK version 5.1 * */
24/* * * */
25/* * A Fortran Package of Fast Fourier * */
26/* * * */
27/* * Subroutines and Example Programs * */
28/* * * */
29/* * by * */
30/* * * */
31/* * Paul Swarztrauber and Dick Valent * */
32/* * * */
33/* * of * */
34/* * * */
35/* * the National Center for Atmospheric Research * */
36/* * * */
37/* * Boulder, Colorado (80307) U.S.A. * */
38/* * * */
39/* * which is sponsored by * */
40/* * * */
41/* * the National Science Foundation * */
42/* * * */
43/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
44
45/* Subroutine */ int c1fgkf_(integer *ido, integer *ip, integer *l1, integer *
46 lid, integer *na, doublereal *cc, doublereal *cc1, integer *in1,
47 doublereal *ch, doublereal *ch1, integer *in2, doublereal *wa)
48{
49 /* System generated locals */
50 integer ch_dim1, ch_dim2, ch_dim3, ch_offset, cc_dim1, cc_dim2, cc_dim3,
51 cc_offset, cc1_dim1, cc1_dim2, cc1_offset, ch1_dim1, ch1_dim2,
52 ch1_offset, wa_dim1, wa_dim2, wa_offset, i__1, i__2, i__3;
53
54 /* Local variables */
55 integer i__, j, k, l, jc, lc, ki;
56 doublereal sn, wai, war;
57 integer ipp2, idlj, ipph;
58 doublereal chold1, chold2;
59
60
61/* FFTPACK 5.1 auxiliary routine */
62
63 /* Parameter adjustments */
64 wa_dim1 = *ido;
65 wa_dim2 = *ip - 1;
66 wa_offset = 1 + wa_dim1 * (1 + wa_dim2);
67 wa -= wa_offset;
68 cc1_dim1 = *in1;
69 cc1_dim2 = *lid;
70 cc1_offset = 1 + cc1_dim1 * (1 + cc1_dim2);
71 cc1 -= cc1_offset;
72 cc_dim1 = *in1;
73 cc_dim2 = *l1;
74 cc_dim3 = *ip;
75 cc_offset = 1 + cc_dim1 * (1 + cc_dim2 * (1 + cc_dim3));
76 cc -= cc_offset;
77 ch1_dim1 = *in2;
78 ch1_dim2 = *lid;
79 ch1_offset = 1 + ch1_dim1 * (1 + ch1_dim2);
80 ch1 -= ch1_offset;
81 ch_dim1 = *in2;
82 ch_dim2 = *l1;
83 ch_dim3 = *ido;
84 ch_offset = 1 + ch_dim1 * (1 + ch_dim2 * (1 + ch_dim3));
85 ch -= ch_offset;
86
87 /* Function Body */
88 ipp2 = *ip + 2;
89 ipph = (*ip + 1) / 2;
90 i__1 = *lid;
91 for (ki = 1; ki <= i__1; ++ki) {
92 ch1[(ki + ch1_dim2) * ch1_dim1 + 1] = cc1[(ki + cc1_dim2) * cc1_dim1
93 + 1];
94 ch1[(ki + ch1_dim2) * ch1_dim1 + 2] = cc1[(ki + cc1_dim2) * cc1_dim1
95 + 2];
96/* L110: */
97 }
98 i__1 = ipph;
99 for (j = 2; j <= i__1; ++j) {
100 jc = ipp2 - j;
101 i__2 = *lid;
102 for (ki = 1; ki <= i__2; ++ki) {
103 ch1[(ki + j * ch1_dim2) * ch1_dim1 + 1] = cc1[(ki + j * cc1_dim2)
104 * cc1_dim1 + 1] + cc1[(ki + jc * cc1_dim2) * cc1_dim1 + 1]
105 ;
106 ch1[(ki + jc * ch1_dim2) * ch1_dim1 + 1] = cc1[(ki + j * cc1_dim2)
107 * cc1_dim1 + 1] - cc1[(ki + jc * cc1_dim2) * cc1_dim1 +
108 1];
109 ch1[(ki + j * ch1_dim2) * ch1_dim1 + 2] = cc1[(ki + j * cc1_dim2)
110 * cc1_dim1 + 2] + cc1[(ki + jc * cc1_dim2) * cc1_dim1 + 2]
111 ;
112 ch1[(ki + jc * ch1_dim2) * ch1_dim1 + 2] = cc1[(ki + j * cc1_dim2)
113 * cc1_dim1 + 2] - cc1[(ki + jc * cc1_dim2) * cc1_dim1 +
114 2];
115/* L112: */
116 }
117/* L111: */
118 }
119 i__1 = ipph;
120 for (j = 2; j <= i__1; ++j) {
121 i__2 = *lid;
122 for (ki = 1; ki <= i__2; ++ki) {
123 cc1[(ki + cc1_dim2) * cc1_dim1 + 1] += ch1[(ki + j * ch1_dim2) *
124 ch1_dim1 + 1];
125 cc1[(ki + cc1_dim2) * cc1_dim1 + 2] += ch1[(ki + j * ch1_dim2) *
126 ch1_dim1 + 2];
127/* L117: */
128 }
129/* L118: */
130 }
131 i__1 = ipph;
132 for (l = 2; l <= i__1; ++l) {
133 lc = ipp2 - l;
134 i__2 = *lid;
135 for (ki = 1; ki <= i__2; ++ki) {
136 cc1[(ki + l * cc1_dim2) * cc1_dim1 + 1] = ch1[(ki + ch1_dim2) *
137 ch1_dim1 + 1] + wa[(l - 1 + wa_dim2) * wa_dim1 + 1] * ch1[
138 (ki + (ch1_dim2 << 1)) * ch1_dim1 + 1];
139 cc1[(ki + lc * cc1_dim2) * cc1_dim1 + 1] = -wa[(l - 1 + (wa_dim2
140 << 1)) * wa_dim1 + 1] * ch1[(ki + *ip * ch1_dim2) *
141 ch1_dim1 + 1];
142 cc1[(ki + l * cc1_dim2) * cc1_dim1 + 2] = ch1[(ki + ch1_dim2) *
143 ch1_dim1 + 2] + wa[(l - 1 + wa_dim2) * wa_dim1 + 1] * ch1[
144 (ki + (ch1_dim2 << 1)) * ch1_dim1 + 2];
145 cc1[(ki + lc * cc1_dim2) * cc1_dim1 + 2] = -wa[(l - 1 + (wa_dim2
146 << 1)) * wa_dim1 + 1] * ch1[(ki + *ip * ch1_dim2) *
147 ch1_dim1 + 2];
148/* L113: */
149 }
150 i__2 = ipph;
151 for (j = 3; j <= i__2; ++j) {
152 jc = ipp2 - j;
153 idlj = (l - 1) * (j - 1) % *ip;
154 war = wa[(idlj + wa_dim2) * wa_dim1 + 1];
155 wai = -wa[(idlj + (wa_dim2 << 1)) * wa_dim1 + 1];
156 i__3 = *lid;
157 for (ki = 1; ki <= i__3; ++ki) {
158 cc1[(ki + l * cc1_dim2) * cc1_dim1 + 1] += war * ch1[(ki + j *
159 ch1_dim2) * ch1_dim1 + 1];
160 cc1[(ki + lc * cc1_dim2) * cc1_dim1 + 1] += wai * ch1[(ki +
161 jc * ch1_dim2) * ch1_dim1 + 1];
162 cc1[(ki + l * cc1_dim2) * cc1_dim1 + 2] += war * ch1[(ki + j *
163 ch1_dim2) * ch1_dim1 + 2];
164 cc1[(ki + lc * cc1_dim2) * cc1_dim1 + 2] += wai * ch1[(ki +
165 jc * ch1_dim2) * ch1_dim1 + 2];
166/* L114: */
167 }
168/* L115: */
169 }
170/* L116: */
171 }
172 if (*ido > 1) {
173 goto L136;
174 }
175 sn = 1. / (doublereal) (*ip * *l1);
176 if (*na == 1) {
177 goto L146;
178 }
179 i__1 = *lid;
180 for (ki = 1; ki <= i__1; ++ki) {
181 cc1[(ki + cc1_dim2) * cc1_dim1 + 1] = sn * cc1[(ki + cc1_dim2) *
182 cc1_dim1 + 1];
183 cc1[(ki + cc1_dim2) * cc1_dim1 + 2] = sn * cc1[(ki + cc1_dim2) *
184 cc1_dim1 + 2];
185/* L149: */
186 }
187 i__1 = ipph;
188 for (j = 2; j <= i__1; ++j) {
189 jc = ipp2 - j;
190 i__2 = *lid;
191 for (ki = 1; ki <= i__2; ++ki) {
192 chold1 = sn * (cc1[(ki + j * cc1_dim2) * cc1_dim1 + 1] - cc1[(ki
193 + jc * cc1_dim2) * cc1_dim1 + 2]);
194 chold2 = sn * (cc1[(ki + j * cc1_dim2) * cc1_dim1 + 1] + cc1[(ki
195 + jc * cc1_dim2) * cc1_dim1 + 2]);
196 cc1[(ki + j * cc1_dim2) * cc1_dim1 + 1] = chold1;
197 cc1[(ki + jc * cc1_dim2) * cc1_dim1 + 2] = sn * (cc1[(ki + j *
198 cc1_dim2) * cc1_dim1 + 2] - cc1[(ki + jc * cc1_dim2) *
199 cc1_dim1 + 1]);
200 cc1[(ki + j * cc1_dim2) * cc1_dim1 + 2] = sn * (cc1[(ki + j *
201 cc1_dim2) * cc1_dim1 + 2] + cc1[(ki + jc * cc1_dim2) *
202 cc1_dim1 + 1]);
203 cc1[(ki + jc * cc1_dim2) * cc1_dim1 + 1] = chold2;
204/* L119: */
205 }
206/* L120: */
207 }
208 return 0;
209L146:
210 i__1 = *lid;
211 for (ki = 1; ki <= i__1; ++ki) {
212 ch1[(ki + ch1_dim2) * ch1_dim1 + 1] = sn * cc1[(ki + cc1_dim2) *
213 cc1_dim1 + 1];
214 ch1[(ki + ch1_dim2) * ch1_dim1 + 2] = sn * cc1[(ki + cc1_dim2) *
215 cc1_dim1 + 2];
216/* L147: */
217 }
218 i__1 = ipph;
219 for (j = 2; j <= i__1; ++j) {
220 jc = ipp2 - j;
221 i__2 = *lid;
222 for (ki = 1; ki <= i__2; ++ki) {
223 ch1[(ki + j * ch1_dim2) * ch1_dim1 + 1] = sn * (cc1[(ki + j *
224 cc1_dim2) * cc1_dim1 + 1] - cc1[(ki + jc * cc1_dim2) *
225 cc1_dim1 + 2]);
226 ch1[(ki + j * ch1_dim2) * ch1_dim1 + 2] = sn * (cc1[(ki + j *
227 cc1_dim2) * cc1_dim1 + 2] + cc1[(ki + jc * cc1_dim2) *
228 cc1_dim1 + 1]);
229 ch1[(ki + jc * ch1_dim2) * ch1_dim1 + 1] = sn * (cc1[(ki + j *
230 cc1_dim2) * cc1_dim1 + 1] + cc1[(ki + jc * cc1_dim2) *
231 cc1_dim1 + 2]);
232 ch1[(ki + jc * ch1_dim2) * ch1_dim1 + 2] = sn * (cc1[(ki + j *
233 cc1_dim2) * cc1_dim1 + 2] - cc1[(ki + jc * cc1_dim2) *
234 cc1_dim1 + 1]);
235/* L144: */
236 }
237/* L145: */
238 }
239 return 0;
240L136:
241 i__1 = *lid;
242 for (ki = 1; ki <= i__1; ++ki) {
243 ch1[(ki + ch1_dim2) * ch1_dim1 + 1] = cc1[(ki + cc1_dim2) * cc1_dim1
244 + 1];
245 ch1[(ki + ch1_dim2) * ch1_dim1 + 2] = cc1[(ki + cc1_dim2) * cc1_dim1
246 + 2];
247/* L137: */
248 }
249 i__1 = ipph;
250 for (j = 2; j <= i__1; ++j) {
251 jc = ipp2 - j;
252 i__2 = *lid;
253 for (ki = 1; ki <= i__2; ++ki) {
254 ch1[(ki + j * ch1_dim2) * ch1_dim1 + 1] = cc1[(ki + j * cc1_dim2)
255 * cc1_dim1 + 1] - cc1[(ki + jc * cc1_dim2) * cc1_dim1 + 2]
256 ;
257 ch1[(ki + j * ch1_dim2) * ch1_dim1 + 2] = cc1[(ki + j * cc1_dim2)
258 * cc1_dim1 + 2] + cc1[(ki + jc * cc1_dim2) * cc1_dim1 + 1]
259 ;
260 ch1[(ki + jc * ch1_dim2) * ch1_dim1 + 1] = cc1[(ki + j * cc1_dim2)
261 * cc1_dim1 + 1] + cc1[(ki + jc * cc1_dim2) * cc1_dim1 +
262 2];
263 ch1[(ki + jc * ch1_dim2) * ch1_dim1 + 2] = cc1[(ki + j * cc1_dim2)
264 * cc1_dim1 + 2] - cc1[(ki + jc * cc1_dim2) * cc1_dim1 +
265 1];
266/* L134: */
267 }
268/* L135: */
269 }
270 i__1 = *ido;
271 for (i__ = 1; i__ <= i__1; ++i__) {
272 i__2 = *l1;
273 for (k = 1; k <= i__2; ++k) {
274 cc[(k + (i__ * cc_dim3 + 1) * cc_dim2) * cc_dim1 + 1] = ch[(k + (
275 i__ + ch_dim3) * ch_dim2) * ch_dim1 + 1];
276 cc[(k + (i__ * cc_dim3 + 1) * cc_dim2) * cc_dim1 + 2] = ch[(k + (
277 i__ + ch_dim3) * ch_dim2) * ch_dim1 + 2];
278/* L130: */
279 }
280/* L131: */
281 }
282 i__1 = *ip;
283 for (j = 2; j <= i__1; ++j) {
284 i__2 = *l1;
285 for (k = 1; k <= i__2; ++k) {
286 cc[(k + (j + cc_dim3) * cc_dim2) * cc_dim1 + 1] = ch[(k + (j *
287 ch_dim3 + 1) * ch_dim2) * ch_dim1 + 1];
288 cc[(k + (j + cc_dim3) * cc_dim2) * cc_dim1 + 2] = ch[(k + (j *
289 ch_dim3 + 1) * ch_dim2) * ch_dim1 + 2];
290/* L122: */
291 }
292/* L123: */
293 }
294 i__1 = *ip;
295 for (j = 2; j <= i__1; ++j) {
296 i__2 = *ido;
297 for (i__ = 2; i__ <= i__2; ++i__) {
298 i__3 = *l1;
299 for (k = 1; k <= i__3; ++k) {
300 cc[(k + (j + i__ * cc_dim3) * cc_dim2) * cc_dim1 + 1] = wa[
301 i__ + (j - 1 + wa_dim2) * wa_dim1] * ch[(k + (i__ + j
302 * ch_dim3) * ch_dim2) * ch_dim1 + 1] + wa[i__ + (j -
303 1 + (wa_dim2 << 1)) * wa_dim1] * ch[(k + (i__ + j *
304 ch_dim3) * ch_dim2) * ch_dim1 + 2];
305 cc[(k + (j + i__ * cc_dim3) * cc_dim2) * cc_dim1 + 2] = wa[
306 i__ + (j - 1 + wa_dim2) * wa_dim1] * ch[(k + (i__ + j
307 * ch_dim3) * ch_dim2) * ch_dim1 + 2] - wa[i__ + (j -
308 1 + (wa_dim2 << 1)) * wa_dim1] * ch[(k + (i__ + j *
309 ch_dim3) * ch_dim2) * ch_dim1 + 1];
310/* L124: */
311 }
312/* L125: */
313 }
314/* L126: */
315 }
316 return 0;
317} /* c1fgkf_ */
318