/* 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_ */