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