PLaSK library
Loading...
Searching...
No Matches
cosqf1.c
Go to the documentation of this file.
1/* cosqf1.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/* Table of constant values */
16
17static integer c_n5 = -5;
18
19/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
20/* * * */
21/* * copyright (c) 2011 by UCAR * */
22/* * * */
23/* * University Corporation for Atmospheric Research * */
24/* * * */
25/* * all rights reserved * */
26/* * * */
27/* * FFTPACK version 5.1 * */
28/* * * */
29/* * A Fortran Package of Fast Fourier * */
30/* * * */
31/* * Subroutines and Example Programs * */
32/* * * */
33/* * by * */
34/* * * */
35/* * Paul Swarztrauber and Dick Valent * */
36/* * * */
37/* * of * */
38/* * * */
39/* * the National Center for Atmospheric Research * */
40/* * * */
41/* * Boulder, Colorado (80307) U.S.A. * */
42/* * * */
43/* * which is sponsored by * */
44/* * * */
45/* * the National Science Foundation * */
46/* * * */
47/* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
48
49/* Subroutine */ int cosqf1_(integer *n, integer *inc, doublereal *x,
50 doublereal *wsave, doublereal *work, integer *ier)
51{
52 /* System generated locals */
53 integer x_dim1, x_offset, i__1;
54
55 /* Builtin functions */
56 double log(doublereal);
57
58 /* Local variables */
59 integer i__, k, kc, np2, ns2, ier1;
60 doublereal xim1;
61 integer modn, lenx, lnwk, lnsv;
62 extern /* Subroutine */ int rfft1f_(integer *, integer *, doublereal *,
63 integer *, doublereal *, integer *, doublereal *, integer *,
64 integer *), xerfft_(char *, integer *, ftnlen);
65
66 /* Parameter adjustments */
67 x_dim1 = *inc;
68 x_offset = 1 + x_dim1;
69 x -= x_offset;
70 --wsave;
71 --work;
72
73 /* Function Body */
74 *ier = 0;
75 ns2 = (*n + 1) / 2;
76 np2 = *n + 2;
77 i__1 = ns2;
78 for (k = 2; k <= i__1; ++k) {
79 kc = np2 - k;
80 work[k] = x[k * x_dim1 + 1] + x[kc * x_dim1 + 1];
81 work[kc] = x[k * x_dim1 + 1] - x[kc * x_dim1 + 1];
82/* L101: */
83 }
84 modn = *n % 2;
85 if (modn != 0) {
86 goto L301;
87 }
88 work[ns2 + 1] = x[(ns2 + 1) * x_dim1 + 1] + x[(ns2 + 1) * x_dim1 + 1];
89L301:
90 i__1 = ns2;
91 for (k = 2; k <= i__1; ++k) {
92 kc = np2 - k;
93 x[k * x_dim1 + 1] = wsave[k - 1] * work[kc] + wsave[kc - 1] * work[k];
94 x[kc * x_dim1 + 1] = wsave[k - 1] * work[k] - wsave[kc - 1] * work[kc]
95 ;
96/* L102: */
97 }
98 if (modn != 0) {
99 goto L303;
100 }
101 x[(ns2 + 1) * x_dim1 + 1] = wsave[ns2] * work[ns2 + 1];
102L303:
103 lenx = *inc * (*n - 1) + 1;
104 lnsv = *n + (integer) (log((doublereal) (*n)) / log(2.)) + 4;
105 lnwk = *n;
106
107 rfft1f_(n, inc, &x[x_offset], &lenx, &wsave[*n + 1], &lnsv, &work[1], &
108 lnwk, &ier1);
109 if (ier1 != 0) {
110 *ier = 20;
111 xerfft_("COSQF1", &c_n5, (ftnlen)6);
112 goto L400;
113 }
114
115 i__1 = *n;
116 for (i__ = 3; i__ <= i__1; i__ += 2) {
117 xim1 = (x[(i__ - 1) * x_dim1 + 1] + x[i__ * x_dim1 + 1]) * .5;
118 x[i__ * x_dim1 + 1] = (x[(i__ - 1) * x_dim1 + 1] - x[i__ * x_dim1 + 1]
119 ) * .5;
120 x[(i__ - 1) * x_dim1 + 1] = xim1;
121/* L103: */
122 }
123L400:
124 return 0;
125} /* cosqf1_ */
126