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