void dpolint (const double *xa, const double *ya, int_t n,
double x, double *y, double *dy)
{
register int_t ns = 1;
double dif = fabs (x - xa[1]),
*c = dvector (1, n),
*d = dvector (1, n);
register int_t i, m;
double den, dift, ho, hp, w;
for (i = 1; i <= n; i++) {
if ((dift = fabs (x-xa[i])) < dif) {
ns = i;
dif = dift;
}
c[i] = ya[i];
d[i] = ya[i];
}
*y = ya[ns--];
for (m = 1; m < n; m++) {
for (i = 1; i <= n - m; i++) {
ho = xa[i] - x;
hp = xa[i+m] -x;
w = c[i+1] - d[i];
if ((den = ho-hp) == 0.0)
message("dpolint()", "two x values the same (within roundoff)", ERROR);
den = w / den;
d[i] = hp * den;
c[i] = ho * den;
}
*y += (*dy=((ns<<1) < (n-m) ? c[ns+1] : d[ns--]));
}
freeDvector (c, 1);
freeDvector (d, 1);
}
void polcoe(int n, double *x, double *y, double *c)
/* ========================================================================= *
* polcoe(): calculate polynomial coefficients given knot points. *
* *
* Given arrays x[0..n] and y[0..n] containing tabulated function y_i=f(x_i) *
* this routine returns an array of coefficients c[0..n], such that *
* y_i = c_j x_i^j. *
* *
* Numerical Recipes /S 3.5. See also the caveats there. *
* ========================================================================= */
{
int i, j, k;
double phi, ff, b, *s;
s = dvector(0, n);
dzero(n+1, s, 1);
dzero(n+1, c, 1);
s[n] -= x[0];
for (i=1; i<=n; i++) {
for (j=n-i; j<=n-1; j++)
s[j] -= x[i]*s[j+1];
s[n] -= x[i];
}
for (j=0; j<=n; j++) {
phi = n + 1;
for (k=n; k>=1; k--)
phi = k*s[k] + x[j]*phi;
ff = y[j] / phi;
b = 1.0;
for (k=n; k>=0; k--) {
c[k] += b * ff;
b = s[k] + x[j]*b;
}
}
freeDvector(s, 0);
}
void dspline (integer n, double yp1, double ypn,
const double* x, const double* y, double* y2)
{
register integer i, k;
double h = x[1] - x[0],
*u = dvector (0, n-2);
double p, qn, sig, un, hh;
if (yp1 > 0.99e30)
y2[0] = u[0] = 0.0;
else {
y2[0] = -0.5;
u [0] = (3.0 / h) * ((y[1]-y[0]) / h - yp1);
}
for (i = 1; i < n-1; i++) {
hh = 1.0 / (x[i+1] - x[i-1]);
sig = h * hh;
p = sig * y2[i-1] + 2.0;
y2[i] = (sig - 1.0) / p;
u [i] = (y[i] - y[i-1]) / h;
u [i] = (y[i+1] - y[i]) / (h = x[i+1] - x[i]) - u[i];
u [i] = (6.0 * u[i] * hh - sig * u[i-1]) / p;
}
if (ypn > 0.99e30)
qn = un = 0.0;
else {
qn = 0.5;
un = (3.0 / h) * (ypn - (y[n-1]-y[n-2])/h);
}
y2[n-1] = (un - qn * u[n-2]) / (qn * y2[n-2] + 1.0);
for (k = n-2; k; k--) y2[k] = y2[k] * y2[k+1] + u[k];
freeDvector(u, 0);
}
int main (int argc,
char** argv)
/* ------------------------------------------------------------------------- *
* Wrapper.
* ------------------------------------------------------------------------- */
{
char buf[STR_MAX], fields[STR_MAX], fmt[STR_MAX];
int i, j, n, np, nz, nel, mode = 0, swab = 0, cmplx = 0;
int nfields, nplane, nplaneEven, nptsEven, ntot;
FILE *fp_in = stdin, *fp_out = stdout;
double **data, *plane, *vcmpt;
getargs (argc, argv, &fp_in, &mode, &cmplx);
format (fmt);
while (fgets (buf, STR_MAX, fp_in)) {
fputs (buf, fp_out); fgets (buf, STR_MAX, fp_in);
fputs (buf, fp_out); fgets (buf, STR_MAX, fp_in);
if (sscanf (buf, "%d%*s%d%d", &np, &nz, &nel) != 3)
message (prog, "unable to read the file size", ERROR);
if (2 * mode > nz) {
sprintf (fields, "too many modes (%1d) for input (nz = %1d)", mode, nz);
message (prog, fields, ERROR);
}
if (cmplx && nz != 2) {
sprintf (fields, "need nz = 2 with full-complex single mode (%1d)", nz);
message (prog, fields, ERROR);
}
fprintf (fp_out, hdr_fmt[2], np, np, 1, nel);
n = 6;
while (--n) {
fgets (buf, STR_MAX, fp_in);
fputs (buf, fp_out);
}
fgets (fields, STR_MAX, fp_in);
memset (fields+25, '\0', STR_MAX-25);
for (nfields = 0, i = 0; i < 25; i++) if (isalpha(fields[i])) nfields++;
if (nfields < 4) {
if (!(strchr(fields, 'u') && strchr(fields, 'v')))
message (prog, "need fields u, v to compute K.E.", ERROR);
} else {
if (!(strchr(fields, 'u') && strchr(fields, 'v') && strchr(fields, 'w')))
message (prog, "need fields u, v, w to compute K.E.", ERROR);
}
fprintf (fp_out, hdr_fmt[8], "q");
fgets (buf, STR_MAX, fp_in);
for (i = 0; i < strlen (buf); i++) buf[i] = tolower (buf[i]);
if (!strstr(buf, "binary"))
message (prog, "input file not binary format", ERROR);
if (!strstr (buf, "endian"))
message (prog, "input field file in unknown binary format", WARNING);
else
swab = ((strstr (buf, "big") && strstr (fmt, "little")) ||
(strstr (fmt, "big") && strstr (buf, "little")) );
sprintf (buf, "%s %s", "binary", fmt);
fprintf (fp_out, hdr_fmt[9], buf);
/* -- Set sizes, allocate storage. */
nplane = np * np * nel;
nplaneEven = (nplane & 1) ? nplane + 1 : nplane;
nptsEven = nz * nplaneEven;
ntot = nfields * nptsEven;
data = dmatrix (0, nfields - 1, 0, nptsEven - 1);
plane = dvector (0, nplane - 1);
/* -- Read in all data fields. */
dzero (ntot, data[0], 1);
dzero (nplane, plane, 1);
for (i = 0; i < nfields; i++) {
for (j = 0; j < nz; j++) {
if (fread (data[i] + j*nplaneEven, sizeof (double), nplane, fp_in)
!= nplane)
message (prog, "an error occured while reading", ERROR);
}
if (swab) dbrev (nptsEven, data[i], 1, data[i], 1);
if (!cmplx) dDFTr (data[i], nz, nplaneEven, +1);
}
/* -- Compute K.E.: start by adding in real part. */
for (i = 0; i < nfields - 1; i++) {
vcmpt = data[_index (fields, 'u' + i)] + 2 * mode * nplaneEven;
dvvtvp (nplane, vcmpt, 1, vcmpt, 1, plane, 1, plane, 1);
}
/* -- Add in imaginary part if not mode zero. */
if (mode || cmplx) {
for (i = 0; i < nfields - 1; i++) {
vcmpt = data[_index (fields, 'u' + i)] + (2 * mode + 1) * nplaneEven;
dvvtvp (nplane, vcmpt, 1, vcmpt, 1, plane, 1, plane, 1);
}
}
/* -- Normalize to make q = 0.5*UiUi. */
dsmul (nplane, 0.5, plane, 1, plane, 1);
if (fwrite (plane, sizeof (double), nplane, fp_out) != nplane)
message (prog, "an error occured while writing", ERROR);
freeDmatrix (data, 0, 0);
freeDvector (plane, 0);
}
return EXIT_SUCCESS;
}
int main (int argc,
char** argv)
/* ------------------------------------------------------------------------- *
* Wrapper.
* ------------------------------------------------------------------------- */
{
char buf[STR_MAX], fmt[STR_MAX];
int i, j, k, n, np, nzin, nzout, nel, nrep = 1, force = 0;
int nfields, nplane, nptin, nptout, ntot, swab;
FILE *fp_in = stdin, *fp_out = stdout;
double *datain, *dataout, beta;
getargs (argc, argv, &fp_in, &nrep, &force);
format (fmt);
while (fgets (buf, STR_MAX, fp_in)) {
fputs (buf, fp_out); fgets (buf, STR_MAX, fp_in);
fputs (buf, fp_out); fgets (buf, STR_MAX, fp_in);
if (sscanf (buf, "%d%*s%d%d", &np, &nzin, &nel) != 3)
message (prog, "unable to read the file size", ERROR);
if (!force) {
if ((nzout = roundup (nzin)) != nzin)
message (prog, "input nz does not have 2, 3, 5 factors", ERROR);
nzout = roundup (nzin * nrep);
} else
nzout = nzin * nrep;
fprintf (fp_out, hdr_fmt[2], np, np, nzout, nel);
n = 4;
while (n--) { fgets (buf, STR_MAX, fp_in); fputs (buf, fp_out); }
fgets (buf, STR_MAX, fp_in);
sscanf (buf, "%lf", &beta);
beta /= nrep;
fprintf (fp_out, hdr_fmt[7], beta);
fgets (buf, STR_MAX, fp_in); fputs (buf, fp_out);
for (nfields = 0, i = 0; i < 25; i++) if (isalnum(buf[i])) nfields++;
fgets (buf, STR_MAX, fp_in);
if (!strstr(buf, "binary"))
message (prog, "input file not binary format", ERROR);
swab = (strstr (buf, "big") && strstr (fmt, "little")) ||
(strstr (fmt, "big") && strstr (buf, "little"));
strcat (strcpy (buf, "binary "), fmt);
fprintf (fp_out, hdr_fmt[9], buf);
/* -- Set sizes, allocate storage. */
nplane = np * np * nel;
ntot = nplane + (nplane & 1);
nptin = nzin * ntot;
nptout = nzout * ntot;
datain = dvector (0, nptin - 1);
dataout = dvector (0, nptout - 1);
/* -- Read and write all data fields. */
for (i = 0; i < nfields; i++) {
dzero (nptin, datain, 1);
dzero (nptout, dataout, 1);
for (j = 0; j < nzin; j++) {
if (fread (datain+j*ntot, sizeof (double), nplane, fp_in) != nplane)
message (prog, "an error occured while reading", ERROR);
if (swab) dbrev (ntot, datain+j*ntot, 1, datain+j*ntot, 1);
}
if (force) { /* -- We can just copy in physical space. */
for (k = 0; k < nrep; k++) {
for (j = 0; j < nzin; j++) {
if (fwrite (datain+j*ntot, sizeof (double), nplane, fp_out) != nplane)
message (prog, "an error occured while writing", ERROR);
}
}
} else { /* -- Have to go to Fourier space for padding. */
dDFTr (datain, nzin, ntot, FORWARD);
pack (datain, nzin, dataout, nzout, nrep, ntot);
dDFTr (dataout, nzout, ntot, INVERSE);
for (j = 0; j < nzout; j++)
if (fwrite (dataout+j*ntot, sizeof (double), nplane, fp_out) != nplane)
message (prog, "an error occured while writing", ERROR);
}
}
}
freeDvector (datain, 0);
freeDvector (dataout, 0);
return EXIT_SUCCESS;
}
int main (int argc,
char** argv)
/* ------------------------------------------------------------------------- *
* Wrapper.
* ------------------------------------------------------------------------- */
{
char buf[STR_MAX], fmt[STR_MAX];
int i, j, k, np, nz, nel, nrep = 1;
int nfields, nplane, nptin, nptout, ntot, swab;
FILE *fp_in = stdin, *fp_out = stdout;
double *data;
getargs (argc, argv, &fp_in, &nrep);
format (fmt);
while (fgets (buf, STR_MAX, fp_in)) {
fputs (buf, fp_out); fgets (buf, STR_MAX, fp_in);
fputs (buf, fp_out); fgets (buf, STR_MAX, fp_in);
if (sscanf (buf, "%d%*s%d%d", &np, &nz, &nel) != 3)
message (prog, "unable to read the file size", ERROR);
fprintf (fp_out, hdr_fmt[2], np, np, nz, nel*nrep);
i = 5;
while (i--) { fgets (buf, STR_MAX, fp_in); fputs (buf, fp_out); }
fgets (buf, STR_MAX, fp_in); fputs (buf, fp_out);
for (nfields = 0, i = 0; i < 25; i++) if (isalnum(buf[i])) nfields++;
fgets (buf, STR_MAX, fp_in);
if (!strstr(buf, "binary"))
message (prog, "input file not binary format", ERROR);
swab = (strstr (buf, "big") && strstr (fmt, "little")) ||
(strstr (fmt, "big") && strstr (buf, "little"));
strcat (strcpy (buf, "binary "), fmt);
fprintf (fp_out, hdr_fmt[9], buf);
/* -- Set sizes, allocate storage. */
nplane = np * np * nel;
ntot = nz * nplane;
data = dvector (0, ntot - 1);
/* -- Read and write all data fields. */
for (i = 0; i < nfields; i++) {
if (fread (data, sizeof (double), ntot, fp_in) != ntot)
message (prog, "an error occured while reading", ERROR);
if (swab) dbrev (ntot, data, 1, data, 1);
for (j = 0; j < nz; j++)
for (k = 0; k < nrep; k++)
if (fwrite (data+j*nplane, sizeof(double), nplane, fp_out) != nplane)
message (prog, "an error occured while writing", ERROR);
}
}
freeDvector (data, 0);
return EXIT_SUCCESS;
}
void dDFTr (double* data,
const int_t tlen,
const int_t ntrn,
const int_t sign)
/* ------------------------------------------------------------------------- *
* Carry out multiple 1D single--complex Fourier transforms of data.
* Data is to be Fourier transformed in the direction normal to the most
* rapid traverse through memory, with sucessive points in the transform
* separated by ntrn. Data has a total of tlen * ntrn real points.
*
* Input parameters:
* ----------------
* tlen: number of real data in each transform, product of prime numbers.
* ntrn: number of transforms to perform (also skip in data).
* sign: transform direction: +1 ==> r-->c, -1 ==> c-->r.
*
* Notes:
* -----
* (1) Data are scaled/normalized with 1/tlen when sign is +1, so that
* the zeroth Fourier mode contains the spatial average value.
* (2) After forward (r-->c) transform, data are ordered so that within
* each transform, the zeroth mode datum comes first. The zeroth
* mode is followed by the real datum from the maximum frequency mode,
* after which the real and imaginary parts for each mode alternate.
* ------------------------------------------------------------------------- */
{
const char routine[] = "dDFTr";
char err[STR_MAX];
const int_t ntot = tlen * ntrn;
register int_t i;
int_t dum, ip, iq, ir, ipqr2, *ifax;
register double *work, *Wtab, *ptr;
if (tlen < 2 || !ntrn) return;
#if defined(_SX) /* -- Use NEC FFT routines. */
ifax = ivector (0, 63);
work = dvector (0, ntot + tlen - 1);
Wtab = work + ntot;
rftfax (tlen, ifax, Wtab);
if (ifax[0] == -99)
message (routine, "tlen needs prime factors 2, 3, 5", ERROR);
if (sign == FORWARD) {
rfft (data, work, Wtab, ifax, tlen, ntrn, 1.0 / (double) tlen);
dcopy ((tlen - 2) * ntrn, data + ntrn, 1, work, 1);
dcopy ( ntrn, data + (tlen - 1) * ntrn, 1, data + ntrn, 1);
dcopy ((tlen - 2) * ntrn, work, 1, data + 2 * ntrn, 1);
} else {
dcopy ((tlen - 2) * ntrn, data + 2 * ntrn, 1, work, 1);
dcopy ( ntrn, data + ntrn, 1, data + (tlen - 1) * ntrn, 1);
dcopy ((tlen - 2) * ntrn, work, 1, data + ntrn, 1);
rfft (data, work, Wtab, ifax, tlen, ntrn, -1.0);
}
freeIvector (ifax, 0);
freeDvector (work, 0);
#elif defined(DEBUG_FFT) /* -- Unvectorized FFTPACK routines. */
work = dvector (0, 3 * tlen - 1);
ifax = ivector (0, 14);
Wtab = work + 2 * tlen;
ptr = data;
drffti (tlen, Wtab, ifax);
switch (sign) {
case FORWARD:
for (i = 0; i < ntrn; i++, ptr++) {
dcopy (tlen, ptr, ntrn, work, 1);
drfftf (tlen, work, work + tlen, Wtab, ifax);
dcopy (tlen - 2, work + 1, 1, ptr + 2 * ntrn, ntrn);
ptr[0] = work[0];
ptr[ntrn] = work[tlen - 1];
}
dscal (ntot, 1.0 / tlen, data, 1);
break;
case INVERSE:
for (i = 0; i < ntrn; i++, ptr++) {
work[tlen - 1] = ptr[ntrn];
work[0] = ptr[0];
dcopy (tlen - 2, ptr + 2 * ntrn, ntrn, work + 1, 1);
drfftb (tlen, work, work + tlen, Wtab, ifax);
dcopy (tlen, work, 1, ptr, ntrn);
}
break;
default:
message (routine, "illegal direction flag", ERROR);
break;
}
freeDvector (work, 0);
freeIvector (ifax, 0);
#else /* -- Temperton FFT routine is default. */
dum = tlen;
prf235 (&dum, &ip, &iq, &ir, &ipqr2);
if (!dum) {
sprintf (err, "transform length (%1d) needs prime factors 2, 3, 5", tlen);
message (routine, err, ERROR);
}
if (ntrn & 1) {
sprintf (err, "number of transforms (%1d) must be even", ntrn);
message (routine, err, ERROR);
}
work = dvector (0, ntot + ipqr2 - 1);
Wtab = work + ntot;
dsetpf (Wtab, tlen, ip, iq, ir);
dmpfft (data, work, ntrn, tlen, ip, iq, ir, Wtab, sign);
if (sign == FORWARD) dscal (ntot, 1.0 / tlen, data, 1);
freeDvector (work, 0);
#endif
}
