/* DECK DLI */
doublereal dli_(doublereal *x)
{
/* System generated locals */
doublereal ret_val, d__1;
/* Local variables */
extern doublereal dei_(doublereal *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DLI */
/* ***PURPOSE Compute the logarithmic integral. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C5 */
/* ***TYPE DOUBLE PRECISION (ALI-S, DLI-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC INTEGRAL, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DLI(X) calculates the double precision logarithmic integral */
/* for double precision argument X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED DEI, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 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) */
/* ***END PROLOGUE DLI */
/* ***FIRST EXECUTABLE STATEMENT DLI */
if (*x <= 0.) {
xermsg_("SLATEC", "DLI", "LOG INTEGRAL UNDEFINED FOR X LE 0", &c__1, &
c__2, (ftnlen)6, (ftnlen)3, (ftnlen)33);
}
if (*x == 1.) {
xermsg_("SLATEC", "DLI", "LOG INTEGRAL UNDEFINED FOR X = 0", &c__2, &
c__2, (ftnlen)6, (ftnlen)3, (ftnlen)32);
}
d__1 = log(*x);
ret_val = dei_(&d__1);
return ret_val;
} /* dli_ */
/* DECK XLEGF */
/* Subroutine */ int xlegf_(real *dnu1, integer *nudiff, integer *mu1,
integer *mu2, real *theta, integer *id, real *pqa, integer *ipqa,
integer *ierror)
{
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__, l;
static real x, sx, pi2, dnu2;
extern /* Subroutine */ int xred_(real *, integer *, integer *), xset_(
integer *, integer *, real *, integer *, integer *), xpmu_(real *,
real *, integer *, integer *, real *, real *, real *, integer *,
real *, integer *, integer *), xqmu_(real *, real *, integer *,
integer *, real *, real *, real *, integer *, real *, integer *,
integer *), xqnu_(real *, real *, integer *, real *, real *, real
*, integer *, real *, integer *, integer *), xpnrm_(real *, real *
, integer *, integer *, real *, integer *, integer *), xpmup_(
real *, real *, integer *, integer *, real *, integer *, integer *
), xpqnu_(real *, real *, integer *, real *, integer *, real *,
integer *, integer *), xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE XLEGF */
/* ***PURPOSE Compute normalized Legendre polynomials and associated */
/* Legendre functions. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C3A2, C9 */
/* ***TYPE SINGLE PRECISION (XLEGF-S, DXLEGF-D) */
/* ***KEYWORDS LEGENDRE FUNCTIONS */
/* ***AUTHOR Smith, John M., (NBS and George Mason University) */
/* ***DESCRIPTION */
/* XLEGF: Extended-range Single-precision Legendre Functions */
/* A feature of the XLEGF subroutine for Legendre functions is */
/* the use of extended-range arithmetic, a software extension of */
/* ordinary floating-point arithmetic that greatly increases the */
/* exponent range of the representable numbers. This avoids the */
/* need for scaling the solutions to lie within the exponent range */
/* of the most restrictive manufacturer's hardware. The increased */
/* exponent range is achieved by allocating an integer storage */
/* location together with each floating-point storage location. */
/* The interpretation of the pair (X,I) where X is floating-point */
/* and I is integer is X*(IR**I) where IR is the internal radix of */
/* the computer arithmetic. */
/* This subroutine computes one of the following vectors: */
/* 1. Legendre function of the first kind of negative order, either */
/* a. P(-MU1,NU,X), P(-MU1-1,NU,X), ..., P(-MU2,NU,X) or */
/* b. P(-MU,NU1,X), P(-MU,NU1+1,X), ..., P(-MU,NU2,X) */
/* 2. Legendre function of the second kind, either */
/* a. Q(MU1,NU,X), Q(MU1+1,NU,X), ..., Q(MU2,NU,X) or */
/* b. Q(MU,NU1,X), Q(MU,NU1+1,X), ..., Q(MU,NU2,X) */
/* 3. Legendre function of the first kind of positive order, either */
/* a. P(MU1,NU,X), P(MU1+1,NU,X), ..., P(MU2,NU,X) or */
/* b. P(MU,NU1,X), P(MU,NU1+1,X), ..., P(MU,NU2,X) */
/* 4. Normalized Legendre polynomials, either */
/* a. PN(MU1,NU,X), PN(MU1+1,NU,X), ..., PN(MU2,NU,X) or */
/* b. PN(MU,NU1,X), PN(MU,NU1+1,X), ..., PN(MU,NU2,X) */
/* where X = COS(THETA). */
/* The input values to XLEGF are DNU1, NUDIFF, MU1, MU2, THETA, */
/* and ID. These must satisfy */
/* DNU1 is REAL and greater than or equal to -0.5; */
/* NUDIFF is INTEGER and non-negative; */
/* MU1 is INTEGER and non-negative; */
/* MU2 is INTEGER and greater than or equal to MU1; */
/* THETA is REAL and in the half-open interval (0,PI/2]; */
/* ID is INTEGER and equal to 1, 2, 3 or 4; */
/* and additionally either NUDIFF = 0 or MU2 = MU1. */
/* If ID=1 and NUDIFF=0, a vector of type 1a above is computed */
/* with NU=DNU1. */
/* If ID=1 and MU1=MU2, a vector of type 1b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* If ID=2 and NUDIFF=0, a vector of type 2a above is computed */
/* with NU=DNU1. */
/* If ID=2 and MU1=MU2, a vector of type 2b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* If ID=3 and NUDIFF=0, a vector of type 3a above is computed */
/* with NU=DNU1. */
/* If ID=3 and MU1=MU2, a vector of type 3b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* If ID=4 and NUDIFF=0, a vector of type 4a above is computed */
/* with NU=DNU1. */
/* If ID=4 and MU1=MU2, a vector of type 4b above is computed */
/* with NU1=DNU1, NU2=DNU1+NUDIFF and MU=MU1. */
/* In each case the vector of computed Legendre function values */
/* is returned in the extended-range vector (PQA(I),IPQA(I)). The */
/* length of this vector is either MU2-MU1+1 or NUDIFF+1. */
/* Where possible, XLEGF returns IPQA(I) as zero. In this case the */
/* value of the Legendre function is contained entirely in PQA(I), */
/* so it can be used in subsequent computations without further */
/* consideration of extended-range arithmetic. If IPQA(I) is nonzero, */
/* then the value of the Legendre function is not representable in */
/* floating-point because of underflow or overflow. The program that */
/* calls XLEGF must test IPQA(I) to ensure correct usage. */
/* IERROR is an error indicator. If no errors are detected, IERROR=0 */
/* when control returns to the calling routine. If an error is detected, */
/* IERROR is returned as nonzero. The calling routine must check the */
/* value of IERROR. */
/* If IERROR=110 or 111, invalid input was provided to XLEGF. */
/* If IERROR=101,102,103, or 104, invalid input was provided to XSET. */
/* If IERROR=105 or 106, an internal consistency error occurred in */
/* XSET (probably due to a software malfunction in the library routine */
/* I1MACH). */
/* If IERROR=107, an overflow or underflow of an extended-range number */
/* was detected in XADJ. */
/* If IERROR=108, an overflow or underflow of an extended-range number */
/* was detected in XC210. */
/* ***SEE ALSO XSET */
/* ***REFERENCES Olver and Smith, Associated Legendre Functions on the */
/* Cut, J Comp Phys, v 51, n 3, Sept 1983, pp 502--518. */
/* Smith, Olver and Lozier, Extended-Range Arithmetic and */
/* Normalized Legendre Polynomials, ACM Trans on Math */
/* Softw, v 7, n 1, March 1981, pp 93--105. */
/* ***ROUTINES CALLED XERMSG, XPMU, XPMUP, XPNRM, XPQNU, XQMU, XQNU, */
/* XRED, XSET */
/* ***REVISION HISTORY (YYMMDD) */
/* 820728 DATE WRITTEN */
/* 890126 Revised to meet SLATEC CML recommendations. (DWL and JMS) */
/* 901019 Revisions to prologue. (DWL and WRB) */
/* 901106 Changed all specific intrinsics to generic. (WRB) */
/* Corrected order of sections in prologue and added TYPE */
/* section. (WRB) */
/* CALLs to XERROR changed to CALLs to XERMSG. (WRB) */
/* 920127 Revised PURPOSE section of prologue. (DWL) */
/* ***END PROLOGUE XLEGF */
/* ***FIRST EXECUTABLE STATEMENT XLEGF */
/* Parameter adjustments */
--ipqa;
--pqa;
/* Function Body */
*ierror = 0;
xset_(&c__0, &c__0, &c_b4, &c__0, ierror);
if (*ierror != 0) {
return 0;
}
pi2 = atan(1.f) * 2.f;
/* ZERO OUTPUT ARRAYS */
l = *mu2 - *mu1 + *nudiff + 1;
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
pqa[i__] = 0.f;
/* L290: */
ipqa[i__] = 0;
}
/* CHECK FOR VALID INPUT VALUES */
if (*nudiff < 0) {
goto L400;
}
if (*dnu1 < -.5f) {
goto L400;
}
if (*mu2 < *mu1) {
goto L400;
}
if (*mu1 < 0) {
goto L400;
}
if (*theta <= 0.f || *theta > pi2) {
goto L420;
}
if (*id < 1 || *id > 4) {
goto L400;
}
if (*mu1 != *mu2 && *nudiff > 0) {
goto L400;
}
/* IF DNU1 IS NOT AN INTEGER, NORMALIZED P(MU,DNU,X) */
/* CANNOT BE CALCULATED. IF DNU1 IS AN INTEGER AND */
/* MU1.GT.DNU2 THEN ALL VALUES OF P(+MU,DNU,X) AND */
/* NORMALIZED P(MU,NU,X) WILL BE ZERO. */
dnu2 = *dnu1 + *nudiff;
if (*id == 3 && r_mod(dnu1, &c_b9) != 0.f) {
goto L295;
}
if (*id == 4 && r_mod(dnu1, &c_b9) != 0.f) {
goto L400;
}
if ((*id == 3 || *id == 4) && (real) (*mu1) > dnu2) {
return 0;
}
L295:
x = cos(*theta);
sx = 1.f / sin(*theta);
if (*id == 2) {
goto L300;
}
if (*mu2 - *mu1 <= 0) {
goto L360;
}
/* FIXED NU, VARIABLE MU */
/* CALL XPMU TO CALCULATE P(-MU1,NU,X),....,P(-MU2,NU,X) */
xpmu_(dnu1, &dnu2, mu1, mu2, theta, &x, &sx, id, &pqa[1], &ipqa[1],
ierror);
if (*ierror != 0) {
return 0;
}
goto L380;
L300:
if (*mu2 == *mu1) {
goto L320;
}
/* FIXED NU, VARIABLE MU */
/* CALL XQMU TO CALCULATE Q(MU1,NU,X),....,Q(MU2,NU,X) */
xqmu_(dnu1, &dnu2, mu1, mu2, theta, &x, &sx, id, &pqa[1], &ipqa[1],
ierror);
if (*ierror != 0) {
return 0;
}
goto L390;
/* FIXED MU, VARIABLE NU */
/* CALL XQNU TO CALCULATE Q(MU,DNU1,X),....,Q(MU,DNU2,X) */
L320:
xqnu_(dnu1, &dnu2, mu1, theta, &x, &sx, id, &pqa[1], &ipqa[1], ierror);
if (*ierror != 0) {
return 0;
}
goto L390;
/* FIXED MU, VARIABLE NU */
/* CALL XPQNU TO CALCULATE P(-MU,DNU1,X),....,P(-MU,DNU2,X) */
L360:
xpqnu_(dnu1, &dnu2, mu1, theta, id, &pqa[1], &ipqa[1], ierror);
if (*ierror != 0) {
return 0;
}
/* IF ID = 3, TRANSFORM P(-MU,NU,X) VECTOR INTO */
/* P(MU,NU,X) VECTOR. */
L380:
if (*id == 3) {
xpmup_(dnu1, &dnu2, mu1, mu2, &pqa[1], &ipqa[1], ierror);
}
if (*ierror != 0) {
return 0;
}
/* IF ID = 4, TRANSFORM P(-MU,NU,X) VECTOR INTO */
/* NORMALIZED P(MU,NU,X) VECTOR. */
if (*id == 4) {
xpnrm_(dnu1, &dnu2, mu1, mu2, &pqa[1], &ipqa[1], ierror);
}
if (*ierror != 0) {
return 0;
}
/* PLACE RESULTS IN REDUCED FORM IF POSSIBLE */
/* AND RETURN TO MAIN PROGRAM. */
L390:
i__1 = l;
for (i__ = 1; i__ <= i__1; ++i__) {
xred_(&pqa[i__], &ipqa[i__], ierror);
if (*ierror != 0) {
return 0;
}
/* L395: */
}
return 0;
/* ***** ERROR TERMINATION ***** */
L400:
xermsg_("SLATEC", "XLEGF", "DNU1, NUDIFF, MU1, MU2, or ID not valid", &
c__110, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)39);
*ierror = 110;
return 0;
L420:
xermsg_("SLATEC", "XLEGF", "THETA out of range", &c__111, &c__1, (ftnlen)
6, (ftnlen)5, (ftnlen)18);
*ierror = 111;
return 0;
} /* xlegf_ */
/* DECK DBETAI */
doublereal dbetai_(doublereal *x, doublereal *pin, doublereal *qin)
{
/* Initialized data */
// static logical first = TRUE_;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1;
/* Builtin functions */
double log(doublereal), d_int(doublereal *), exp(doublereal);
/* Local variables */
doublereal c__;
integer i__, n;
doublereal p, q, y, p1;
integer ib;
doublereal xb, xi, ps;
/* static */ doublereal eps, sml;
doublereal term;
extern doublereal d1mach_(integer *), dlbeta_(doublereal *, doublereal *);
/* static */ doublereal alneps, alnsml;
doublereal finsum;
extern /* Subroutine */ int xermsg_(const char *, const char *, const char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DBETAI */
/* ***PURPOSE Calculate the incomplete Beta function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7F */
/* ***TYPE DOUBLE PRECISION (BETAI-S, DBETAI-D) */
/* ***KEYWORDS FNLIB, INCOMPLETE BETA FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DBETAI calculates the DOUBLE PRECISION incomplete beta function. */
/* The incomplete beta function ratio is the probability that a */
/* random variable from a beta distribution having parameters PIN and */
/* QIN will be less than or equal to X. */
/* -- Input Arguments -- All arguments are DOUBLE PRECISION. */
/* X upper limit of integration. X must be in (0,1) inclusive. */
/* PIN first beta distribution parameter. PIN must be .GT. 0.0. */
/* QIN second beta distribution parameter. QIN must be .GT. 0.0. */
/* ***REFERENCES Nancy E. Bosten and E. L. Battiste, Remark on Algorithm */
/* 179, Communications of the ACM 17, 3 (March 1974), */
/* pp. 156. */
/* ***ROUTINES CALLED D1MACH, DLBETA, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 890911 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) */
/* 920528 DESCRIPTION and REFERENCES sections revised. (WRB) */
/* ***END PROLOGUE DBETAI */
/* ***FIRST EXECUTABLE STATEMENT DBETAI */
// d1mach has been made thread safe, so there is no need for the
// statics in determining these values
// if (first) {
// eps = d1mach_(&c__3);
// alneps = log(eps);
// sml = d1mach_(&c__1);
// alnsml = log(sml);
// }
// first = FALSE_;
eps = d1mach_(&c__3);
alneps = log(eps);
sml = d1mach_(&c__1);
alnsml = log(sml);
if (*x < 0. || *x > 1.) {
xermsg_("SLATEC", "DBETAI", "X IS NOT IN THE RANGE (0,1)", &c__1, &
c__2, (ftnlen)6, (ftnlen)6, (ftnlen)27);
}
if (*pin <= 0. || *qin <= 0.) {
xermsg_("SLATEC", "DBETAI", "P AND/OR Q IS LE ZERO", &c__2, &c__2, (
ftnlen)6, (ftnlen)6, (ftnlen)21);
}
y = *x;
p = *pin;
q = *qin;
if (q <= p && *x < .8) {
goto L20;
}
if (*x < .2) {
goto L20;
}
y = 1. - y;
p = *qin;
q = *pin;
L20:
if ((p + q) * y / (p + 1.) < eps) {
goto L80;
}
/* EVALUATE THE INFINITE SUM FIRST. TERM WILL EQUAL */
/* Y**P/BETA(PS,P) * (1.-PS)-SUB-I * Y**I / FAC(I) . */
ps = q - d_int(&q);
if (ps == 0.) {
ps = 1.;
}
xb = p * log(y) - dlbeta_(&ps, &p) - log(p);
ret_val = 0.;
if (xb < alnsml) {
goto L40;
}
ret_val = exp(xb);
term = ret_val * p;
if (ps == 1.) {
goto L40;
}
/* Computing MAX */
d__1 = alneps / log(y);
n = (integer) max(d__1,4.);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (doublereal) i__;
term = term * (xi - ps) * y / xi;
ret_val += term / (p + xi);
/* L30: */
}
/* NOW EVALUATE THE FINITE SUM, MAYBE. */
L40:
if (q <= 1.) {
goto L70;
}
xb = p * log(y) + q * log(1. - y) - dlbeta_(&p, &q) - log(q);
/* Computing MAX */
d__1 = xb / alnsml;
ib = (integer) max(d__1,0.);
term = exp(xb - ib * alnsml);
c__ = 1. / (1. - y);
p1 = q * c__ / (p + q - 1.);
finsum = 0.;
n = (integer) q;
if (q == (doublereal) n) {
--n;
}
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (p1 <= 1. && term / eps <= finsum) {
goto L60;
}
xi = (doublereal) i__;
term = (q - xi + 1.) * c__ * term / (p + q - xi);
if (term > 1.) {
--ib;
}
if (term > 1.) {
term *= sml;
}
if (ib == 0) {
finsum += term;
}
/* L50: */
}
L60:
ret_val += finsum;
L70:
if (y != *x || p != *pin) {
ret_val = 1. - ret_val;
}
/* Computing MAX */
d__1 = min(ret_val,1.);
ret_val = max(d__1,0.);
return ret_val;
L80:
ret_val = 0.;
xb = p * log((max(y,sml))) - log(p) - dlbeta_(&p, &q);
if (xb > alnsml && y != 0.) {
ret_val = exp(xb);
}
if (y != *x || p != *pin) {
ret_val = 1. - ret_val;
}
return ret_val;
} /* dbetai_ */
/* DECK XSETF */
/* Subroutine */ int xsetf_(integer *kontrl)
{
/* System generated locals */
address a__1[2];
integer i__1[2];
char ch__1[27];
/* 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 junk;
static char xern1[8];
extern integer j4save_(integer *, integer *, logical *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE XSETF */
/* ***PURPOSE Set the error control flag. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3A */
/* ***TYPE ALL (XSETF-A) */
/* ***KEYWORDS ERROR, XERROR */
/* ***AUTHOR Jones, R. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* XSETF sets the error control flag value to KONTRL. */
/* (KONTRL is an input parameter only.) */
/* The following table shows how each message is treated, */
/* depending on the values of KONTRL and LEVEL. (See XERMSG */
/* for description of LEVEL.) */
/* If KONTRL is zero or negative, no information other than the */
/* message itself (including numeric values, if any) will be */
/* printed. If KONTRL is positive, introductory messages, */
/* trace-backs, etc., will be printed in addition to the message. */
/* ABS(KONTRL) */
/* LEVEL 0 1 2 */
/* value */
/* 2 fatal fatal fatal */
/* 1 not printed printed fatal */
/* 0 not printed printed printed */
/* -1 not printed printed printed */
/* only only */
/* once once */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED J4SAVE, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 790801 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) */
/* 900510 Change call to XERRWV to XERMSG. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XSETF */
/* ***FIRST EXECUTABLE STATEMENT XSETF */
if (abs(*kontrl) > 2) {
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*kontrl), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 19, a__1[0] = "INVALID ARGUMENT = ";
i__1[1] = 8, a__1[1] = xern1;
s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)27);
xermsg_("SLATEC", "XSETF", ch__1, &c__1, &c__2, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
junk = j4save_(&c__2, kontrl, &c_true);
return 0;
} /* xsetf_ */
/* DECK DPFQAD */
/* Subroutine */ int dpfqad_(D_fp f, integer *ldc, doublereal *c__,
doublereal *xi, integer *lxi, integer *k, integer *id, doublereal *x1,
doublereal *x2, doublereal *tol, doublereal *quad, integer *ierr)
{
/* System generated locals */
integer c_dim1, c_offset, i__1;
/* Local variables */
static doublereal a, b, q, aa, bb, ta, tb;
static integer mf1, mf2, il1, il2;
static doublereal ans;
static integer ilo, iflg, left;
static doublereal wtol;
static integer inppv;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int dppgq8_(D_fp, integer *, doublereal *,
doublereal *, integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *),
xermsg_(char *, char *, char *, integer *, integer *, ftnlen,
ftnlen, ftnlen), dintrv_(doublereal *, integer *, doublereal *,
integer *, integer *, integer *);
/* ***BEGIN PROLOGUE DPFQAD */
/* ***PURPOSE Compute the integral on (X1,X2) of a product of a */
/* function F and the ID-th derivative of a B-spline, */
/* (PP-representation). */
/* ***LIBRARY SLATEC */
/* ***CATEGORY H2A2A1, E3, K6 */
/* ***TYPE DOUBLE PRECISION (PFQAD-S, DPFQAD-D) */
/* ***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION, QUADRATURE, SPLINES */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract **** a double precision routine **** */
/* DPFQAD computes the integral on (X1,X2) of a product of a */
/* function F and the ID-th derivative of a B-spline, using the */
/* PP-representation (C,XI,LXI,K). (X1,X2) is normally a sub- */
/* interval of XI(1) .LE. X .LE. XI(LXI+1). An integration */
/* routine, DPPGQ8 (a modification of GAUS8), integrates the */
/* product on subintervals of (X1,X2) formed by the included */
/* break points. Integration outside of (XI(1),XI(LXI+1)) is */
/* permitted provided F is defined. */
/* The maximum number of significant digits obtainable in */
/* DBSQAD is the smaller of 18 and the number of digits */
/* carried in double precision arithmetic. */
/* Description of arguments */
/* Input F,C,XI,X1,X2,TOL are double precision */
/* F - external function of one argument for the */
/* integrand PF(X)=F(X)*DPPVAL(LDC,C,XI,LXI,K,ID,X, */
/* INPPV) */
/* LDC - leading dimension of matrix C, LDC .GE. K */
/* C(I,J) - right Taylor derivatives at XI(J), I=1,K , J=1,LXI */
/* XI(*) - break point array of length LXI+1 */
/* LXI - number of polynomial pieces */
/* K - order of B-spline, K .GE. 1 */
/* ID - order of the spline derivative, 0 .LE. ID .LE. K-1 */
/* ID=0 gives the spline function */
/* X1,X2 - end points of quadrature interval, normally in */
/* XI(1) .LE. X .LE. XI(LXI+1) */
/* TOL - desired accuracy for the quadrature, suggest */
/* 10.*DTOL .LT. TOL .LE. 0.1 where DTOL is the */
/* maximum of 1.0D-18 and double precision unit */
/* roundoff for the machine = D1MACH(4) */
/* Output QUAD is double precision */
/* QUAD - integral of PF(X) on (X1,X2) */
/* IERR - a status code */
/* IERR=1 normal return */
/* 2 some quadrature does not meet the */
/* requested tolerance */
/* Error Conditions */
/* Improper input is a fatal error. */
/* Some quadrature does not meet the requested tolerance. */
/* ***REFERENCES D. E. Amos, Quadrature subroutines for splines and */
/* B-splines, Report SAND79-1825, Sandia Laboratories, */
/* December 1979. */
/* ***ROUTINES CALLED D1MACH, DINTRV, DPPGQ8, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800901 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DPFQAD */
/* ***FIRST EXECUTABLE STATEMENT DPFQAD */
/* Parameter adjustments */
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
--xi;
/* Function Body */
*ierr = 1;
*quad = 0.;
if (*k < 1) {
goto L100;
}
if (*ldc < *k) {
goto L105;
}
if (*id < 0 || *id >= *k) {
goto L110;
}
if (*lxi < 1) {
goto L115;
}
wtol = d1mach_(&c__4);
wtol = max(wtol,1e-18);
if (*tol < wtol || *tol > .1) {
goto L20;
}
aa = min(*x1,*x2);
bb = max(*x1,*x2);
if (aa == bb) {
return 0;
}
ilo = 1;
dintrv_(&xi[1], lxi, &aa, &ilo, &il1, &mf1);
dintrv_(&xi[1], lxi, &bb, &ilo, &il2, &mf2);
q = 0.;
inppv = 1;
i__1 = il2;
for (left = il1; left <= i__1; ++left) {
ta = xi[left];
a = max(aa,ta);
if (left == 1) {
a = aa;
}
tb = bb;
if (left < *lxi) {
tb = xi[left + 1];
}
b = min(bb,tb);
dppgq8_((D_fp)f, ldc, &c__[c_offset], &xi[1], lxi, k, id, &a, &b, &
inppv, tol, &ans, &iflg);
if (iflg > 1) {
*ierr = 2;
}
q += ans;
/* L10: */
}
if (*x1 > *x2) {
q = -q;
}
*quad = q;
return 0;
L20:
xermsg_("SLATEC", "DPFQAD", "TOL IS LESS DTOL OR GREATER THAN 0.1", &c__2,
&c__1, (ftnlen)6, (ftnlen)6, (ftnlen)36);
return 0;
L100:
xermsg_("SLATEC", "DPFQAD", "K DOES NOT SATISFY K.GE.1", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)25);
return 0;
L105:
xermsg_("SLATEC", "DPFQAD", "LDC DOES NOT SATISFY LDC.GE.K", &c__2, &c__1,
(ftnlen)6, (ftnlen)6, (ftnlen)29);
return 0;
L110:
xermsg_("SLATEC", "DPFQAD", "ID DOES NOT SATISFY 0.LE.ID.LT.K", &c__2, &
c__1, (ftnlen)6, (ftnlen)6, (ftnlen)32);
return 0;
L115:
xermsg_("SLATEC", "DPFQAD", "LXI DOES NOT SATISFY LXI.GE.1", &c__2, &c__1,
(ftnlen)6, (ftnlen)6, (ftnlen)29);
return 0;
} /* dpfqad_ */
/* DECK BESJ */
/* Subroutine */ int besj_(real *x, real *alpha, integer *n, real *y, integer
*nz)
{
/* Initialized data */
static real rtwo = 1.34839972492648f;
static real pdf = .785398163397448f;
static real rttp = .797884560802865f;
static real pidt = 1.5707963267949f;
static real pp[4] = { 8.72909153935547f,.26569393226503f,
.124578576865586f,7.70133747430388e-4f };
static integer inlim = 150;
static real fnulim[2] = { 100.f,60.f };
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer i__, k;
static real s, t;
static integer i1, i2;
static real s1, s2, t1, t2, ak, ap, fn, sa;
static integer kk, in, km;
static real sb, ta, tb;
static integer is, nn, kt, ns;
static real tm, wk[7], tx, xo2, dfn, akm, arg, fnf, fni, gln, ans, dtm,
tfn, fnu, tau, tol, etx, rtx, trx, fnp1, xo2l, sxo2, coef, earg,
relb;
static integer ialp;
static real rden;
static integer iflw;
static real slim, temp[3], rtol, elim1, fidal;
static integer idalp;
static real flgjy;
extern /* Subroutine */ int jairy_();
static real rzden, tolln;
extern /* Subroutine */ int asyjy_(U_fp, real *, real *, real *, integer *
, real *, real *, integer *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
static real dalpha;
extern doublereal alngam_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESJ */
/* ***PURPOSE Compute an N member sequence of J Bessel functions */
/* J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA */
/* and X. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10A3 */
/* ***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) */
/* ***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* Daniel, S. L., (SNLA) */
/* Weston, M. K., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESJ computes an N member sequence of J Bessel functions */
/* J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. */
/* A combination of the power series, the asymptotic expansion */
/* for X to infinity and the uniform asymptotic expansion for */
/* NU to infinity are applied over subdivisions of the (NU,X) */
/* plane. For values of (NU,X) not covered by one of these */
/* formulae, the order is incremented or decremented by integer */
/* values into a region where one of the formulae apply. Backward */
/* recursion is applied to reduce orders by integer values except */
/* where the entire sequence lies in the oscillatory region. In */
/* this case forward recursion is stable and values from the */
/* asymptotic expansion for X to infinity start the recursion */
/* when it is efficient to do so. Leading terms of the series */
/* and uniform expansion are tested for underflow. If a sequence */
/* is requested and the last member would underflow, the result */
/* is set to zero and the next lower order tried, etc., until a */
/* member comes on scale or all members are set to zero. */
/* Overflow cannot occur. */
/* Description of Arguments */
/* Input */
/* X - X .GE. 0.0E0 */
/* ALPHA - order of first member of the sequence, */
/* ALPHA .GE. 0.0E0 */
/* N - number of members in the sequence, N .GE. 1 */
/* Output */
/* Y - a vector whose first N components contain */
/* values for J/sub(ALPHA+K-1)/(X), K=1,...,N */
/* NZ - number of components of Y set to zero due to */
/* underflow, */
/* NZ=0 , normal return, computation completed */
/* NZ .NE. 0, last NZ components of Y set to zero, */
/* Y(K)=0.0E0, K=N-NZ+1,...,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Underflow - a non-fatal error (NZ .NE. 0) */
/* ***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 */
/* subroutines IBESS and JBESS for Bessel functions */
/* I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM */
/* Transactions on Mathematical Software 3, (1977), */
/* pp. 76-92. */
/* F. W. J. Olver, Tables of Bessel Functions of Moderate */
/* or Large Orders, NPL Mathematical Tables 6, Her */
/* Majesty's Stationery Office, London, 1962. */
/* ***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESJ */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESJ */
*nz = 0;
kt = 1;
ns = 0;
/* I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE */
/* I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE */
ta = r1mach_(&c__3);
tol = dmax(ta,1e-15f);
i1 = i1mach_(&c__11) + 1;
i2 = i1mach_(&c__12);
tb = r1mach_(&c__5);
elim1 = (i2 * tb + 3.f) * -2.303f;
rtol = 1.f / tol;
slim = r1mach_(&c__1) * 1e3f * rtol;
/* TOLLN = -LN(TOL) */
tolln = tb * 2.303f * i1;
tolln = dmin(tolln,34.5388f);
if ((i__1 = *n - 1) < 0) {
goto L720;
} else if (i__1 == 0) {
goto L10;
} else {
goto L20;
}
L10:
kt = 2;
L20:
nn = *n;
if (*x < 0.f) {
goto L730;
} else if (*x == 0) {
goto L30;
} else {
goto L80;
}
L30:
if (*alpha < 0.f) {
goto L710;
} else if (*alpha == 0) {
goto L40;
} else {
goto L50;
}
L40:
y[1] = 1.f;
if (*n == 1) {
return 0;
}
i1 = 2;
goto L60;
L50:
i1 = 1;
L60:
i__1 = *n;
for (i__ = i1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L70: */
}
return 0;
L80:
if (*alpha < 0.f) {
goto L710;
}
ialp = (integer) (*alpha);
fni = (real) (ialp + *n - 1);
fnf = *alpha - ialp;
dfn = fni + fnf;
fnu = dfn;
xo2 = *x * .5f;
sxo2 = xo2 * xo2;
/* DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X */
/* TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE */
/* APPLIED. */
if (sxo2 <= fnu + 1.f) {
goto L90;
}
ta = dmax(20.f,fnu);
if (*x > ta) {
goto L120;
}
if (*x > 12.f) {
goto L110;
}
xo2l = log(xo2);
ns = (integer) (sxo2 - fnu) + 1;
goto L100;
L90:
fn = fnu;
fnp1 = fn + 1.f;
xo2l = log(xo2);
is = kt;
if (*x <= .5f) {
goto L330;
}
ns = 0;
L100:
fni += ns;
dfn = fni + fnf;
fn = dfn;
fnp1 = fn + 1.f;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L330;
L110:
/* Computing MAX */
r__1 = 36.f - fnu;
ans = dmax(r__1,0.f);
ns = (integer) ans;
fni += ns;
dfn = fni + fnf;
fn = dfn;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L130;
L120:
rtx = sqrt(*x);
tau = rtwo * rtx;
ta = tau + fnulim[kt - 1];
if (fnu <= ta) {
goto L480;
}
fn = fnu;
is = kt;
/* UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY */
L130:
i1 = (i__1 = 3 - is, abs(i__1));
i1 = max(i1,1);
flgjy = 1.f;
asyjy_((U_fp)jairy_, x, &fn, &flgjy, &i1, &temp[is - 1], wk, &iflw);
if (iflw != 0) {
goto L380;
}
switch (is) {
case 1: goto L320;
case 2: goto L450;
case 3: goto L620;
}
L310:
temp[0] = temp[2];
kt = 1;
L320:
is = 2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if (i1 == 2) {
goto L450;
}
goto L130;
/* SERIES FOR (X/2)**2.LE.NU+1 */
L330:
gln = alngam_(&fnp1);
arg = fn * xo2l - gln;
if (arg < -elim1) {
goto L400;
}
earg = exp(arg);
L340:
s = 1.f;
if (*x < tol) {
goto L360;
}
ak = 3.f;
t2 = 1.f;
t = 1.f;
s1 = fn;
for (k = 1; k <= 17; ++k) {
s2 = t2 + s1;
t = -t * sxo2 / s2;
s += t;
if (dabs(t) < tol) {
goto L360;
}
t2 += ak;
ak += 2.f;
s1 += fn;
/* L350: */
}
L360:
temp[is - 1] = s * earg;
switch (is) {
case 1: goto L370;
case 2: goto L450;
case 3: goto L610;
}
L370:
earg = earg * fn / xo2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
is = 2;
goto L340;
/* SET UNDERFLOW VALUE AND UPDATE PARAMETERS */
/* UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE */
/* LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. */
L380:
y[nn] = 0.f;
--nn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L390;
} else {
goto L130;
}
L390:
kt = 2;
is = 2;
goto L130;
L400:
y[nn] = 0.f;
--nn;
fnp1 = fn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L410;
} else {
goto L420;
}
L410:
kt = 2;
is = 2;
L420:
if (sxo2 <= fnp1) {
goto L430;
}
goto L130;
L430:
arg = arg - xo2l + log(fnp1);
if (arg < -elim1) {
goto L400;
}
goto L330;
L440:
*nz = *n - nn;
return 0;
/* BACKWARD RECURSION SECTION */
L450:
if (ns != 0) {
goto L451;
}
*nz = *n - nn;
if (kt == 2) {
goto L470;
}
/* BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA */
y[nn] = temp[0];
y[nn - 1] = temp[1];
if (nn == 2) {
return 0;
}
L451:
trx = 2.f / *x;
dtm = fni;
tm = (dtm + fnf) * trx;
ak = 1.f;
ta = temp[0];
tb = temp[1];
if (dabs(ta) > slim) {
goto L455;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L455:
kk = 2;
in = ns - 1;
if (in == 0) {
goto L690;
}
if (ns != 0) {
goto L670;
}
k = nn - 2;
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
--k;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L460: */
}
return 0;
L470:
y[1] = temp[1];
return 0;
/* ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN */
/* OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER */
/* OF THE SEQUENCE IS ALSO IN THE REGION. */
L480:
in = (integer) (*alpha - tau + 2.f);
if (in <= 0) {
goto L490;
}
idalp = ialp - in - 1;
kt = 1;
goto L500;
L490:
idalp = ialp;
in = 0;
L500:
is = kt;
fidal = (real) idalp;
dalpha = fidal + fnf;
arg = *x - pidt * dalpha - pdf;
sa = sin(arg);
sb = cos(arg);
coef = rttp / rtx;
etx = *x * 8.f;
L510:
dtm = fidal + fidal;
dtm *= dtm;
tm = 0.f;
if (fidal == 0.f && dabs(fnf) < tol) {
goto L520;
}
tm = fnf * 4.f * (fidal + fidal + fnf);
L520:
trx = dtm - 1.f;
t2 = (trx + tm) / etx;
s2 = t2;
relb = tol * dabs(t2);
t1 = etx;
s1 = 1.f;
fn = 1.f;
ak = 8.f;
for (k = 1; k <= 13; ++k) {
t1 += etx;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = -t2 * ap / t1;
s1 += t2;
t1 += etx;
ak += 8.f;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = t2 * ap / t1;
s2 += t2;
if (dabs(t2) <= relb) {
goto L540;
}
ak += 8.f;
/* L530: */
}
L540:
temp[is - 1] = coef * (s1 * sb - s2 * sa);
if (is == 2) {
goto L560;
}
fidal += 1.f;
dalpha = fidal + fnf;
is = 2;
tb = sa;
sa = -sb;
sb = tb;
goto L510;
/* FORWARD RECURSION SECTION */
L560:
if (kt == 2) {
goto L470;
}
s1 = temp[0];
s2 = temp[1];
tx = 2.f / *x;
tm = dalpha * tx;
if (in == 0) {
goto L580;
}
/* FORWARD RECUR TO INDEX ALPHA */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
/* L570: */
}
if (nn == 1) {
goto L600;
}
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
L580:
/* FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 */
y[1] = s1;
y[2] = s2;
if (nn == 2) {
return 0;
}
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = tm * y[i__ - 1] - y[i__ - 2];
tm += tx;
/* L590: */
}
return 0;
L600:
y[1] = s2;
return 0;
/* BACKWARD RECURSION WITH NORMALIZATION BY */
/* ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. */
L610:
/* COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION */
/* Computing MAX */
r__1 = 3.f - fn;
akm = dmax(r__1,0.f);
km = (integer) akm;
tfn = fn + km;
ta = (gln + tfn - .9189385332f - .0833333333f / tfn) / (tfn + .5f);
ta = xo2l - ta;
tb = -(1.f - 1.5f / tfn) / tfn;
akm = tolln / (-ta + sqrt(ta * ta - tolln * tb)) + 1.5f;
in = km + (integer) akm;
goto L660;
L620:
/* COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION */
gln = wk[2] + wk[1];
if (wk[5] > 30.f) {
goto L640;
}
rden = (pp[3] * wk[5] + pp[2]) * wk[5] + 1.f;
rzden = pp[0] + pp[1] * wk[5];
ta = rzden / rden;
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
goto L650;
L630:
tb = ((wk[0] * .0887944358f + .167989473f) * wk[0] + 1.259921049f) / wk[6]
;
goto L650;
L640:
ta = tolln * .5f / wk[3];
ta = ((ta * .049382716f - .1111111111f) * ta + .6666666667f) * ta * wk[5];
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
L650:
in = (integer) (ta / tb + 1.5f);
if (in > inlim) {
goto L310;
}
L660:
dtm = fni + in;
trx = 2.f / *x;
tm = (dtm + fnf) * trx;
ta = 0.f;
tb = tol;
kk = 1;
ak = 1.f;
L670:
/* BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO */
/* UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L680: */
}
/* NORMALIZATION */
if (kk != 1) {
goto L690;
}
s = temp[2];
sa = ta / tb;
ta = s;
tb = s;
if (dabs(s) > slim) {
goto L685;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L685:
ta *= sa;
kk = 2;
in = ns;
if (ns != 0) {
goto L670;
}
L690:
y[nn] = tb * ak;
*nz = *n - nn;
if (nn == 1) {
return 0;
}
k = nn - 1;
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
if (nn == 2) {
return 0;
}
dtm += -1.f;
tm = (dtm + fnf) * trx;
k = nn - 2;
/* BACKWARD RECUR INDEXED */
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
dtm += -1.f;
tm = (dtm + fnf) * trx;
--k;
/* L700: */
}
return 0;
L710:
xermsg_("SLATEC", "BESJ", "ORDER, ALPHA, LESS THAN ZERO.", &c__2, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)29);
return 0;
L720:
xermsg_("SLATEC", "BESJ", "N LESS THAN ONE.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)16);
return 0;
L730:
xermsg_("SLATEC", "BESJ", "X LESS THAN ZERO.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)17);
return 0;
} /* besj_ */
/* DECK LA05BD */
/* Subroutine */ int la05bd_(doublereal *a, integer *ind, integer *ia,
integer *n, integer *ip, integer *iw, doublereal *w, doublereal *g,
doublereal *b, logical *trans)
{
/* System generated locals */
integer ind_dim1, ind_offset, iw_dim1, iw_offset, ip_dim1, ip_offset,
i__1, i__2, i__3;
/* Local variables */
static integer i__, j, k, l1, k2, n1;
static doublereal am;
static integer ii, kk, kl, kp, nz, kpc, kll;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), xsetun_(integer *);
/* ***BEGIN PROLOGUE LA05BD */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (LA05BS-S, LA05BD-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* THIS SUBPROGRAM IS A SLIGHT MODIFICATION OF A SUBPROGRAM */
/* FROM THE C. 1979 AERE HARWELL LIBRARY. THE NAME OF THE */
/* CORRESPONDING HARWELL CODE CAN BE OBTAINED BY DELETING */
/* THE FINAL LETTER =D= IN THE NAMES USED HERE. */
/* REVISED SEP. 13, 1979. */
/* ROYALTIES HAVE BEEN PAID TO AERE-UK FOR USE OF THEIR CODES */
/* IN THE PACKAGE GIVEN HERE. ANY PRIMARY USAGE OF THE HARWELL */
/* SUBROUTINES REQUIRES A ROYALTY AGREEMENT AND PAYMENT BETWEEN */
/* THE USER AND AERE-UK. ANY USAGE OF THE SANDIA WRITTEN CODES */
/* DSPLP( ) (WHICH USES THE HARWELL SUBROUTINES) IS PERMITTED. */
/* IP(I,1),IP(I,2) POINT TO START OF ROW/COLUMN I OF U. */
/* IW(I,1),IW(I,2) ARE LENGTHS OF ROW/COL I OF U. */
/* IW(.,3),IW(.,4) HOLD ROW/COL NUMBERS IN PIVOTAL ORDER. */
/* ***SEE ALSO DSPLP */
/* ***ROUTINES CALLED XERMSG, XSETUN */
/* ***COMMON BLOCKS LA05DD */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900402 Added TYPE section. (WRB) */
/* 920410 Corrected second dimension on IW declaration. (WRB) */
/* ***END PROLOGUE LA05BD */
/* ***FIRST EXECUTABLE STATEMENT LA05BD */
/* Parameter adjustments */
--a;
ind_dim1 = *ia;
ind_offset = 1 + ind_dim1;
ind -= ind_offset;
iw_dim1 = *n;
iw_offset = 1 + iw_dim1;
iw -= iw_offset;
ip_dim1 = *n;
ip_offset = 1 + ip_dim1;
ip -= ip_offset;
--w;
--b;
/* Function Body */
if (*g < 0.) {
goto L130;
}
kll = *ia - la05dd_1.lenl + 1;
if (*trans) {
goto L80;
}
/* MULTIPLY VECTOR BY INVERSE OF L */
if (la05dd_1.lenl <= 0) {
goto L20;
}
l1 = *ia + 1;
i__1 = la05dd_1.lenl;
for (kk = 1; kk <= i__1; ++kk) {
k = l1 - kk;
i__ = ind[k + ind_dim1];
if (b[i__] == 0.) {
goto L10;
}
j = ind[k + (ind_dim1 << 1)];
b[j] += a[k] * b[i__];
L10:
;
}
L20:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
w[i__] = b[i__];
b[i__] = 0.;
/* L30: */
}
/* MULTIPLY VECTOR BY INVERSE OF U */
n1 = *n + 1;
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = n1 - ii;
i__ = iw[i__ + iw_dim1 * 3];
am = w[i__];
kp = ip[i__ + ip_dim1];
if (kp > 0) {
goto L50;
}
kp = -kp;
ip[i__ + ip_dim1] = kp;
nz = iw[i__ + iw_dim1];
kl = kp - 1 + nz;
k2 = kp + 1;
i__2 = kl;
for (k = k2; k <= i__2; ++k) {
j = ind[k + (ind_dim1 << 1)];
am -= a[k] * b[j];
/* L40: */
}
L50:
if (am == 0.f) {
goto L70;
}
j = ind[kp + (ind_dim1 << 1)];
b[j] = am / a[kp];
kpc = ip[j + (ip_dim1 << 1)];
kl = iw[j + (iw_dim1 << 1)] + kpc - 1;
if (kl == kpc) {
goto L70;
}
k2 = kpc + 1;
i__2 = kl;
for (k = k2; k <= i__2; ++k) {
i__ = ind[k + ind_dim1];
ip[i__ + ip_dim1] = -(i__3 = ip[i__ + ip_dim1], abs(i__3));
/* L60: */
}
L70:
;
}
goto L140;
/* MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF U */
L80:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
w[i__] = b[i__];
b[i__] = 0.;
/* L90: */
}
i__1 = *n;
for (ii = 1; ii <= i__1; ++ii) {
i__ = iw[ii + (iw_dim1 << 2)];
am = w[i__];
if (am == 0.) {
goto L110;
}
j = iw[ii + iw_dim1 * 3];
kp = ip[j + ip_dim1];
am /= a[kp];
b[j] = am;
kl = iw[j + iw_dim1] + kp - 1;
if (kp == kl) {
goto L110;
}
k2 = kp + 1;
i__2 = kl;
for (k = k2; k <= i__2; ++k) {
i__ = ind[k + (ind_dim1 << 1)];
w[i__] -= am * a[k];
/* L100: */
}
L110:
;
}
/* MULTIPLY VECTOR BY INVERSE OF TRANSPOSE OF L */
if (kll > *ia) {
return 0;
}
i__1 = *ia;
for (k = kll; k <= i__1; ++k) {
j = ind[k + (ind_dim1 << 1)];
if (b[j] == 0.) {
goto L120;
}
i__ = ind[k + ind_dim1];
b[i__] += a[k] * b[j];
L120:
;
}
goto L140;
L130:
xsetun_(&la05dd_1.lp);
if (la05dd_1.lp > 0) {
xermsg_("SLATEC", "LA05BD", "EARLIER ENTRY GAVE ERROR RETURN.", &c_n8,
&c__2, (ftnlen)6, (ftnlen)6, (ftnlen)32);
}
L140:
return 0;
} /* la05bd_ */
/* DECK BESYNU */
/* Subroutine */ int besynu_(real *x, real *fnu, integer *n, real *y)
{
/* Initialized data */
static real x1 = 3.f;
static real x2 = 20.f;
static real pi = 3.14159265358979f;
static real rthpi = .797884560802865f;
static real hpi = 1.5707963267949f;
static real cc[8] = { .577215664901533f,-.0420026350340952f,
-.0421977345555443f,.007218943246663f,-2.152416741149e-4f,
-2.01348547807e-5f,1.133027232e-6f,6.116095e-9f };
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Local variables */
static real a[120], f, g;
static integer i__, j, k;
static real p, q, s, a1, a2, g1, g2, s1, s2, t1, t2, cb[120], fc, ak, bk,
ck, fk, fn, rb[120];
static integer kk;
static real cs, sa, sb, cx;
static integer nn;
static real tb, fx, tm, pt, rs, ss, st, rx, cp1, cp2, cs1, cs2, rp1, rp2,
rs1, rs2, cbk, cck, arg, rbk, rck, fhs, fks, cpt, dnu, fmu;
static integer inu;
static real tol, etx, smu, rpt, dnu2, coef, relb, flrx;
extern doublereal gamma_(real *);
static real etest;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESYNU */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to BESY */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (BESYNU-S, DBSYNU-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESYNU computes N member sequences of Y Bessel functions */
/* Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and */
/* positive X. Equations of the references are implemented on */
/* small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). */
/* Forward recursion with the three term recursion relation */
/* generates higher orders FNU+I-1, I=1,...,N. */
/* To start the recursion FNU is normalized to the interval */
/* -0.5.LE.DNU.LT.0.5. A special form of the power series is */
/* implemented on 0.LT.X.LE.X1 while the Miller algorithm for the */
/* K Bessel function in terms of the confluent hypergeometric */
/* function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X */
/* Here I is the complex number SQRT(-1.). */
/* For X.GT.X2, the asymptotic expansion for large X is used. */
/* When FNU is a half odd integer, a special formula for */
/* DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. */
/* BESYNU assumes that a significant digit SINH(X) function is */
/* available. */
/* Description of Arguments */
/* Input */
/* X - X.GT.0.0E0 */
/* FNU - Order of initial Y function, FNU.GE.0.0E0 */
/* N - Number of members of the sequence, N.GE.1 */
/* Output */
/* Y - A vector whose first N components contain values */
/* for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Overflow - a fatal error */
/* ***SEE ALSO BESY */
/* ***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary */
/* Bessel function of the second kind, Journal of */
/* Computational Physics 21, (1976), pp. 343-350. */
/* N. M. Temme, On the numerical evaluation of the modified */
/* Bessel function of the third kind, Journal of */
/* Computational Physics 19, (1975), pp. 324-337. */
/* ***ROUTINES CALLED GAMMA, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 900328 Added TYPE section. (WRB) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* 910408 Updated the AUTHOR and REFERENCES sections. (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESYNU */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESYNU */
ak = r1mach_(&c__3);
tol = dmax(ak,1e-15f);
if (*x <= 0.f) {
goto L270;
}
if (*fnu < 0.f) {
goto L280;
}
if (*n < 1) {
goto L290;
}
rx = 2.f / *x;
inu = (integer) (*fnu + .5f);
dnu = *fnu - inu;
if (dabs(dnu) == .5f) {
goto L260;
}
dnu2 = 0.f;
if (dabs(dnu) < tol) {
goto L10;
}
dnu2 = dnu * dnu;
L10:
if (*x > x1) {
goto L120;
}
/* SERIES FOR X.LE.X1 */
a1 = 1.f - dnu;
a2 = dnu + 1.f;
t1 = 1.f / gamma_(&a1);
t2 = 1.f / gamma_(&a2);
if (dabs(dnu) > .1f) {
goto L40;
}
/* SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
s = cc[0];
ak = 1.f;
for (k = 2; k <= 8; ++k) {
ak *= dnu2;
tm = cc[k - 1] * ak;
s += tm;
if (dabs(tm) < tol) {
goto L30;
}
/* L20: */
}
L30:
g1 = -(s + s);
goto L50;
L40:
g1 = (t1 - t2) / dnu;
L50:
g2 = t1 + t2;
smu = 1.f;
fc = 1.f / pi;
flrx = log(rx);
fmu = dnu * flrx;
tm = 0.f;
if (dnu == 0.f) {
goto L60;
}
tm = sin(dnu * hpi) / dnu;
tm = (dnu + dnu) * tm * tm;
fc = dnu / sin(dnu * pi);
if (fmu != 0.f) {
smu = sinh(fmu) / fmu;
}
L60:
f = fc * (g1 * cosh(fmu) + g2 * flrx * smu);
fx = exp(fmu);
p = fc * t1 * fx;
q = fc * t2 / fx;
g = f + tm * q;
ak = 1.f;
ck = 1.f;
bk = 1.f;
s1 = g;
s2 = p;
if (inu > 0 || *n > 1) {
goto L90;
}
if (*x < tol) {
goto L80;
}
cx = *x * *x * .25f;
L70:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
g = f + tm * q;
ck = -ck * cx / ak;
t1 = ck * g;
s1 += t1;
bk = bk + ak + ak + 1.f;
ak += 1.f;
s = dabs(t1) / (dabs(s1) + 1.f);
if (s > tol) {
goto L70;
}
L80:
y[1] = -s1;
return 0;
L90:
if (*x < tol) {
goto L110;
}
cx = *x * *x * .25f;
L100:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
g = f + tm * q;
ck = -ck * cx / ak;
t1 = ck * g;
s1 += t1;
t2 = ck * (p - ak * g);
s2 += t2;
bk = bk + ak + ak + 1.f;
ak += 1.f;
s = dabs(t1) / (dabs(s1) + 1.f) + dabs(t2) / (dabs(s2) + 1.f);
if (s > tol) {
goto L100;
}
L110:
s2 = -s2 * rx;
s1 = -s1;
goto L160;
L120:
coef = rthpi / sqrt(*x);
if (*x > x2) {
goto L210;
}
/* MILLER ALGORITHM FOR X1.LT.X.LE.X2 */
etest = cos(pi * dnu) / (pi * *x * tol);
fks = 1.f;
fhs = .25f;
fk = 0.f;
rck = 2.f;
cck = *x + *x;
rp1 = 0.f;
cp1 = 0.f;
rp2 = 1.f;
cp2 = 0.f;
k = 0;
L130:
++k;
fk += 1.f;
ak = (fhs - dnu2) / (fks + fk);
pt = fk + 1.f;
rbk = rck / pt;
cbk = cck / pt;
rpt = rp2;
cpt = cp2;
rp2 = rbk * rpt - cbk * cpt - ak * rp1;
cp2 = cbk * rpt + rbk * cpt - ak * cp1;
rp1 = rpt;
cp1 = cpt;
rb[k - 1] = rbk;
cb[k - 1] = cbk;
a[k - 1] = ak;
rck += 2.f;
fks = fks + fk + fk + 1.f;
fhs = fhs + fk + fk;
/* Computing MAX */
r__1 = dabs(rp1), r__2 = dabs(cp1);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rp1 / pt;
/* Computing 2nd power */
r__2 = cp1 / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt = pt * sqrt(fc) * fk;
if (etest > pt) {
goto L130;
}
kk = k;
rs = 1.f;
cs = 0.f;
rp1 = 0.f;
cp1 = 0.f;
rp2 = 1.f;
cp2 = 0.f;
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
rpt = rp2;
cpt = cp2;
rp2 = (rb[kk - 1] * rpt - cb[kk - 1] * cpt - rp1) / a[kk - 1];
cp2 = (cb[kk - 1] * rpt + rb[kk - 1] * cpt - cp1) / a[kk - 1];
rp1 = rpt;
cp1 = cpt;
rs += rp2;
cs += cp2;
--kk;
/* L140: */
}
/* Computing MAX */
r__1 = dabs(rs), r__2 = dabs(cs);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rs / pt;
/* Computing 2nd power */
r__2 = cs / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt *= sqrt(fc);
rs1 = (rp2 * (rs / pt) + cp2 * (cs / pt)) / pt;
cs1 = (cp2 * (rs / pt) - rp2 * (cs / pt)) / pt;
fc = hpi * (dnu - .5f) - *x;
p = cos(fc);
q = sin(fc);
s1 = (cs1 * q - rs1 * p) * coef;
if (inu > 0 || *n > 1) {
goto L150;
}
y[1] = s1;
return 0;
L150:
/* Computing MAX */
r__1 = dabs(rp2), r__2 = dabs(cp2);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rp2 / pt;
/* Computing 2nd power */
r__2 = cp2 / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt *= sqrt(fc);
rpt = dnu + .5f - (rp1 * (rp2 / pt) + cp1 * (cp2 / pt)) / pt;
cpt = *x - (cp1 * (rp2 / pt) - rp1 * (cp2 / pt)) / pt;
cs2 = cs1 * cpt - rs1 * rpt;
rs2 = rpt * cs1 + rs1 * cpt;
s2 = (rs2 * q + cs2 * p) * coef / *x;
/* FORWARD RECURSION ON THE THREE TERM RECURSION RELATION */
L160:
ck = (dnu + dnu + 2.f) / *x;
if (*n == 1) {
--inu;
}
if (inu > 0) {
goto L170;
}
if (*n > 1) {
goto L190;
}
s1 = s2;
goto L190;
L170:
i__1 = inu;
for (i__ = 1; i__ <= i__1; ++i__) {
st = s2;
s2 = ck * s2 - s1;
s1 = st;
ck += rx;
/* L180: */
}
if (*n == 1) {
s1 = s2;
}
L190:
y[1] = s1;
if (*n == 1) {
return 0;
}
y[2] = s2;
if (*n == 2) {
return 0;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = ck * y[i__ - 1] - y[i__ - 2];
ck += rx;
/* L200: */
}
return 0;
/* ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 */
L210:
nn = 2;
if (inu == 0 && *n == 1) {
nn = 1;
}
dnu2 = dnu + dnu;
fmu = 0.f;
if (dabs(dnu2) < tol) {
goto L220;
}
fmu = dnu2 * dnu2;
L220:
arg = *x - hpi * (dnu + .5f);
sa = sin(arg);
sb = cos(arg);
etx = *x * 8.f;
i__1 = nn;
for (k = 1; k <= i__1; ++k) {
s1 = s2;
t2 = (fmu - 1.f) / etx;
ss = t2;
relb = tol * dabs(t2);
t1 = etx;
s = 1.f;
fn = 1.f;
ak = 0.f;
for (j = 1; j <= 13; ++j) {
t1 += etx;
ak += 8.f;
fn += ak;
t2 = -t2 * (fmu - fn) / t1;
s += t2;
t1 += etx;
ak += 8.f;
fn += ak;
t2 = t2 * (fmu - fn) / t1;
ss += t2;
if (dabs(t2) <= relb) {
goto L240;
}
/* L230: */
}
L240:
s2 = coef * (s * sa + ss * sb);
fmu = fmu + dnu * 8.f + 4.f;
tb = sa;
sa = -sb;
sb = tb;
/* L250: */
}
if (nn > 1) {
goto L160;
}
s1 = s2;
goto L190;
/* FNU=HALF ODD INTEGER CASE */
L260:
coef = rthpi / sqrt(*x);
s1 = coef * sin(*x);
s2 = -coef * cos(*x);
goto L160;
L270:
xermsg_("SLATEC", "BESYNU", "X NOT GREATER THAN ZERO", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
return 0;
L280:
xermsg_("SLATEC", "BESYNU", "FNU NOT ZERO OR POSITIVE", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)24);
return 0;
L290:
xermsg_("SLATEC", "BESYNU", "N NOT GREATER THAN 0", &c__2, &c__1, (ftnlen)
6, (ftnlen)6, (ftnlen)20);
return 0;
} /* besynu_ */
/* DECK BESY1 */
doublereal besy1_(real *x)
{
/* Initialized data */
static real by1cs[14] = { .03208047100611908629f,1.26270789743350045f,
.006499961899923175f,-.08936164528860504117f,
.01325088122175709545f,-8.9790591196483523e-4f,
3.647361487958306e-5f,-1.001374381666e-6f,1.99453965739e-8f,
-3.0230656018e-10f,3.60987815e-12f,-3.487488e-14f,2.7838e-16f,
-1.86e-18f };
static real bm1cs[21] = { .1047362510931285f,.00442443893702345f,
-5.661639504035e-5f,2.31349417339e-6f,-1.7377182007e-7f,
1.89320993e-8f,-2.65416023e-9f,4.4740209e-10f,-8.691795e-11f,
1.891492e-11f,-4.51884e-12f,1.16765e-12f,-3.2265e-13f,9.45e-14f,
-2.913e-14f,9.39e-15f,-3.15e-15f,1.09e-15f,-3.9e-16f,1.4e-16f,
-5e-17f };
static real bth1cs[24] = { .7406014102631385f,-.00457175565963769f,
1.19818510964326e-4f,-6.964561891648e-6f,6.55495621447e-7f,
-8.4066228945e-8f,1.3376886564e-8f,-2.499565654e-9f,5.294951e-10f,
-1.24135944e-10f,3.1656485e-11f,-8.66864e-12f,2.523758e-12f,
-7.75085e-13f,2.49527e-13f,-8.3773e-14f,2.9205e-14f,-1.0534e-14f,
3.919e-15f,-1.5e-15f,5.89e-16f,-2.37e-16f,9.7e-17f,-4e-17f };
static real twodpi = .63661977236758134f;
static real pi4 = .78539816339744831f;
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1, r__2;
/* Local variables */
static real y, z__;
static integer ntm1, nty1;
static real ampl, xmin, xmax, xsml;
extern doublereal besj1_(real *);
static integer ntth1;
static real theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESY1 */
/* ***PURPOSE Compute the Bessel function of the second kind of order */
/* one. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10A1 */
/* ***TYPE SINGLE PRECISION (BESY1-S, DBESY1-D) */
/* ***KEYWORDS BESSEL FUNCTION, FNLIB, ORDER ONE, SECOND KIND, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* BESY1(X) calculates the Bessel function of the second kind of */
/* order one for real argument X. */
/* Series for BY1 on the interval 0. to 1.60000D+01 */
/* with weighted error 1.87E-18 */
/* log weighted error 17.73 */
/* significant figures required 17.83 */
/* decimal places required 18.30 */
/* Series for BM1 on the interval 0. to 6.25000D-02 */
/* with weighted error 5.61E-17 */
/* log weighted error 16.25 */
/* significant figures required 14.97 */
/* decimal places required 16.91 */
/* Series for BTH1 on the interval 0. to 6.25000D-02 */
/* with weighted error 4.10E-17 */
/* log weighted error 16.39 */
/* significant figures required 15.96 */
/* decimal places required 17.08 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED BESJ1, CSEVL, INITS, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770401 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* ***END PROLOGUE BESY1 */
/* ***FIRST EXECUTABLE STATEMENT BESY1 */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
nty1 = inits_(by1cs, &c__14, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntm1 = inits_(bm1cs, &c__21, &r__1);
r__1 = r1mach_(&c__3) * .1f;
ntth1 = inits_(bth1cs, &c__24, &r__1);
/* Computing MAX */
r__1 = log(r1mach_(&c__1)), r__2 = -log(r1mach_(&c__2));
xmin = exp(dmax(r__1,r__2) + .01f) * 1.571f;
xsml = sqrt(r1mach_(&c__3) * 4.f);
xmax = 1.f / r1mach_(&c__4);
}
first = FALSE_;
if (*x <= 0.f) {
xermsg_("SLATEC", "BESY1", "X IS ZERO OR NEGATIVE", &c__1, &c__2, (
ftnlen)6, (ftnlen)5, (ftnlen)21);
}
if (*x > 4.f) {
goto L20;
}
if (*x < xmin) {
xermsg_("SLATEC", "BESY1", "X SO SMALL Y1 OVERFLOWS", &c__3, &c__2, (
ftnlen)6, (ftnlen)5, (ftnlen)23);
}
y = 0.f;
if (*x > xsml) {
y = *x * *x;
}
r__1 = y * .125f - 1.f;
ret_val = twodpi * log(*x * .5f) * besj1_(x) + (csevl_(&r__1, by1cs, &
nty1) + .5f) / *x;
return ret_val;
L20:
if (*x > xmax) {
xermsg_("SLATEC", "BESY1", "NO PRECISION BECAUSE X IS BIG", &c__2, &
c__2, (ftnlen)6, (ftnlen)5, (ftnlen)29);
}
/* Computing 2nd power */
r__1 = *x;
z__ = 32.f / (r__1 * r__1) - 1.f;
ampl = (csevl_(&z__, bm1cs, &ntm1) + .75f) / sqrt(*x);
theta = *x - pi4 * 3.f + csevl_(&z__, bth1cs, &ntth1) / *x;
ret_val = ampl * sin(theta);
return ret_val;
} /* besy1_ */
/* DECK DGAMLM */
/* Subroutine */ int dgamlm_(doublereal *xmin, doublereal *xmax)
{
/* System generated locals */
doublereal d__1, d__2;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer i__;
doublereal xln, xold;
extern doublereal d1mach_(integer *);
doublereal alnbig, alnsml;
extern /* Subroutine */ int xermsg_(const char *, const char *, const char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DGAMLM */
/* ***PURPOSE Compute the minimum and maximum bounds for the argument in */
/* the Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A, R2 */
/* ***TYPE DOUBLE PRECISION (GAMLIM-S, DGAMLM-D) */
/* ***KEYWORDS COMPLETE GAMMA FUNCTION, FNLIB, LIMITS, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* Calculate the minimum and maximum legal bounds for X in gamma(X). */
/* XMIN and XMAX are not the only bounds, but they are the only non- */
/* trivial ones to calculate. */
/* Output Arguments -- */
/* XMIN double precision minimum legal value of X in gamma(X). Any */
/* smaller value of X might result in underflow. */
/* XMAX double precision maximum legal value of X in gamma(X). Any */
/* larger value of X might cause overflow. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED D1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770601 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) */
/* ***END PROLOGUE DGAMLM */
/* ***FIRST EXECUTABLE STATEMENT DGAMLM */
alnsml = log(d1mach_(&c__1));
*xmin = -alnsml;
for (i__ = 1; i__ <= 10; ++i__) {
xold = *xmin;
xln = log(*xmin);
*xmin -= *xmin * ((*xmin + .5) * xln - *xmin - .2258 + alnsml) / (*
xmin * xln + .5);
if ((d__1 = *xmin - xold, abs(d__1)) < .005) {
goto L20;
}
/* L10: */
}
xermsg_("SLATEC", "DGAMLM", "UNABLE TO FIND XMIN", &c__1, &c__2, (ftnlen)
6, (ftnlen)6, (ftnlen)19);
L20:
*xmin = -(*xmin) + .01;
alnbig = log(d1mach_(&c__2));
*xmax = alnbig;
for (i__ = 1; i__ <= 10; ++i__) {
xold = *xmax;
xln = log(*xmax);
*xmax -= *xmax * ((*xmax - .5) * xln - *xmax + .9189 - alnbig) / (*
xmax * xln - .5);
if ((d__1 = *xmax - xold, abs(d__1)) < .005) {
goto L40;
}
/* L30: */
}
xermsg_("SLATEC", "DGAMLM", "UNABLE TO FIND XMAX", &c__2, &c__2, (ftnlen)
6, (ftnlen)6, (ftnlen)19);
L40:
*xmax += -.01;
/* Computing MAX */
d__1 = *xmin, d__2 = -(*xmax) + 1.;
*xmin = max(d__1,d__2);
return 0;
} /* dgamlm_ */
/* DECK SREADP */
/* Subroutine */ int sreadp_(integer *ipage, integer *list, real *rlist,
integer *lpage, integer *irec)
{
/* System generated locals */
address a__1[4];
integer i__1, i__2, i__3[4];
char ch__1[40];
/* Local variables */
static integer i__, lpg;
static char xern1[8], xern2[8];
static integer irecn, ipagef;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static cilist io___4 = { 1, 0, 0, 0, 0 };
static cilist io___6 = { 1, 0, 0, 0, 0 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___10 = { 0, xern2, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SREADP */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to SPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (SREADP-S, DREADP-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* READ RECORD NUMBER IRECN, OF LENGTH LPG, FROM UNIT */
/* NUMBER IPAGEF INTO THE STORAGE ARRAY, LIST(*). */
/* READ RECORD IRECN+1, OF LENGTH LPG, FROM UNIT NUMBER */
/* IPAGEF INTO THE STORAGE ARRAY RLIST(*). */
/* TO CONVERT THIS PROGRAM UNIT TO DOUBLE PRECISION CHANGE */
/* /REAL (12 BLANKS)/ TO /DOUBLE PRECISION/. */
/* ***SEE ALSO SPLP */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890605 Corrected references to XERRWV. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* ***END PROLOGUE SREADP */
/* ***FIRST EXECUTABLE STATEMENT SREADP */
/* Parameter adjustments */
--rlist;
--list;
/* Function Body */
ipagef = *ipage;
lpg = *lpage;
irecn = *irec;
io___4.ciunit = ipagef;
io___4.cirec = irecn;
i__1 = s_rdue(&io___4);
if (i__1 != 0) {
goto L100;
}
i__2 = lpg;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_uio(&c__1, (char *)&list[i__], (ftnlen)sizeof(integer));
if (i__1 != 0) {
goto L100;
}
}
i__1 = e_rdue();
if (i__1 != 0) {
goto L100;
}
io___6.ciunit = ipagef;
io___6.cirec = irecn + 1;
i__1 = s_rdue(&io___6);
if (i__1 != 0) {
goto L100;
}
i__2 = lpg;
for (i__ = 1; i__ <= i__2; ++i__) {
i__1 = do_uio(&c__1, (char *)&rlist[i__], (ftnlen)sizeof(real));
if (i__1 != 0) {
goto L100;
}
}
i__1 = e_rdue();
if (i__1 != 0) {
goto L100;
}
return 0;
L100:
s_wsfi(&io___8);
do_fio(&c__1, (char *)&lpg, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___10);
do_fio(&c__1, (char *)&irecn, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__3[0] = 15, a__1[0] = "IN SPLP, LPG = ";
i__3[1] = 8, a__1[1] = xern1;
i__3[2] = 9, a__1[2] = " IRECN = ";
i__3[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__3, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SREADP", ch__1, &c__100, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)40);
return 0;
} /* sreadp_ */
/* DECK CGEEV */
/* Subroutine */ int cgeev_(real *a, integer *lda, integer *n, real *e, real *
v, integer *ldv, real *work, integer *job, integer *info)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer i__, j, k, l, m, ihi, ilo;
extern /* Subroutine */ int cbal_(integer *, integer *, real *, real *,
integer *, integer *, real *);
static integer mdim;
extern /* Subroutine */ int corth_(integer *, integer *, integer *,
integer *, real *, real *, real *, real *), comqr_(integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
integer *), cbabk2_(integer *, integer *, integer *, integer *,
real *, integer *, real *, real *), scopy_(integer *, real *,
integer *, real *, integer *), comqr2_(integer *, integer *,
integer *, integer *, real *, real *, real *, real *, real *,
real *, real *, real *, integer *), xermsg_(char *, char *, char *
, integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE CGEEV */
/* ***PURPOSE Compute the eigenvalues and, optionally, the eigenvectors */
/* of a complex general matrix. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D4A4 */
/* ***TYPE COMPLEX (SGEEV-S, CGEEV-C) */
/* ***KEYWORDS EIGENVALUES, EIGENVECTORS, GENERAL MATRIX */
/* ***AUTHOR Kahaner, D. K., (NBS) */
/* Moler, C. B., (U. of New Mexico) */
/* Stewart, G. W., (U. of Maryland) */
/* ***DESCRIPTION */
/* Abstract */
/* CGEEV computes the eigenvalues and, optionally, */
/* the eigenvectors of a general complex matrix. */
/* Call Sequence Parameters- */
/* (The values of parameters marked with * (star) will be changed */
/* by CGEEV.) */
/* A* COMPLEX(LDA,N) */
/* complex nonsymmetric input matrix. */
/* LDA INTEGER */
/* set by the user to */
/* the leading dimension of the complex array A. */
/* N INTEGER */
/* set by the user to */
/* the order of the matrices A and V, and */
/* the number of elements in E. */
/* E* COMPLEX(N) */
/* on return from CGEEV E contains the eigenvalues of A. */
/* See also INFO below. */
/* V* COMPLEX(LDV,N) */
/* on return from CGEEV if the user has set JOB */
/* = 0 V is not referenced. */
/* = nonzero the N eigenvectors of A are stored in the */
/* first N columns of V. See also INFO below. */
/* (If the input matrix A is nearly degenerate, V */
/* will be badly conditioned, i.e. have nearly */
/* dependent columns.) */
/* LDV INTEGER */
/* set by the user to */
/* the leading dimension of the array V if JOB is also */
/* set nonzero. In that case N must be .LE. LDV. */
/* If JOB is set to zero LDV is not referenced. */
/* WORK* REAL(3N) */
/* temporary storage vector. Contents changed by CGEEV. */
/* JOB INTEGER */
/* set by the user to */
/* = 0 eigenvalues only to be calculated by CGEEV. */
/* neither V nor LDV are referenced. */
/* = nonzero eigenvalues and vectors to be calculated. */
/* In this case A & V must be distinct arrays. */
/* Also, if LDA > LDV, CGEEV changes all the */
/* elements of A thru column N. If LDA < LDV, */
/* CGEEV changes all the elements of V through */
/* column N. If LDA = LDV only A(I,J) and V(I, */
/* J) for I,J = 1,...,N are changed by CGEEV. */
/* INFO* INTEGER */
/* on return from CGEEV the value of INFO is */
/* = 0 normal return, calculation successful. */
/* = K if the eigenvalue iteration fails to converge, */
/* eigenvalues K+1 through N are correct, but */
/* no eigenvectors were computed even if they were */
/* requested (JOB nonzero). */
/* Error Messages */
/* No. 1 recoverable N is greater than LDA */
/* No. 2 recoverable N is less than one. */
/* No. 3 recoverable JOB is nonzero and N is greater than LDV */
/* No. 4 warning LDA > LDV, elements of A other than the */
/* N by N input elements have been changed */
/* No. 5 warning LDA < LDV, elements of V other than the */
/* N by N output elements have been changed */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CBABK2, CBAL, COMQR, COMQR2, CORTH, SCOPY, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800808 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* ***END PROLOGUE CGEEV */
/* ***FIRST EXECUTABLE STATEMENT CGEEV */
/* Parameter adjustments */
--work;
--v;
--e;
--a;
/* Function Body */
if (*n > *lda) {
xermsg_("SLATEC", "CGEEV", "N .GT. LDA.", &c__1, &c__1, (ftnlen)6, (
ftnlen)5, (ftnlen)11);
}
if (*n > *lda) {
return 0;
}
if (*n < 1) {
xermsg_("SLATEC", "CGEEV", "N .LT. 1", &c__2, &c__1, (ftnlen)6, (
ftnlen)5, (ftnlen)8);
}
if (*n < 1) {
return 0;
}
if (*n == 1 && *job == 0) {
goto L35;
}
mdim = *lda << 1;
if (*job == 0) {
goto L5;
}
if (*n > *ldv) {
xermsg_("SLATEC", "CGEEV", "JOB .NE. 0 AND N .GT. LDV.", &c__3, &c__1,
(ftnlen)6, (ftnlen)5, (ftnlen)26);
}
if (*n > *ldv) {
return 0;
}
if (*n == 1) {
goto L35;
}
/* REARRANGE A IF NECESSARY WHEN LDA.GT.LDV AND JOB .NE.0 */
/* Computing MIN */
i__1 = mdim, i__2 = *ldv << 1;
mdim = min(i__1,i__2);
if (*lda < *ldv) {
xermsg_("SLATEC", "CGEEV", "LDA.LT.LDV, ELEMENTS OF V OTHER THAN TH"
"E N BY N OUTPUT ELEMENTS HAVE BEEN CHANGED.", &c__5, &c__0, (
ftnlen)6, (ftnlen)5, (ftnlen)83);
}
if (*lda <= *ldv) {
goto L5;
}
xermsg_("SLATEC", "CGEEV", "LDA.GT.LDV, ELEMENTS OF A OTHER THAN THE N B"
"Y N INPUT ELEMENTS HAVE BEEN CHANGED.", &c__4, &c__0, (ftnlen)6, (
ftnlen)5, (ftnlen)81);
l = *n - 1;
i__1 = l;
for (j = 1; j <= i__1; ++j) {
i__ = *n << 1;
m = (j << 1) * *ldv + 1;
k = (j << 1) * *lda + 1;
scopy_(&i__, &a[k], &c__1, &a[m], &c__1);
/* L4: */
}
L5:
/* SEPARATE REAL AND IMAGINARY PARTS */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
k = (j - 1) * mdim + 1;
l = k + *n;
scopy_(n, &a[k + 1], &c__2, &work[1], &c__1);
scopy_(n, &a[k], &c__2, &a[k], &c__1);
scopy_(n, &work[1], &c__1, &a[l], &c__1);
/* L6: */
}
/* SCALE AND ORTHOGONAL REDUCTION TO HESSENBERG. */
cbal_(&mdim, n, &a[1], &a[*n + 1], &ilo, &ihi, &work[1]);
corth_(&mdim, n, &ilo, &ihi, &a[1], &a[*n + 1], &work[*n + 1], &work[(*n
<< 1) + 1]);
if (*job != 0) {
goto L10;
}
/* EIGENVALUES ONLY */
comqr_(&mdim, n, &ilo, &ihi, &a[1], &a[*n + 1], &e[1], &e[*n + 1], info);
goto L30;
/* EIGENVALUES AND EIGENVECTORS. */
L10:
comqr2_(&mdim, n, &ilo, &ihi, &work[*n + 1], &work[(*n << 1) + 1], &a[1],
&a[*n + 1], &e[1], &e[*n + 1], &v[1], &v[*n + 1], info);
if (*info != 0) {
goto L30;
}
cbabk2_(&mdim, n, &ilo, &ihi, &work[1], n, &v[1], &v[*n + 1]);
/* CONVERT EIGENVECTORS TO COMPLEX STORAGE. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
k = (j - 1) * mdim + 1;
i__ = (j - 1 << 1) * *ldv + 1;
l = k + *n;
scopy_(n, &v[k], &c__1, &work[1], &c__1);
scopy_(n, &v[l], &c__1, &v[i__ + 1], &c__2);
scopy_(n, &work[1], &c__1, &v[i__], &c__2);
/* L20: */
}
/* CONVERT EIGENVALUES TO COMPLEX STORAGE. */
L30:
scopy_(n, &e[1], &c__1, &work[1], &c__1);
scopy_(n, &e[*n + 1], &c__1, &e[2], &c__2);
scopy_(n, &work[1], &c__1, &e[1], &c__2);
return 0;
/* TAKE CARE OF N=1 CASE */
L35:
e[1] = a[1];
e[2] = a[2];
*info = 0;
if (*job == 0) {
return 0;
}
v[1] = a[1];
v[2] = a[2];
return 0;
} /* cgeev_ */
/* DECK BINTK */
/* Subroutine */ int bintk_(real *x, real *y, real *t, integer *n, integer *k,
real *bcoef, real *q, real *work)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer i__, j, jj;
static real xi;
static integer km1, np1, left, lenq, kpkm2;
extern /* Subroutine */ int bnfac_(real *, integer *, integer *, integer *
, integer *, integer *);
static integer iflag;
extern /* Subroutine */ int bnslv_(real *, integer *, integer *, integer *
, integer *, real *), bspvn_(real *, integer *, integer *,
integer *, real *, integer *, real *, real *, integer *);
static integer iwork, ilp1mx;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BINTK */
/* ***PURPOSE Compute the B-representation of a spline which interpolates */
/* given data. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY E1A */
/* ***TYPE SINGLE PRECISION (BINTK-S, DBINTK-D) */
/* ***KEYWORDS B-SPLINE, DATA FITTING, INTERPOLATION */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Written by Carl de Boor and modified by D. E. Amos */
/* Abstract */
/* BINTK is the SPLINT routine of the reference. */
/* BINTK produces the B-spline coefficients, BCOEF, of the */
/* B-spline of order K with knots T(I), I=1,...,N+K, which */
/* takes on the value Y(I) at X(I), I=1,...,N. The spline or */
/* any of its derivatives can be evaluated by calls to BVALU. */
/* The I-th equation of the linear system A*BCOEF = B for the */
/* coefficients of the interpolant enforces interpolation at */
/* X(I)), I=1,...,N. Hence, B(I) = Y(I), all I, and A is */
/* a band matrix with 2K-1 bands if A is invertible. The matrix */
/* A is generated row by row and stored, diagonal by diagonal, */
/* in the rows of Q, with the main diagonal going into row K. */
/* The banded system is then solved by a call to BNFAC (which */
/* constructs the triangular factorization for A and stores it */
/* again in Q), followed by a call to BNSLV (which then */
/* obtains the solution BCOEF by substitution). BNFAC does no */
/* pivoting, since the total positivity of the matrix A makes */
/* this unnecessary. The linear system to be solved is */
/* (theoretically) invertible if and only if */
/* T(I) .LT. X(I)) .LT. T(I+K), all I. */
/* Equality is permitted on the left for I=1 and on the right */
/* for I=N when K knots are used at X(1) or X(N). Otherwise, */
/* violation of this condition is certain to lead to an error. */
/* Description of Arguments */
/* Input */
/* X - vector of length N containing data point abscissa */
/* in strictly increasing order. */
/* Y - corresponding vector of length N containing data */
/* point ordinates. */
/* T - knot vector of length N+K */
/* since T(1),..,T(K) .LE. X(1) and T(N+1),..,T(N+K) */
/* .GE. X(N), this leaves only N-K knots (not nec- */
/* essarily X(I)) values) interior to (X(1),X(N)) */
/* N - number of data points, N .GE. K */
/* K - order of the spline, K .GE. 1 */
/* Output */
/* BCOEF - a vector of length N containing the B-spline */
/* coefficients */
/* Q - a work vector of length (2*K-1)*N, containing */
/* the triangular factorization of the coefficient */
/* matrix of the linear system being solved. The */
/* coefficients for the interpolant of an */
/* additional data set (X(I)),YY(I)), I=1,...,N */
/* with the same abscissa can be obtained by loading */
/* YY into BCOEF and then executing */
/* CALL BNSLV (Q,2K-1,N,K-1,K-1,BCOEF) */
/* WORK - work vector of length 2*K */
/* Error Conditions */
/* Improper input is a fatal error */
/* Singular system of equations is a fatal error */
/* ***REFERENCES D. E. Amos, Computation with splines and B-splines, */
/* Report SAND78-1968, Sandia Laboratories, March 1979. */
/* Carl de Boor, Package for calculating with B-splines, */
/* SIAM Journal on Numerical Analysis 14, 3 (June 1977), */
/* pp. 441-472. */
/* Carl de Boor, A Practical Guide to Splines, Applied */
/* Mathematics Series 27, Springer-Verlag, New York, */
/* 1978. */
/* ***ROUTINES CALLED BNFAC, BNSLV, BSPVN, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800901 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BINTK */
/* DIMENSION Q(2*K-1,N), T(N+K) */
/* ***FIRST EXECUTABLE STATEMENT BINTK */
/* Parameter adjustments */
--work;
--q;
--bcoef;
--t;
--y;
--x;
/* Function Body */
if (*k < 1) {
goto L100;
}
if (*n < *k) {
goto L105;
}
jj = *n - 1;
if (jj == 0) {
goto L6;
}
i__1 = jj;
for (i__ = 1; i__ <= i__1; ++i__) {
if (x[i__] >= x[i__ + 1]) {
goto L110;
}
/* L5: */
}
L6:
np1 = *n + 1;
km1 = *k - 1;
kpkm2 = km1 << 1;
left = *k;
/* ZERO OUT ALL ENTRIES OF Q */
lenq = *n * (*k + km1);
i__1 = lenq;
for (i__ = 1; i__ <= i__1; ++i__) {
q[i__] = 0.f;
/* L10: */
}
/* *** LOOP OVER I TO CONSTRUCT THE N INTERPOLATION EQUATIONS */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = x[i__];
/* Computing MIN */
i__2 = i__ + *k;
ilp1mx = min(i__2,np1);
/* *** FIND LEFT IN THE CLOSED INTERVAL (I,I+K-1) SUCH THAT */
/* T(LEFT) .LE. X(I) .LT. T(LEFT+1) */
/* MATRIX IS SINGULAR IF THIS IS NOT POSSIBLE */
left = max(left,i__);
if (xi < t[left]) {
goto L80;
}
L20:
if (xi < t[left + 1]) {
goto L30;
}
++left;
if (left < ilp1mx) {
goto L20;
}
--left;
if (xi > t[left + 1]) {
goto L80;
}
/* *** THE I-TH EQUATION ENFORCES INTERPOLATION AT XI, HENCE */
/* A(I,J) = B(J,K,T)(XI), ALL J. ONLY THE K ENTRIES WITH J = */
/* LEFT-K+1,...,LEFT ACTUALLY MIGHT BE NONZERO. THESE K NUMBERS */
/* ARE RETURNED, IN BCOEF (USED FOR TEMP. STORAGE HERE), BY THE */
/* FOLLOWING */
L30:
bspvn_(&t[1], k, k, &c__1, &xi, &left, &bcoef[1], &work[1], &iwork);
/* WE THEREFORE WANT BCOEF(J) = B(LEFT-K+J)(XI) TO GO INTO */
/* A(I,LEFT-K+J), I.E., INTO Q(I-(LEFT+J)+2*K,(LEFT+J)-K) SINCE */
/* A(I+J,J) IS TO GO INTO Q(I+K,J), ALL I,J, IF WE CONSIDER Q */
/* AS A TWO-DIM. ARRAY , WITH 2*K-1 ROWS (SEE COMMENTS IN */
/* BNFAC). IN THE PRESENT PROGRAM, WE TREAT Q AS AN EQUIVALENT */
/* ONE-DIMENSIONAL ARRAY (BECAUSE OF FORTRAN RESTRICTIONS ON */
/* DIMENSION STATEMENTS) . WE THEREFORE WANT BCOEF(J) TO GO INTO */
/* ENTRY */
/* I -(LEFT+J) + 2*K + ((LEFT+J) - K-1)*(2*K-1) */
/* = I-LEFT+1 + (LEFT -K)*(2*K-1) + (2*K-2)*J */
/* OF Q . */
jj = i__ - left + 1 + (left - *k) * (*k + km1);
i__2 = *k;
for (j = 1; j <= i__2; ++j) {
jj += kpkm2;
q[jj] = bcoef[j];
/* L40: */
}
/* L50: */
}
/* ***OBTAIN FACTORIZATION OF A , STORED AGAIN IN Q. */
i__1 = *k + km1;
bnfac_(&q[1], &i__1, n, &km1, &km1, &iflag);
switch (iflag) {
case 1: goto L60;
case 2: goto L90;
}
/* *** SOLVE A*BCOEF = Y BY BACKSUBSTITUTION */
L60:
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
bcoef[i__] = y[i__];
/* L70: */
}
i__1 = *k + km1;
bnslv_(&q[1], &i__1, n, &km1, &km1, &bcoef[1]);
return 0;
L80:
xermsg_("SLATEC", "BINTK", "SOME ABSCISSA WAS NOT IN THE SUPPORT OF THE "
"CORRESPONDING BASIS FUNCTION AND THE SYSTEM IS SINGULAR.", &c__2,
&c__1, (ftnlen)6, (ftnlen)5, (ftnlen)100);
return 0;
L90:
xermsg_("SLATEC", "BINTK", "THE SYSTEM OF SOLVER DETECTS A SINGULAR SYST"
"EM ALTHOUGH THE THEORETICAL CONDITIONS FOR A SOLUTION WERE SATIS"
"FIED.", &c__8, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)113);
return 0;
L100:
xermsg_("SLATEC", "BINTK", "K DOES NOT SATISFY K.GE.1", &c__2, &c__1, (
ftnlen)6, (ftnlen)5, (ftnlen)25);
return 0;
L105:
xermsg_("SLATEC", "BINTK", "N DOES NOT SATISFY N.GE.K", &c__2, &c__1, (
ftnlen)6, (ftnlen)5, (ftnlen)25);
return 0;
L110:
xermsg_("SLATEC", "BINTK", "X(I) DOES NOT SATISFY X(I).LT.X(I+1) FOR SOM"
"E I", &c__2, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)47);
return 0;
} /* bintk_ */
/* DECK PCHIM */
/* Subroutine */ int pchim_(integer *n, real *x, real *f, real *d__, integer *
incfd, integer *ierr)
{
/* Initialized data */
static real zero = 0.f;
static real three = 3.f;
/* System generated locals */
integer f_dim1, f_offset, d_dim1, d_offset, i__1;
real r__1, r__2;
/* Local variables */
static integer i__;
static real h1, h2, w1, w2, del1, del2, dmin__, dmax__, hsum, drat1,
drat2, dsave;
extern doublereal pchst_(real *, real *);
static integer nless1;
static real hsumt3;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE PCHIM */
/* ***PURPOSE Set derivatives needed to determine a monotone piecewise */
/* cubic Hermite interpolant to given data. Boundary values */
/* are provided which are compatible with monotonicity. The */
/* interpolant will have an extremum at each point where mono- */
/* tonicity switches direction. (See PCHIC if user control is */
/* desired over boundary or switch conditions.) */
/* ***LIBRARY SLATEC (PCHIP) */
/* ***CATEGORY E1A */
/* ***TYPE SINGLE PRECISION (PCHIM-S, DPCHIM-D) */
/* ***KEYWORDS CUBIC HERMITE INTERPOLATION, MONOTONE INTERPOLATION, */
/* PCHIP, PIECEWISE CUBIC INTERPOLATION */
/* ***AUTHOR Fritsch, F. N., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* P.O. Box 808 (L-316) */
/* Livermore, CA 94550 */
/* FTS 532-4275, (510) 422-4275 */
/* ***DESCRIPTION */
/* PCHIM: Piecewise Cubic Hermite Interpolation to */
/* Monotone data. */
/* Sets derivatives needed to determine a monotone piecewise cubic */
/* Hermite interpolant to the data given in X and F. */
/* Default boundary conditions are provided which are compatible */
/* with monotonicity. (See PCHIC if user control of boundary con- */
/* ditions is desired.) */
/* If the data are only piecewise monotonic, the interpolant will */
/* have an extremum at each point where monotonicity switches direc- */
/* tion. (See PCHIC if user control is desired in such cases.) */
/* To facilitate two-dimensional applications, includes an increment */
/* between successive values of the F- and D-arrays. */
/* The resulting piecewise cubic Hermite function may be evaluated */
/* by PCHFE or PCHFD. */
/* ---------------------------------------------------------------------- */
/* Calling sequence: */
/* PARAMETER (INCFD = ...) */
/* INTEGER N, IERR */
/* REAL X(N), F(INCFD,N), D(INCFD,N) */
/* CALL PCHIM (N, X, F, D, INCFD, IERR) */
/* Parameters: */
/* N -- (input) number of data points. (Error return if N.LT.2 .) */
/* If N=2, simply does linear interpolation. */
/* X -- (input) real array of independent variable values. The */
/* elements of X must be strictly increasing: */
/* X(I-1) .LT. X(I), I = 2(1)N. */
/* (Error return if not.) */
/* F -- (input) real array of dependent variable values to be inter- */
/* polated. F(1+(I-1)*INCFD) is value corresponding to X(I). */
/* PCHIM is designed for monotonic data, but it will work for */
/* any F-array. It will force extrema at points where mono- */
/* tonicity switches direction. If some other treatment of */
/* switch points is desired, PCHIC should be used instead. */
/* ----- */
/* D -- (output) real array of derivative values at the data points. */
/* If the data are monotonic, these values will determine a */
/* a monotone cubic Hermite function. */
/* The value corresponding to X(I) is stored in */
/* D(1+(I-1)*INCFD), I=1(1)N. */
/* No other entries in D are changed. */
/* INCFD -- (input) increment between successive values in F and D. */
/* This argument is provided primarily for 2-D applications. */
/* (Error return if INCFD.LT.1 .) */
/* IERR -- (output) error flag. */
/* Normal return: */
/* IERR = 0 (no errors). */
/* Warning error: */
/* IERR.GT.0 means that IERR switches in the direction */
/* of monotonicity were detected. */
/* "Recoverable" errors: */
/* IERR = -1 if N.LT.2 . */
/* IERR = -2 if INCFD.LT.1 . */
/* IERR = -3 if the X-array is not strictly increasing. */
/* (The D-array has not been changed in any of these cases.) */
/* NOTE: The above errors are checked in the order listed, */
/* and following arguments have **NOT** been validated. */
/* ***REFERENCES 1. F. N. Fritsch and J. Butland, A method for construc- */
/* ting local monotone piecewise cubic interpolants, SIAM */
/* Journal on Scientific and Statistical Computing 5, 2 */
/* (June 1984), pp. 300-304. */
/* 2. F. N. Fritsch and R. E. Carlson, Monotone piecewise */
/* cubic interpolation, SIAM Journal on Numerical Ana- */
/* lysis 17, 2 (April 1980), pp. 238-246. */
/* ***ROUTINES CALLED PCHST, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 811103 DATE WRITTEN */
/* 820201 1. Introduced PCHST to reduce possible over/under- */
/* flow problems. */
/* 2. Rearranged derivative formula for same reason. */
/* 820602 1. Modified end conditions to be continuous functions */
/* of data when monotonicity switches in next interval. */
/* 2. Modified formulas so end conditions are less prone */
/* of over/underflow problems. */
/* 820803 Minor cosmetic changes for release 1. */
/* 870813 Updated Reference 1. */
/* 890411 Added SAVE statements (Vers. 3.2). */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890703 Corrected category record. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 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) */
/* 920429 Revised format and order of references. (WRB,FNF) */
/* ***END PROLOGUE PCHIM */
/* Programming notes: */
/* 1. The function PCHST(ARG1,ARG2) is assumed to return zero if */
/* either argument is zero, +1 if they are of the same sign, and */
/* -1 if they are of opposite sign. */
/* 2. To produce a double precision version, simply: */
/* a. Change PCHIM to DPCHIM wherever it occurs, */
/* b. Change PCHST to DPCHST wherever it occurs, */
/* c. Change all references to the Fortran intrinsics to their */
/* double precision equivalents, */
/* d. Change the real declarations to double precision, and */
/* e. Change the constants ZERO and THREE to double precision. */
/* DECLARE ARGUMENTS. */
/* DECLARE LOCAL VARIABLES. */
/* Parameter adjustments */
--x;
d_dim1 = *incfd;
d_offset = 1 + d_dim1;
d__ -= d_offset;
f_dim1 = *incfd;
f_offset = 1 + f_dim1;
f -= f_offset;
/* Function Body */
/* VALIDITY-CHECK ARGUMENTS. */
/* ***FIRST EXECUTABLE STATEMENT PCHIM */
if (*n < 2) {
goto L5001;
}
if (*incfd < 1) {
goto L5002;
}
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (x[i__] <= x[i__ - 1]) {
goto L5003;
}
/* L1: */
}
/* FUNCTION DEFINITION IS OK, GO ON. */
*ierr = 0;
nless1 = *n - 1;
h1 = x[2] - x[1];
del1 = (f[(f_dim1 << 1) + 1] - f[f_dim1 + 1]) / h1;
dsave = del1;
/* SPECIAL CASE N=2 -- USE LINEAR INTERPOLATION. */
if (nless1 > 1) {
goto L10;
}
d__[d_dim1 + 1] = del1;
d__[*n * d_dim1 + 1] = del1;
goto L5000;
/* NORMAL CASE (N .GE. 3). */
L10:
h2 = x[3] - x[2];
del2 = (f[f_dim1 * 3 + 1] - f[(f_dim1 << 1) + 1]) / h2;
/* SET D(1) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE */
/* SHAPE-PRESERVING. */
hsum = h1 + h2;
w1 = (h1 + hsum) / hsum;
w2 = -h1 / hsum;
d__[d_dim1 + 1] = w1 * del1 + w2 * del2;
if (pchst_(&d__[d_dim1 + 1], &del1) <= zero) {
d__[d_dim1 + 1] = zero;
} else if (pchst_(&del1, &del2) < zero) {
/* NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. */
dmax__ = three * del1;
if ((r__1 = d__[d_dim1 + 1], dabs(r__1)) > dabs(dmax__)) {
d__[d_dim1 + 1] = dmax__;
}
}
/* LOOP THROUGH INTERIOR POINTS. */
i__1 = nless1;
for (i__ = 2; i__ <= i__1; ++i__) {
if (i__ == 2) {
goto L40;
}
h1 = h2;
h2 = x[i__ + 1] - x[i__];
hsum = h1 + h2;
del1 = del2;
del2 = (f[(i__ + 1) * f_dim1 + 1] - f[i__ * f_dim1 + 1]) / h2;
L40:
/* SET D(I)=0 UNLESS DATA ARE STRICTLY MONOTONIC. */
d__[i__ * d_dim1 + 1] = zero;
if ((r__1 = pchst_(&del1, &del2)) < 0.f) {
goto L42;
} else if (r__1 == 0) {
goto L41;
} else {
goto L45;
}
/* COUNT NUMBER OF CHANGES IN DIRECTION OF MONOTONICITY. */
L41:
if (del2 == zero) {
goto L50;
}
if (pchst_(&dsave, &del2) < zero) {
++(*ierr);
}
dsave = del2;
goto L50;
L42:
++(*ierr);
dsave = del2;
goto L50;
/* USE BRODLIE MODIFICATION OF BUTLAND FORMULA. */
L45:
hsumt3 = hsum + hsum + hsum;
w1 = (hsum + h1) / hsumt3;
w2 = (hsum + h2) / hsumt3;
/* Computing MAX */
r__1 = dabs(del1), r__2 = dabs(del2);
dmax__ = dmax(r__1,r__2);
/* Computing MIN */
r__1 = dabs(del1), r__2 = dabs(del2);
dmin__ = dmin(r__1,r__2);
drat1 = del1 / dmax__;
drat2 = del2 / dmax__;
d__[i__ * d_dim1 + 1] = dmin__ / (w1 * drat1 + w2 * drat2);
L50:
;
}
/* SET D(N) VIA NON-CENTERED THREE-POINT FORMULA, ADJUSTED TO BE */
/* SHAPE-PRESERVING. */
w1 = -h2 / hsum;
w2 = (h2 + hsum) / hsum;
d__[*n * d_dim1 + 1] = w1 * del1 + w2 * del2;
if (pchst_(&d__[*n * d_dim1 + 1], &del2) <= zero) {
d__[*n * d_dim1 + 1] = zero;
} else if (pchst_(&del1, &del2) < zero) {
/* NEED DO THIS CHECK ONLY IF MONOTONICITY SWITCHES. */
dmax__ = three * del2;
if ((r__1 = d__[*n * d_dim1 + 1], dabs(r__1)) > dabs(dmax__)) {
d__[*n * d_dim1 + 1] = dmax__;
}
}
/* NORMAL RETURN. */
L5000:
return 0;
/* ERROR RETURNS. */
L5001:
/* N.LT.2 RETURN. */
*ierr = -1;
xermsg_("SLATEC", "PCHIM", "NUMBER OF DATA POINTS LESS THAN TWO", ierr, &
c__1, (ftnlen)6, (ftnlen)5, (ftnlen)35);
return 0;
L5002:
/* INCFD.LT.1 RETURN. */
*ierr = -2;
xermsg_("SLATEC", "PCHIM", "INCREMENT LESS THAN ONE", ierr, &c__1, (
ftnlen)6, (ftnlen)5, (ftnlen)23);
return 0;
L5003:
/* X-ARRAY NOT STRICTLY INCREASING. */
*ierr = -3;
xermsg_("SLATEC", "PCHIM", "X-ARRAY NOT STRICTLY INCREASING", ierr, &c__1,
(ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
/* ------------- LAST LINE OF PCHIM FOLLOWS ------------------------------ */
} /* pchim_ */
/* DECK D1MACH */
doublereal d1mach_(integer *i__)
{
/* System generated locals */
doublereal ret_val;
static doublereal equiv_4[6];
/* Local variables */
#define log10 ((integer *)equiv_4 + 8)
#define dmach (equiv_4)
#define large ((integer *)equiv_4 + 2)
#define small ((integer *)equiv_4)
#define diver ((integer *)equiv_4 + 6)
#define right ((integer *)equiv_4 + 4)
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE D1MACH */
/* ***PURPOSE Return floating point machine dependent constants. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY R1 */
/* ***TYPE DOUBLE PRECISION (R1MACH-S, D1MACH-D) */
/* ***KEYWORDS MACHINE CONSTANTS */
/* ***AUTHOR Fox, P. A., (Bell Labs) */
/* Hall, A. D., (Bell Labs) */
/* Schryer, N. L., (Bell Labs) */
/* ***DESCRIPTION */
/* D1MACH can be used to obtain machine-dependent parameters for the */
/* local machine environment. It is a function subprogram with one */
/* (input) argument, and can be referenced as follows: */
/* D = D1MACH(I) */
/* where I=1,...,5. The (output) value of D above is determined by */
/* the (input) value of I. The results for various values of I are */
/* discussed below. */
/* D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. */
/* D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. */
/* D1MACH( 3) = B**(-T), the smallest relative spacing. */
/* D1MACH( 4) = B**(1-T), the largest relative spacing. */
/* D1MACH( 5) = LOG10(B) */
/* Assume double precision numbers are represented in the T-digit, */
/* base-B form */
/* sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) */
/* where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and */
/* EMIN .LE. E .LE. EMAX. */
/* The values of B, T, EMIN and EMAX are provided in I1MACH as */
/* follows: */
/* I1MACH(10) = B, the base. */
/* I1MACH(14) = T, the number of base-B digits. */
/* I1MACH(15) = EMIN, the smallest exponent E. */
/* I1MACH(16) = EMAX, the largest exponent E. */
/* To alter this function for a particular environment, the desired */
/* set of DATA statements should be activated by removing the C from */
/* column 1. Also, the values of D1MACH(1) - D1MACH(4) should be */
/* checked for consistency with the local operating system. */
/* ***REFERENCES P. A. Fox, A. D. Hall and N. L. Schryer, Framework for */
/* a portable library, ACM Transactions on Mathematical */
/* Software 4, 2 (June 1978), pp. 177-188. */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 DATE WRITTEN */
/* 890213 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) */
/* 900618 Added DEC RISC constants. (WRB) */
/* 900723 Added IBM RS 6000 constants. (WRB) */
/* 900911 Added SUN 386i constants. (WRB) */
/* 910710 Added HP 730 constants. (SMR) */
/* 911114 Added Convex IEEE constants. (WRB) */
/* 920121 Added SUN -r8 compiler option constants. (WRB) */
/* 920229 Added Touchstone Delta i860 constants. (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* 920625 Added CONVEX -p8 and -pd8 compiler option constants. */
/* (BKS, WRB) */
/* 930201 Added DEC Alpha and SGI constants. (RWC and WRB) */
/* ***END PROLOGUE D1MACH */
/* MACHINE CONSTANTS FOR THE AMIGA */
/* ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION */
/* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
/* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
/* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
/* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
/* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
/* MACHINE CONSTANTS FOR THE AMIGA */
/* ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT */
/* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
/* DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / */
/* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
/* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
/* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
/* MACHINE CONSTANTS FOR THE APOLLO */
/* DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / */
/* DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / */
/* DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / */
/* DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / */
/* DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / */
/* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM */
/* DATA SMALL(1) / ZC00800000 / */
/* DATA SMALL(2) / Z000000000 / */
/* DATA LARGE(1) / ZDFFFFFFFF / */
/* DATA LARGE(2) / ZFFFFFFFFF / */
/* DATA RIGHT(1) / ZCC5800000 / */
/* DATA RIGHT(2) / Z000000000 / */
/* DATA DIVER(1) / ZCC6800000 / */
/* DATA DIVER(2) / Z000000000 / */
/* DATA LOG10(1) / ZD00E730E7 / */
/* DATA LOG10(2) / ZC77800DC0 / */
/* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM */
/* DATA SMALL(1) / O1771000000000000 / */
/* DATA SMALL(2) / O0000000000000000 / */
/* DATA LARGE(1) / O0777777777777777 / */
/* DATA LARGE(2) / O0007777777777777 / */
/* DATA RIGHT(1) / O1461000000000000 / */
/* DATA RIGHT(2) / O0000000000000000 / */
/* DATA DIVER(1) / O1451000000000000 / */
/* DATA DIVER(2) / O0000000000000000 / */
/* DATA LOG10(1) / O1157163034761674 / */
/* DATA LOG10(2) / O0006677466732724 / */
/* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS */
/* DATA SMALL(1) / O1771000000000000 / */
/* DATA SMALL(2) / O7770000000000000 / */
/* DATA LARGE(1) / O0777777777777777 / */
/* DATA LARGE(2) / O7777777777777777 / */
/* DATA RIGHT(1) / O1461000000000000 / */
/* DATA RIGHT(2) / O0000000000000000 / */
/* DATA DIVER(1) / O1451000000000000 / */
/* DATA DIVER(2) / O0000000000000000 / */
/* DATA LOG10(1) / O1157163034761674 / */
/* DATA LOG10(2) / O0006677466732724 / */
/* MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE */
/* DATA SMALL(1) / Z"3001800000000000" / */
/* DATA SMALL(2) / Z"3001000000000000" / */
/* DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / */
/* DATA LARGE(2) / Z"4FFE000000000000" / */
/* DATA RIGHT(1) / Z"3FD2800000000000" / */
/* DATA RIGHT(2) / Z"3FD2000000000000" / */
/* DATA DIVER(1) / Z"3FD3800000000000" / */
/* DATA DIVER(2) / Z"3FD3000000000000" / */
/* DATA LOG10(1) / Z"3FFF9A209A84FBCF" / */
/* DATA LOG10(2) / Z"3FFFF7988F8959AC" / */
/* MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES */
/* DATA SMALL(1) / 00564000000000000000B / */
/* DATA SMALL(2) / 00000000000000000000B / */
/* DATA LARGE(1) / 37757777777777777777B / */
/* DATA LARGE(2) / 37157777777777777777B / */
/* DATA RIGHT(1) / 15624000000000000000B / */
/* DATA RIGHT(2) / 00000000000000000000B / */
/* DATA DIVER(1) / 15634000000000000000B / */
/* DATA DIVER(2) / 00000000000000000000B / */
/* DATA LOG10(1) / 17164642023241175717B / */
/* DATA LOG10(2) / 16367571421742254654B / */
/* MACHINE CONSTANTS FOR THE CELERITY C1260 */
/* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
/* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
/* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
/* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
/* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
/* MACHINE CONSTANTS FOR THE CONVEX */
/* USING THE -fn OR -pd8 COMPILER OPTION */
/* DATA DMACH(1) / Z'0010000000000000' / */
/* DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3CC0000000000000' / */
/* DATA DMACH(4) / Z'3CD0000000000000' / */
/* DATA DMACH(5) / Z'3FF34413509F79FF' / */
/* MACHINE CONSTANTS FOR THE CONVEX */
/* USING THE -fi COMPILER OPTION */
/* DATA DMACH(1) / Z'0010000000000000' / */
/* DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3CA0000000000000' / */
/* DATA DMACH(4) / Z'3CB0000000000000' / */
/* DATA DMACH(5) / Z'3FD34413509F79FF' / */
/* MACHINE CONSTANTS FOR THE CONVEX */
/* USING THE -p8 COMPILER OPTION */
/* DATA DMACH(1) / Z'00010000000000000000000000000000' / */
/* DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3F900000000000000000000000000000' / */
/* DATA DMACH(4) / Z'3F910000000000000000000000000000' / */
/* DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' / */
/* MACHINE CONSTANTS FOR THE CRAY */
/* DATA SMALL(1) / 201354000000000000000B / */
/* DATA SMALL(2) / 000000000000000000000B / */
/* DATA LARGE(1) / 577767777777777777777B / */
/* DATA LARGE(2) / 000007777777777777774B / */
/* DATA RIGHT(1) / 376434000000000000000B / */
/* DATA RIGHT(2) / 000000000000000000000B / */
/* DATA DIVER(1) / 376444000000000000000B / */
/* DATA DIVER(2) / 000000000000000000000B / */
/* DATA LOG10(1) / 377774642023241175717B / */
/* DATA LOG10(2) / 000007571421742254654B / */
/* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 */
/* NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - */
/* STATIC DMACH(5) */
/* DATA SMALL / 20K, 3*0 / */
/* DATA LARGE / 77777K, 3*177777K / */
/* DATA RIGHT / 31420K, 3*0 / */
/* DATA DIVER / 32020K, 3*0 / */
/* DATA LOG10 / 40423K, 42023K, 50237K, 74776K / */
/* MACHINE CONSTANTS FOR THE DEC ALPHA */
/* USING G_FLOAT */
/* DATA DMACH(1) / '0000000000000010'X / */
/* DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X / */
/* DATA DMACH(3) / '0000000000003CC0'X / */
/* DATA DMACH(4) / '0000000000003CD0'X / */
/* DATA DMACH(5) / '79FF509F44133FF3'X / */
/* MACHINE CONSTANTS FOR THE DEC ALPHA */
/* USING IEEE_FORMAT */
/* DATA DMACH(1) / '0010000000000000'X / */
/* DATA DMACH(2) / '7FEFFFFFFFFFFFFF'X / */
/* DATA DMACH(3) / '3CA0000000000000'X / */
/* DATA DMACH(4) / '3CB0000000000000'X / */
/* DATA DMACH(5) / '3FD34413509F79FF'X / */
/* MACHINE CONSTANTS FOR THE DEC RISC */
/* DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/ */
/* DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/ */
/* DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/ */
/* DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/ */
/* DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/ */
/* MACHINE CONSTANTS FOR THE DEC VAX */
/* USING D_FLOATING */
/* (EXPRESSED IN INTEGER AND HEXADECIMAL) */
/* THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS */
/* THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS */
/* DATA SMALL(1), SMALL(2) / 128, 0 / */
/* DATA LARGE(1), LARGE(2) / -32769, -1 / */
/* DATA RIGHT(1), RIGHT(2) / 9344, 0 / */
/* DATA DIVER(1), DIVER(2) / 9472, 0 / */
/* DATA LOG10(1), LOG10(2) / 546979738, -805796613 / */
/* DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / */
/* DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / */
/* DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / */
/* DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / */
/* DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / */
/* MACHINE CONSTANTS FOR THE DEC VAX */
/* USING G_FLOATING */
/* (EXPRESSED IN INTEGER AND HEXADECIMAL) */
/* THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS */
/* THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS */
/* DATA SMALL(1), SMALL(2) / 16, 0 / */
/* DATA LARGE(1), LARGE(2) / -32769, -1 / */
/* DATA RIGHT(1), RIGHT(2) / 15552, 0 / */
/* DATA DIVER(1), DIVER(2) / 15568, 0 / */
/* DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / */
/* DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / */
/* DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / */
/* DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / */
/* DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / */
/* DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / */
/* MACHINE CONSTANTS FOR THE ELXSI 6400 */
/* (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) */
/* DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / */
/* DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / */
/* DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / */
/* DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / */
/* DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / */
/* MACHINE CONSTANTS FOR THE HARRIS 220 */
/* DATA SMALL(1), SMALL(2) / '20000000, '00000201 / */
/* DATA LARGE(1), LARGE(2) / '37777777, '37777577 / */
/* DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / */
/* DATA DIVER(1), DIVER(2) / '20000000, '00000334 / */
/* DATA LOG10(1), LOG10(2) / '23210115, '10237777 / */
/* MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES */
/* DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / */
/* DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / */
/* DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / */
/* DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / */
/* DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / */
/* MACHINE CONSTANTS FOR THE HP 730 */
/* DATA DMACH(1) / Z'0010000000000000' / */
/* DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3CA0000000000000' / */
/* DATA DMACH(4) / Z'3CB0000000000000' / */
/* DATA DMACH(5) / Z'3FD34413509F79FF' / */
/* MACHINE CONSTANTS FOR THE HP 2100 */
/* THREE WORD DOUBLE PRECISION OPTION WITH FTN4 */
/* DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / */
/* DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / */
/* DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / */
/* DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / */
/* DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / */
/* MACHINE CONSTANTS FOR THE HP 2100 */
/* FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 */
/* DATA SMALL(1), SMALL(2) / 40000B, 0 / */
/* DATA SMALL(3), SMALL(4) / 0, 1 / */
/* DATA LARGE(1), LARGE(2) / 77777B, 177777B / */
/* DATA LARGE(3), LARGE(4) / 177777B, 177776B / */
/* DATA RIGHT(1), RIGHT(2) / 40000B, 0 / */
/* DATA RIGHT(3), RIGHT(4) / 0, 225B / */
/* DATA DIVER(1), DIVER(2) / 40000B, 0 / */
/* DATA DIVER(3), DIVER(4) / 0, 227B / */
/* DATA LOG10(1), LOG10(2) / 46420B, 46502B / */
/* DATA LOG10(3), LOG10(4) / 76747B, 176377B / */
/* MACHINE CONSTANTS FOR THE HP 9000 */
/* DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / */
/* DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / */
/* DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / */
/* DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / */
/* DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / */
/* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, */
/* THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND */
/* THE PERKIN ELMER (INTERDATA) 7/32. */
/* DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / */
/* DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / */
/* DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / */
/* DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / */
/* DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / */
/* MACHINE CONSTANTS FOR THE IBM PC */
/* ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION */
/* ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. */
/* DATA SMALL(1) / 2.23D-308 / */
/* DATA LARGE(1) / 1.79D+308 / */
/* DATA RIGHT(1) / 1.11D-16 / */
/* DATA DIVER(1) / 2.22D-16 / */
/* DATA LOG10(1) / 0.301029995663981195D0 / */
/* MACHINE CONSTANTS FOR THE IBM RS 6000 */
/* DATA DMACH(1) / Z'0010000000000000' / */
/* DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3CA0000000000000' / */
/* DATA DMACH(4) / Z'3CB0000000000000' / */
/* DATA DMACH(5) / Z'3FD34413509F79FF' / */
/* MACHINE CONSTANTS FOR THE INTEL i860 */
/* DATA DMACH(1) / Z'0010000000000000' / */
/* DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3CA0000000000000' / */
/* DATA DMACH(4) / Z'3CB0000000000000' / */
/* DATA DMACH(5) / Z'3FD34413509F79FF' / */
/* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) */
/* DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / */
/* DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / */
/* DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / */
/* DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / */
/* DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / */
/* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) */
/* DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / */
/* DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / */
/* DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / */
/* DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / */
/* DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / */
/* MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING */
/* 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). */
/* DATA SMALL(1), SMALL(2) / 8388608, 0 / */
/* DATA LARGE(1), LARGE(2) / 2147483647, -1 / */
/* DATA RIGHT(1), RIGHT(2) / 612368384, 0 / */
/* DATA DIVER(1), DIVER(2) / 620756992, 0 / */
/* DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / */
/* DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / */
/* DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / */
/* DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / */
/* DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / */
/* DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / */
/* MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING */
/* 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). */
/* DATA SMALL(1), SMALL(2) / 128, 0 / */
/* DATA SMALL(3), SMALL(4) / 0, 0 / */
/* DATA LARGE(1), LARGE(2) / 32767, -1 / */
/* DATA LARGE(3), LARGE(4) / -1, -1 / */
/* DATA RIGHT(1), RIGHT(2) / 9344, 0 / */
/* DATA RIGHT(3), RIGHT(4) / 0, 0 / */
/* DATA DIVER(1), DIVER(2) / 9472, 0 / */
/* DATA DIVER(3), DIVER(4) / 0, 0 / */
/* DATA LOG10(1), LOG10(2) / 16282, 8346 / */
/* DATA LOG10(3), LOG10(4) / -31493, -12296 / */
/* DATA SMALL(1), SMALL(2) / O000200, O000000 / */
/* DATA SMALL(3), SMALL(4) / O000000, O000000 / */
/* DATA LARGE(1), LARGE(2) / O077777, O177777 / */
/* DATA LARGE(3), LARGE(4) / O177777, O177777 / */
/* DATA RIGHT(1), RIGHT(2) / O022200, O000000 / */
/* DATA RIGHT(3), RIGHT(4) / O000000, O000000 / */
/* DATA DIVER(1), DIVER(2) / O022400, O000000 / */
/* DATA DIVER(3), DIVER(4) / O000000, O000000 / */
/* DATA LOG10(1), LOG10(2) / O037632, O020232 / */
/* DATA LOG10(3), LOG10(4) / O102373, O147770 / */
/* MACHINE CONSTANTS FOR THE SILICON GRAPHICS */
/* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
/* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
/* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
/* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
/* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
/* MACHINE CONSTANTS FOR THE SUN */
/* DATA DMACH(1) / Z'0010000000000000' / */
/* DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3CA0000000000000' / */
/* DATA DMACH(4) / Z'3CB0000000000000' / */
/* DATA DMACH(5) / Z'3FD34413509F79FF' / */
/* MACHINE CONSTANTS FOR THE SUN */
/* USING THE -r8 COMPILER OPTION */
/* DATA DMACH(1) / Z'00010000000000000000000000000000' / */
/* DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' / */
/* DATA DMACH(3) / Z'3F8E0000000000000000000000000000' / */
/* DATA DMACH(4) / Z'3F8F0000000000000000000000000000' / */
/* DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' / */
/* MACHINE CONSTANTS FOR THE SUN 386i */
/* DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' / */
/* DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' / */
/* DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' / */
/* DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF' */
/* DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' / */
/* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER */
/* DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / */
/* DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / */
/* DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / */
/* DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / */
/* DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / */
/* ***FIRST EXECUTABLE STATEMENT D1MACH */
if (*i__ < 1 || *i__ > 5) {
xermsg_("SLATEC", "D1MACH", "I OUT OF BOUNDS", &c__1, &c__2, (ftnlen)
6, (ftnlen)6, (ftnlen)15);
}
ret_val = dmach[*i__ - 1];
return ret_val;
} /* d1mach_ */
/* DECK CHU */
doublereal chu_(real *a, real *b, real *x)
{
/* Initialized data */
static real pi = 3.14159265358979324f;
static real eps = 0.f;
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
doublereal d__1, d__2;
/* Local variables */
static integer i__, m, n;
static real t, a0, b0, c0, xi, xn, xi1, sum;
extern doublereal gamr_(real *);
static real beps;
extern doublereal poch_(real *, real *);
static real alnx, pch1i;
extern doublereal poch1_(real *, real *), r9chu_(real *, real *, real *);
static real xeps1;
extern doublereal gamma_(real *);
static real aintb;
static integer istrt;
static real pch1ai;
extern doublereal r1mach_(integer *);
static real gamri1, pochai, gamrni, factor;
extern doublereal exprel_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real xtoeps;
/* ***BEGIN PROLOGUE CHU */
/* ***PURPOSE Compute the logarithmic confluent hypergeometric function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C11 */
/* ***TYPE SINGLE PRECISION (CHU-S, DCHU-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CHU computes the logarithmic confluent hypergeometric function, */
/* U(A,B,X). */
/* Input Parameters: */
/* A real */
/* B real */
/* X real and positive */
/* This routine is not valid when 1+A-B is close to zero if X is small. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU, */
/* XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770801 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) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CHU */
/* ***FIRST EXECUTABLE STATEMENT CHU */
if (eps == 0.f) {
eps = r1mach_(&c__3);
}
if (*x == 0.f) {
xermsg_("SLATEC", "CHU", "X IS ZERO SO CHU IS INFINITE", &c__1, &c__2,
(ftnlen)6, (ftnlen)3, (ftnlen)28);
}
if (*x < 0.f) {
xermsg_("SLATEC", "CHU", "X IS NEGATIVE, USE CCHU", &c__2, &c__2, (
ftnlen)6, (ftnlen)3, (ftnlen)23);
}
/* Computing MAX */
r__2 = dabs(*a);
/* Computing MAX */
r__3 = (r__1 = *a + 1.f - *b, dabs(r__1));
if (dmax(r__2,1.f) * dmax(r__3,1.f) < dabs(*x) * .99f) {
goto L120;
}
/* THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL */
/* APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. */
if ((r__1 = *a + 1.f - *b, dabs(r__1)) < sqrt(eps)) {
xermsg_("SLATEC", "CHU", "ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO F"
"OR SMALL X", &c__10, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
}
r__1 = *b + .5f;
aintb = r_int(&r__1);
if (*b < 0.f) {
r__1 = *b - .5f;
aintb = r_int(&r__1);
}
beps = *b - aintb;
n = aintb;
alnx = log(*x);
xtoeps = exp(-beps * alnx);
/* EVALUATE THE FINITE SUM. ----------------------------------------- */
if (n >= 1) {
goto L40;
}
/* CONSIDER THE CASE B .LT. 1.0 FIRST. */
sum = 1.f;
if (n == 0) {
goto L30;
}
t = 1.f;
m = -n;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi1 = (real) (i__ - 1);
t = t * (*a + xi1) * *x / ((*b + xi1) * (xi1 + 1.f));
sum += t;
/* L20: */
}
L30:
r__1 = *a + 1.f - *b;
r__2 = -(*a);
sum = poch_(&r__1, &r__2) * sum;
goto L70;
/* NOW CONSIDER THE CASE B .GE. 1.0. */
L40:
sum = 0.f;
m = n - 2;
if (m < 0) {
goto L70;
}
t = 1.f;
sum = 1.f;
if (m == 0) {
goto L60;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (real) i__;
t = t * (*a - *b + xi) * *x / ((1.f - *b + xi) * xi);
sum += t;
/* L50: */
}
L60:
r__1 = *b - 1.f;
i__1 = 1 - n;
sum = gamma_(&r__1) * gamr_(a) * pow_ri(x, &i__1) * xtoeps * sum;
/* NOW EVALUATE THE INFINITE SUM. ----------------------------------- */
L70:
istrt = 0;
if (n < 1) {
istrt = 1 - n;
}
xi = (real) istrt;
r__1 = *a + 1.f - *b;
factor = pow_ri(&c_b25, &n) * gamr_(&r__1) * pow_ri(x, &istrt);
if (beps != 0.f) {
factor = factor * beps * pi / sin(beps * pi);
}
pochai = poch_(a, &xi);
r__1 = xi + 1.f;
gamri1 = gamr_(&r__1);
r__1 = aintb + xi;
gamrni = gamr_(&r__1);
r__1 = xi - beps;
r__2 = xi + 1.f - beps;
b0 = factor * poch_(a, &r__1) * gamrni * gamr_(&r__2);
if ((r__1 = xtoeps - 1.f, dabs(r__1)) > .5f) {
goto L90;
}
/* X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING */
/* THE DIFFERENCES */
r__1 = *a + xi;
r__2 = -beps;
pch1ai = poch1_(&r__1, &r__2);
r__1 = xi + 1.f - beps;
pch1i = poch1_(&r__1, &beps);
r__1 = *b + xi;
r__2 = -beps;
c0 = factor * pochai * gamrni * gamri1 * (-poch1_(&r__1, &r__2) + pch1ai
- pch1i + beps * pch1ai * pch1i);
/* XEPS1 = (1.0 - X**(-BEPS)) / BEPS */
r__1 = -beps * alnx;
xeps1 = alnx * exprel_(&r__1);
ret_val = sum + c0 + xeps1 * b0;
xn = (real) n;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
b0 = (*a + xi1 - beps) * b0 * *x / ((xn + xi1) * (xi - beps));
c0 = (*a + xi1) * c0 * *x / ((*b + xi1) * xi) - ((*a - 1.f) * (xn +
xi * 2.f - 1.f) + xi * (xi - beps)) * b0 / (xi * (*b + xi1) *
(*a + xi1 - beps));
t = c0 + xeps1 * b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L80: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD */
/* FORMULATION IS STABLE. */
L90:
r__1 = *b + xi;
a0 = factor * pochai * gamr_(&r__1) * gamri1 / beps;
b0 = xtoeps * b0 / beps;
ret_val = sum + a0 - b0;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
a0 = (*a + xi1) * a0 * *x / ((*b + xi1) * xi);
b0 = (*a + xi1 - beps) * b0 * *x / ((aintb + xi1) * (xi - beps));
t = a0 - b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L100: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION. */
L120:
d__1 = (doublereal) (*x);
d__2 = (doublereal) (-(*a));
ret_val = pow_dd(&d__1, &d__2) * r9chu_(a, b, x);
L130:
return ret_val;
} /* chu_ */
/* DECK MPBLAS */
/* Subroutine */ int mpblas_(integer *i1)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
extern integer i1mach_(integer *);
static integer mpbexp;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE MPBLAS */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DQDOTA and DQDOTI */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (MPBLAS-A) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* This subroutine is called to set up Brent's 'mp' package */
/* for use by the extended precision inner products from the BLAS. */
/* In the SLATEC library we require the Extended Precision MP number */
/* to have a mantissa twice as long as Double Precision numbers. */
/* The calculation of MPT (and MPMXR which is the actual array size) */
/* in this routine will give 2x (or slightly more) on the machine */
/* that we are running on. The INTEGER array size of 30 was chosen */
/* to be slightly longer than the longest INTEGER array needed on */
/* any machine that we are currently aware of. */
/* ***SEE ALSO DQDOTA, DQDOTI */
/* ***REFERENCES R. P. Brent, A Fortran multiple-precision arithmetic */
/* package, ACM Transactions on Mathematical Software 4, */
/* 1 (March 1978), pp. 57-70. */
/* R. P. Brent, MP, a Fortran multiple-precision arithmetic */
/* package, Algorithm 524, ACM Transactions on Mathema- */
/* tical Software 4, 1 (March 1978), pp. 71-81. */
/* ***ROUTINES CALLED I1MACH, XERMSG */
/* ***COMMON BLOCKS MPCOM */
/* ***REVISION HISTORY (YYMMDD) */
/* 791001 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) */
/* 900402 Added TYPE section. (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* 930124 Increased Array size in MPCON for SUN -r8, and calculate */
/* size for Quad Precision for 2x DP. (RWC) */
/* ***END PROLOGUE MPBLAS */
/* ***FIRST EXECUTABLE STATEMENT MPBLAS */
*i1 = 1;
/* For full extended precision accuracy, MPB should be as large as */
/* possible, subject to the restrictions in Brent's paper. */
/* Statements below are for an integer wordlength of 48, 36, 32, */
/* 24, 18, and 16. Pick one, or generate a new one. */
/* 48 MPB = 4194304 */
/* 36 MPB = 65536 */
/* 32 MPB = 16384 */
/* 24 MPB = 1024 */
/* 18 MPB = 128 */
/* 16 MPB = 64 */
mpbexp = i1mach_(&c__8) / 2 - 2;
mpcom_1.mpb = pow_ii(&c__2, &mpbexp);
/* Set up remaining parameters */
/* UNIT FOR ERROR MESSAGES */
mpcom_1.mplun = i1mach_(&c__4);
/* NUMBER OF MP DIGITS */
mpcom_1.mpt = ((i1mach_(&c__14) << 1) + mpbexp - 1) / mpbexp;
/* DIMENSION OF R */
mpcom_1.mpmxr = mpcom_1.mpt + 4;
if (mpcom_1.mpmxr > 30) {
xermsg_("SLATEC", "MPBLAS", "Array space not sufficient for Quad Pre"
"cision 2x Double Precision, Proceeding.", &c__1, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)78);
mpcom_1.mpt = 26;
mpcom_1.mpmxr = 30;
}
/* EXPONENT RANGE */
/* Computing MIN */
i__1 = 32767, i__2 = i1mach_(&c__9) / 4 - 1;
mpcom_1.mpm = min(i__1,i__2);
return 0;
} /* mpblas_ */
/* DECK AI */
doublereal ai_(real *x)
{
/* Initialized data */
static real aifcs[9] = { -.0379713584966699975f,.05919188853726363857f,
9.8629280577279975e-4f,6.84884381907656e-6f,2.594202596219e-8f,
6.176612774e-11f,1.0092454e-13f,1.2014e-16f,1e-19f };
static real aigcs[8] = { .01815236558116127f,.02157256316601076f,
2.5678356987483e-4f,1.42652141197e-6f,4.57211492e-9f,9.52517e-12f,
1.392e-14f,1e-17f };
static logical first = TRUE_;
/* System generated locals */
real ret_val, r__1;
doublereal d__1;
/* Local variables */
static real z__, xm;
extern doublereal aie_(real *);
static integer naif, naig;
static real xmax, x3sml, theta;
extern doublereal csevl_(real *, real *, integer *);
extern integer inits_(real *, integer *, real *);
static real xmaxt;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int r9aimp_(real *, real *, real *), xermsg_(char
*, char *, char *, integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE AI */
/* ***PURPOSE Evaluate the Airy function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C10D */
/* ***TYPE SINGLE PRECISION (AI-S, DAI-D) */
/* ***KEYWORDS AIRY FUNCTION, FNLIB, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* AI(X) computes the Airy function Ai(X) */
/* Series for AIF on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.09E-19 */
/* log weighted error 18.96 */
/* significant figures required 17.76 */
/* decimal places required 19.44 */
/* Series for AIG on the interval -1.00000D+00 to 1.00000D+00 */
/* with weighted error 1.51E-17 */
/* log weighted error 16.82 */
/* significant figures required 15.19 */
/* decimal places required 17.27 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED AIE, CSEVL, INITS, R1MACH, R9AIMP, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920618 Removed space from variable names. (RWC, WRB) */
/* ***END PROLOGUE AI */
/* ***FIRST EXECUTABLE STATEMENT AI */
if (first) {
r__1 = r1mach_(&c__3) * .1f;
naif = inits_(aifcs, &c__9, &r__1);
r__1 = r1mach_(&c__3) * .1f;
naig = inits_(aigcs, &c__8, &r__1);
d__1 = (doublereal) r1mach_(&c__3);
x3sml = pow_dd(&d__1, &c_b7);
d__1 = (doublereal) (log(r1mach_(&c__1)) * -1.5f);
xmaxt = pow_dd(&d__1, &c_b9);
xmax = xmaxt - xmaxt * log(xmaxt) / (sqrt(xmaxt) * 4.f + 1.f) - .01f;
}
first = FALSE_;
if (*x >= -1.f) {
goto L20;
}
r9aimp_(x, &xm, &theta);
ret_val = xm * cos(theta);
return ret_val;
L20:
if (*x > 1.f) {
goto L30;
}
z__ = 0.f;
if (dabs(*x) > x3sml) {
/* Computing 3rd power */
r__1 = *x;
z__ = r__1 * (r__1 * r__1);
}
ret_val = csevl_(&z__, aifcs, &naif) - *x * (csevl_(&z__, aigcs, &naig) +
.25f) + .375f;
return ret_val;
L30:
if (*x > xmax) {
goto L40;
}
ret_val = aie_(x) * exp(*x * -2.f * sqrt(*x) / 3.f);
return ret_val;
L40:
ret_val = 0.f;
xermsg_("SLATEC", "AI", "X SO BIG AI UNDERFLOWS", &c__1, &c__1, (ftnlen)6,
(ftnlen)2, (ftnlen)22);
return ret_val;
} /* ai_ */
/* DECK D9LGMC */
doublereal d9lgmc_(doublereal *x)
{
/* Initialized data */
static doublereal algmcs[15] = { .1666389480451863247205729650822,
-1.384948176067563840732986059135e-5,
9.810825646924729426157171547487e-9,
-1.809129475572494194263306266719e-11,
6.221098041892605227126015543416e-14,
-3.399615005417721944303330599666e-16,
2.683181998482698748957538846666e-18,
-2.868042435334643284144622399999e-20,
3.962837061046434803679306666666e-22,
-6.831888753985766870111999999999e-24,
1.429227355942498147573333333333e-25,
-3.547598158101070547199999999999e-27,1.025680058010470912e-28,
-3.401102254316748799999999999999e-30,
1.276642195630062933333333333333e-31 };
static logical first = TRUE_;
/* System generated locals */
real r__1;
doublereal ret_val, d__1, d__2;
/* Local variables */
static doublereal xbig, xmax;
static integer nalgm;
extern doublereal d1mach_(integer *), dcsevl_(doublereal *, doublereal *,
integer *);
extern integer initds_(doublereal *, integer *, real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE D9LGMC */
/* ***SUBSIDIARY */
/* ***PURPOSE Compute the log Gamma correction factor so that */
/* LOG(DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-5.)*LOG(X) - X */
/* + D9LGMC(X). */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7E */
/* ***TYPE DOUBLE PRECISION (R9LGMC-S, D9LGMC-D, C9LGMC-C) */
/* ***KEYWORDS COMPLETE GAMMA FUNCTION, CORRECTION TERM, FNLIB, */
/* LOG GAMMA, LOGARITHM, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* Compute the log gamma correction factor for X .GE. 10. so that */
/* LOG (DGAMMA(X)) = LOG(SQRT(2*PI)) + (X-.5)*LOG(X) - X + D9lGMC(X) */
/* Series for ALGM on the interval 0. to 1.00000E-02 */
/* with weighted error 1.28E-31 */
/* log weighted error 30.89 */
/* significant figures required 29.81 */
/* decimal places required 31.48 */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED D1MACH, DCSEVL, INITDS, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770601 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) */
/* 900720 Routine changed from user-callable to subsidiary. (WRB) */
/* ***END PROLOGUE D9LGMC */
/* ***FIRST EXECUTABLE STATEMENT D9LGMC */
if (first) {
r__1 = (real) d1mach_(&c__3);
nalgm = initds_(algmcs, &c__15, &r__1);
xbig = 1. / sqrt(d1mach_(&c__3));
/* Computing MIN */
d__1 = log(d1mach_(&c__2) / 12.), d__2 = -log(d1mach_(&c__1) * 12.);
xmax = exp((min(d__1,d__2)));
}
first = FALSE_;
if (*x < 10.) {
xermsg_("SLATEC", "D9LGMC", "X MUST BE GE 10", &c__1, &c__2, (ftnlen)
6, (ftnlen)6, (ftnlen)15);
}
if (*x >= xmax) {
goto L20;
}
ret_val = 1. / (*x * 12.);
if (*x < xbig) {
/* Computing 2nd power */
d__2 = 10. / *x;
d__1 = d__2 * d__2 * 2. - 1.;
ret_val = dcsevl_(&d__1, algmcs, &nalgm) / *x;
}
return ret_val;
L20:
ret_val = 0.;
xermsg_("SLATEC", "D9LGMC", "X SO BIG D9LGMC UNDERFLOWS", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)26);
return ret_val;
} /* d9lgmc_ */
/* DECK IPPERM */
/* Subroutine */ int ipperm_(integer *ix, integer *n, integer *iperm, integer
*ier)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer i__, indx, indx0, itemp, istrt;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE IPPERM */
/* ***PURPOSE Rearrange a given array according to a prescribed */
/* permutation vector. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY N8 */
/* ***TYPE INTEGER (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H) */
/* ***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR */
/* ***AUTHOR McClain, M. A., (NIST) */
/* Rhoads, G. S., (NBS) */
/* ***DESCRIPTION */
/* IPPERM rearranges the data vector IX according to the */
/* permutation IPERM: IX(I) <--- IX(IPERM(I)). IPERM could come */
/* from one of the sorting routines IPSORT, SPSORT, DPSORT or */
/* HPSORT. */
/* Description of Parameters */
/* IX - input/output -- integer array of values to be rearranged. */
/* N - input -- number of values in integer array IX. */
/* IPERM - input -- permutation vector. */
/* IER - output -- error indicator: */
/* = 0 if no error, */
/* = 1 if N is zero or negative, */
/* = 2 if IPERM is not a valid permutation. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 900618 DATE WRITTEN */
/* 920507 Modified by M. McClain to revise prologue text. */
/* ***END PROLOGUE IPPERM */
/* ***FIRST EXECUTABLE STATEMENT IPPERM */
/* Parameter adjustments */
--iperm;
--ix;
/* Function Body */
*ier = 0;
if (*n < 1) {
*ier = 1;
xermsg_("SLATEC", "IPPERM", "The number of values to be rearranged, "
"N, is not positive.", ier, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)58);
return 0;
}
/* CHECK WHETHER IPERM IS A VALID PERMUTATION */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
indx = (i__2 = iperm[i__], abs(i__2));
if (indx >= 1 && indx <= *n) {
if (iperm[indx] > 0) {
iperm[indx] = -iperm[indx];
goto L100;
}
}
*ier = 2;
xermsg_("SLATEC", "IPPERM", "The permutation vector, IPERM, is not v"
"alid.", ier, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)44);
return 0;
L100:
;
}
/* REARRANGE THE VALUES OF IX */
/* USE THE IPERM VECTOR AS A FLAG. */
/* IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION */
i__1 = *n;
for (istrt = 1; istrt <= i__1; ++istrt) {
if (iperm[istrt] > 0) {
goto L330;
}
indx = istrt;
indx0 = indx;
itemp = ix[istrt];
L320:
if (iperm[indx] >= 0) {
goto L325;
}
ix[indx] = ix[-iperm[indx]];
indx0 = indx;
iperm[indx] = -iperm[indx];
indx = iperm[indx];
goto L320;
L325:
ix[indx0] = itemp;
L330:
;
}
return 0;
} /* ipperm_ */
/* DECK SGEIR */
/* Subroutine */ int sgeir_(real *a, integer *lda, integer *n, real *v,
integer *itask, integer *ind, real *work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer a_dim1, a_offset, work_dim1, work_offset, i__1[4], i__2[3], i__3;
real r__1, r__2, r__3;
char ch__1[40], ch__2[27], ch__3[31];
/* Local variables */
static integer j, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int sgefa_(real *, integer *, integer *, integer *
, integer *), sgesl_(real *, integer *, integer *, integer *,
real *, integer *);
static real dnorm;
extern doublereal sasum_(integer *, real *, integer *);
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
static real xnorm;
extern doublereal r1mach_(integer *), sdsdot_(integer *, real *, real *,
integer *, real *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE SGEIR */
/* ***PURPOSE Solve a general system of linear equations. Iterative */
/* refinement is used to obtain an error estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2A1 */
/* ***TYPE SINGLE PRECISION (SGEIR-S, CGEIR-C) */
/* ***KEYWORDS COMPLEX LINEAR EQUATIONS, GENERAL MATRIX, */
/* GENERAL SYSTEM OF LINEAR EQUATIONS */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine SGEIR solves a general NxN system of single */
/* precision linear equations using LINPACK subroutines SGEFA and */
/* SGESL. One pass of iterative refinement is used only to obtain */
/* an estimate of the accuracy. That is, if A is an NxN real */
/* matrix and if X and B are real N-vectors, then SGEIR solves */
/* the equation */
/* A*X=B. */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to calculate */
/* the solution, X. Then the residual vector is found and */
/* used to calculate an estimate of the relative error, IND. */
/* IND estimates the accuracy of the solution only when the */
/* input matrix and the right hand side are represented */
/* exactly in the computer and does not take into account */
/* any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to solve only (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, */
/* LDA, N, WORK, and IWORK must not have been altered by the */
/* user following factorization (ITASK=1). IND will not be */
/* changed by SGEIR in this case. */
/* Argument Description *** */
/* A REAL(LDA,N) */
/* the doubly subscripted array with dimension (LDA,N) */
/* which contains the coefficient matrix. A is not */
/* altered by the routine. */
/* LDA INTEGER */
/* the leading dimension of the array A. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. The first N elements of */
/* the array A are the elements of the first column of */
/* matrix A. N must be greater than or equal to 1. */
/* (terminal error message IND=-2) */
/* V REAL(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* If ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* If ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A (stored in WORK). */
/* If ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X. IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK REAL(N*(N+1)) */
/* a singly subscripted array of dimension at least N*(N+1). */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than one. */
/* IND=-3 terminal ITASK is less than one. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* Note- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED R1MACH, SASUM, SCOPY, SDSDOT, SGEFA, SGESL, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800430 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 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 SGEIR */
/* ***FIRST EXECUTABLE STATEMENT SGEIR */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "SGEIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "SGEIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "SGEIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*itask == 1) {
/* MOVE MATRIX A TO WORK */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
scopy_(n, &a[j * a_dim1 + 1], &c__1, &work[j * work_dim1 + 1], &
c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
sgefa_(&work[work_offset], n, n, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "SGEIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
scopy_(n, &v[1], &c__1, &work[(*n + 1) * work_dim1 + 1], &c__1);
sgesl_(&work[work_offset], n, n, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = sasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
r__1 = -work[j + (*n + 1) * work_dim1];
work[j + (*n + 1) * work_dim1] = sdsdot_(n, &r__1, &a[j + a_dim1],
lda, &v[1], &c__1);
/* L40: */
}
/* SOLVE A*DELTA=R */
sgesl_(&work[work_offset], n, n, &iwork[1], &work[(*n + 1) * work_dim1 +
1], &c__0);
/* FORM NORM OF DELTA */
dnorm = sasum_(n, &work[(*n + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "SGEIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* sgeir_ */
/* DECK CNBIR */
/* Subroutine */ int cnbir_(complex *abe, integer *lda, integer *n, integer *
ml, integer *mu, complex *v, integer *itask, integer *ind, complex *
work, integer *iwork)
{
/* System generated locals */
address a__1[4], a__2[3];
integer abe_dim1, abe_offset, work_dim1, work_offset, i__1[4], i__2[3],
i__3, i__4, i__5;
real r__1, r__2, r__3;
complex q__1, q__2;
char ch__1[40], ch__2[27], ch__3[31], ch__4[29];
/* Local variables */
static integer j, k, l, m, nc, kk, info;
static char xern1[8], xern2[8];
extern /* Subroutine */ int cnbfa_(complex *, integer *, integer *,
integer *, integer *, integer *, integer *), cnbsl_(complex *,
integer *, integer *, integer *, integer *, integer *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
static real dnorm, xnorm;
extern doublereal r1mach_(integer *);
extern /* Complex */ void cdcdot_(complex *, integer *, complex *,
complex *, integer *, complex *, integer *);
extern doublereal scasum_(integer *, complex *, integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE CNBIR */
/* ***PURPOSE Solve a general nonsymmetric banded system of linear */
/* equations. Iterative refinement is used to obtain an error */
/* estimate. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY D2C2 */
/* ***TYPE COMPLEX (SNBIR-S, CNBIR-C) */
/* ***KEYWORDS BANDED, LINEAR EQUATIONS, NONSYMMETRIC */
/* ***AUTHOR Voorhees, E. A., (LANL) */
/* ***DESCRIPTION */
/* Subroutine CNBIR solves a general nonsymmetric banded NxN */
/* system of single precision complex linear equations using */
/* SLATEC subroutines CNBFA and CNBSL. These are adaptations */
/* of the LINPACK subroutines CGBFA and CGBSL which require */
/* a different format for storing the matrix elements. */
/* One pass of iterative refinement is used only to obtain an */
/* estimate of the accuracy. If A is an NxN complex banded */
/* matrix and if X and B are complex N-vectors, then CNBIR */
/* solves the equation */
/* A*X=B. */
/* A band matrix is a matrix whose nonzero elements are all */
/* fairly near the main diagonal, specifically A(I,J) = 0 */
/* if I-J is greater than ML or J-I is greater than */
/* MU . The integers ML and MU are called the lower and upper */
/* band widths and M = ML+MU+1 is the total band width. */
/* CNBIR uses less time and storage than the corresponding */
/* program for general matrices (CGEIR) if 2*ML+MU .LT. N . */
/* The matrix A is first factored into upper and lower tri- */
/* angular matrices U and L using partial pivoting. These */
/* factors and the pivoting information are used to find the */
/* solution vector X . Then the residual vector is found and used */
/* to calculate an estimate of the relative error, IND . IND esti- */
/* mates the accuracy of the solution only when the input matrix */
/* and the right hand side are represented exactly in the computer */
/* and does not take into account any errors in the input data. */
/* If the equation A*X=B is to be solved for more than one vector */
/* B, the factoring of A does not need to be performed again and */
/* the option to only solve (ITASK .GT. 1) will be faster for */
/* the succeeding solutions. In this case, the contents of A, LDA, */
/* N, WORK and IWORK must not have been altered by the user follow- */
/* ing factorization (ITASK=1). IND will not be changed by CNBIR */
/* in this case. */
/* Band Storage */
/* If A is a band matrix, the following program segment */
/* will set up the input. */
/* ML = (band width below the diagonal) */
/* MU = (band width above the diagonal) */
/* DO 20 I = 1, N */
/* J1 = MAX(1, I-ML) */
/* J2 = MIN(N, I+MU) */
/* DO 10 J = J1, J2 */
/* K = J - I + ML + 1 */
/* ABE(I,K) = A(I,J) */
/* 10 CONTINUE */
/* 20 CONTINUE */
/* This uses columns 1 through ML+MU+1 of ABE . */
/* Example: If the original matrix is */
/* 11 12 13 0 0 0 */
/* 21 22 23 24 0 0 */
/* 0 32 33 34 35 0 */
/* 0 0 43 44 45 46 */
/* 0 0 0 54 55 56 */
/* 0 0 0 0 65 66 */
/* then N = 6, ML = 1, MU = 2, LDA .GE. 5 and ABE should contain */
/* * 11 12 13 , * = not used */
/* 21 22 23 24 */
/* 32 33 34 35 */
/* 43 44 45 46 */
/* 54 55 56 * */
/* 65 66 * * */
/* Argument Description *** */
/* ABE COMPLEX(LDA,MM) */
/* on entry, contains the matrix in band storage as */
/* described above. MM must not be less than M = */
/* ML+MU+1 . The user is cautioned to dimension ABE */
/* with care since MM is not an argument and cannot */
/* be checked by CNBIR. The rows of the original */
/* matrix are stored in the rows of ABE and the */
/* diagonals of the original matrix are stored in */
/* columns 1 through ML+MU+1 of ABE . ABE is */
/* not altered by the program. */
/* LDA INTEGER */
/* the leading dimension of array ABE. LDA must be great- */
/* er than or equal to N. (terminal error message IND=-1) */
/* N INTEGER */
/* the order of the matrix A. N must be greater */
/* than or equal to 1 . (terminal error message IND=-2) */
/* ML INTEGER */
/* the number of diagonals below the main diagonal. */
/* ML must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-5) */
/* MU INTEGER */
/* the number of diagonals above the main diagonal. */
/* MU must not be less than zero nor greater than or */
/* equal to N . (terminal error message IND=-6) */
/* V COMPLEX(N) */
/* on entry, the singly subscripted array(vector) of di- */
/* mension N which contains the right hand side B of a */
/* system of simultaneous linear equations A*X=B. */
/* on return, V contains the solution vector, X . */
/* ITASK INTEGER */
/* if ITASK=1, the matrix A is factored and then the */
/* linear equation is solved. */
/* if ITASK .GT. 1, the equation is solved using the existing */
/* factored matrix A and IWORK. */
/* if ITASK .LT. 1, then terminal error message IND=-3 is */
/* printed. */
/* IND INTEGER */
/* GT. 0 IND is a rough estimate of the number of digits */
/* of accuracy in the solution, X . IND=75 means */
/* that the solution vector X is zero. */
/* LT. 0 see error message corresponding to IND below. */
/* WORK COMPLEX(N*(NC+1)) */
/* a singly subscripted array of dimension at least */
/* N*(NC+1) where NC = 2*ML+MU+1 . */
/* IWORK INTEGER(N) */
/* a singly subscripted array of dimension at least N. */
/* Error Messages Printed *** */
/* IND=-1 terminal N is greater than LDA. */
/* IND=-2 terminal N is less than 1. */
/* IND=-3 terminal ITASK is less than 1. */
/* IND=-4 terminal The matrix A is computationally singular. */
/* A solution has not been computed. */
/* IND=-5 terminal ML is less than zero or is greater than */
/* or equal to N . */
/* IND=-6 terminal MU is less than zero or is greater than */
/* or equal to N . */
/* IND=-10 warning The solution has no apparent significance. */
/* The solution may be inaccurate or the matrix */
/* A may be poorly scaled. */
/* NOTE- The above terminal(*fatal*) error messages are */
/* designed to be handled by XERMSG in which */
/* LEVEL=1 (recoverable) and IFLAG=2 . LEVEL=0 */
/* for warning error messages from XERMSG. Unless */
/* the user provides otherwise, an error message */
/* will be printed followed by an abort. */
/* ***REFERENCES J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W. */
/* Stewart, LINPACK Users' Guide, SIAM, 1979. */
/* ***ROUTINES CALLED CCOPY, CDCDOT, CNBFA, CNBSL, R1MACH, SCASUM, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800819 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 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, cvt GOTO's to */
/* IF-THEN-ELSE. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE CNBIR */
/* ***FIRST EXECUTABLE STATEMENT CNBIR */
/* Parameter adjustments */
abe_dim1 = *lda;
abe_offset = 1 + abe_dim1;
abe -= abe_offset;
work_dim1 = *n;
work_offset = 1 + work_dim1;
work -= work_offset;
--v;
--iwork;
/* Function Body */
if (*lda < *n) {
*ind = -1;
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*lda), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 6, a__1[0] = "LDA = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " IS LESS THAN N = ";
i__1[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__1, &c__4, (ftnlen)40);
xermsg_("SLATEC", "CNBIR", ch__1, &c_n1, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)40);
return 0;
}
if (*n <= 0) {
*ind = -2;
s_wsfi(&io___5);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 4, a__2[0] = "N = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__2, a__2, i__2, &c__3, (ftnlen)27);
xermsg_("SLATEC", "CNBIR", ch__2, &c_n2, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)27);
return 0;
}
if (*itask < 1) {
*ind = -3;
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*itask), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 8, a__2[0] = "ITASK = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 15, a__2[2] = " IS LESS THAN 1";
s_cat(ch__3, a__2, i__2, &c__3, (ftnlen)31);
xermsg_("SLATEC", "CNBIR", ch__3, &c_n3, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)31);
return 0;
}
if (*ml < 0 || *ml >= *n) {
*ind = -5;
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*ml), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "ML = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n5, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
if (*mu < 0 || *mu >= *n) {
*ind = -6;
s_wsfi(&io___8);
do_fio(&c__1, (char *)&(*mu), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 5, a__2[0] = "MU = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 16, a__2[2] = " IS OUT OF RANGE";
s_cat(ch__4, a__2, i__2, &c__3, (ftnlen)29);
xermsg_("SLATEC", "CNBIR", ch__4, &c_n6, &c__1, (ftnlen)6, (ftnlen)5,
(ftnlen)29);
return 0;
}
nc = (*ml << 1) + *mu + 1;
if (*itask == 1) {
/* MOVE MATRIX ABE TO WORK */
m = *ml + *mu + 1;
i__3 = m;
for (j = 1; j <= i__3; ++j) {
ccopy_(n, &abe[j * abe_dim1 + 1], &c__1, &work[j * work_dim1 + 1],
&c__1);
/* L10: */
}
/* FACTOR MATRIX A INTO LU */
cnbfa_(&work[work_offset], n, n, ml, mu, &iwork[1], &info);
/* CHECK FOR COMPUTATIONALLY SINGULAR MATRIX */
if (info != 0) {
*ind = -4;
xermsg_("SLATEC", "CNBIR", "SINGULAR MATRIX A - NO SOLUTION", &
c_n4, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
}
}
/* SOLVE WHEN FACTORING COMPLETE */
/* MOVE VECTOR B TO WORK */
ccopy_(n, &v[1], &c__1, &work[(nc + 1) * work_dim1 + 1], &c__1);
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &v[1], &c__0);
/* FORM NORM OF X0 */
xnorm = scasum_(n, &v[1], &c__1);
if (xnorm == 0.f) {
*ind = 75;
return 0;
}
/* COMPUTE RESIDUAL */
i__3 = *n;
for (j = 1; j <= i__3; ++j) {
/* Computing MAX */
i__4 = 1, i__5 = *ml + 2 - j;
k = max(i__4,i__5);
/* Computing MAX */
i__4 = 1, i__5 = j - *ml;
kk = max(i__4,i__5);
/* Computing MIN */
i__4 = j - 1;
/* Computing MIN */
i__5 = *n - j;
l = min(i__4,*ml) + min(i__5,*mu) + 1;
i__4 = j + (nc + 1) * work_dim1;
i__5 = j + (nc + 1) * work_dim1;
q__2.r = -work[i__5].r, q__2.i = -work[i__5].i;
cdcdot_(&q__1, &l, &q__2, &abe[j + k * abe_dim1], lda, &v[kk], &c__1);
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L40: */
}
/* SOLVE A*DELTA=R */
cnbsl_(&work[work_offset], n, n, ml, mu, &iwork[1], &work[(nc + 1) *
work_dim1 + 1], &c__0);
/* FORM NORM OF DELTA */
dnorm = scasum_(n, &work[(nc + 1) * work_dim1 + 1], &c__1);
/* COMPUTE IND (ESTIMATE OF NO. OF SIGNIFICANT DIGITS) */
/* AND CHECK FOR IND GREATER THAN ZERO */
/* Computing MAX */
r__2 = r1mach_(&c__4), r__3 = dnorm / xnorm;
r__1 = dmax(r__2,r__3);
*ind = -r_lg10(&r__1);
if (*ind <= 0) {
*ind = -10;
xermsg_("SLATEC", "CNBIR", "SOLUTION MAY HAVE NO SIGNIFICANCE", &
c_n10, &c__0, (ftnlen)6, (ftnlen)5, (ftnlen)33);
}
return 0;
} /* cnbir_ */
/* DECK DPLPDM */
/* Subroutine */ int dplpdm_(integer *mrelas, integer *nvars__, integer *lmx,
integer *lbm, integer *nredc, integer *info, integer *iopt, integer *
ibasis, integer *imat, integer *ibrc, integer *ipr, integer *iwr,
integer *ind, integer *ibb, doublereal *anorm, doublereal *eps,
doublereal *uu, doublereal *gg, doublereal *amat, doublereal *basmat,
doublereal *csc, doublereal *wr, logical *singlr, logical *redbas)
{
/* System generated locals */
address a__1[2];
integer ibrc_dim1, ibrc_offset, i__1, i__2[2];
char ch__1[55];
/* Local variables */
static integer i__, j, k;
static doublereal aij, one;
static integer nzbm;
static doublereal zero;
static char xern3[16];
extern /* Subroutine */ int la05ad_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *, doublereal *,
doublereal *, doublereal *);
extern doublereal dasum_(integer *, doublereal *, integer *);
static integer iplace;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), dpnnzr_(integer *, doublereal
*, integer *, doublereal *, integer *, integer *);
/* Fortran I/O blocks */
static icilist io___10 = { 0, xern3, 0, "(1PE15.6)", 16, 1 };
/* ***BEGIN PROLOGUE DPLPDM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SPLPDM-S, DPLPDM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* THIS SUBPROGRAM IS FROM THE DSPLP( ) PACKAGE. IT PERFORMS THE */
/* TASK OF DEFINING THE ENTRIES OF THE BASIS MATRIX AND */
/* DECOMPOSING IT USING THE LA05 PACKAGE. */
/* IT IS THE MAIN PART OF THE PROCEDURE (DECOMPOSE BASIS MATRIX). */
/* ***SEE ALSO DSPLP */
/* ***ROUTINES CALLED DASUM, DPNNZR, LA05AD, XERMSG */
/* ***COMMON BLOCKS LA05DD */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 890605 Added DASUM to list of DOUBLE PRECISION variables. */
/* 890605 Removed unreferenced labels. (WRB) */
/* 891009 Removed unreferenced variable. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls, convert do-it-yourself */
/* DO loops to DO loops. (RWC) */
/* ***END PROLOGUE DPLPDM */
/* COMMON BLOCK USED BY LA05 () PACKAGE.. */
/* ***FIRST EXECUTABLE STATEMENT DPLPDM */
/* Parameter adjustments */
ibrc_dim1 = *lbm;
ibrc_offset = 1 + ibrc_dim1;
ibrc -= ibrc_offset;
--ibasis;
--imat;
--ipr;
--iwr;
--ind;
--ibb;
--amat;
--basmat;
--csc;
--wr;
/* Function Body */
zero = 0.;
one = 1.;
/* DEFINE BASIS MATRIX BY COLUMNS FOR SPARSE MATRIX EQUATION SOLVER. */
/* THE LA05AD() SUBPROGRAM REQUIRES THE NONZERO ENTRIES OF THE MATRIX */
/* TOGETHER WITH THE ROW AND COLUMN INDICES. */
nzbm = 0;
/* DEFINE DEPENDENT VARIABLE COLUMNS. THESE ARE */
/* COLS. OF THE IDENTITY MATRIX AND IMPLICITLY GENERATED. */
i__1 = *mrelas;
for (k = 1; k <= i__1; ++k) {
j = ibasis[k];
if (j > *nvars__) {
++nzbm;
if (ind[j] == 2) {
basmat[nzbm] = one;
} else {
basmat[nzbm] = -one;
}
ibrc[nzbm + ibrc_dim1] = j - *nvars__;
ibrc[nzbm + (ibrc_dim1 << 1)] = k;
} else {
/* DEFINE THE INDEP. VARIABLE COLS. THIS REQUIRES RETRIEVING */
/* THE COLS. FROM THE SPARSE MATRIX DATA STRUCTURE. */
i__ = 0;
L10:
dpnnzr_(&i__, &aij, &iplace, &amat[1], &imat[1], &j);
if (i__ > 0) {
++nzbm;
basmat[nzbm] = aij * csc[j];
ibrc[nzbm + ibrc_dim1] = i__;
ibrc[nzbm + (ibrc_dim1 << 1)] = k;
goto L10;
}
}
/* L20: */
}
*singlr = FALSE_;
/* RECOMPUTE MATRIX NORM USING CRUDE NORM = SUM OF MAGNITUDES. */
*anorm = dasum_(&nzbm, &basmat[1], &c__1);
la05dd_1.small = *eps * *anorm;
/* GET AN L-U FACTORIZATION OF THE BASIS MATRIX. */
++(*nredc);
*redbas = TRUE_;
la05ad_(&basmat[1], &ibrc[ibrc_offset], &nzbm, lbm, mrelas, &ipr[1], &iwr[
1], &wr[1], gg, uu);
/* CHECK RETURN VALUE OF ERROR FLAG, GG. */
if (*gg >= zero) {
return 0;
}
if (*gg == -7.f) {
xermsg_("SLATEC", "DPLPDM", "IN DSPLP, SHORT ON STORAGE FOR LA05AD. "
" USE PRGOPT(*) TO GIVE MORE.", &c__28, iopt, (ftnlen)6, (
ftnlen)6, (ftnlen)67);
*info = -28;
} else if (*gg == -5.f) {
*singlr = TRUE_;
} else {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&(*gg), (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__1[0] = "IN DSPLP, LA05AD RETURNED ERROR FLAG = ";
i__2[1] = 16, a__1[1] = xern3;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)55);
xermsg_("SLATEC", "DPLPDM", ch__1, &c__27, iopt, (ftnlen)6, (ftnlen)6,
(ftnlen)55);
*info = -27;
}
return 0;
} /* dplpdm_ */
/* DECK ISORT */
/* Subroutine */ int isort_(integer *ix, integer *iy, integer *n, integer *
kflag)
{
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__, j, k, l, m;
static real r__;
static integer t, ij, il[21], kk, nn, iu[21], tt, ty, tty;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE ISORT */
/* ***PURPOSE Sort an array and optionally make the same interchanges in */
/* an auxiliary array. The array may be sorted in increasing */
/* or decreasing order. A slightly modified QUICKSORT */
/* algorithm is used. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY N6A2A */
/* ***TYPE INTEGER (SSORT-S, DSORT-D, ISORT-I) */
/* ***KEYWORDS SINGLETON QUICKSORT, SORT, SORTING */
/* ***AUTHOR Jones, R. E., (SNLA) */
/* Kahaner, D. K., (NBS) */
/* Wisniewski, J. A., (SNLA) */
/* ***DESCRIPTION */
/* ISORT sorts array IX and optionally makes the same interchanges in */
/* array IY. The array IX may be sorted in increasing order or */
/* decreasing order. A slightly modified quicksort algorithm is used. */
/* Description of Parameters */
/* IX - integer array of values to be sorted */
/* IY - integer array to be (optionally) carried along */
/* N - number of values in integer array IX to be sorted */
/* KFLAG - control parameter */
/* = 2 means sort IX in increasing order and carry IY along. */
/* = 1 means sort IX in increasing order (ignoring IY) */
/* = -1 means sort IX in decreasing order (ignoring IY) */
/* = -2 means sort IX in decreasing order and carry IY along. */
/* ***REFERENCES R. C. Singleton, Algorithm 347, An efficient algorithm */
/* for sorting with minimal storage, Communications of */
/* the ACM, 12, 3 (1969), pp. 185-187. */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 761118 DATE WRITTEN */
/* 810801 Modified by David K. Kahaner. */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891009 Removed unreferenced statement labels. (WRB) */
/* 891009 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) */
/* 901012 Declared all variables; changed X,Y to IX,IY. (M. McClain) */
/* 920501 Reformatted the REFERENCES section. (DWL, WRB) */
/* 920519 Clarified error messages. (DWL) */
/* 920801 Declarations section rebuilt and code restructured to use */
/* IF-THEN-ELSE-ENDIF. (RWC, WRB) */
/* ***END PROLOGUE ISORT */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Local Scalars .. */
/* .. Local Arrays .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* ***FIRST EXECUTABLE STATEMENT ISORT */
/* Parameter adjustments */
--iy;
--ix;
/* Function Body */
nn = *n;
if (nn < 1) {
xermsg_("SLATEC", "ISORT", "The number of values to be sorted is not"
" positive.", &c__1, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)50);
return 0;
}
kk = abs(*kflag);
if (kk != 1 && kk != 2) {
xermsg_("SLATEC", "ISORT", "The sort control parameter, K, is not 2,"
" 1, -1, or -2.", &c__2, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)
54);
return 0;
}
/* Alter array IX to get decreasing order if needed */
if (*kflag <= -1) {
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
ix[i__] = -ix[i__];
/* L10: */
}
}
if (kk == 2) {
goto L100;
}
/* Sort IX only */
m = 1;
i__ = 1;
j = nn;
r__ = .375f;
L20:
if (i__ == j) {
goto L60;
}
if (r__ <= .5898437f) {
r__ += .0390625f;
} else {
r__ += -.21875f;
}
L30:
k = i__;
/* Select a central element of the array and save it in location T */
ij = i__ + (integer) ((j - i__) * r__);
t = ix[ij];
/* If first element of array is greater than T, interchange with T */
if (ix[i__] > t) {
ix[ij] = ix[i__];
ix[i__] = t;
t = ix[ij];
}
l = j;
/* If last element of array is less than than T, interchange with T */
if (ix[j] < t) {
ix[ij] = ix[j];
ix[j] = t;
t = ix[ij];
/* If first element of array is greater than T, interchange with T */
if (ix[i__] > t) {
ix[ij] = ix[i__];
ix[i__] = t;
t = ix[ij];
}
}
/* Find an element in the second half of the array which is smaller */
/* than T */
L40:
--l;
if (ix[l] > t) {
goto L40;
}
/* Find an element in the first half of the array which is greater */
/* than T */
L50:
++k;
if (ix[k] < t) {
goto L50;
}
/* Interchange these elements */
if (k <= l) {
tt = ix[l];
ix[l] = ix[k];
ix[k] = tt;
goto L40;
}
/* Save upper and lower subscripts of the array yet to be sorted */
if (l - i__ > j - k) {
il[m - 1] = i__;
iu[m - 1] = l;
i__ = k;
++m;
} else {
il[m - 1] = k;
iu[m - 1] = j;
j = l;
++m;
}
goto L70;
/* Begin again on another portion of the unsorted array */
L60:
--m;
if (m == 0) {
goto L190;
}
i__ = il[m - 1];
j = iu[m - 1];
L70:
if (j - i__ >= 1) {
goto L30;
}
if (i__ == 1) {
goto L20;
}
--i__;
L80:
++i__;
if (i__ == j) {
goto L60;
}
t = ix[i__ + 1];
if (ix[i__] <= t) {
goto L80;
}
k = i__;
L90:
ix[k + 1] = ix[k];
--k;
if (t < ix[k]) {
goto L90;
}
ix[k + 1] = t;
goto L80;
/* Sort IX and carry IY along */
L100:
m = 1;
i__ = 1;
j = nn;
r__ = .375f;
L110:
if (i__ == j) {
goto L150;
}
if (r__ <= .5898437f) {
r__ += .0390625f;
} else {
r__ += -.21875f;
}
L120:
k = i__;
/* Select a central element of the array and save it in location T */
ij = i__ + (integer) ((j - i__) * r__);
t = ix[ij];
ty = iy[ij];
/* If first element of array is greater than T, interchange with T */
if (ix[i__] > t) {
ix[ij] = ix[i__];
ix[i__] = t;
t = ix[ij];
iy[ij] = iy[i__];
iy[i__] = ty;
ty = iy[ij];
}
l = j;
/* If last element of array is less than T, interchange with T */
if (ix[j] < t) {
ix[ij] = ix[j];
ix[j] = t;
t = ix[ij];
iy[ij] = iy[j];
iy[j] = ty;
ty = iy[ij];
/* If first element of array is greater than T, interchange with T */
if (ix[i__] > t) {
ix[ij] = ix[i__];
ix[i__] = t;
t = ix[ij];
iy[ij] = iy[i__];
iy[i__] = ty;
ty = iy[ij];
}
}
/* Find an element in the second half of the array which is smaller */
/* than T */
L130:
--l;
if (ix[l] > t) {
goto L130;
}
/* Find an element in the first half of the array which is greater */
/* than T */
L140:
++k;
if (ix[k] < t) {
goto L140;
}
/* Interchange these elements */
if (k <= l) {
tt = ix[l];
ix[l] = ix[k];
ix[k] = tt;
tty = iy[l];
iy[l] = iy[k];
iy[k] = tty;
goto L130;
}
/* Save upper and lower subscripts of the array yet to be sorted */
if (l - i__ > j - k) {
il[m - 1] = i__;
iu[m - 1] = l;
i__ = k;
++m;
} else {
il[m - 1] = k;
iu[m - 1] = j;
j = l;
++m;
}
goto L160;
/* Begin again on another portion of the unsorted array */
L150:
--m;
if (m == 0) {
goto L190;
}
i__ = il[m - 1];
j = iu[m - 1];
L160:
if (j - i__ >= 1) {
goto L120;
}
if (i__ == 1) {
goto L110;
}
--i__;
L170:
++i__;
if (i__ == j) {
goto L150;
}
t = ix[i__ + 1];
ty = iy[i__ + 1];
if (ix[i__] <= t) {
goto L170;
}
k = i__;
L180:
ix[k + 1] = ix[k];
iy[k + 1] = iy[k];
--k;
if (t < ix[k]) {
goto L180;
}
ix[k + 1] = t;
iy[k + 1] = ty;
goto L170;
/* Clean up */
L190:
if (*kflag <= -1) {
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
ix[i__] = -ix[i__];
/* L200: */
}
}
return 0;
} /* isort_ */
/* DECK DEFCMN */
/* Subroutine */ int defcmn_(integer *ndata, doublereal *xdata, doublereal *
ydata, doublereal *sddata, integer *nord, integer *nbkpt, doublereal *
bkptin, integer *mdein, integer *mdeout, doublereal *coeff,
doublereal *bf, doublereal *xtemp, doublereal *ptemp, doublereal *
bkpt, doublereal *g, integer *mdg, doublereal *w, integer *mdw,
integer *lw)
{
/* System generated locals */
address a__1[4];
integer bf_dim1, bf_offset, g_dim1, g_offset, w_dim1, w_offset, i__1,
i__2[4], i__3;
doublereal d__1, d__2;
char ch__1[112];
/* Local variables */
static integer i__, l, n, nb, ip, ir, mt, np1;
static doublereal xval, xmin, xmax;
static integer irow;
static char xern1[8], xern2[8];
static integer idata;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static integer ileft;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dsort_(doublereal *, doublereal *,
integer *, integer *);
static doublereal dummy, rnorm;
static integer nordm1, nordp1;
extern /* Subroutine */ int dbndac_(doublereal *, integer *, integer *,
integer *, integer *, integer *, integer *), dbndsl_(integer *,
doublereal *, integer *, integer *, integer *, integer *,
doublereal *, integer *, doublereal *), dfspvn_(doublereal *,
integer *, integer *, doublereal *, integer *, doublereal *);
static integer intseq;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* Fortran I/O blocks */
static icilist io___5 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___7 = { 0, xern2, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DEFCMN */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DEFC */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (EFCMN-S, DEFCMN-D) */
/* ***AUTHOR Hanson, R. J., (SNLA) */
/* ***DESCRIPTION */
/* This is a companion subprogram to DEFC( ). */
/* This subprogram does weighted least squares fitting of data by */
/* B-spline curves. */
/* The documentation for DEFC( ) has complete usage instructions. */
/* ***SEE ALSO DEFC */
/* ***ROUTINES CALLED DBNDAC, DBNDSL, DCOPY, DFSPVN, DSCAL, DSORT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890618 Completely restructured and extensively revised (WRB & RWC) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 900604 DP version created from SP version. (RWC) */
/* ***END PROLOGUE DEFCMN */
/* ***FIRST EXECUTABLE STATEMENT DEFCMN */
/* Initialize variables and analyze input. */
/* Parameter adjustments */
--xdata;
--ydata;
--sddata;
bf_dim1 = *nord;
bf_offset = 1 + bf_dim1;
bf -= bf_offset;
--bkptin;
--coeff;
--xtemp;
--ptemp;
--bkpt;
g_dim1 = *mdg;
g_offset = 1 + g_dim1;
g -= g_offset;
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
/* Function Body */
n = *nbkpt - *nord;
np1 = n + 1;
/* Initially set all output coefficients to zero. */
dcopy_(&n, &c_b2, &c__0, &coeff[1], &c__1);
*mdeout = -1;
if (*nord < 1 || *nord > 20) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, THE ORDER OF THE B-SPLINE MUST"
" BE 1 THRU 20.", &c__3, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)
53);
return 0;
}
if (*nbkpt < *nord << 1) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, THE NUMBER OF KNOTS MUST BE AT"
" LEAST TWICE THE B-SPLINE ORDER.", &c__4, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)71);
return 0;
}
if (*ndata < 0) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, THE NUMBER OF DATA POINTS MUST"
" BE NONNEGATIVE.", &c__5, &c__1, (ftnlen)6, (ftnlen)6, (
ftnlen)55);
return 0;
}
/* Computing 2nd power */
i__1 = *nord;
nb = (*nbkpt - *nord + 3) * (*nord + 1) + (*nbkpt + 1) * (*nord + 1) + (
max(*nbkpt,*ndata) << 1) + *nbkpt + i__1 * i__1;
if (*lw < nb) {
s_wsfi(&io___5);
do_fio(&c__1, (char *)&nb, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___7);
do_fio(&c__1, (char *)&(*lw), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 87, a__1[0] = "IN DEFC, INSUFFICIENT STORAGE FOR W(*). CH"
"ECK FORMULA THAT READS LW.GE. ... . NEED = ";
i__2[1] = 8, a__1[1] = xern1;
i__2[2] = 9, a__1[2] = " GIVEN = ";
i__2[3] = 8, a__1[3] = xern2;
s_cat(ch__1, a__1, i__2, &c__4, (ftnlen)112);
xermsg_("SLATEC", "DEFCMN", ch__1, &c__6, &c__1, (ftnlen)6, (ftnlen)6,
(ftnlen)112);
*mdeout = -1;
return 0;
}
if (*mdein != 1 && *mdein != 2) {
xermsg_("SLATEC", "DEFCMN", "IN DEFC, INPUT VALUE OF MDEIN MUST BE 1"
"-2.", &c__7, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)42);
return 0;
}
/* Sort the breakpoints. */
dcopy_(nbkpt, &bkptin[1], &c__1, &bkpt[1], &c__1);
dsort_(&bkpt[1], &dummy, nbkpt, &c__1);
/* Save interval containing knots. */
xmin = bkpt[*nord];
xmax = bkpt[np1];
nordm1 = *nord - 1;
nordp1 = *nord + 1;
/* Process least squares equations. */
/* Sort data and an array of pointers. */
dcopy_(ndata, &xdata[1], &c__1, &xtemp[1], &c__1);
i__1 = *ndata;
for (i__ = 1; i__ <= i__1; ++i__) {
ptemp[i__] = (doublereal) i__;
/* L100: */
}
if (*ndata > 0) {
dsort_(&xtemp[1], &ptemp[1], ndata, &c__2);
xmin = min(xmin,xtemp[1]);
/* Computing MAX */
d__1 = xmax, d__2 = xtemp[*ndata];
xmax = max(d__1,d__2);
}
/* Fix breakpoint array if needed. This should only involve very */
/* minor differences with the input array of breakpoints. */
i__1 = *nord;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
d__1 = bkpt[i__];
bkpt[i__] = min(d__1,xmin);
/* L110: */
}
i__1 = *nbkpt;
for (i__ = np1; i__ <= i__1; ++i__) {
/* Computing MAX */
d__1 = bkpt[i__];
bkpt[i__] = max(d__1,xmax);
/* L120: */
}
/* Initialize parameters of banded matrix processor, DBNDAC( ). */
mt = 0;
ip = 1;
ir = 1;
ileft = *nord;
intseq = 1;
i__1 = *ndata;
for (idata = 1; idata <= i__1; ++idata) {
/* Sorted indices are in PTEMP(*). */
l = (integer) ptemp[idata];
xval = xdata[l];
/* When interval changes, process equations in the last block. */
if (xval >= bkpt[ileft + 1]) {
i__3 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__3);
mt = 0;
/* Move pointer up to have BKPT(ILEFT).LE.XVAL, ILEFT.LE.N. */
i__3 = n;
for (ileft = ileft; ileft <= i__3; ++ileft) {
if (xval < bkpt[ileft + 1]) {
goto L140;
}
if (*mdein == 2) {
/* Data is being sequentially accumulated. */
/* Transfer previously accumulated rows from W(*,*) to */
/* G(*,*) and process them. */
dcopy_(&nordp1, &w[intseq + w_dim1], mdw, &g[ir + g_dim1],
mdg);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &intseq)
;
++intseq;
}
/* L130: */
}
}
/* Obtain B-spline function value. */
L140:
dfspvn_(&bkpt[1], nord, &c__1, &xval, &ileft, &bf[bf_offset]);
/* Move row into place. */
irow = ir + mt;
++mt;
dcopy_(nord, &bf[bf_offset], &c__1, &g[irow + g_dim1], mdg);
g[irow + nordp1 * g_dim1] = ydata[l];
/* Scale data if uncertainty is nonzero. */
if (sddata[l] != 0.) {
d__1 = 1. / sddata[l];
dscal_(&nordp1, &d__1, &g[irow + g_dim1], mdg);
}
/* When staging work area is exhausted, process rows. */
if (irow == *mdg - 1) {
i__3 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__3);
mt = 0;
}
/* L150: */
}
/* Process last block of equations. */
i__1 = ileft - nordm1;
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &mt, &i__1);
/* Finish processing any previously accumulated rows from W(*,*) */
/* to G(*,*). */
if (*mdein == 2) {
i__1 = np1;
for (i__ = intseq; i__ <= i__1; ++i__) {
dcopy_(&nordp1, &w[i__ + w_dim1], mdw, &g[ir + g_dim1], mdg);
i__3 = min(n,i__);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &i__3);
/* L160: */
}
}
/* Last call to adjust block positioning. */
dcopy_(&nordp1, &c_b2, &c__0, &g[ir + g_dim1], mdg);
dbndac_(&g[g_offset], mdg, nord, &ip, &ir, &c__1, &np1);
/* Transfer accumulated rows from G(*,*) to W(*,*) for */
/* possible later sequential accumulation. */
i__1 = np1;
for (i__ = 1; i__ <= i__1; ++i__) {
dcopy_(&nordp1, &g[i__ + g_dim1], mdg, &w[i__ + w_dim1], mdw);
/* L170: */
}
/* Solve for coefficients when possible. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (g[i__ + g_dim1] == 0.) {
*mdeout = 2;
return 0;
}
/* L180: */
}
/* All the diagonal terms in the accumulated triangular */
/* matrix are nonzero. The solution can be computed but */
/* it may be unsuitable for further use due to poor */
/* conditioning or the lack of constraints. No checking */
/* for either of these is done here. */
dbndsl_(&c__1, &g[g_offset], mdg, nord, &ip, &ir, &coeff[1], &n, &rnorm);
*mdeout = 1;
return 0;
} /* defcmn_ */
/* DECK POLINT */
/* Subroutine */ int polint_(integer *n, real *x, real *y, real *c__)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer i__, k, km1;
static real dif;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE POLINT */
/* ***PURPOSE Produce the polynomial which interpolates a set of discrete */
/* data points. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY E1B */
/* ***TYPE SINGLE PRECISION (POLINT-S, DPLINT-D) */
/* ***KEYWORDS POLYNOMIAL INTERPOLATION */
/* ***AUTHOR Huddleston, R. E., (SNLL) */
/* ***DESCRIPTION */
/* Written by Robert E. Huddleston, Sandia Laboratories, Livermore */
/* Abstract */
/* Subroutine POLINT is designed to produce the polynomial which */
/* interpolates the data (X(I),Y(I)), I=1,...,N. POLINT sets up */
/* information in the array C which can be used by subroutine POLYVL */
/* to evaluate the polynomial and its derivatives and by subroutine */
/* POLCOF to produce the coefficients. */
/* Formal Parameters */
/* N - the number of data points (N .GE. 1) */
/* X - the array of abscissas (all of which must be distinct) */
/* Y - the array of ordinates */
/* C - an array of information used by subroutines */
/* ******* Dimensioning Information ******* */
/* Arrays X,Y, and C must be dimensioned at least N 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 */
/* 861211 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) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE POLINT */
/* ***FIRST EXECUTABLE STATEMENT POLINT */
/* Parameter adjustments */
--c__;
--y;
--x;
/* Function Body */
if (*n <= 0) {
goto L91;
}
c__[1] = y[1];
if (*n == 1) {
return 0;
}
i__1 = *n;
for (k = 2; k <= i__1; ++k) {
c__[k] = y[k];
km1 = k - 1;
i__2 = km1;
for (i__ = 1; i__ <= i__2; ++i__) {
/* CHECK FOR DISTINCT X VALUES */
dif = x[i__] - x[k];
if (dif == 0.f) {
goto L92;
}
c__[k] = (c__[i__] - c__[k]) / dif;
/* L10010: */
}
}
return 0;
L91:
xermsg_("SLATEC", "POLINT", "N IS ZERO OR NEGATIVE.", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)22);
return 0;
L92:
xermsg_("SLATEC", "POLINT", "THE ABSCISSAS ARE NOT DISTINCT.", &c__2, &
c__1, (ftnlen)6, (ftnlen)6, (ftnlen)31);
return 0;
} /* polint_ */
/* DECK DBOLSM */
/* Subroutine */ int dbolsm_(doublereal *w, integer *mdw, integer *minput,
integer *ncols, doublereal *bl, doublereal *bu, integer *ind, integer
*iopt, doublereal *x, doublereal *rnorm, integer *mode, doublereal *
rw, doublereal *ww, doublereal *scl, integer *ibasis, integer *ibb)
{
/* System generated locals */
address a__1[3], a__2[4], a__3[6], a__4[5], a__5[2], a__6[7];
integer w_dim1, w_offset, i__1[3], i__2[4], i__3, i__4[6], i__5[5], i__6[
2], i__7[7], i__8, i__9, i__10;
doublereal d__1, d__2;
char ch__1[47], ch__2[50], ch__3[79], ch__4[53], ch__5[94], ch__6[75],
ch__7[83], ch__8[92], ch__9[105], ch__10[102], ch__11[61], ch__12[
110], ch__13[134], ch__14[44], ch__15[76];
/* Local variables */
static integer i__, j;
static doublereal t, t1, t2, sc;
static integer ip, jp, lp;
static doublereal ss, wt, cl1, cl2, cl3, fac, big;
static integer lds;
static doublereal bou, beta;
static integer jbig, jmag, ioff, jcol;
static doublereal wbig;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal wmag;
static integer mval, iter;
extern /* Subroutine */ int drot_(integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, doublereal *);
static doublereal xnew;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static char xern1[8], xern2[8], xern3[16], xern4[16];
static doublereal alpha;
static logical found;
static integer nsetb;
extern /* Subroutine */ int drotg_(doublereal *, doublereal *, doublereal
*, doublereal *), dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static integer igopr, itmax, itemp;
extern /* Subroutine */ int dswap_(integer *, doublereal *, integer *,
doublereal *, integer *), daxpy_(integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *);
static integer lgopr;
extern /* Subroutine */ int dmout_(integer *, integer *, integer *,
doublereal *, char *, integer *, ftnlen);
static integer jdrop;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int dvout_(integer *, doublereal *, char *,
integer *, ftnlen), ivout_(integer *, integer *, char *, integer *
, ftnlen);
static integer mrows, jdrop1, jdrop2, jlarge;
static doublereal colabv, colblo, wlarge, tolind;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static integer iprint;
static logical constr;
static doublereal tolsze;
/* Fortran I/O blocks */
static icilist io___2 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___3 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___4 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___6 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___8 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___9 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___10 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___12 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___14 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___15 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___16 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___17 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___18 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___31 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___32 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___33 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___34 = { 0, xern4, 0, "(1PD15.6)", 16, 1 };
static icilist io___35 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___36 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___37 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___38 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___39 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___40 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___41 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___42 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___43 = { 0, xern2, 0, "(I8)", 8, 1 };
static icilist io___44 = { 0, xern3, 0, "(1PD15.6)", 16, 1 };
static icilist io___45 = { 0, xern1, 0, "(I8)", 8, 1 };
static icilist io___54 = { 0, xern1, 0, "(I8)", 8, 1 };
/* ***BEGIN PROLOGUE DBOLSM */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBOCLS and DBOLS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SBOLSM-S, DBOLSM-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* **** Double Precision Version of SBOLSM **** */
/* **** All INPUT and OUTPUT real variables are DOUBLE PRECISION **** */
/* Solve E*X = F (least squares sense) with bounds on */
/* selected X values. */
/* The user must have DIMENSION statements of the form: */
/* DIMENSION W(MDW,NCOLS+1), BL(NCOLS), BU(NCOLS), */
/* * X(NCOLS+NX), RW(NCOLS), WW(NCOLS), SCL(NCOLS) */
/* INTEGER IND(NCOLS), IOPT(1+NI), IBASIS(NCOLS), IBB(NCOLS) */
/* (Here NX=number of extra locations required for options 1,...,7; */
/* NX=0 for no options; here NI=number of extra locations possibly */
/* required for options 1-7; NI=0 for no options; NI=14 if all the */
/* options are simultaneously in use.) */
/* INPUT */
/* ----- */
/* -------------------- */
/* W(MDW,*),MINPUT,NCOLS */
/* -------------------- */
/* The array W(*,*) contains the matrix [E:F] on entry. The matrix */
/* [E:F] has MINPUT rows and NCOLS+1 columns. This data is placed in */
/* the array W(*,*) with E occupying the first NCOLS columns and the */
/* right side vector F in column NCOLS+1. The row dimension, MDW, of */
/* the array W(*,*) must satisfy the inequality MDW .ge. MINPUT. */
/* Other values of MDW are errors. The values of MINPUT and NCOLS */
/* must be positive. Other values are errors. */
/* ------------------ */
/* BL(*),BU(*),IND(*) */
/* ------------------ */
/* These arrays contain the information about the bounds that the */
/* solution values are to satisfy. The value of IND(J) tells the */
/* type of bound and BL(J) and BU(J) give the explicit values for */
/* the respective upper and lower bounds. */
/* 1. For IND(J)=1, require X(J) .ge. BL(J). */
/* 2. For IND(J)=2, require X(J) .le. BU(J). */
/* 3. For IND(J)=3, require X(J) .ge. BL(J) and */
/* X(J) .le. BU(J). */
/* 4. For IND(J)=4, no bounds on X(J) are required. */
/* The values of BL(*),BL(*) are modified by the subprogram. Values */
/* other than 1,2,3 or 4 for IND(J) are errors. In the case IND(J)=3 */
/* (upper and lower bounds) the condition BL(J) .gt. BU(J) is an */
/* error. */
/* ------- */
/* IOPT(*) */
/* ------- */
/* This is the array where the user can specify nonstandard options */
/* for DBOLSM. Most of the time this feature can be ignored by */
/* setting the input value IOPT(1)=99. Occasionally users may have */
/* needs that require use of the following subprogram options. For */
/* details about how to use the options see below: IOPT(*) CONTENTS. */
/* Option Number Brief Statement of Purpose */
/* ----- ------ ----- --------- -- ------- */
/* 1 Move the IOPT(*) processing pointer. */
/* 2 Change rank determination tolerance. */
/* 3 Change blow-up factor that determines the */
/* size of variables being dropped from active */
/* status. */
/* 4 Reset the maximum number of iterations to use */
/* in solving the problem. */
/* 5 The data matrix is triangularized before the */
/* problem is solved whenever (NCOLS/MINPUT) .lt. */
/* FAC. Change the value of FAC. */
/* 6 Redefine the weighting matrix used for */
/* linear independence checking. */
/* 7 Debug output is desired. */
/* 99 No more options to change. */
/* ---- */
/* X(*) */
/* ---- */
/* This array is used to pass data associated with options 1,2,3 and */
/* 5. Ignore this input parameter if none of these options are used. */
/* Otherwise see below: IOPT(*) CONTENTS. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays must be initialized by the user. The values */
/* IBASIS(J)=J, J=1,...,NCOLS */
/* IBB(J) =1, J=1,...,NCOLS */
/* are appropriate except when using nonstandard features. */
/* ------ */
/* SCL(*) */
/* ------ */
/* This is the array of scaling factors to use on the columns of the */
/* matrix E. These values must be defined by the user. To suppress */
/* any column scaling set SCL(J)=1.0, J=1,...,NCOLS. */
/* OUTPUT */
/* ------ */
/* ---------- */
/* X(*),RNORM */
/* ---------- */
/* The array X(*) contains a solution (if MODE .ge. 0 or .eq. -22) */
/* for the constrained least squares problem. The value RNORM is the */
/* minimum residual vector length. */
/* ---- */
/* MODE */
/* ---- */
/* The sign of mode determines whether the subprogram has completed */
/* normally, or encountered an error condition or abnormal status. */
/* A value of MODE .ge. 0 signifies that the subprogram has completed */
/* normally. The value of MODE (.ge. 0) is the number of variables */
/* in an active status: not at a bound nor at the value ZERO, for */
/* the case of free variables. A negative value of MODE will be one */
/* of the 18 cases -38,-37,...,-22, or -1. Values .lt. -1 correspond */
/* to an abnormal completion of the subprogram. To understand the */
/* abnormal completion codes see below: ERROR MESSAGES for DBOLSM */
/* An approximate solution will be returned to the user only when */
/* maximum iterations is reached, MODE=-22. */
/* ----------- */
/* RW(*),WW(*) */
/* ----------- */
/* These are working arrays each with NCOLS entries. The array RW(*) */
/* contains the working (scaled, nonactive) solution values. The */
/* array WW(*) contains the working (scaled, active) gradient vector */
/* values. */
/* ---------------- */
/* IBASIS(*),IBB(*) */
/* ---------------- */
/* These arrays contain information about the status of the solution */
/* when MODE .ge. 0. The indices IBASIS(K), K=1,...,MODE, show the */
/* nonactive variables; indices IBASIS(K), K=MODE+1,..., NCOLS are */
/* the active variables. The value (IBB(J)-1) is the number of times */
/* variable J was reflected from its upper bound. (Normally the user */
/* can ignore these parameters.) */
/* IOPT(*) CONTENTS */
/* ------- -------- */
/* The option array allows a user to modify internal variables in */
/* the subprogram without recompiling the source code. A central */
/* goal of the initial software design was to do a good job for most */
/* people. Thus the use of options will be restricted to a select */
/* group of users. The processing of the option array proceeds as */
/* follows: a pointer, here called LP, is initially set to the value */
/* 1. The value is updated as the options are processed. At the */
/* pointer position the option number is extracted and used for */
/* locating other information that allows for options to be changed. */
/* The portion of the array IOPT(*) that is used for each option is */
/* fixed; the user and the subprogram both know how many locations */
/* are needed for each option. A great deal of error checking is */
/* done by the subprogram on the contents of the option array. */
/* Nevertheless it is still possible to give the subprogram optional */
/* input that is meaningless. For example, some of the options use */
/* the location X(NCOLS+IOFF) for passing data. The user must manage */
/* the allocation of these locations when more than one piece of */
/* option data is being passed to the subprogram. */
/* 1 */
/* - */
/* Move the processing pointer (either forward or backward) to the */
/* location IOPT(LP+1). The processing pointer is moved to location */
/* LP+2 of IOPT(*) in case IOPT(LP)=-1. For example to skip over */
/* locations 3,...,NCOLS+2 of IOPT(*), */
/* IOPT(1)=1 */
/* IOPT(2)=NCOLS+3 */
/* (IOPT(I), I=3,...,NCOLS+2 are not defined here.) */
/* IOPT(NCOLS+3)=99 */
/* CALL DBOLSM */
/* CAUTION: Misuse of this option can yield some very hard-to-find */
/* bugs. Use it with care. */
/* 2 */
/* - */
/* The algorithm that solves the bounded least squares problem */
/* iteratively drops columns from the active set. This has the */
/* effect of joining a new column vector to the QR factorization of */
/* the rectangular matrix consisting of the partially triangularized */
/* nonactive columns. After triangularizing this matrix a test is */
/* made on the size of the pivot element. The column vector is */
/* rejected as dependent if the magnitude of the pivot element is */
/* .le. TOL* magnitude of the column in components strictly above */
/* the pivot element. Nominally the value of this (rank) tolerance */
/* is TOL = SQRT(R1MACH(4)). To change only the value of TOL, for */
/* example, */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=TOL */
/* IOPT(LP)=2 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 2 is */
/* used; The required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of TOL .le. R1MACH(4) gives a */
/* warning message; it is not considered an error. */
/* 3 */
/* - */
/* A solution component is left active (not used) if, roughly */
/* speaking, it seems too large. Mathematically the new component is */
/* left active if the magnitude is .ge.((vector norm of F)/(matrix */
/* norm of E))/BLOWUP. Nominally the factor BLOWUP = SQRT(R1MACH(4)). */
/* To change only the value of BLOWUP, for example, */
/* X(NCOLS+2)=BLOWUP */
/* IOPT(1)=3 */
/* IOPT(2)=2 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=BLOWUP */
/* IOPT(LP)=3 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The required length of IOPT(*) is increased by 2 if option 3 is */
/* used; the required length of X(*) is increased by 1. A value of */
/* IOFF .le. 0 is an error. A value of BLOWUP .le. 0.0 is an error. */
/* 4 */
/* - */
/* Normally the algorithm for solving the bounded least squares */
/* problem requires between NCOLS/3 and NCOLS drop-add steps to */
/* converge. (this remark is based on examining a small number of */
/* test cases.) The amount of arithmetic for such problems is */
/* typically about twice that required for linear least squares if */
/* there are no bounds and if plane rotations are used in the */
/* solution method. Convergence of the algorithm, while */
/* mathematically certain, can be much slower than indicated. To */
/* avoid this potential but unlikely event ITMAX drop-add steps are */
/* permitted. Nominally ITMAX=5*(MAX(MINPUT,NCOLS)). To change the */
/* value of ITMAX, for example, */
/* IOPT(1)=4 */
/* IOPT(2)=ITMAX */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* IOPT(LP)=4 */
/* IOPT(LP+1)=ITMAX */
/* . */
/* CALL DBOLSM */
/* The value of ITMAX must be .gt. 0. Other values are errors. Use */
/* of this option increases the required length of IOPT(*) by 2. */
/* 5 */
/* - */
/* For purposes of increased efficiency the MINPUT by NCOLS+1 data */
/* matrix [E:F] is triangularized as a first step whenever MINPUT */
/* satisfies FAC*MINPUT .gt. NCOLS. Nominally FAC=0.75. To change the */
/* value of FAC, */
/* X(NCOLS+3)=FAC */
/* IOPT(1)=5 */
/* IOPT(2)=3 */
/* IOPT(3)=99 */
/* CALL DBOLSM */
/* Generally, if LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=FAC */
/* IOPT(LP)=5 */
/* IOPT(LP+1)=IOFF */
/* . */
/* CALL DBOLSM */
/* The value of FAC must be nonnegative. Other values are errors. */
/* Resetting FAC=0.0 suppresses the initial triangularization step. */
/* Use of this option increases the required length of IOPT(*) by 2; */
/* The required length of of X(*) is increased by 1. */
/* 6 */
/* - */
/* The norm used in testing the magnitudes of the pivot element */
/* compared to the mass of the column above the pivot line can be */
/* changed. The type of change that this option allows is to weight */
/* the components with an index larger than MVAL by the parameter */
/* WT. Normally MVAL=0 and WT=1. To change both the values MVAL and */
/* WT, where LP is the processing pointer for IOPT(*), */
/* X(NCOLS+IOFF)=WT */
/* IOPT(LP)=6 */
/* IOPT(LP+1)=IOFF */
/* IOPT(LP+2)=MVAL */
/* Use of this option increases the required length of IOPT(*) by 3. */
/* The length of X(*) is increased by 1. Values of MVAL must be */
/* nonnegative and not greater than MINPUT. Other values are errors. */
/* The value of WT must be positive. Any other value is an error. If */
/* either error condition is present a message will be printed. */
/* 7 */
/* - */
/* Debug output, showing the detailed add-drop steps for the */
/* constrained least squares problem, is desired. This option is */
/* intended to be used to locate suspected bugs. */
/* 99 */
/* -- */
/* There are no more options to change. */
/* The values for options are 1,...,7,99, and are the only ones */
/* permitted. Other values are errors. Options -99,-1,...,-7 mean */
/* that the repective options 99,1,...,7 are left at their default */
/* values. An example is the option to modify the (rank) tolerance: */
/* X(NCOLS+1)=TOL */
/* IOPT(1)=-2 */
/* IOPT(2)=1 */
/* IOPT(3)=99 */
/* Error Messages for DBOLSM */
/* ----- -------- --- --------- */
/* -22 MORE THAN ITMAX = ... ITERATIONS SOLVING BOUNDED LEAST */
/* SQUARES PROBLEM. */
/* -23 THE OPTION NUMBER = ... IS NOT DEFINED. */
/* -24 THE OFFSET = ... BEYOND POSTION NCOLS = ... MUST BE POSITIVE */
/* FOR OPTION NUMBER 2. */
/* -25 THE TOLERANCE FOR RANK DETERMINATION = ... IS LESS THAN */
/* MACHINE PRECISION = .... */
/* -26 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 3. */
/* -27 THE RECIPROCAL OF THE BLOW-UP FACTOR FOR REJECTING VARIABLES */
/* MUST BE POSITIVE. NOW = .... */
/* -28 THE MAXIMUM NUMBER OF ITERATIONS = ... MUST BE POSITIVE. */
/* -29 THE OFFSET = ... BEYOND POSITION NCOLS = ... MUST BE POSTIVE */
/* FOR OPTION NUMBER 5. */
/* -30 THE FACTOR (NCOLS/MINPUT) WHERE PRETRIANGULARIZING IS */
/* PERFORMED MUST BE NONNEGATIVE. NOW = .... */
/* -31 THE NUMBER OF ROWS = ... MUST BE POSITIVE. */
/* -32 THE NUMBER OF COLUMNS = ... MUST BE POSTIVE. */
/* -33 THE ROW DIMENSION OF W(,) = ... MUST BE .GE. THE NUMBER OF */
/* ROWS = .... */
/* -34 FOR J = ... THE CONSTRAINT INDICATOR MUST BE 1-4. */
/* -35 FOR J = ... THE LOWER BOUND = ... IS .GT. THE UPPER BOUND = */
/* .... */
/* -36 THE INPUT ORDER OF COLUMNS = ... IS NOT BETWEEN 1 AND NCOLS */
/* = .... */
/* -37 THE BOUND POLARITY FLAG IN COMPONENT J = ... MUST BE */
/* POSITIVE. NOW = .... */
/* -38 THE ROW SEPARATOR TO APPLY WEIGHTING (...) MUST LIE BETWEEN */
/* 0 AND MINPUT = .... WEIGHT = ... MUST BE POSITIVE. */
/* ***SEE ALSO DBOCLS, DBOLS */
/* ***ROUTINES CALLED D1MACH, DAXPY, DCOPY, DDOT, DMOUT, DNRM2, DROT, */
/* DROTG, DSWAP, DVOUT, IVOUT, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 821220 DATE WRITTEN */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Convert XERRWV calls to XERMSG calls. (RWC) */
/* 920422 Fixed usage of MINPUT. (WRB) */
/* 901009 Editorial changes, code now reads from top to bottom. (RWC) */
/* ***END PROLOGUE DBOLSM */
/* PURPOSE */
/* ------- */
/* THIS IS THE MAIN SUBPROGRAM THAT SOLVES THE BOUNDED */
/* LEAST SQUARES PROBLEM. THE PROBLEM SOLVED HERE IS: */
/* SOLVE E*X = F (LEAST SQUARES SENSE) */
/* WITH BOUNDS ON SELECTED X VALUES. */
/* TO CHANGE THIS SUBPROGRAM FROM SINGLE TO DOUBLE PRECISION BEGIN */
/* EDITING AT THE CARD 'C++'. */
/* CHANGE THE SUBPROGRAM NAME TO DBOLSM AND THE STRINGS */
/* /SAXPY/ TO /DAXPY/, /SCOPY/ TO /DCOPY/, */
/* /SDOT/ TO /DDOT/, /SNRM2/ TO /DNRM2/, */
/* /SROT/ TO /DROT/, /SROTG/ TO /DROTG/, /R1MACH/ TO /D1MACH/, */
/* /SVOUT/ TO /DVOUT/, /SMOUT/ TO /DMOUT/, */
/* /SSWAP/ TO /DSWAP/, /E0/ TO /D0/, */
/* /REAL / TO /DOUBLE PRECISION/. */
/* ++ */
/* ***FIRST EXECUTABLE STATEMENT DBOLSM */
/* Verify that the problem dimensions are defined properly. */
/* Parameter adjustments */
w_dim1 = *mdw;
w_offset = 1 + w_dim1;
w -= w_offset;
--bl;
--bu;
--ind;
--iopt;
--x;
--rw;
--ww;
--scl;
--ibasis;
--ibb;
/* Function Body */
if (*minput <= 0) {
s_wsfi(&io___2);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 21, a__1[0] = "THE NUMBER OF ROWS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__1, a__1, i__1, &c__3, (ftnlen)47);
xermsg_("SLATEC", "DBOLSM", ch__1, &c__31, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)47);
*mode = -31;
return 0;
}
if (*ncols <= 0) {
s_wsfi(&io___3);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 24, a__1[0] = "THE NUMBER OF COLUMNS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__2, a__1, i__1, &c__3, (ftnlen)50);
xermsg_("SLATEC", "DBOLSM", ch__2, &c__32, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)50);
*mode = -32;
return 0;
}
if (*mdw < *minput) {
s_wsfi(&io___4);
do_fio(&c__1, (char *)&(*mdw), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___6);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 28, a__2[0] = "THE ROW DIMENSION OF W(,) = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 35, a__2[2] = " MUST BE .GE. THE NUMBER OF ROWS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__3, a__2, i__2, &c__4, (ftnlen)79);
xermsg_("SLATEC", "DBOLSM", ch__3, &c__33, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)79);
*mode = -33;
return 0;
}
/* Verify that bound information is correct. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] < 1 || ind[j] > 4) {
s_wsfi(&io___8);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___9);
do_fio(&c__1, (char *)&ind[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 8, a__1[0] = "FOR J = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 37, a__1[2] = " THE CONSTRAINT INDICATOR MUST BE 1-4";
s_cat(ch__4, a__1, i__1, &c__3, (ftnlen)53);
xermsg_("SLATEC", "DBOLSM", ch__4, &c__34, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)53);
*mode = -34;
return 0;
}
/* L10: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 3) {
if (bu[j] < bl[j]) {
s_wsfi(&io___10);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___12);
do_fio(&c__1, (char *)&bl[j], (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___14);
do_fio(&c__1, (char *)&bu[j], (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__4[0] = 8, a__3[0] = "FOR J = ";
i__4[1] = 8, a__3[1] = xern1;
i__4[2] = 19, a__3[2] = " THE LOWER BOUND = ";
i__4[3] = 16, a__3[3] = xern3;
i__4[4] = 27, a__3[4] = " IS .GT. THE UPPER BOUND = ";
i__4[5] = 16, a__3[5] = xern4;
s_cat(ch__5, a__3, i__4, &c__6, (ftnlen)94);
xermsg_("SLATEC", "DBOLSM", ch__5, &c__35, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)94);
*mode = -35;
return 0;
}
}
/* L20: */
}
/* Check that permutation and polarity arrays have been set. */
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibasis[j] < 1 || ibasis[j] > *ncols) {
s_wsfi(&io___15);
do_fio(&c__1, (char *)&ibasis[j], (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___16);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 29, a__2[0] = "THE INPUT ORDER OF COLUMNS = ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 30, a__2[2] = " IS NOT BETWEEN 1 AND NCOLS = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__6, a__2, i__2, &c__4, (ftnlen)75);
xermsg_("SLATEC", "DBOLSM", ch__6, &c__36, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)75);
*mode = -36;
return 0;
}
if (ibb[j] <= 0) {
s_wsfi(&io___17);
do_fio(&c__1, (char *)&j, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___18);
do_fio(&c__1, (char *)&ibb[j], (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__2[0] = 41, a__2[0] = "THE BOUND POLARITY FLAG IN COMPONENT J "
"= ";
i__2[1] = 8, a__2[1] = xern1;
i__2[2] = 26, a__2[2] = " MUST BE POSITIVE.$$NOW = ";
i__2[3] = 8, a__2[3] = xern2;
s_cat(ch__7, a__2, i__2, &c__4, (ftnlen)83);
xermsg_("SLATEC", "DBOLSM", ch__7, &c__37, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)83);
*mode = -37;
return 0;
}
/* L30: */
}
/* Process the option array. */
fac = .75;
tolind = sqrt(d1mach_(&c__4));
tolsze = sqrt(d1mach_(&c__4));
itmax = max(*minput,*ncols) * 5;
wt = 1.;
mval = 0;
iprint = 0;
/* Changes to some parameters can occur through the option array, */
/* IOPT(*). Process this array looking carefully for input data */
/* errors. */
lp = 0;
lds = 0;
/* Test for no more options. */
L590:
lp += lds;
ip = iopt[lp + 1];
jp = abs(ip);
if (ip == 99) {
goto L470;
} else if (jp == 99) {
lds = 1;
} else if (jp == 1) {
/* Move the IOPT(*) processing pointer. */
if (ip > 0) {
lp = iopt[lp + 2] - 1;
lds = 0;
} else {
lds = 2;
}
} else if (jp == 2) {
/* Change tolerance for rank determination. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___31);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___32);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 2.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__24, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -24;
return 0;
}
tolind = x[*ncols + ioff];
if (tolind < d1mach_(&c__4)) {
s_wsfi(&io___33);
do_fio(&c__1, (char *)&tolind, (ftnlen)sizeof(doublereal));
e_wsfi();
s_wsfi(&io___34);
d__1 = d1mach_(&c__4);
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__2[0] = 39, a__2[0] = "THE TOLERANCE FOR RANK DETERMINATIO"
"N = ";
i__2[1] = 16, a__2[1] = xern3;
i__2[2] = 34, a__2[2] = " IS LESS THAN MACHINE PRECISION = ";
i__2[3] = 16, a__2[3] = xern4;
s_cat(ch__9, a__2, i__2, &c__4, (ftnlen)105);
xermsg_("SLATEC", "DBOLSM", ch__9, &c__25, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)105);
*mode = -25;
}
}
lds = 2;
} else if (jp == 3) {
/* Change blowup factor for allowing variables to become */
/* inactive. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___35);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___36);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 3.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__26, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -26;
return 0;
}
tolsze = x[*ncols + ioff];
if (tolsze <= 0.) {
s_wsfi(&io___37);
do_fio(&c__1, (char *)&tolsze, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 86, a__5[0] = "THE RECIPROCAL OF THE BLOW-UP FACTO"
"R FOR REJECTING VARIABLES MUST BE POSITIVE.$$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__10, a__5, i__6, &c__2, (ftnlen)102);
xermsg_("SLATEC", "DBOLSM", ch__10, &c__27, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)102);
*mode = -27;
return 0;
}
}
lds = 2;
} else if (jp == 4) {
/* Change the maximum number of iterations allowed. */
if (ip > 0) {
itmax = iopt[lp + 2];
if (itmax <= 0) {
s_wsfi(&io___38);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 35, a__1[0] = "THE MAXIMUM NUMBER OF ITERATIONS = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 18, a__1[2] = " MUST BE POSITIVE.";
s_cat(ch__11, a__1, i__1, &c__3, (ftnlen)61);
xermsg_("SLATEC", "DBOLSM", ch__11, &c__28, &c__1, (ftnlen)6,
(ftnlen)6, (ftnlen)61);
*mode = -28;
return 0;
}
}
lds = 2;
} else if (jp == 5) {
/* Change the factor for pretriangularizing the data matrix. */
if (ip > 0) {
ioff = iopt[lp + 2];
if (ioff <= 0) {
s_wsfi(&io___39);
do_fio(&c__1, (char *)&ioff, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___40);
do_fio(&c__1, (char *)&(*ncols), (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__5[0] = 13, a__4[0] = "THE OFFSET = ";
i__5[1] = 8, a__4[1] = xern1;
i__5[2] = 25, a__4[2] = " BEYOND POSITION NCOLS = ";
i__5[3] = 8, a__4[3] = xern2;
i__5[4] = 38, a__4[4] = " MUST BE POSITIVE FOR OPTION NUMBER"
" 5.";
s_cat(ch__8, a__4, i__5, &c__5, (ftnlen)92);
xermsg_("SLATEC", "DBOLSM", ch__8, &c__29, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)92);
*mode = -29;
return 0;
}
fac = x[*ncols + ioff];
if (fac < 0.) {
s_wsfi(&io___41);
do_fio(&c__1, (char *)&fac, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__6[0] = 94, a__5[0] = "THE FACTOR (NCOLS/MINPUT) WHERE PRE"
"-TRIANGULARIZING IS PERFORMED MUST BE NON-NEGATIVE.$"
"$NOW = ";
i__6[1] = 16, a__5[1] = xern3;
s_cat(ch__12, a__5, i__6, &c__2, (ftnlen)110);
xermsg_("SLATEC", "DBOLSM", ch__12, &c__30, &c__0, (ftnlen)6,
(ftnlen)6, (ftnlen)110);
*mode = -30;
return 0;
}
}
lds = 2;
} else if (jp == 6) {
/* Change the weighting factor (from 1.0) to apply to components */
/* numbered .gt. MVAL (initially set to 1.) This trick is needed */
/* for applications of this subprogram to the heavily weighted */
/* least squares problem that come from equality constraints. */
if (ip > 0) {
ioff = iopt[lp + 2];
mval = iopt[lp + 3];
wt = x[*ncols + ioff];
}
if (mval < 0 || mval > *minput || wt <= 0.) {
s_wsfi(&io___42);
do_fio(&c__1, (char *)&mval, (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___43);
do_fio(&c__1, (char *)&(*minput), (ftnlen)sizeof(integer));
e_wsfi();
s_wsfi(&io___44);
do_fio(&c__1, (char *)&wt, (ftnlen)sizeof(doublereal));
e_wsfi();
/* Writing concatenation */
i__7[0] = 38, a__6[0] = "THE ROW SEPARATOR TO APPLY WEIGHTING (";
i__7[1] = 8, a__6[1] = xern1;
i__7[2] = 34, a__6[2] = ") MUST LIE BETWEEN 0 AND MINPUT = ";
i__7[3] = 8, a__6[3] = xern2;
i__7[4] = 12, a__6[4] = ".$$WEIGHT = ";
i__7[5] = 16, a__6[5] = xern3;
i__7[6] = 18, a__6[6] = " MUST BE POSITIVE.";
s_cat(ch__13, a__6, i__7, &c__7, (ftnlen)134);
xermsg_("SLATEC", "DBOLSM", ch__13, &c__38, &c__0, (ftnlen)6, (
ftnlen)6, (ftnlen)134);
*mode = -38;
return 0;
}
lds = 3;
} else if (jp == 7) {
/* Turn on debug output. */
if (ip > 0) {
iprint = 1;
}
lds = 2;
} else {
s_wsfi(&io___45);
do_fio(&c__1, (char *)&ip, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 20, a__1[0] = "THE OPTION NUMBER = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 16, a__1[2] = " IS NOT DEFINED.";
s_cat(ch__14, a__1, i__1, &c__3, (ftnlen)44);
xermsg_("SLATEC", "DBOLSM", ch__14, &c__23, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)44);
*mode = -23;
return 0;
}
goto L590;
/* Pretriangularize rectangular arrays of certain sizes for */
/* increased efficiency. */
L470:
if (fac * *minput > (doublereal) (*ncols)) {
i__3 = *ncols + 1;
for (j = 1; j <= i__3; ++j) {
i__8 = j + mval + 1;
for (i__ = *minput; i__ >= i__8; --i__) {
drotg_(&w[i__ - 1 + j * w_dim1], &w[i__ + j * w_dim1], &sc, &
ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[i__ - 1 + (j + 1) * w_dim1], mdw, &w[i__ + (j
+ 1) * w_dim1], mdw, &sc, &ss);
/* L480: */
}
/* L490: */
}
mrows = *ncols + mval + 1;
} else {
mrows = *minput;
}
/* Set the X(*) array to zero so all components are defined. */
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
/* The arrays IBASIS(*) and IBB(*) are initialized by the calling */
/* program and the column scaling is defined in the calling program. */
/* 'BIG' is plus infinity on this machine. */
big = d1mach_(&c__2);
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ind[j] == 1) {
bu[j] = big;
} else if (ind[j] == 2) {
bl[j] = -big;
} else if (ind[j] == 4) {
bl[j] = -big;
bu[j] = big;
}
/* L550: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (bl[j] <= 0. && 0. <= bu[j] && (d__1 = bu[j], abs(d__1)) < (d__2 =
bl[j], abs(d__2)) || bu[j] < 0.) {
t = bu[j];
bu[j] = -bl[j];
bl[j] = -t;
scl[j] = -scl[j];
i__8 = mrows;
for (i__ = 1; i__ <= i__8; ++i__) {
w[i__ + j * w_dim1] = -w[i__ + j * w_dim1];
/* L560: */
}
}
/* Indices in set T(=TIGHT) are denoted by negative values */
/* of IBASIS(*). */
if (bl[j] >= 0.) {
ibasis[j] = -ibasis[j];
t = -bl[j];
bu[j] += t;
daxpy_(&mrows, &t, &w[j * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
}
/* L570: */
}
nsetb = 0;
iter = 0;
if (iprint > 0) {
i__3 = *ncols + 1;
dmout_(&mrows, &i__3, mdw, &w[w_offset], "(' PRETRI. INPUT MATRIX')",
&c_n4, (ftnlen)25);
dvout_(ncols, &bl[1], "(' LOWER BOUNDS')", &c_n4, (ftnlen)17);
dvout_(ncols, &bu[1], "(' UPPER BOUNDS')", &c_n4, (ftnlen)17);
}
L580:
++iter;
if (iter > itmax) {
s_wsfi(&io___54);
do_fio(&c__1, (char *)&itmax, (ftnlen)sizeof(integer));
e_wsfi();
/* Writing concatenation */
i__1[0] = 18, a__1[0] = "MORE THAN ITMAX = ";
i__1[1] = 8, a__1[1] = xern1;
i__1[2] = 50, a__1[2] = " ITERATIONS SOLVING BOUNDED LEAST SQUARES P"
"ROBLEM.";
s_cat(ch__15, a__1, i__1, &c__3, (ftnlen)76);
xermsg_("SLATEC", "DBOLSM", ch__15, &c__22, &c__1, (ftnlen)6, (ftnlen)
6, (ftnlen)76);
*mode = -22;
/* Rescale and translate variables. */
igopr = 1;
goto L130;
}
/* Find a variable to become non-active. */
/* T */
/* Compute (negative) of gradient vector, W = E *(F-E*X). */
dcopy_(ncols, &c_b185, &c__0, &ww[1], &c__1);
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
i__8 = mrows - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
/* Computing MIN */
i__10 = nsetb + 1;
ww[j] = ddot_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1, &w[min(
i__10,mrows) + (*ncols + 1) * w_dim1], &c__1) * (d__1 = scl[
jcol], abs(d__1));
/* L200: */
}
if (iprint > 0) {
dvout_(ncols, &ww[1], "(' GRADIENT VALUES')", &c_n4, (ftnlen)20);
ivout_(ncols, &ibasis[1], "(' INTERNAL VARIABLE ORDER')", &c_n4, (
ftnlen)28);
ivout_(ncols, &ibb[1], "(' BOUND POLARITY')", &c_n4, (ftnlen)19);
}
/* If active set = number of total rows, quit. */
L210:
if (nsetb == mrows) {
found = FALSE_;
goto L120;
}
/* Choose an extremal component of gradient vector for a candidate */
/* to become non-active. */
wlarge = -big;
wmag = -big;
i__3 = *ncols;
for (j = nsetb + 1; j <= i__3; ++j) {
t = ww[j];
if (t == big) {
goto L220;
}
itemp = ibasis[j];
jcol = abs(itemp);
i__8 = mval - nsetb;
/* Computing MIN */
i__9 = nsetb + 1;
t1 = dnrm2_(&i__8, &w[min(i__9,mrows) + j * w_dim1], &c__1);
if (itemp < 0) {
if (ibb[jcol] % 2 == 0) {
t = -t;
}
if (t < 0.) {
goto L220;
}
if (mval > nsetb) {
t = t1;
}
if (t > wlarge) {
wlarge = t;
jlarge = j;
}
} else {
if (mval > nsetb) {
t = t1;
}
if (abs(t) > wmag) {
wmag = abs(t);
jmag = j;
}
}
L220:
;
}
/* Choose magnitude of largest component of gradient for candidate. */
jbig = 0;
wbig = 0.;
if (wlarge > 0.) {
jbig = jlarge;
wbig = wlarge;
}
if (wmag >= wbig) {
jbig = jmag;
wbig = wmag;
}
if (jbig == 0) {
found = FALSE_;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' FOUND NO VARIABLE TO ENTER')", &c_n4, (
ftnlen)31);
}
goto L120;
}
/* See if the incoming column is sufficiently independent. This */
/* test is made before an elimination is performed. */
if (iprint > 0) {
ivout_(&c__1, &jbig, "(' TRY TO BRING IN THIS COL.')", &c_n4, (ftnlen)
30);
}
if (mval <= nsetb) {
cl1 = dnrm2_(&mval, &w[jbig * w_dim1 + 1], &c__1);
i__3 = nsetb - mval;
/* Computing MIN */
i__8 = mval + 1;
cl2 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
i__3 = mrows - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
drotg_(&cl1, &cl2, &sc, &ss);
colabv = abs(cl1);
colblo = cl3;
} else {
cl1 = dnrm2_(&nsetb, &w[jbig * w_dim1 + 1], &c__1);
i__3 = mval - nsetb;
/* Computing MIN */
i__8 = nsetb + 1;
cl2 = dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &c__1);
i__3 = mrows - mval;
/* Computing MIN */
i__8 = mval + 1;
cl3 = abs(wt) * dnrm2_(&i__3, &w[min(i__8,mrows) + jbig * w_dim1], &
c__1);
colabv = cl1;
drotg_(&cl2, &cl3, &sc, &ss);
colblo = abs(cl2);
}
if (colblo <= tolind * colabv) {
ww[jbig] = big;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE IS DEPENDENT, NOT USED.')", &
c_n4, (ftnlen)37);
}
goto L210;
}
/* Swap matrix columns NSETB+1 and JBIG, plus pointer information, */
/* and gradient values. */
++nsetb;
if (nsetb != jbig) {
dswap_(&mrows, &w[nsetb * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &
c__1);
dswap_(&c__1, &ww[nsetb], &c__1, &ww[jbig], &c__1);
itemp = ibasis[nsetb];
ibasis[nsetb] = ibasis[jbig];
ibasis[jbig] = itemp;
}
/* Eliminate entries below the pivot line in column NSETB. */
if (mrows > nsetb) {
i__3 = nsetb + 1;
for (i__ = mrows; i__ >= i__3; --i__) {
if (i__ == mval + 1) {
goto L230;
}
drotg_(&w[i__ - 1 + nsetb * w_dim1], &w[i__ + nsetb * w_dim1], &
sc, &ss);
w[i__ + nsetb * w_dim1] = 0.;
i__8 = *ncols - nsetb + 1;
drot_(&i__8, &w[i__ - 1 + (nsetb + 1) * w_dim1], mdw, &w[i__ + (
nsetb + 1) * w_dim1], mdw, &sc, &ss);
L230:
;
}
if (mval >= nsetb && mval < mrows) {
drotg_(&w[nsetb + nsetb * w_dim1], &w[mval + 1 + nsetb * w_dim1],
&sc, &ss);
w[mval + 1 + nsetb * w_dim1] = 0.;
i__3 = *ncols - nsetb + 1;
drot_(&i__3, &w[nsetb + (nsetb + 1) * w_dim1], mdw, &w[mval + 1 +
(nsetb + 1) * w_dim1], mdw, &sc, &ss);
}
}
if (w[nsetb + nsetb * w_dim1] == 0.) {
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' PIVOT IS ZERO, NOT USED.')", &c_n4, (
ftnlen)29);
}
goto L210;
}
/* Check that new variable is moving in the right direction. */
itemp = ibasis[nsetb];
jcol = abs(itemp);
xnew = w[nsetb + (*ncols + 1) * w_dim1] / w[nsetb + nsetb * w_dim1] / (
d__1 = scl[jcol], abs(d__1));
if (itemp < 0) {
/* IF(WW(NSETB).GE.ZERO.AND.XNEW.LE.ZERO) exit(quit) */
/* IF(WW(NSETB).LE.ZERO.AND.XNEW.GE.ZERO) exit(quit) */
if (ww[nsetb] >= 0. && xnew <= 0. || ww[nsetb] <= 0. && xnew >= 0.) {
goto L240;
}
}
found = TRUE_;
goto L120;
L240:
ww[nsetb] = big;
--nsetb;
if (iprint > 0) {
ivout_(&c__0, &i__, "(' VARIABLE HAS BAD DIRECTION, NOT USED.')", &
c_n4, (ftnlen)42);
}
goto L210;
/* Solve the triangular system. */
L270:
dcopy_(&nsetb, &w[(*ncols + 1) * w_dim1 + 1], &c__1, &rw[1], &c__1);
for (j = nsetb; j >= 1; --j) {
rw[j] /= w[j + j * w_dim1];
jcol = (i__3 = ibasis[j], abs(i__3));
t = rw[j];
if (ibb[jcol] % 2 == 0) {
rw[j] = -rw[j];
}
i__3 = j - 1;
d__1 = -t;
daxpy_(&i__3, &d__1, &w[j * w_dim1 + 1], &c__1, &rw[1], &c__1);
rw[j] /= (d__1 = scl[jcol], abs(d__1));
/* L280: */
}
if (iprint > 0) {
dvout_(&nsetb, &rw[1], "(' SOLN. VALUES')", &c_n4, (ftnlen)17);
ivout_(&nsetb, &ibasis[1], "(' COLS. USED')", &c_n4, (ftnlen)15);
}
if (lgopr == 2) {
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] <= bou) {
jdrop1 = j;
goto L340;
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (x[j] >= bou) {
jdrop2 = j;
goto L340;
}
/* L450: */
}
goto L340;
}
/* See if the unconstrained solution (obtained by solving the */
/* triangular system) satisfies the problem bounds. */
alpha = 2.;
beta = 2.;
x[nsetb] = 0.;
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
itemp = ibasis[j];
jcol = abs(itemp);
t1 = 2.;
t2 = 2.;
if (itemp < 0) {
bou = 0.;
} else {
bou = bl[jcol];
}
if (-bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] <= bou) {
t1 = (x[j] - bou) / (x[j] - rw[j]);
}
bou = bu[jcol];
if (bou != big) {
bou /= (d__1 = scl[jcol], abs(d__1));
}
if (rw[j] >= bou) {
t2 = (bou - x[j]) / (rw[j] - x[j]);
}
/* If not, then compute a step length so that the variables remain */
/* feasible. */
if (t1 < alpha) {
alpha = t1;
jdrop1 = j;
}
if (t2 < beta) {
beta = t2;
jdrop2 = j;
}
/* L310: */
}
constr = alpha < 2. || beta < 2.;
if (! constr) {
/* Accept the candidate because it satisfies the stated bounds */
/* on the variables. */
dcopy_(&nsetb, &rw[1], &c__1, &x[1], &c__1);
goto L580;
}
/* Take a step that is as large as possible with all variables */
/* remaining feasible. */
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
x[j] += min(alpha,beta) * (rw[j] - x[j]);
/* L330: */
}
if (alpha <= beta) {
jdrop2 = 0;
} else {
jdrop1 = 0;
}
L340:
if (jdrop1 + jdrop2 <= 0 || nsetb <= 0) {
goto L580;
}
/* L350: */
jdrop = jdrop1 + jdrop2;
itemp = ibasis[jdrop];
jcol = abs(itemp);
if (jdrop2 > 0) {
/* Variable is at an upper bound. Subtract multiple of this */
/* column from right hand side. */
t = bu[jcol];
if (itemp > 0) {
bu[jcol] = t - bl[jcol];
bl[jcol] = -t;
itemp = -itemp;
scl[jcol] = -scl[jcol];
i__3 = jdrop;
for (i__ = 1; i__ <= i__3; ++i__) {
w[i__ + jdrop * w_dim1] = -w[i__ + jdrop * w_dim1];
/* L360: */
}
} else {
++ibb[jcol];
if (ibb[jcol] % 2 == 0) {
t = -t;
}
}
/* Variable is at a lower bound. */
} else {
if ((doublereal) itemp < 0.) {
t = 0.;
} else {
t = -bl[jcol];
bu[jcol] += t;
itemp = -itemp;
}
}
daxpy_(&jdrop, &t, &w[jdrop * w_dim1 + 1], &c__1, &w[(*ncols + 1) *
w_dim1 + 1], &c__1);
/* Move certain columns left to achieve upper Hessenberg form. */
dcopy_(&jdrop, &w[jdrop * w_dim1 + 1], &c__1, &rw[1], &c__1);
i__3 = nsetb;
for (j = jdrop + 1; j <= i__3; ++j) {
ibasis[j - 1] = ibasis[j];
x[j - 1] = x[j];
dcopy_(&j, &w[j * w_dim1 + 1], &c__1, &w[(j - 1) * w_dim1 + 1], &c__1)
;
/* L370: */
}
ibasis[nsetb] = itemp;
w[nsetb * w_dim1 + 1] = 0.;
i__3 = mrows - jdrop;
dcopy_(&i__3, &w[nsetb * w_dim1 + 1], &c__0, &w[jdrop + 1 + nsetb *
w_dim1], &c__1);
dcopy_(&jdrop, &rw[1], &c__1, &w[nsetb * w_dim1 + 1], &c__1);
/* Transform the matrix from upper Hessenberg form to upper */
/* triangular form. */
--nsetb;
i__3 = nsetb;
for (i__ = jdrop; i__ <= i__3; ++i__) {
/* Look for small pivots and avoid mixing weighted and */
/* nonweighted rows. */
if (i__ == mval) {
t = 0.;
i__8 = nsetb;
for (j = i__; j <= i__8; ++j) {
jcol = (i__9 = ibasis[j], abs(i__9));
t1 = (d__1 = w[i__ + j * w_dim1] * scl[jcol], abs(d__1));
if (t1 > t) {
jbig = j;
t = t1;
}
/* L380: */
}
goto L400;
}
drotg_(&w[i__ + i__ * w_dim1], &w[i__ + 1 + i__ * w_dim1], &sc, &ss);
w[i__ + 1 + i__ * w_dim1] = 0.;
i__8 = *ncols - i__ + 1;
drot_(&i__8, &w[i__ + (i__ + 1) * w_dim1], mdw, &w[i__ + 1 + (i__ + 1)
* w_dim1], mdw, &sc, &ss);
/* L390: */
}
goto L430;
/* The triangularization is completed by giving up the Hessenberg */
/* form and triangularizing a rectangular matrix. */
L400:
dswap_(&mrows, &w[i__ * w_dim1 + 1], &c__1, &w[jbig * w_dim1 + 1], &c__1);
dswap_(&c__1, &ww[i__], &c__1, &ww[jbig], &c__1);
dswap_(&c__1, &x[i__], &c__1, &x[jbig], &c__1);
itemp = ibasis[i__];
ibasis[i__] = ibasis[jbig];
ibasis[jbig] = itemp;
jbig = i__;
i__3 = nsetb;
for (j = jbig; j <= i__3; ++j) {
i__8 = mrows;
for (i__ = j + 1; i__ <= i__8; ++i__) {
drotg_(&w[j + j * w_dim1], &w[i__ + j * w_dim1], &sc, &ss);
w[i__ + j * w_dim1] = 0.;
i__9 = *ncols - j + 1;
drot_(&i__9, &w[j + (j + 1) * w_dim1], mdw, &w[i__ + (j + 1) *
w_dim1], mdw, &sc, &ss);
/* L410: */
}
/* L420: */
}
/* See if the remaining coefficients are feasible. They should be */
/* because of the way MIN(ALPHA,BETA) was chosen. Any that are not */
/* feasible will be set to their bounds and appropriately translated. */
L430:
jdrop1 = 0;
jdrop2 = 0;
lgopr = 2;
goto L270;
/* Find a variable to become non-active. */
L120:
if (found) {
lgopr = 1;
goto L270;
}
/* Rescale and translate variables. */
igopr = 2;
L130:
dcopy_(&nsetb, &x[1], &c__1, &rw[1], &c__1);
dcopy_(ncols, &c_b185, &c__0, &x[1], &c__1);
i__3 = nsetb;
for (j = 1; j <= i__3; ++j) {
jcol = (i__8 = ibasis[j], abs(i__8));
x[jcol] = rw[j] * (d__1 = scl[jcol], abs(d__1));
/* L140: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (ibb[j] % 2 == 0) {
x[j] = bu[j] - x[j];
}
/* L150: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
jcol = ibasis[j];
if (jcol < 0) {
x[-jcol] = bl[-jcol] + x[-jcol];
}
/* L160: */
}
i__3 = *ncols;
for (j = 1; j <= i__3; ++j) {
if (scl[j] < 0.) {
x[j] = -x[j];
}
/* L170: */
}
i__ = max(nsetb,mval);
i__3 = mrows - i__;
/* Computing MIN */
i__8 = i__ + 1;
*rnorm = dnrm2_(&i__3, &w[min(i__8,mrows) + (*ncols + 1) * w_dim1], &c__1)
;
if (igopr == 2) {
*mode = nsetb;
}
return 0;
} /* dbolsm_ */
/* DECK DCHFDV */
/* Subroutine */ int dchfdv_(doublereal *x1, doublereal *x2, doublereal *f1,
doublereal *f2, doublereal *d1, doublereal *d2, integer *ne,
doublereal *xe, doublereal *fe, doublereal *de, integer *next,
integer *ierr)
{
/* Initialized data */
static doublereal zero = 0.;
/* System generated locals */
integer i__1;
/* Local variables */
static doublereal h__;
static integer i__;
static doublereal x, c2, c3, c2t2, c3t3, xma, xmi, del1, del2, delta;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DCHFDV */
/* ***PURPOSE Evaluate a cubic polynomial given in Hermite form and its */
/* first derivative at an array of points. While designed for */
/* use by DPCHFD, it may be useful directly as an evaluator */
/* for a piecewise cubic Hermite function in applications, */
/* such as graphing, where the interval is known in advance. */
/* If only function values are required, use DCHFEV instead. */
/* ***LIBRARY SLATEC (PCHIP) */
/* ***CATEGORY E3, H1 */
/* ***TYPE DOUBLE PRECISION (CHFDV-S, DCHFDV-D) */
/* ***KEYWORDS CUBIC HERMITE DIFFERENTIATION, CUBIC HERMITE EVALUATION, */
/* CUBIC POLYNOMIAL EVALUATION, PCHIP */
/* ***AUTHOR Fritsch, F. N., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* P.O. Box 808 (L-316) */
/* Livermore, CA 94550 */
/* FTS 532-4275, (510) 422-4275 */
/* ***DESCRIPTION */
/* DCHFDV: Cubic Hermite Function and Derivative Evaluator */
/* Evaluates the cubic polynomial determined by function values */
/* F1,F2 and derivatives D1,D2 on interval (X1,X2), together with */
/* its first derivative, at the points XE(J), J=1(1)NE. */
/* If only function values are required, use DCHFEV, instead. */
/* ---------------------------------------------------------------------- */
/* Calling sequence: */
/* INTEGER NE, NEXT(2), IERR */
/* DOUBLE PRECISION X1, X2, F1, F2, D1, D2, XE(NE), FE(NE), */
/* DE(NE) */
/* CALL DCHFDV (X1,X2, F1,F2, D1,D2, NE, XE, FE, DE, NEXT, IERR) */
/* Parameters: */
/* X1,X2 -- (input) endpoints of interval of definition of cubic. */
/* (Error return if X1.EQ.X2 .) */
/* F1,F2 -- (input) values of function at X1 and X2, respectively. */
/* D1,D2 -- (input) values of derivative at X1 and X2, respectively. */
/* NE -- (input) number of evaluation points. (Error return if */
/* NE.LT.1 .) */
/* XE -- (input) real*8 array of points at which the functions are to */
/* be evaluated. If any of the XE are outside the interval */
/* [X1,X2], a warning error is returned in NEXT. */
/* FE -- (output) real*8 array of values of the cubic function */
/* defined by X1,X2, F1,F2, D1,D2 at the points XE. */
/* DE -- (output) real*8 array of values of the first derivative of */
/* the same function at the points XE. */
/* NEXT -- (output) integer array indicating number of extrapolation */
/* points: */
/* NEXT(1) = number of evaluation points to left of interval. */
/* NEXT(2) = number of evaluation points to right of interval. */
/* IERR -- (output) error flag. */
/* Normal return: */
/* IERR = 0 (no errors). */
/* "Recoverable" errors: */
/* IERR = -1 if NE.LT.1 . */
/* IERR = -2 if X1.EQ.X2 . */
/* (Output arrays have not been changed in either case.) */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 811019 DATE WRITTEN */
/* 820803 Minor cosmetic changes for release 1. */
/* 870707 Corrected XERROR calls for d.p. names(s). */
/* 870813 Minor cosmetic changes. */
/* 890411 Added SAVE statements (Vers. 3.2). */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 891006 Cosmetic changes to prologue. (WRB) */
/* 891006 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) */
/* ***END PROLOGUE DCHFDV */
/* Programming notes: */
/* To produce a single precision version, simply: */
/* a. Change DCHFDV to CHFDV wherever it occurs, */
/* b. Change the double precision declaration to real, and */
/* c. Change the constant ZERO to single precision. */
/* DECLARE ARGUMENTS. */
/* DECLARE LOCAL VARIABLES. */
/* Parameter adjustments */
--next;
--de;
--fe;
--xe;
/* Function Body */
/* VALIDITY-CHECK ARGUMENTS. */
/* ***FIRST EXECUTABLE STATEMENT DCHFDV */
if (*ne < 1) {
goto L5001;
}
h__ = *x2 - *x1;
if (h__ == zero) {
goto L5002;
}
/* INITIALIZE. */
*ierr = 0;
next[1] = 0;
next[2] = 0;
xmi = min(zero,h__);
xma = max(zero,h__);
/* COMPUTE CUBIC COEFFICIENTS (EXPANDED ABOUT X1). */
delta = (*f2 - *f1) / h__;
del1 = (*d1 - delta) / h__;
del2 = (*d2 - delta) / h__;
/* (DELTA IS NO LONGER NEEDED.) */
c2 = -(del1 + del1 + del2);
c2t2 = c2 + c2;
c3 = (del1 + del2) / h__;
/* (H, DEL1 AND DEL2 ARE NO LONGER NEEDED.) */
c3t3 = c3 + c3 + c3;
/* EVALUATION LOOP. */
i__1 = *ne;
for (i__ = 1; i__ <= i__1; ++i__) {
x = xe[i__] - *x1;
fe[i__] = *f1 + x * (*d1 + x * (c2 + x * c3));
de[i__] = *d1 + x * (c2t2 + x * c3t3);
/* COUNT EXTRAPOLATION POINTS. */
if (x < xmi) {
++next[1];
}
if (x > xma) {
++next[2];
}
/* (NOTE REDUNDANCY--IF EITHER CONDITION IS TRUE, OTHER IS FALSE.) */
/* L500: */
}
/* NORMAL RETURN. */
return 0;
/* ERROR RETURNS. */
L5001:
/* NE.LT.1 RETURN. */
*ierr = -1;
xermsg_("SLATEC", "DCHFDV", "NUMBER OF EVALUATION POINTS LESS THAN ONE",
ierr, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)41);
return 0;
L5002:
/* X1.EQ.X2 RETURN. */
*ierr = -2;
xermsg_("SLATEC", "DCHFDV", "INTERVAL ENDPOINTS EQUAL", ierr, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)24);
return 0;
/* ------------- LAST LINE OF DCHFDV FOLLOWS ----------------------------- */
} /* dchfdv_ */
/* DECK DPRWPG */
/* Subroutine */ int dprwpg_(integer *key, integer *ipage, integer *lpg,
doublereal *sx, integer *ix)
{
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen), dprwvr_(integer *, integer *,
integer *, doublereal *, integer *);
/* ***BEGIN PROLOGUE DPRWPG */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSPLP */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (PRWPGE-S, DPRWPG-D) */
/* ***AUTHOR Hanson, R. J., (SNLA) */
/* Wisniewski, J. A., (SNLA) */
/* ***DESCRIPTION */
/* DPRWPG LIMITS THE TYPE OF STORAGE TO A SEQUENTIAL SCHEME. */
/* VIRTUAL MEMORY PAGE READ/WRITE SUBROUTINE. */
/* DEPENDING ON THE VALUE OF KEY, SUBROUTINE DPRWPG() PERFORMS A PAGE */
/* READ OR WRITE OF PAGE IPAGE. THE PAGE HAS LENGTH LPG. */
/* KEY IS A FLAG INDICATING WHETHER A PAGE READ OR WRITE IS */
/* TO BE PERFORMED. */
/* IF KEY = 1 DATA IS READ. */
/* IF KEY = 2 DATA IS WRITTEN. */
/* IPAGE IS THE PAGE NUMBER OF THE MATRIX TO BE ACCESSED. */
/* LPG IS THE LENGTH OF THE PAGE OF THE MATRIX TO BE ACCESSED. */
/* SX(*),IX(*) IS THE MATRIX TO BE ACCESSED. */
/* THIS SUBROUTINE IS A MODIFICATION OF THE SUBROUTINE LRWPGE, */
/* SANDIA LABS. REPT. SAND78-0785. */
/* MODIFICATIONS BY K.L. HIEBERT AND R.J. HANSON */
/* REVISED 811130-1000 */
/* REVISED YYMMDD-HHMM */
/* ***SEE ALSO DSPLP */
/* ***ROUTINES CALLED DPRWVR, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 811215 DATE WRITTEN */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900328 Added TYPE section. (WRB) */
/* 900510 Fixed error messages and replaced GOTOs with */
/* IF-THEN-ELSE. (RWC) */
/* 910403 Updated AUTHOR and DESCRIPTION sections. (WRB) */
/* ***END PROLOGUE DPRWPG */
/* ***FIRST EXECUTABLE STATEMENT DPRWPG */
/* CHECK IF IPAGE IS IN RANGE. */
/* Parameter adjustments */
--ix;
--sx;
/* Function Body */
if (*ipage < 1) {
xermsg_("SLATEC", "DPRWPG", "THE VALUE OF IPAGE (PAGE NUMBER) WAS NO"
"T IN THE RANGE1.LE.IPAGE.LE.MAXPGE.", &c__55, &c__1, (ftnlen)
6, (ftnlen)6, (ftnlen)74);
}
/* CHECK IF LPG IS POSITIVE. */
if (*lpg <= 0) {
xermsg_("SLATEC", "DPRWPG", "THE VALUE OF LPG (PAGE LENGTH) WAS NONP"
"OSITIVE.", &c__55, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)47);
}
/* DECIDE IF WE ARE READING OR WRITING. */
if (*key == 1) {
/* CODE TO DO A PAGE READ. */
dprwvr_(key, ipage, lpg, &sx[1], &ix[1]);
} else if (*key == 2) {
/* CODE TO DO A PAGE WRITE. */
dprwvr_(key, ipage, lpg, &sx[1], &ix[1]);
} else {
xermsg_("SLATEC", "DPRWPG", "THE VALUE OF KEY (READ-WRITE FLAG) WAS "
"NOT 1 OR 2.", &c__55, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)50)
;
}
return 0;
} /* dprwpg_ */
/* DECK PCHFE */
/* Subroutine */ int pchfe_(integer *n, real *x, real *f, real *d__, integer *
incfd, logical *skip, integer *ne, real *xe, real *fe, integer *ierr)
{
/* System generated locals */
integer f_dim1, f_offset, d_dim1, d_offset, i__1, i__2;
/* Local variables */
static integer i__, j, nj, ir, ierc, next[2];
extern /* Subroutine */ int chfev_(real *, real *, real *, real *, real *,
real *, integer *, real *, real *, integer *, integer *);
static integer jfirst;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE PCHFE */
/* ***PURPOSE Evaluate a piecewise cubic Hermite function at an array of */
/* points. May be used by itself for Hermite interpolation, */
/* or as an evaluator for PCHIM or PCHIC. */
/* ***LIBRARY SLATEC (PCHIP) */
/* ***CATEGORY E3 */
/* ***TYPE SINGLE PRECISION (PCHFE-S, DPCHFE-D) */
/* ***KEYWORDS CUBIC HERMITE EVALUATION, HERMITE INTERPOLATION, PCHIP, */
/* PIECEWISE CUBIC EVALUATION */
/* ***AUTHOR Fritsch, F. N., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* P.O. Box 808 (L-316) */
/* Livermore, CA 94550 */
/* FTS 532-4275, (510) 422-4275 */
/* ***DESCRIPTION */
/* PCHFE: Piecewise Cubic Hermite Function Evaluator */
/* Evaluates the cubic Hermite function defined by N, X, F, D at */
/* the points XE(J), J=1(1)NE. */
/* To provide compatibility with PCHIM and PCHIC, includes an */
/* increment between successive values of the F- and D-arrays. */
/* ---------------------------------------------------------------------- */
/* Calling sequence: */
/* PARAMETER (INCFD = ...) */
/* INTEGER N, NE, IERR */
/* REAL X(N), F(INCFD,N), D(INCFD,N), XE(NE), FE(NE) */
/* LOGICAL SKIP */
/* CALL PCHFE (N, X, F, D, INCFD, SKIP, NE, XE, FE, IERR) */
/* Parameters: */
/* N -- (input) number of data points. (Error return if N.LT.2 .) */
/* X -- (input) real array of independent variable values. The */
/* elements of X must be strictly increasing: */
/* X(I-1) .LT. X(I), I = 2(1)N. */
/* (Error return if not.) */
/* F -- (input) real array of function values. F(1+(I-1)*INCFD) is */
/* the value corresponding to X(I). */
/* D -- (input) real array of derivative values. D(1+(I-1)*INCFD) is */
/* the value corresponding to X(I). */
/* INCFD -- (input) increment between successive values in F and D. */
/* (Error return if INCFD.LT.1 .) */
/* SKIP -- (input/output) logical variable which should be set to */
/* .TRUE. if the user wishes to skip checks for validity of */
/* preceding parameters, or to .FALSE. otherwise. */
/* This will save time in case these checks have already */
/* been performed (say, in PCHIM or PCHIC). */
/* SKIP will be set to .TRUE. on normal return. */
/* NE -- (input) number of evaluation points. (Error return if */
/* NE.LT.1 .) */
/* XE -- (input) real array of points at which the function is to be */
/* evaluated. */
/* NOTES: */
/* 1. The evaluation will be most efficient if the elements */
/* of XE are increasing relative to X; */
/* that is, XE(J) .GE. X(I) */
/* implies XE(K) .GE. X(I), all K.GE.J . */
/* 2. If any of the XE are outside the interval [X(1),X(N)], */
/* values are extrapolated from the nearest extreme cubic, */
/* and a warning error is returned. */
/* FE -- (output) real array of values of the cubic Hermite function */
/* defined by N, X, F, D at the points XE. */
/* IERR -- (output) error flag. */
/* Normal return: */
/* IERR = 0 (no errors). */
/* Warning error: */
/* IERR.GT.0 means that extrapolation was performed at */
/* IERR points. */
/* "Recoverable" errors: */
/* IERR = -1 if N.LT.2 . */
/* IERR = -2 if INCFD.LT.1 . */
/* IERR = -3 if the X-array is not strictly increasing. */
/* IERR = -4 if NE.LT.1 . */
/* (The FE-array has not been changed in any of these cases.) */
/* NOTE: The above errors are checked in the order listed, */
/* and following arguments have **NOT** been validated. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED CHFEV, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 811020 DATE WRITTEN */
/* 820803 Minor cosmetic changes for release 1. */
/* 870707 Minor cosmetic changes to prologue. */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890831 Modified array declarations. (WRB) */
/* 890831 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) */
/* ***END PROLOGUE PCHFE */
/* Programming notes: */
/* 1. To produce a double precision version, simply: */
/* a. Change PCHFE to DPCHFE, and CHFEV to DCHFEV, wherever they */
/* occur, */
/* b. Change the real declaration to double precision, */
/* 2. Most of the coding between the call to CHFEV and the end of */
/* the IR-loop could be eliminated if it were permissible to */
/* assume that XE is ordered relative to X. */
/* 3. CHFEV does not assume that X1 is less than X2. thus, it would */
/* be possible to write a version of PCHFE that assumes a strict- */
/* ly decreasing X-array by simply running the IR-loop backwards */
/* (and reversing the order of appropriate tests). */
/* 4. The present code has a minor bug, which I have decided is not */
/* worth the effort that would be required to fix it. */
/* If XE contains points in [X(N-1),X(N)], followed by points .LT. */
/* X(N-1), followed by points .GT.X(N), the extrapolation points */
/* will be counted (at least) twice in the total returned in IERR. */
/* DECLARE ARGUMENTS. */
/* DECLARE LOCAL VARIABLES. */
/* VALIDITY-CHECK ARGUMENTS. */
/* ***FIRST EXECUTABLE STATEMENT PCHFE */
/* Parameter adjustments */
--x;
d_dim1 = *incfd;
d_offset = 1 + d_dim1;
d__ -= d_offset;
f_dim1 = *incfd;
f_offset = 1 + f_dim1;
f -= f_offset;
--xe;
--fe;
/* Function Body */
if (*skip) {
goto L5;
}
if (*n < 2) {
goto L5001;
}
if (*incfd < 1) {
goto L5002;
}
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
if (x[i__] <= x[i__ - 1]) {
goto L5003;
}
/* L1: */
}
/* FUNCTION DEFINITION IS OK, GO ON. */
L5:
if (*ne < 1) {
goto L5004;
}
*ierr = 0;
*skip = TRUE_;
/* LOOP OVER INTERVALS. ( INTERVAL INDEX IS IL = IR-1 . ) */
/* ( INTERVAL IS X(IL).LE.X.LT.X(IR) . ) */
jfirst = 1;
ir = 2;
L10:
/* SKIP OUT OF LOOP IF HAVE PROCESSED ALL EVALUATION POINTS. */
if (jfirst > *ne) {
goto L5000;
}
/* LOCATE ALL POINTS IN INTERVAL. */
i__1 = *ne;
for (j = jfirst; j <= i__1; ++j) {
if (xe[j] >= x[ir]) {
goto L30;
}
/* L20: */
}
j = *ne + 1;
goto L40;
/* HAVE LOCATED FIRST POINT BEYOND INTERVAL. */
L30:
if (ir == *n) {
j = *ne + 1;
}
L40:
nj = j - jfirst;
/* SKIP EVALUATION IF NO POINTS IN INTERVAL. */
if (nj == 0) {
goto L50;
}
/* EVALUATE CUBIC AT XE(I), I = JFIRST (1) J-1 . */
/* ---------------------------------------------------------------- */
chfev_(&x[ir - 1], &x[ir], &f[(ir - 1) * f_dim1 + 1], &f[ir * f_dim1 + 1],
&d__[(ir - 1) * d_dim1 + 1], &d__[ir * d_dim1 + 1], &nj, &xe[
jfirst], &fe[jfirst], next, &ierc);
/* ---------------------------------------------------------------- */
if (ierc < 0) {
goto L5005;
}
if (next[1] == 0) {
goto L42;
}
/* IF (NEXT(2) .GT. 0) THEN */
/* IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(2) TO THE */
/* RIGHT OF X(IR). */
if (ir < *n) {
goto L41;
}
/* IF (IR .EQ. N) THEN */
/* THESE ARE ACTUALLY EXTRAPOLATION POINTS. */
*ierr += next[1];
goto L42;
L41:
/* ELSE */
/* WE SHOULD NEVER HAVE GOTTEN HERE. */
goto L5005;
/* ENDIF */
/* ENDIF */
L42:
if (next[0] == 0) {
goto L49;
}
/* IF (NEXT(1) .GT. 0) THEN */
/* IN THE CURRENT SET OF XE-POINTS, THERE ARE NEXT(1) TO THE */
/* LEFT OF X(IR-1). */
if (ir > 2) {
goto L43;
}
/* IF (IR .EQ. 2) THEN */
/* THESE ARE ACTUALLY EXTRAPOLATION POINTS. */
*ierr += next[0];
goto L49;
L43:
/* ELSE */
/* XE IS NOT ORDERED RELATIVE TO X, SO MUST ADJUST */
/* EVALUATION INTERVAL. */
/* FIRST, LOCATE FIRST POINT TO LEFT OF X(IR-1). */
i__1 = j - 1;
for (i__ = jfirst; i__ <= i__1; ++i__) {
if (xe[i__] < x[ir - 1]) {
goto L45;
}
/* L44: */
}
/* NOTE-- CANNOT DROP THROUGH HERE UNLESS THERE IS AN ERROR */
/* IN CHFEV. */
goto L5005;
L45:
/* RESET J. (THIS WILL BE THE NEW JFIRST.) */
j = i__;
/* NOW FIND OUT HOW FAR TO BACK UP IN THE X-ARRAY. */
i__1 = ir - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (xe[j] < x[i__]) {
goto L47;
}
/* L46: */
}
/* NB-- CAN NEVER DROP THROUGH HERE, SINCE XE(J).LT.X(IR-1). */
L47:
/* AT THIS POINT, EITHER XE(J) .LT. X(1) */
/* OR X(I-1) .LE. XE(J) .LT. X(I) . */
/* RESET IR, RECOGNIZING THAT IT WILL BE INCREMENTED BEFORE */
/* CYCLING. */
/* Computing MAX */
i__1 = 1, i__2 = i__ - 1;
ir = max(i__1,i__2);
/* ENDIF */
/* ENDIF */
L49:
jfirst = j;
/* END OF IR-LOOP. */
L50:
++ir;
if (ir <= *n) {
goto L10;
}
/* NORMAL RETURN. */
L5000:
return 0;
/* ERROR RETURNS. */
L5001:
/* N.LT.2 RETURN. */
*ierr = -1;
xermsg_("SLATEC", "PCHFE", "NUMBER OF DATA POINTS LESS THAN TWO", ierr, &
c__1, (ftnlen)6, (ftnlen)5, (ftnlen)35);
return 0;
L5002:
/* INCFD.LT.1 RETURN. */
*ierr = -2;
xermsg_("SLATEC", "PCHFE", "INCREMENT LESS THAN ONE", ierr, &c__1, (
ftnlen)6, (ftnlen)5, (ftnlen)23);
return 0;
L5003:
/* X-ARRAY NOT STRICTLY INCREASING. */
*ierr = -3;
xermsg_("SLATEC", "PCHFE", "X-ARRAY NOT STRICTLY INCREASING", ierr, &c__1,
(ftnlen)6, (ftnlen)5, (ftnlen)31);
return 0;
L5004:
/* NE.LT.1 RETURN. */
*ierr = -4;
xermsg_("SLATEC", "PCHFE", "NUMBER OF EVALUATION POINTS LESS THAN ONE",
ierr, &c__1, (ftnlen)6, (ftnlen)5, (ftnlen)41);
return 0;
L5005:
/* ERROR RETURN FROM CHFEV. */
/* *** THIS CASE SHOULD NEVER OCCUR *** */
*ierr = -5;
xermsg_("SLATEC", "PCHFE", "ERROR RETURN FROM CHFEV -- FATAL", ierr, &
c__2, (ftnlen)6, (ftnlen)5, (ftnlen)32);
return 0;
/* ------------- LAST LINE OF PCHFE FOLLOWS ------------------------------ */
} /* pchfe_ */
