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