PLaSK library
Loading...
Searching...
No Matches
cosqb1.c
Go to the documentation of this file.
1/* cosqb1.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 cosqb1_(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 rfft1b_(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 = *n;
78 for (i__ = 3; i__ <= i__1; i__ += 2) {
79 xim1 = x[(i__ - 1) * x_dim1 + 1] + x[i__ * x_dim1 + 1];
80 x[i__ * x_dim1 + 1] = (x[(i__ - 1) * x_dim1 + 1] - x[i__ * x_dim1 + 1]
81 ) * .5;
82 x[(i__ - 1) * x_dim1 + 1] = xim1 * .5;
83/* L101: */
84 }
85 x[x_dim1 + 1] *= .5;
86 modn = *n % 2;
87 if (modn != 0) {
88 goto L302;
89 }
90 x[*n * x_dim1 + 1] *= .5;
91L302:
92 lenx = *inc * (*n - 1) + 1;
93 lnsv = *n + (integer) (log((doublereal) (*n)) / log(2.)) + 4;
94 lnwk = *n;
95
96 rfft1b_(n, inc, &x[x_offset], &lenx, &wsave[*n + 1], &lnsv, &work[1], &
97 lnwk, &ier1);
98 if (ier1 != 0) {
99 *ier = 20;
100 xerfft_("COSQB1", &c_n5, (ftnlen)6);
101 goto L400;
102 }
103
104 i__1 = ns2;
105 for (k = 2; k <= i__1; ++k) {
106 kc = np2 - k;
107 work[k] = wsave[k - 1] * x[kc * x_dim1 + 1] + wsave[kc - 1] * x[k *
108 x_dim1 + 1];
109 work[kc] = wsave[k - 1] * x[k * x_dim1 + 1] - wsave[kc - 1] * x[kc *
110 x_dim1 + 1];
111/* L102: */
112 }
113 if (modn != 0) {
114 goto L305;
115 }
116 x[(ns2 + 1) * x_dim1 + 1] = wsave[ns2] * (x[(ns2 + 1) * x_dim1 + 1] + x[(
117 ns2 + 1) * x_dim1 + 1]);
118L305:
119 i__1 = ns2;
120 for (k = 2; k <= i__1; ++k) {
121 kc = np2 - k;
122 x[k * x_dim1 + 1] = work[k] + work[kc];
123 x[kc * x_dim1 + 1] = work[k] - work[kc];
124/* L103: */
125 }
126 x[x_dim1 + 1] += x[x_dim1 + 1];
127L400:
128 return 0;
129} /* cosqb1_ */
130