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