PLaSK library
Loading...
Searching...
No Matches
cmfgkf.c
Go to the documentation of this file.
1/* cmfgkf.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 cmfgkf_(integer *lot, integer *ido, integer *ip, integer
46 *l1, integer *lid, integer *na, doublereal *cc, doublereal *cc1,
47 integer *im1, integer *in1, doublereal *ch, doublereal *ch1, integer *
48 im2, integer *in2, doublereal *wa)
49{
50 /* System generated locals */
51 integer ch_dim2, ch_dim3, ch_dim4, ch_offset, cc_dim2, cc_dim3, cc_dim4,
52 cc_offset, cc1_dim2, cc1_dim3, cc1_offset, ch1_dim2, ch1_dim3,
53 ch1_offset, wa_dim1, wa_dim2, wa_offset, i__1, i__2, i__3, i__4,
54 i__5;
55
56 /* Local variables */
57 integer i__, j, k, l, m1, m2, jc, lc, ki;
58 doublereal sn;
59 integer m1d, m2s;
60 doublereal wai, war;
61 integer ipp2, idlj, ipph;
62 doublereal chold1, chold2;
63
64
65/* FFTPACK 5.0 auxiliary routine */
66
67 /* Parameter adjustments */
68 wa_dim1 = *ido;
69 wa_dim2 = *ip - 1;
70 wa_offset = 1 + wa_dim1 * (1 + wa_dim2);
71 wa -= wa_offset;
72 cc1_dim2 = *in1;
73 cc1_dim3 = *lid;
74 cc1_offset = 1 + 2 * (1 + cc1_dim2 * (1 + cc1_dim3));
75 cc1 -= cc1_offset;
76 cc_dim2 = *in1;
77 cc_dim3 = *l1;
78 cc_dim4 = *ip;
79 cc_offset = 1 + 2 * (1 + cc_dim2 * (1 + cc_dim3 * (1 + cc_dim4)));
80 cc -= cc_offset;
81 ch1_dim2 = *in2;
82 ch1_dim3 = *lid;
83 ch1_offset = 1 + 2 * (1 + ch1_dim2 * (1 + ch1_dim3));
84 ch1 -= ch1_offset;
85 ch_dim2 = *in2;
86 ch_dim3 = *l1;
87 ch_dim4 = *ido;
88 ch_offset = 1 + 2 * (1 + ch_dim2 * (1 + ch_dim3 * (1 + ch_dim4)));
89 ch -= ch_offset;
90
91 /* Function Body */
92 m1d = (*lot - 1) * *im1 + 1;
93 m2s = 1 - *im2;
94 ipp2 = *ip + 2;
95 ipph = (*ip + 1) / 2;
96 i__1 = *lid;
97 for (ki = 1; ki <= i__1; ++ki) {
98 m2 = m2s;
99 i__2 = m1d;
100 i__3 = *im1;
101 for (m1 = 1; i__3 < 0 ? m1 >= i__2 : m1 <= i__2; m1 += i__3) {
102 m2 += *im2;
103 ch1[(m2 + (ki + ch1_dim3) * ch1_dim2 << 1) + 1] = cc1[(m1 + (ki +
104 cc1_dim3) * cc1_dim2 << 1) + 1];
105 ch1[(m2 + (ki + ch1_dim3) * ch1_dim2 << 1) + 2] = cc1[(m1 + (ki +
106 cc1_dim3) * cc1_dim2 << 1) + 2];
107/* L110: */
108 }
109 }
110 i__3 = ipph;
111 for (j = 2; j <= i__3; ++j) {
112 jc = ipp2 - j;
113 i__2 = *lid;
114 for (ki = 1; ki <= i__2; ++ki) {
115 m2 = m2s;
116 i__1 = m1d;
117 i__4 = *im1;
118 for (m1 = 1; i__4 < 0 ? m1 >= i__1 : m1 <= i__1; m1 += i__4) {
119 m2 += *im2;
120 ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 << 1) + 1] = cc1[(m1
121 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] + cc1[(m1
122 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1];
123 ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 << 1) + 1] = cc1[(
124 m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] - cc1[(
125 m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1];
126 ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 << 1) + 2] = cc1[(m1
127 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] + cc1[(m1
128 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2];
129 ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 << 1) + 2] = cc1[(
130 m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] - cc1[(
131 m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2];
132/* L112: */
133 }
134 }
135/* L111: */
136 }
137 i__3 = ipph;
138 for (j = 2; j <= i__3; ++j) {
139 i__4 = *lid;
140 for (ki = 1; ki <= i__4; ++ki) {
141 m2 = m2s;
142 i__1 = m1d;
143 i__2 = *im1;
144 for (m1 = 1; i__2 < 0 ? m1 >= i__1 : m1 <= i__1; m1 += i__2) {
145 m2 += *im2;
146 cc1[(m1 + (ki + cc1_dim3) * cc1_dim2 << 1) + 1] += ch1[(m2 + (
147 ki + j * ch1_dim3) * ch1_dim2 << 1) + 1];
148 cc1[(m1 + (ki + cc1_dim3) * cc1_dim2 << 1) + 2] += ch1[(m2 + (
149 ki + j * ch1_dim3) * ch1_dim2 << 1) + 2];
150/* L117: */
151 }
152 }
153/* L118: */
154 }
155 i__3 = ipph;
156 for (l = 2; l <= i__3; ++l) {
157 lc = ipp2 - l;
158 i__2 = *lid;
159 for (ki = 1; ki <= i__2; ++ki) {
160 m2 = m2s;
161 i__1 = m1d;
162 i__4 = *im1;
163 for (m1 = 1; i__4 < 0 ? m1 >= i__1 : m1 <= i__1; m1 += i__4) {
164 m2 += *im2;
165 cc1[(m1 + (ki + l * cc1_dim3) * cc1_dim2 << 1) + 1] = ch1[(m2
166 + (ki + ch1_dim3) * ch1_dim2 << 1) + 1] + wa[(l - 1 +
167 wa_dim2) * wa_dim1 + 1] * ch1[(m2 + (ki + (ch1_dim3 <<
168 1)) * ch1_dim2 << 1) + 1];
169 cc1[(m1 + (ki + lc * cc1_dim3) * cc1_dim2 << 1) + 1] = -wa[(l
170 - 1 + (wa_dim2 << 1)) * wa_dim1 + 1] * ch1[(m2 + (ki
171 + *ip * ch1_dim3) * ch1_dim2 << 1) + 1];
172 cc1[(m1 + (ki + l * cc1_dim3) * cc1_dim2 << 1) + 2] = ch1[(m2
173 + (ki + ch1_dim3) * ch1_dim2 << 1) + 2] + wa[(l - 1 +
174 wa_dim2) * wa_dim1 + 1] * ch1[(m2 + (ki + (ch1_dim3 <<
175 1)) * ch1_dim2 << 1) + 2];
176 cc1[(m1 + (ki + lc * cc1_dim3) * cc1_dim2 << 1) + 2] = -wa[(l
177 - 1 + (wa_dim2 << 1)) * wa_dim1 + 1] * ch1[(m2 + (ki
178 + *ip * ch1_dim3) * ch1_dim2 << 1) + 2];
179/* L113: */
180 }
181 }
182 i__4 = ipph;
183 for (j = 3; j <= i__4; ++j) {
184 jc = ipp2 - j;
185 idlj = (l - 1) * (j - 1) % *ip;
186 war = wa[(idlj + wa_dim2) * wa_dim1 + 1];
187 wai = -wa[(idlj + (wa_dim2 << 1)) * wa_dim1 + 1];
188 i__1 = *lid;
189 for (ki = 1; ki <= i__1; ++ki) {
190 m2 = m2s;
191 i__2 = m1d;
192 i__5 = *im1;
193 for (m1 = 1; i__5 < 0 ? m1 >= i__2 : m1 <= i__2; m1 += i__5) {
194 m2 += *im2;
195 cc1[(m1 + (ki + l * cc1_dim3) * cc1_dim2 << 1) + 1] +=
196 war * ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 <<
197 1) + 1];
198 cc1[(m1 + (ki + lc * cc1_dim3) * cc1_dim2 << 1) + 1] +=
199 wai * ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 <<
200 1) + 1];
201 cc1[(m1 + (ki + l * cc1_dim3) * cc1_dim2 << 1) + 2] +=
202 war * ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 <<
203 1) + 2];
204 cc1[(m1 + (ki + lc * cc1_dim3) * cc1_dim2 << 1) + 2] +=
205 wai * ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 <<
206 1) + 2];
207/* L114: */
208 }
209 }
210/* L115: */
211 }
212/* L116: */
213 }
214 if (*ido > 1) {
215 goto L136;
216 }
217 sn = 1. / (doublereal) (*ip * *l1);
218 if (*na == 1) {
219 goto L146;
220 }
221 i__3 = *lid;
222 for (ki = 1; ki <= i__3; ++ki) {
223 m2 = m2s;
224 i__4 = m1d;
225 i__5 = *im1;
226 for (m1 = 1; i__5 < 0 ? m1 >= i__4 : m1 <= i__4; m1 += i__5) {
227 m2 += *im2;
228 cc1[(m1 + (ki + cc1_dim3) * cc1_dim2 << 1) + 1] = sn * cc1[(m1 + (
229 ki + cc1_dim3) * cc1_dim2 << 1) + 1];
230 cc1[(m1 + (ki + cc1_dim3) * cc1_dim2 << 1) + 2] = sn * cc1[(m1 + (
231 ki + cc1_dim3) * cc1_dim2 << 1) + 2];
232/* L149: */
233 }
234 }
235 i__5 = ipph;
236 for (j = 2; j <= i__5; ++j) {
237 jc = ipp2 - j;
238 i__4 = *lid;
239 for (ki = 1; ki <= i__4; ++ki) {
240 i__3 = m1d;
241 i__2 = *im1;
242 for (m1 = 1; i__2 < 0 ? m1 >= i__3 : m1 <= i__3; m1 += i__2) {
243 chold1 = sn * (cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1)
244 + 1] - cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1)
245 + 2]);
246 chold2 = sn * (cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1)
247 + 1] + cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1)
248 + 2]);
249 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] = chold1;
250 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2] = sn * (
251 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] -
252 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1]);
253 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] = sn * (
254 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] +
255 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1]);
256 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1] = chold2;
257/* L119: */
258 }
259 }
260/* L120: */
261 }
262 return 0;
263L146:
264 i__5 = *lid;
265 for (ki = 1; ki <= i__5; ++ki) {
266 m2 = m2s;
267 i__2 = m1d;
268 i__3 = *im1;
269 for (m1 = 1; i__3 < 0 ? m1 >= i__2 : m1 <= i__2; m1 += i__3) {
270 m2 += *im2;
271 ch1[(m2 + (ki + ch1_dim3) * ch1_dim2 << 1) + 1] = sn * cc1[(m1 + (
272 ki + cc1_dim3) * cc1_dim2 << 1) + 1];
273 ch1[(m2 + (ki + ch1_dim3) * ch1_dim2 << 1) + 2] = sn * cc1[(m1 + (
274 ki + cc1_dim3) * cc1_dim2 << 1) + 2];
275/* L147: */
276 }
277 }
278 i__3 = ipph;
279 for (j = 2; j <= i__3; ++j) {
280 jc = ipp2 - j;
281 i__2 = *lid;
282 for (ki = 1; ki <= i__2; ++ki) {
283 m2 = m2s;
284 i__5 = m1d;
285 i__4 = *im1;
286 for (m1 = 1; i__4 < 0 ? m1 >= i__5 : m1 <= i__5; m1 += i__4) {
287 m2 += *im2;
288 ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 << 1) + 1] = sn * (
289 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] -
290 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2]);
291 ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 << 1) + 2] = sn * (
292 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] +
293 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1]);
294 ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 << 1) + 1] = sn * (
295 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] +
296 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2]);
297 ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 << 1) + 2] = sn * (
298 cc1[(m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] -
299 cc1[(m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1]);
300/* L144: */
301 }
302 }
303/* L145: */
304 }
305 return 0;
306L136:
307 i__3 = *lid;
308 for (ki = 1; ki <= i__3; ++ki) {
309 m2 = m2s;
310 i__4 = m1d;
311 i__5 = *im1;
312 for (m1 = 1; i__5 < 0 ? m1 >= i__4 : m1 <= i__4; m1 += i__5) {
313 m2 += *im2;
314 ch1[(m2 + (ki + ch1_dim3) * ch1_dim2 << 1) + 1] = cc1[(m1 + (ki +
315 cc1_dim3) * cc1_dim2 << 1) + 1];
316 ch1[(m2 + (ki + ch1_dim3) * ch1_dim2 << 1) + 2] = cc1[(m1 + (ki +
317 cc1_dim3) * cc1_dim2 << 1) + 2];
318/* L137: */
319 }
320 }
321 i__5 = ipph;
322 for (j = 2; j <= i__5; ++j) {
323 jc = ipp2 - j;
324 i__4 = *lid;
325 for (ki = 1; ki <= i__4; ++ki) {
326 m2 = m2s;
327 i__3 = m1d;
328 i__2 = *im1;
329 for (m1 = 1; i__2 < 0 ? m1 >= i__3 : m1 <= i__3; m1 += i__2) {
330 m2 += *im2;
331 ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 << 1) + 1] = cc1[(m1
332 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] - cc1[(m1
333 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2];
334 ch1[(m2 + (ki + j * ch1_dim3) * ch1_dim2 << 1) + 2] = cc1[(m1
335 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] + cc1[(m1
336 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1];
337 ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 << 1) + 1] = cc1[(
338 m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 1] + cc1[(
339 m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 2];
340 ch1[(m2 + (ki + jc * ch1_dim3) * ch1_dim2 << 1) + 2] = cc1[(
341 m1 + (ki + j * cc1_dim3) * cc1_dim2 << 1) + 2] - cc1[(
342 m1 + (ki + jc * cc1_dim3) * cc1_dim2 << 1) + 1];
343/* L134: */
344 }
345 }
346/* L135: */
347 }
348 i__5 = *ido;
349 for (i__ = 1; i__ <= i__5; ++i__) {
350 i__2 = *l1;
351 for (k = 1; k <= i__2; ++k) {
352 m2 = m2s;
353 i__3 = m1d;
354 i__4 = *im1;
355 for (m1 = 1; i__4 < 0 ? m1 >= i__3 : m1 <= i__3; m1 += i__4) {
356 m2 += *im2;
357 cc[(m1 + (k + (i__ * cc_dim4 + 1) * cc_dim3) * cc_dim2 << 1)
358 + 1] = ch[(m2 + (k + (i__ + ch_dim4) * ch_dim3) *
359 ch_dim2 << 1) + 1];
360 cc[(m1 + (k + (i__ * cc_dim4 + 1) * cc_dim3) * cc_dim2 << 1)
361 + 2] = ch[(m2 + (k + (i__ + ch_dim4) * ch_dim3) *
362 ch_dim2 << 1) + 2];
363/* L130: */
364 }
365 }
366/* L131: */
367 }
368 i__5 = *ip;
369 for (j = 2; j <= i__5; ++j) {
370 i__4 = *l1;
371 for (k = 1; k <= i__4; ++k) {
372 m2 = m2s;
373 i__3 = m1d;
374 i__2 = *im1;
375 for (m1 = 1; i__2 < 0 ? m1 >= i__3 : m1 <= i__3; m1 += i__2) {
376 m2 += *im2;
377 cc[(m1 + (k + (j + cc_dim4) * cc_dim3) * cc_dim2 << 1) + 1] =
378 ch[(m2 + (k + (j * ch_dim4 + 1) * ch_dim3) * ch_dim2
379 << 1) + 1];
380 cc[(m1 + (k + (j + cc_dim4) * cc_dim3) * cc_dim2 << 1) + 2] =
381 ch[(m2 + (k + (j * ch_dim4 + 1) * ch_dim3) * ch_dim2
382 << 1) + 2];
383/* L122: */
384 }
385 }
386/* L123: */
387 }
388 i__5 = *ip;
389 for (j = 2; j <= i__5; ++j) {
390 i__2 = *ido;
391 for (i__ = 2; i__ <= i__2; ++i__) {
392 i__3 = *l1;
393 for (k = 1; k <= i__3; ++k) {
394 m2 = m2s;
395 i__4 = m1d;
396 i__1 = *im1;
397 for (m1 = 1; i__1 < 0 ? m1 >= i__4 : m1 <= i__4; m1 += i__1) {
398 m2 += *im2;
399 cc[(m1 + (k + (j + i__ * cc_dim4) * cc_dim3) * cc_dim2 <<
400 1) + 1] = wa[i__ + (j - 1 + wa_dim2) * wa_dim1] *
401 ch[(m2 + (k + (i__ + j * ch_dim4) * ch_dim3) *
402 ch_dim2 << 1) + 1] + wa[i__ + (j - 1 + (wa_dim2 <<
403 1)) * wa_dim1] * ch[(m2 + (k + (i__ + j *
404 ch_dim4) * ch_dim3) * ch_dim2 << 1) + 2];
405 cc[(m1 + (k + (j + i__ * cc_dim4) * cc_dim3) * cc_dim2 <<
406 1) + 2] = wa[i__ + (j - 1 + wa_dim2) * wa_dim1] *
407 ch[(m2 + (k + (i__ + j * ch_dim4) * ch_dim3) *
408 ch_dim2 << 1) + 2] - wa[i__ + (j - 1 + (wa_dim2 <<
409 1)) * wa_dim1] * ch[(m2 + (k + (i__ + j *
410 ch_dim4) * ch_dim3) * ch_dim2 << 1) + 1];
411/* L124: */
412 }
413 }
414/* L125: */
415 }
416/* L126: */
417 }
418 return 0;
419} /* cmfgkf_ */
420