PLaSK library
Loading...
Searching...
No Matches
r1fgkf.c
Go to the documentation of this file.
1/* r1fgkf.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 r1fgkf_(integer *ido, integer *ip, integer *l1, integer *
46 idl1, doublereal *cc, doublereal *c1, doublereal *c2, integer *in1,
47 doublereal *ch, doublereal *ch2, 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, c1_dim1, c1_dim2, c1_dim3, c1_offset, c2_dim1, c2_dim2,
52 c2_offset, ch2_dim1, ch2_dim2, ch2_offset, i__1, i__2, i__3;
53
54 /* Builtin functions */
55 double atan(doublereal), cos(doublereal), sin(doublereal);
56
57 /* Local variables */
58 integer i__, j, k, l, j2, ic, jc, lc, ik, is;
59 doublereal dc2, ai1, ai2, ar1, ar2, ds2;
60 integer nbd;
61 doublereal dcp, arg, dsp, tpi, ar1h, ar2h;
62 integer idp2, ipp2, idij, ipph;
63
64
65 /* Parameter adjustments */
66 --wa;
67 c2_dim1 = *in1;
68 c2_dim2 = *idl1;
69 c2_offset = 1 + c2_dim1 * (1 + c2_dim2);
70 c2 -= c2_offset;
71 c1_dim1 = *in1;
72 c1_dim2 = *ido;
73 c1_dim3 = *l1;
74 c1_offset = 1 + c1_dim1 * (1 + c1_dim2 * (1 + c1_dim3));
75 c1 -= c1_offset;
76 cc_dim1 = *in1;
77 cc_dim2 = *ido;
78 cc_dim3 = *ip;
79 cc_offset = 1 + cc_dim1 * (1 + cc_dim2 * (1 + cc_dim3));
80 cc -= cc_offset;
81 ch2_dim1 = *in2;
82 ch2_dim2 = *idl1;
83 ch2_offset = 1 + ch2_dim1 * (1 + ch2_dim2);
84 ch2 -= ch2_offset;
85 ch_dim1 = *in2;
86 ch_dim2 = *ido;
87 ch_dim3 = *l1;
88 ch_offset = 1 + ch_dim1 * (1 + ch_dim2 * (1 + ch_dim3));
89 ch -= ch_offset;
90
91 /* Function Body */
92 tpi = atan(1.) * 8.;
93 arg = tpi / (doublereal) (*ip);
94 dcp = cos(arg);
95 dsp = sin(arg);
96 ipph = (*ip + 1) / 2;
97 ipp2 = *ip + 2;
98 idp2 = *ido + 2;
99 nbd = (*ido - 1) / 2;
100 if (*ido == 1) {
101 goto L119;
102 }
103 i__1 = *idl1;
104 for (ik = 1; ik <= i__1; ++ik) {
105 ch2[(ik + ch2_dim2) * ch2_dim1 + 1] = c2[(ik + c2_dim2) * c2_dim1 + 1]
106 ;
107/* L101: */
108 }
109 i__1 = *ip;
110 for (j = 2; j <= i__1; ++j) {
111 i__2 = *l1;
112 for (k = 1; k <= i__2; ++k) {
113 ch[((k + j * ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1] = c1[((k + j *
114 c1_dim3) * c1_dim2 + 1) * c1_dim1 + 1];
115/* L102: */
116 }
117/* L103: */
118 }
119 if (nbd > *l1) {
120 goto L107;
121 }
122 is = -(*ido);
123 i__1 = *ip;
124 for (j = 2; j <= i__1; ++j) {
125 is += *ido;
126 idij = is;
127 i__2 = *ido;
128 for (i__ = 3; i__ <= i__2; i__ += 2) {
129 idij += 2;
130 i__3 = *l1;
131 for (k = 1; k <= i__3; ++k) {
132 ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1] =
133 wa[idij - 1] * c1[(i__ - 1 + (k + j * c1_dim3) *
134 c1_dim2) * c1_dim1 + 1] + wa[idij] * c1[(i__ + (k + j
135 * c1_dim3) * c1_dim2) * c1_dim1 + 1];
136 ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1] = wa[
137 idij - 1] * c1[(i__ + (k + j * c1_dim3) * c1_dim2) *
138 c1_dim1 + 1] - wa[idij] * c1[(i__ - 1 + (k + j *
139 c1_dim3) * c1_dim2) * c1_dim1 + 1];
140/* L104: */
141 }
142/* L105: */
143 }
144/* L106: */
145 }
146 goto L111;
147L107:
148 is = -(*ido);
149 i__1 = *ip;
150 for (j = 2; j <= i__1; ++j) {
151 is += *ido;
152 i__2 = *l1;
153 for (k = 1; k <= i__2; ++k) {
154 idij = is;
155 i__3 = *ido;
156 for (i__ = 3; i__ <= i__3; i__ += 2) {
157 idij += 2;
158 ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1] =
159 wa[idij - 1] * c1[(i__ - 1 + (k + j * c1_dim3) *
160 c1_dim2) * c1_dim1 + 1] + wa[idij] * c1[(i__ + (k + j
161 * c1_dim3) * c1_dim2) * c1_dim1 + 1];
162 ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1] = wa[
163 idij - 1] * c1[(i__ + (k + j * c1_dim3) * c1_dim2) *
164 c1_dim1 + 1] - wa[idij] * c1[(i__ - 1 + (k + j *
165 c1_dim3) * c1_dim2) * c1_dim1 + 1];
166/* L108: */
167 }
168/* L109: */
169 }
170/* L110: */
171 }
172L111:
173 if (nbd < *l1) {
174 goto L115;
175 }
176 i__1 = ipph;
177 for (j = 2; j <= i__1; ++j) {
178 jc = ipp2 - j;
179 i__2 = *l1;
180 for (k = 1; k <= i__2; ++k) {
181 i__3 = *ido;
182 for (i__ = 3; i__ <= i__3; i__ += 2) {
183 c1[(i__ - 1 + (k + j * c1_dim3) * c1_dim2) * c1_dim1 + 1] =
184 ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) * ch_dim1
185 + 1] + ch[(i__ - 1 + (k + jc * ch_dim3) * ch_dim2) *
186 ch_dim1 + 1];
187 c1[(i__ - 1 + (k + jc * c1_dim3) * c1_dim2) * c1_dim1 + 1] =
188 ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1]
189 - ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 +
190 1];
191 c1[(i__ + (k + j * c1_dim3) * c1_dim2) * c1_dim1 + 1] = ch[(
192 i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1] +
193 ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 + 1]
194 ;
195 c1[(i__ + (k + jc * c1_dim3) * c1_dim2) * c1_dim1 + 1] = ch[(
196 i__ - 1 + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 + 1]
197 - ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) *
198 ch_dim1 + 1];
199/* L112: */
200 }
201/* L113: */
202 }
203/* L114: */
204 }
205 goto L121;
206L115:
207 i__1 = ipph;
208 for (j = 2; j <= i__1; ++j) {
209 jc = ipp2 - j;
210 i__2 = *ido;
211 for (i__ = 3; i__ <= i__2; i__ += 2) {
212 i__3 = *l1;
213 for (k = 1; k <= i__3; ++k) {
214 c1[(i__ - 1 + (k + j * c1_dim3) * c1_dim2) * c1_dim1 + 1] =
215 ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) * ch_dim1
216 + 1] + ch[(i__ - 1 + (k + jc * ch_dim3) * ch_dim2) *
217 ch_dim1 + 1];
218 c1[(i__ - 1 + (k + jc * c1_dim3) * c1_dim2) * c1_dim1 + 1] =
219 ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1]
220 - ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 +
221 1];
222 c1[(i__ + (k + j * c1_dim3) * c1_dim2) * c1_dim1 + 1] = ch[(
223 i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1] +
224 ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 + 1]
225 ;
226 c1[(i__ + (k + jc * c1_dim3) * c1_dim2) * c1_dim1 + 1] = ch[(
227 i__ - 1 + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 + 1]
228 - ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) *
229 ch_dim1 + 1];
230/* L116: */
231 }
232/* L117: */
233 }
234/* L118: */
235 }
236 goto L121;
237L119:
238 i__1 = *idl1;
239 for (ik = 1; ik <= i__1; ++ik) {
240 c2[(ik + c2_dim2) * c2_dim1 + 1] = ch2[(ik + ch2_dim2) * ch2_dim1 + 1]
241 ;
242/* L120: */
243 }
244L121:
245 i__1 = ipph;
246 for (j = 2; j <= i__1; ++j) {
247 jc = ipp2 - j;
248 i__2 = *l1;
249 for (k = 1; k <= i__2; ++k) {
250 c1[((k + j * c1_dim3) * c1_dim2 + 1) * c1_dim1 + 1] = ch[((k + j *
251 ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1] + ch[((k + jc *
252 ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1];
253 c1[((k + jc * c1_dim3) * c1_dim2 + 1) * c1_dim1 + 1] = ch[((k +
254 jc * ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1] - ch[((k + j *
255 ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1];
256/* L122: */
257 }
258/* L123: */
259 }
260
261 ar1 = 1.;
262 ai1 = 0.;
263 i__1 = ipph;
264 for (l = 2; l <= i__1; ++l) {
265 lc = ipp2 - l;
266 ar1h = dcp * ar1 - dsp * ai1;
267 ai1 = dcp * ai1 + dsp * ar1;
268 ar1 = ar1h;
269 i__2 = *idl1;
270 for (ik = 1; ik <= i__2; ++ik) {
271 ch2[(ik + l * ch2_dim2) * ch2_dim1 + 1] = c2[(ik + c2_dim2) *
272 c2_dim1 + 1] + ar1 * c2[(ik + (c2_dim2 << 1)) * c2_dim1 +
273 1];
274 ch2[(ik + lc * ch2_dim2) * ch2_dim1 + 1] = ai1 * c2[(ik + *ip *
275 c2_dim2) * c2_dim1 + 1];
276/* L124: */
277 }
278 dc2 = ar1;
279 ds2 = ai1;
280 ar2 = ar1;
281 ai2 = ai1;
282 i__2 = ipph;
283 for (j = 3; j <= i__2; ++j) {
284 jc = ipp2 - j;
285 ar2h = dc2 * ar2 - ds2 * ai2;
286 ai2 = dc2 * ai2 + ds2 * ar2;
287 ar2 = ar2h;
288 i__3 = *idl1;
289 for (ik = 1; ik <= i__3; ++ik) {
290 ch2[(ik + l * ch2_dim2) * ch2_dim1 + 1] += ar2 * c2[(ik + j *
291 c2_dim2) * c2_dim1 + 1];
292 ch2[(ik + lc * ch2_dim2) * ch2_dim1 + 1] += ai2 * c2[(ik + jc
293 * c2_dim2) * c2_dim1 + 1];
294/* L125: */
295 }
296/* L126: */
297 }
298/* L127: */
299 }
300 i__1 = ipph;
301 for (j = 2; j <= i__1; ++j) {
302 i__2 = *idl1;
303 for (ik = 1; ik <= i__2; ++ik) {
304 ch2[(ik + ch2_dim2) * ch2_dim1 + 1] += c2[(ik + j * c2_dim2) *
305 c2_dim1 + 1];
306/* L128: */
307 }
308/* L129: */
309 }
310
311 if (*ido < *l1) {
312 goto L132;
313 }
314 i__1 = *l1;
315 for (k = 1; k <= i__1; ++k) {
316 i__2 = *ido;
317 for (i__ = 1; i__ <= i__2; ++i__) {
318 cc[(i__ + (k * cc_dim3 + 1) * cc_dim2) * cc_dim1 + 1] = ch[(i__ +
319 (k + ch_dim3) * ch_dim2) * ch_dim1 + 1];
320/* L130: */
321 }
322/* L131: */
323 }
324 goto L135;
325L132:
326 i__1 = *ido;
327 for (i__ = 1; i__ <= i__1; ++i__) {
328 i__2 = *l1;
329 for (k = 1; k <= i__2; ++k) {
330 cc[(i__ + (k * cc_dim3 + 1) * cc_dim2) * cc_dim1 + 1] = ch[(i__ +
331 (k + ch_dim3) * ch_dim2) * ch_dim1 + 1];
332/* L133: */
333 }
334/* L134: */
335 }
336L135:
337 i__1 = ipph;
338 for (j = 2; j <= i__1; ++j) {
339 jc = ipp2 - j;
340 j2 = j + j;
341 i__2 = *l1;
342 for (k = 1; k <= i__2; ++k) {
343 cc[(*ido + (j2 - 2 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1] = ch[(
344 (k + j * ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1];
345 cc[((j2 - 1 + k * cc_dim3) * cc_dim2 + 1) * cc_dim1 + 1] = ch[((k
346 + jc * ch_dim3) * ch_dim2 + 1) * ch_dim1 + 1];
347/* L136: */
348 }
349/* L137: */
350 }
351 if (*ido == 1) {
352 return 0;
353 }
354 if (nbd < *l1) {
355 goto L141;
356 }
357 i__1 = ipph;
358 for (j = 2; j <= i__1; ++j) {
359 jc = ipp2 - j;
360 j2 = j + j;
361 i__2 = *l1;
362 for (k = 1; k <= i__2; ++k) {
363 i__3 = *ido;
364 for (i__ = 3; i__ <= i__3; i__ += 2) {
365 ic = idp2 - i__;
366 cc[(i__ - 1 + (j2 - 1 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1]
367 = ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) *
368 ch_dim1 + 1] + ch[(i__ - 1 + (k + jc * ch_dim3) *
369 ch_dim2) * ch_dim1 + 1];
370 cc[(ic - 1 + (j2 - 2 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1]
371 = ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) *
372 ch_dim1 + 1] - ch[(i__ - 1 + (k + jc * ch_dim3) *
373 ch_dim2) * ch_dim1 + 1];
374 cc[(i__ + (j2 - 1 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1] =
375 ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1]
376 + ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 +
377 1];
378 cc[(ic + (j2 - 2 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1] =
379 ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 + 1]
380 - ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 +
381 1];
382/* L138: */
383 }
384/* L139: */
385 }
386/* L140: */
387 }
388 return 0;
389L141:
390 i__1 = ipph;
391 for (j = 2; j <= i__1; ++j) {
392 jc = ipp2 - j;
393 j2 = j + j;
394 i__2 = *ido;
395 for (i__ = 3; i__ <= i__2; i__ += 2) {
396 ic = idp2 - i__;
397 i__3 = *l1;
398 for (k = 1; k <= i__3; ++k) {
399 cc[(i__ - 1 + (j2 - 1 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1]
400 = ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) *
401 ch_dim1 + 1] + ch[(i__ - 1 + (k + jc * ch_dim3) *
402 ch_dim2) * ch_dim1 + 1];
403 cc[(ic - 1 + (j2 - 2 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1]
404 = ch[(i__ - 1 + (k + j * ch_dim3) * ch_dim2) *
405 ch_dim1 + 1] - ch[(i__ - 1 + (k + jc * ch_dim3) *
406 ch_dim2) * ch_dim1 + 1];
407 cc[(i__ + (j2 - 1 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1] =
408 ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 + 1]
409 + ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 +
410 1];
411 cc[(ic + (j2 - 2 + k * cc_dim3) * cc_dim2) * cc_dim1 + 1] =
412 ch[(i__ + (k + jc * ch_dim3) * ch_dim2) * ch_dim1 + 1]
413 - ch[(i__ + (k + j * ch_dim3) * ch_dim2) * ch_dim1 +
414 1];
415/* L142: */
416 }
417/* L143: */
418 }
419/* L144: */
420 }
421 return 0;
422} /* r1fgkf_ */
423