255 lines
7.1 KiB
C
255 lines
7.1 KiB
C
/* pvalue.f -- translated by f2c (version 20031025).
|
|
You must link the resulting object file with libf2c:
|
|
on Microsoft Windows system, link with libf2c.lib;
|
|
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
|
|
or, if you install libf2c.a in a standard place, with -lf2c -lm
|
|
-- in that order, at the end of the command line, as in
|
|
cc *.o -lf2c -lm
|
|
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
|
|
|
|
http://www.netlib.org/f2c/libf2c.zip
|
|
*/
|
|
|
|
#ifdef _cpluscplus
|
|
extern "C" {
|
|
#endif
|
|
#include "f2c.h"
|
|
|
|
/* Table of constant values */
|
|
|
|
static integer c__1 = 1;
|
|
static integer c__8 = 8;
|
|
static integer c__2 = 2;
|
|
static integer c__5 = 5;
|
|
|
|
/* DECK PVALUE */
|
|
/* Subroutine */ int pvalue_(integer *l, integer *nder, real *x, real *yfit,
|
|
real *yp, real *a)
|
|
{
|
|
/* System generated locals */
|
|
address a__1[5];
|
|
integer i__1, i__2, i__3[5];
|
|
char ch__1[150];
|
|
|
|
/* Builtin functions */
|
|
integer s_wsfi(icilist *), do_fio(integer *, char *, ftnlen), e_wsfi(void)
|
|
;
|
|
/* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
|
|
|
|
/* Local variables */
|
|
static integer i__, n, k1, k2, k3, k4;
|
|
static real cc;
|
|
static integer ic, kc, in, k1i, lm1, lp1;
|
|
static real dif;
|
|
static integer k3p1, k4p1, ndo;
|
|
static real val;
|
|
static integer ilo, iup, ndp1, inp1, k3pn, k4pn, nord;
|
|
static char xern1[8], xern2[8];
|
|
static integer maxord;
|
|
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
|
|
integer *, ftnlen, ftnlen, ftnlen);
|
|
|
|
/* Fortran I/O blocks */
|
|
static icilist io___28 = { 0, xern1, 0, "(I8)", 8, 1 };
|
|
static icilist io___30 = { 0, xern2, 0, "(I8)", 8, 1 };
|
|
|
|
|
|
/* ***BEGIN PROLOGUE PVALUE */
|
|
/* ***PURPOSE Use the coefficients generated by POLFIT to evaluate the */
|
|
/* polynomial fit of degree L, along with the first NDER of */
|
|
/* its derivatives, at a specified point. */
|
|
/* ***LIBRARY SLATEC */
|
|
/* ***CATEGORY K6 */
|
|
/* ***TYPE SINGLE PRECISION (PVALUE-S, DP1VLU-D) */
|
|
/* ***KEYWORDS CURVE FITTING, LEAST SQUARES, POLYNOMIAL APPROXIMATION */
|
|
/* ***AUTHOR Shampine, L. F., (SNLA) */
|
|
/* Davenport, S. M., (SNLA) */
|
|
/* ***DESCRIPTION */
|
|
|
|
/* Written by L. F. Shampine and S. M. Davenport. */
|
|
|
|
/* Abstract */
|
|
|
|
/* The subroutine PVALUE uses the coefficients generated by POLFIT */
|
|
/* to evaluate the polynomial fit of degree L , along with the first */
|
|
/* NDER of its derivatives, at a specified point. Computationally */
|
|
/* stable recurrence relations are used to perform this task. */
|
|
|
|
/* The parameters for PVALUE are */
|
|
|
|
/* Input -- */
|
|
/* L - the degree of polynomial to be evaluated. L may be */
|
|
/* any non-negative integer which is less than or equal */
|
|
/* to NDEG , the highest degree polynomial provided */
|
|
/* by POLFIT . */
|
|
/* NDER - the number of derivatives to be evaluated. NDER */
|
|
/* may be 0 or any positive value. If NDER is less */
|
|
/* than 0, it will be treated as 0. */
|
|
/* X - the argument at which the polynomial and its */
|
|
/* derivatives are to be evaluated. */
|
|
/* A - work and output array containing values from last */
|
|
/* call to POLFIT . */
|
|
|
|
/* Output -- */
|
|
/* YFIT - value of the fitting polynomial of degree L at X */
|
|
/* YP - array containing the first through NDER derivatives */
|
|
/* of the polynomial of degree L . YP must be */
|
|
/* dimensioned at least NDER in the calling program. */
|
|
|
|
/* ***REFERENCES L. F. Shampine, S. M. Davenport and R. E. Huddleston, */
|
|
/* Curve fitting by polynomials in one variable, Report */
|
|
/* SLA-74-0270, Sandia Laboratories, June 1974. */
|
|
/* ***ROUTINES CALLED XERMSG */
|
|
/* ***REVISION HISTORY (YYMMDD) */
|
|
/* 740601 DATE WRITTEN */
|
|
/* 890531 Changed all specific intrinsics to generic. (WRB) */
|
|
/* 890531 REVISION DATE from Version 3.2 */
|
|
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
|
|
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
|
|
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
|
|
/* 920501 Reformatted the REFERENCES section. (WRB) */
|
|
/* ***END PROLOGUE PVALUE */
|
|
/* ***FIRST EXECUTABLE STATEMENT PVALUE */
|
|
/* Parameter adjustments */
|
|
--a;
|
|
--yp;
|
|
|
|
/* Function Body */
|
|
if (*l < 0) {
|
|
goto L12;
|
|
}
|
|
ndo = max(*nder,0);
|
|
ndo = min(ndo,*l);
|
|
maxord = a[1] + .5f;
|
|
k1 = maxord + 1;
|
|
k2 = k1 + maxord;
|
|
k3 = k2 + maxord + 2;
|
|
nord = a[k3] + .5f;
|
|
if (*l > nord) {
|
|
goto L11;
|
|
}
|
|
k4 = k3 + *l + 1;
|
|
if (*nder < 1) {
|
|
goto L2;
|
|
}
|
|
i__1 = *nder;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
/* L1: */
|
|
yp[i__] = 0.f;
|
|
}
|
|
L2:
|
|
if (*l >= 2) {
|
|
goto L4;
|
|
}
|
|
if (*l == 1) {
|
|
goto L3;
|
|
}
|
|
|
|
/* L IS 0 */
|
|
|
|
val = a[k2 + 1];
|
|
goto L10;
|
|
|
|
/* L IS 1 */
|
|
|
|
L3:
|
|
cc = a[k2 + 2];
|
|
val = a[k2 + 1] + (*x - a[2]) * cc;
|
|
if (*nder >= 1) {
|
|
yp[1] = cc;
|
|
}
|
|
goto L10;
|
|
|
|
/* L IS GREATER THAN 1 */
|
|
|
|
L4:
|
|
ndp1 = ndo + 1;
|
|
k3p1 = k3 + 1;
|
|
k4p1 = k4 + 1;
|
|
lp1 = *l + 1;
|
|
lm1 = *l - 1;
|
|
ilo = k3 + 3;
|
|
iup = k4 + ndp1;
|
|
i__1 = iup;
|
|
for (i__ = ilo; i__ <= i__1; ++i__) {
|
|
/* L5: */
|
|
a[i__] = 0.f;
|
|
}
|
|
dif = *x - a[lp1];
|
|
kc = k2 + lp1;
|
|
a[k4p1] = a[kc];
|
|
a[k3p1] = a[kc - 1] + dif * a[k4p1];
|
|
a[k3 + 2] = a[k4p1];
|
|
|
|
/* EVALUATE RECURRENCE RELATIONS FOR FUNCTION VALUE AND DERIVATIVES */
|
|
|
|
i__1 = lm1;
|
|
for (i__ = 1; i__ <= i__1; ++i__) {
|
|
in = *l - i__;
|
|
inp1 = in + 1;
|
|
k1i = k1 + inp1;
|
|
ic = k2 + in;
|
|
dif = *x - a[inp1];
|
|
val = a[ic] + dif * a[k3p1] - a[k1i] * a[k4p1];
|
|
if (ndo <= 0) {
|
|
goto L8;
|
|
}
|
|
i__2 = ndo;
|
|
for (n = 1; n <= i__2; ++n) {
|
|
k3pn = k3p1 + n;
|
|
k4pn = k4p1 + n;
|
|
/* L6: */
|
|
yp[n] = dif * a[k3pn] + n * a[k3pn - 1] - a[k1i] * a[k4pn];
|
|
}
|
|
|
|
/* SAVE VALUES NEEDED FOR NEXT EVALUATION OF RECURRENCE RELATIONS */
|
|
|
|
i__2 = ndo;
|
|
for (n = 1; n <= i__2; ++n) {
|
|
k3pn = k3p1 + n;
|
|
k4pn = k4p1 + n;
|
|
a[k4pn] = a[k3pn];
|
|
/* L7: */
|
|
a[k3pn] = yp[n];
|
|
}
|
|
L8:
|
|
a[k4p1] = a[k3p1];
|
|
/* L9: */
|
|
a[k3p1] = val;
|
|
}
|
|
|
|
/* NORMAL RETURN OR ABORT DUE TO ERROR */
|
|
|
|
L10:
|
|
*yfit = val;
|
|
return 0;
|
|
|
|
L11:
|
|
s_wsfi(&io___28);
|
|
do_fio(&c__1, (char *)&(*l), (ftnlen)sizeof(integer));
|
|
e_wsfi();
|
|
s_wsfi(&io___30);
|
|
do_fio(&c__1, (char *)&nord, (ftnlen)sizeof(integer));
|
|
e_wsfi();
|
|
/* Writing concatenation */
|
|
i__3[0] = 40, a__1[0] = "THE ORDER OF POLYNOMIAL EVALUATION, L = ";
|
|
i__3[1] = 8, a__1[1] = xern1;
|
|
i__3[2] = 49, a__1[2] = " REQUESTED EXCEEDS THE HIGHEST ORDER FIT, NORD "
|
|
"= ";
|
|
i__3[3] = 8, a__1[3] = xern2;
|
|
i__3[4] = 45, a__1[4] = ", COMPUTED BY POLFIT -- EXECUTION TERMINATED.";
|
|
s_cat(ch__1, a__1, i__3, &c__5, (ftnlen)150);
|
|
xermsg_("SLATEC", "PVALUE", ch__1, &c__8, &c__2, (ftnlen)6, (ftnlen)6, (
|
|
ftnlen)150);
|
|
return 0;
|
|
|
|
L12:
|
|
xermsg_("SLATEC", "PVALUE", "INVALID INPUT PARAMETER. ORDER OF POLYNOMI"
|
|
"AL EVALUATION REQUESTED IS NEGATIVE -- EXECUTION TERMINATED.", &
|
|
c__2, &c__2, (ftnlen)6, (ftnlen)6, (ftnlen)103);
|
|
return 0;
|
|
} /* pvalue_ */
|
|
|
|
#ifdef _cpluscplus
|
|
}
|
|
#endif
|