/* Subroutine */ int dcgne_(S_fp matvec, doublereal *a, integer *ia,
doublereal *x, doublereal *b, integer *n, integer *iparam, doublereal
*rparam, integer *iwork, doublereal *r__, doublereal *h__, doublereal
*d__, doublereal *e, doublereal *cndwk, integer *ierror)
{
/* Format strings */
static char fmt_6[] = "(\002 THE METHOD IS CG ON A*AT (CGNE)\002,/)";
static char fmt_8[] = "(4x,\002CONDA = \002,d12.5,/)";
static char fmt_10[] = "(\002 RESID = 2-NORM OF R\002,/,\002 RELRSD = R"
"ESID / INITIAL RESID\002,/,\002 COND(A) USED IN STOPPING CRITERI"
"ON\002,/)";
static char fmt_25[] = "(\002 INITIAL RESID = \002,d12.5,/)";
static char fmt_35[] = "(\002 ITERS = \002,i5,4x,\002RESID = \002,d12.5,"
"4x,\002RELRSD = \002,d12.5)";
static char fmt_70[] = "(/,\002 NEW ESTIMATES FOR A*AT:\002)";
static char fmt_80[] = "(\002 NEW COND ESTIMATE FOR A = \002,d12.5,/)";
/* System generated locals */
integer i__1;
doublereal d__1;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
double sqrt(doublereal);
/* Local variables */
static integer i__, nce, ido, isp1;
static doublereal beta;
static integer kmax;
extern doublereal dnrm2_(integer *, doublereal *, integer *);
static doublereal conda, alpha, denom;
static integer itmax;
static doublereal rdumm, sdumm;
static integer iters;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static doublereal zdumm;
extern doublereal d1mach_(integer *);
static integer istop, jstop;
static doublereal rnorm, r0norm;
extern /* Subroutine */ int dcgchk_(integer *, doublereal *, integer *);
static doublereal cndaat, ralpha;
static integer icycle;
static doublereal eigmin, eigmax, oldrnm;
extern /* Subroutine */ int donest_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, doublereal *);
extern integer mdstop_(integer *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *
, doublereal *, integer *);
static integer iounit;
static doublereal errtol, wdummy, stptst;
/* Fortran I/O blocks */
static cilist io___10 = { 0, 0, 0, fmt_6, 0 };
static cilist io___11 = { 0, 0, 0, fmt_8, 0 };
static cilist io___12 = { 0, 0, 0, fmt_10, 0 };
static cilist io___21 = { 0, 0, 0, fmt_25, 0 };
static cilist io___30 = { 0, 0, 0, fmt_35, 0 };
static cilist io___34 = { 0, 0, 0, fmt_70, 0 };
static cilist io___35 = { 0, 0, 0, fmt_80, 0 };
/* ***BEGIN PROLOGUE DCGNE */
/* ***DATE WRITTEN 860115 (YYMMDD) */
/* ***REVISION DATE 900210 (YYMMDD) */
/* ***CATEGORY NO. D2A4 */
/* ***KEYWORDS LINEAR SYSTEM,SPARSE,NONSYMMETRIC,NORMAL EQUATIONS, */
/* ITERATIVE,CONJUGATE GRADIENTS */
/* ***AUTHOR ASHBY,STEVEN F., (UIUC) */
/* UNIV. OF ILLINOIS */
/* DEPT. OF COMPUTER SCIENCE */
/* URBANA, IL 61801 */
/* ***AUTHOR HOLST,MICHAEL J., (UIUC) */
/* UNIV. OF ILLINOIS */
/* DEPT. OF COMPUTER SCIENCE */
/* URBANA, IL 61801 */
/* MANTEUFFEL,THOMAS A., (LANL) */
/* LOS ALAMOS NATIONAL LABORATORY */
/* MAIL STOP B265 */
/* LOS ALAMOS, NM 87545 */
/* ***PURPOSE THIS ROUTINE SOLVES THE ARBITRARY LINEAR SYSTEM AX=P BY */
/* APPLYING THE METHOD OF CONJUGATE GRADIENTS TO THE NORMAL */
/* EQUATIONS, A*AT*Y = P, WHERE AT IS THE TRANSPOSE OF A AND */
/* X = AT*Y. */
/* ***DEDCRIPTION */
/* --- ON ENTRY --- */
/* MATVEC EXTERNAL SUBROUTINE MATVEC(JOB,A,IA,W,X,Y,N) */
/* THE USER MUST PROVIDE A SUBROUTINE HAVING THE SPECIFED */
/* PARAMETER LIST. THE SUBROUTINE MUST RETURN THE PRODUCT */
/* (OR A RELATED COMPUTATION; SEE BELOW) Y=A*X, WHERE A IS */
/* THE COEFFICIENT MATRIX OF THE LINEAR SYSTEM. THE MATRIX */
/* A IS REPRESENTED BY THE WORK ARRAYS A AND IA, DEDCRIBED */
/* BELOW. THE INTEGER PARAMETER JOB SPECIFIES THE PRODUCT */
/* TO BE COMPUTED: */
/* JOB=0 Y=A*X */
/* JOB=1 Y=AT*X */
/* JOB=2 Y=W - A*X */
/* JOB=3 Y=W - AT*X. */
/* IN THE ABOVE, AT DENOTES A-TRANSPOSE. NOTE THAT */
/* ONLY THE VALUES OF JOB=0,1 ARE REQUIRED FOR CGCODE. */
/* ALL OF THE ROUTINES IN CGCODE REQUIRE JOB=0; THE */
/* ROUTINES DCGNR, DCGNE, DPCGNR, AND DPCGNE ALSO REQUIRE */
/* THE VALUE OF JOB=1. (THE VALUES OF JOB=2,3 ARE NOT */
/* REQUIRED BY ANY OF THE ROUTINES IN CGCODE, BUT MAY BE */
/* REQUIRED BY OTHER ITERATIVE PACKAGES CONFORMING TO THE */
/* PROPOSED ITERATIVE STANDARD.) THE PARAMETERS W,X,Y ARE */
/* ALL VECTORS OF LENGTH N. THE ONLY PARAMETER THAT MAY BE */
/* CHANGED INSIDE THE ROUTINE IS Y. MATVEC WILL USUALLY */
/* SERVE AS AN INTERFACE TO THE USER'S OWN MATRIX-VECTOR */
/* MULTIPLY SUBROUTINE. */
/* NOTE: MATVEC MUST BE DECLARED IN AN EXTERNAL STATEMENT */
/* IN THE CALLING PROGRAM. */
/* A DBLE ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S DBLE WORK ARRAY, USUALLY */
/* THE MATRIX A. SINCE A IS ONLY ACCESSED BY CALLS TO SUBR */
/* MATVEC, IT MAY BE A DUMMY ADDRESS. */
/* IA INTEGER ARRAY ADDRESS. */
/* THE BASE ADDRESS OF THE USER'S INTEGER WORK ARRAY. THIS */
/* USUALLY CONTAINS ADDITIONAL INFORMATION ABOUT A NEEDED BY */
/* MATVEC. SINCE IA IS ONLY ACCESSED BY CALLS TO MATVEC, IT */
/* MAY BE A DUMMY ADDRESS. */
/* X DBLE(N). */
/* THE INITIAL GUESS VECTOR, X0. */
/* (ON EXIT, X IS OVERWRITTEN WITH THE APPROXIMATE SOLUTION */
/* OF A*X=B.) */
/* B DBLE(N). */
/* THE RIGHT-HAND SIDE VECTOR OF THE LINEAR SYSTEM AX=B. */
/* NOTE: B IS CHANGED BY THE SOLVER. */
/* N INTEGER. */
/* THE ORDER OF THE MATRIX A IN THE LINEAR SYSTEM AX=B. */
/* IPARAM INTEGER(40). */
/* AN ARRAY OF INTEGER INPUT PARAMETERS: */
/* NOTE: IPARAM(1) THROUGH IPARAM(10) ARE MANDATED BY THE */
/* PROPOSED STANDARD; IPARAM(11) THROUGH IPARAM(30) ARE */
/* RESERVED FOR EXPANSION OF THE PROPOSED STANDARD; */
/* IPARAM(31) THROUGH IPARAM(34) ARE ADDITIONAL */
/* PARAMETERS, SPECIFIC TO CGCODE. */
/* IPARAM(1) = NIPAR */
/* LENGTH OF THE IPARAM ARRAY. */
/* IPARAM(2) = NRPAR */
/* LENGTH OF THE RPARAM ARRAY. */
/* IPARAM(3) = NIWK */
/* LENGTH OF THE IWORK ARRAY. */
/* IPARAM(4) = NRWK */
/* LENGTH OF THE RWORK ARRAY. */
/* IPARAM(5) = IOUNIT */
/* IF (IOUNIT > 0) THEN ITERATION INFORMATION (AS */
/* SPECIFIED BY IOLEVL; SEE BELOW) IS SENT TO UNIT=IOUNIT, */
/* WHICH MUST BE OPENED IN THE CALLING PROGRAM. */
/* IF (IOUNIT <= 0) THEN THERE IS NO OUTPUT. */
/* IPARAM(6) = IOLEVL */
/* SPECIFIES THE AMOUNT AND TYPE OF INFORMATION TO BE */
/* OUTPUT IF (IOUNIT > 0): */
/* IOLEVL = 0 OUTPUT ERROR MESSAGES ONLY */
/* IOLEVL = 1 OUTPUT INPUT PARAMETERS AND LEVEL 0 INFO */
/* IOLEVL = 2 OUTPUT STPTST (SEE BELOW) AND LEVEL 1 INFO */
/* IOLEVL = 3 OUTPUT LEVEL 2 INFO AND MORE DETAILS */
/* IPARAM(8) = ISTOP */
/* STOPPING CRITERION FLAG, INTERPRETED AS: */
/* ISTOP = 0 ||E||/||E0|| <= ERRTOL (DEFAULT) */
/* ISTOP = 1 ||R|| <= ERRTOL */
/* ISTOP = 2 ||R||/||B|| <= ERRTOL */
/* ISTOP = 3 ||C*R|| <= ERRTOL */
/* ISTOP = 4 ||C*R||/||C*B|| <= ERRTOL */
/* WHERE E=ERROR, R=RESIDUAL, B=RIGHT HAND SIDE OF A*X=B, */
/* AND C IS THE PRECONDITIONING MATRIX OR PRECONDITIONING */
/* POLYNOMIAL (OR BOTH.) */
/* NOTE: IF ISTOP=0 IS SELECTED BY THE USER, THEN ERRTOL */
/* IS THE AMOUNT BY WHICH THE INITIAL ERROR IS TO BE */
/* REDUCED. BY ESTIMATING THE CONDITION NUMBER OF THE */
/* ITERATION MATRIX, THE CODE ATTEMPTS TO GUARANTEE THAT */
/* THE FINAL RELATIVE ERROR IS .LE. ERRTOL. SEE THE LONG */
/* DEDCRIPTION BELOW FOR DETAILS. */
/* IPARAM(9) = ITMAX */
/* THE MAXIMUM NUMBER OF ITERATIVE STEPS TO BE TAKEN. */
/* IF SOLVER IS UNABLE TO SATISFY THE STOPPING CRITERION */
/* WITHIN ITMAX ITERATIONS, IT RETURNS TO THE CALLING */
/* PROGRAM WITH IERROR=-1000. */
/* IPARAM(31) = ICYCLE */
/* THE FREQUENCY WITH WHICH A CONDITION NUMBER ESTIMATE IS */
/* COMPUTED; SEE THE LONG DEDCRIPTION BELOW. */
/* IPARAM(32) = NCE */
/* THE MAXIMUM NUMBER OF CONDITION NUMBER ESTIMATES TO BE */
/* COMPUTED. IF NCE = 0 NO ESTIMATES ARE COMPUTED. SEE */
/* THE LONG DEDCRIPTION BELOW. */
/* NOTE: KMAX = ICYCLE*NCE IS THE ORDER OF THE LARGEST */
/* ORTHOGONAL SECTION OF C*A USED TO COMPUTE A CONDITION */
/* NUMBER ESTIMATE. THIS ESTIMATE IS ONLY USED IN THE */
/* STOPPING CRITERION. AS SUCH, KMAX SHOULD BE MUCH LESS */
/* THAN N. OTHERWISE THE CODE WILL HAVE EXCESSIVE STORAGE */
/* AND WORK REQUIREMENTS. */
/* RPARAM DBLE(40). */
/* AN ARRAY OF DBLE INPUT PARAMETERS: */
/* NOTE: RPARAM(1) AND RPARAM(2) ARE MANDATED BY THE */
/* PROPOSED STANDARD; RPARAM(3) THROUGH RPARAM(30) ARE */
/* RESERVED FOR EXPANSION OF THE PROPOSED STANDARD; */
/* RPARAM(31) THROUGH RPARAM(34) ARE ADDITIONAL */
/* PARAMETERS, SPECIFIC TO CGCODE. */
/* RPARAM(1) = ERRTOL */
/* USER PROVIDED ERROR TOLERANCE; SEE ISTOP ABOVE, AND THE */
/* LONG DEDCRIPTION BELOW. */
/* RPARAM(31) = CONDES */
/* AN INITIAL ESTIMATE FOR THE COND NUMBER OF THE ITERATION */
/* MATRIX; SEE THE INDIVIDUAL SUBROUTINE'S PROLOGUE. AN */
/* ACCEPTABLE INITIAL VALUE IS 1.0. */
/* R DBLE(N). */
/* WORK ARRAY OF LENGTH .GE. N. */
/* H DBLE(N). */
/* WORK ARRAY OF LENGTH .GE. N. */
/* D,E DBLE(ICYCLE*NCE + 1), DBLE(ICYCLE*NCE + 1). */
/* CNDWK DBLE(2*ICYCLE*NCE). */
/* IWORK INTEGER(ICYCLE*NCE). */
/* WORK ARRAYS FOR COMPUTING CONDITION NUMBER ESTIMATES. */
/* IF NCE = 0 THESE MAY BE DUMMY ADDRESSES. */
/* --- ON RETURN --- */
/* IPARAM THE FOLLOWING ITERATION INFO IS RETURNED VIA THIS ARRAY: */
/* IPARAM(10) = ITERS */
/* THE NUMBER OF ITERATIONS TAKEN. IF IERROR=0, THEN X_ITERS */
/* SATISFIES THE SPECIFIED STOPPING CRITERION. IF */
/* IERROR=-1000, CGCODE WAS UNABLE TO CONVERGE WITHIN ITMAX */
/* ITERATIONS, AND X_ITERS IS CGCODE'S BEST APPROXIMATION TO */
/* THE SOLUTION OF A*X=B. */
/* RPARAM THE FOLLOWING ITERATION INFO IS RETURNED VIA THIS ARRAY: */
/* RPARAM(2) = STPTST */
/* FINAL QUANTITY USED IN THE STOPPING CRITERION; SEE ISTOP */
/* ABOVE, AND THE LONG DEDCRIPTION BELOW. */
/* RPARAM(31) = CONDES */
/* CONDITION NUMBER ESTIMATE; FINAL ESTIMATE USED IN THE */
/* STOPPING CRITERION; SEE ISTOP ABOVE, AND THE LONG */
/* DEDCRIPTION BELOW. */
/* RPARAM(34) = DCRLRS */
/* THE SCALED RELATIVE RESIDUAL USING THE LAST COMPUTED */
/* RESIDUAL. */
/* X THE COMPUTED SOLUTION OF THE LINEAR SYSTEM AX=B. */
/* IERROR INTEGER. */
/* ERROR FLAG (NEGATIVE ERRORS ARE FATAL): */
/* (BELOW, A=SYSTEM MATRIX, Q=LEFT PRECONDITIONING MATRIX.) */
/* IERROR = 0 NORMAL RETURN: ITERATION CONVERGED */
/* IERROR = -1000 METHOD FAILED TO CONVERGE IN ITMAX STEPS */
/* IERROR = +-2000 ERROR IN USER INPUT */
/* IERROR = +-3000 METHOD BREAKDOWN */
/* IERROR = -6000 A DOES NOT SATISTY ASSUMPTIONS OF METHOD */
/* IERROR = -7000 Q DOES NOT SATISTY ASSUMPTIONS OF METHOD */
/* ***LONG DEDCRIPTION */
/* DCGNE IMPLEMENTS THE CLASSICAL CONJUGATE GRADIENT METHOD APPLIED TO */
/* THE NORMAL EQUATIONS A*AT*Y=B, X=A*Y, USING THE OMIN ALGORITHM: */
/* H0 = AT*R0 */
/* P0 = H0 */
/* ALPHA = <R,R>/<P,P> */
/* XNEW = X + ALPHA*P */
/* RNEW = R - ALPHA*(A*P) */
/* HNEW = AT*RNEW */
/* BETA = <RNEW,RNEW>/<R,R> */
/* PNEW = HNEW + BETA*P */
/* THIS ALGORITHM IS GUARANTEED TO CONVERGE FOR ANY NONSINGULAR A. */
/* MATHEMATICALLY, IF A*AT HAS M DISTINCT EIGENVALUES, THE ALGORITHM */
/* WILL CONVERGE IN AT MOST M STEPS. AT EACH STEP THE ALGORITHM */
/* MINIMIZES THE 2-NORM OF THE ERROR. */
/* ALTHOUGH THIS METHOD WILL CONVERGE FOR ANY A, IT MAY CONVERGE VERY */
/* SLOWLY. THIS IS BECAUSE THE CONDITION NUMBER OF A*AT IS THE SQUARE */
/* OF THAT OF A. IF A IS KNOWN TO HAVE ITS SPECTRUM IN THE RIGHT HALF */
/* COMPLEX PLANE, THE USER SHOULD CONSIDER THE CHEBYSHEV ITERATION. */
/* WHEN THE USER SELECTS THE STOPPING CRITERION OPTION ISTOP=0, THEN */
/* THE CODE STOPS WHEN COND(A)*(RNORM/R0NORM) .LE. ERRTOL, THEREBY */
/* ATTEMPTING TO GUARANTEE THAT (FINAL RELATIVE ERROR) .LE. ERRTOL. */
/* A NEW ESTIMATE FOR COND(A) IS COMPUTED EVERY ICYCLE STEPS. THIS */
/* IS DONE BY COMPUTING THE MIN AND MAX EIGENVALUES OF AN ORTHOGONAL */
/* SECTION OF A*AT. THE LARGEST ORTHOG SECTION HAS ORDER ICYCLE*NCE, */
/* WHERE NCE IS THE MAXIMUM NUMBER OF CONDITION ESTIMATES. IF NCE=0, */
/* NO CONDITION ESTIMATES ARE COMPUTED. IN THIS CASE, THE CODE STOPS */
/* WHEN RNORM/R0NORM .LE. ERRTOL. (ALSO SEE THE PROLOGUE TO DCGDRV.) */
/* THIS STOPPING CRITERION WAS IMPLEMENTED BY A.J. ROBERTSON, III */
/* (DEPT. OF MATHEMATICS, UNIV. OF COLORADO AT DENVER). QUESTIONS */
/* MAY BE DIRECTED TO HIM OR TO ONE OF THE AUTHORS. */
/* IN THE IMPLEMENTATION BELOW THE VECTORS H AND AP SHARE SPACE. */
/* DCGNE IS ONE ROUTINE IN A PACKAGE OF CG CODES; THE OTHERS ARE: */
/* DCGDRV : AN INTERFACE TO ANY ROUTINE IN THE PACKAGE */
/* DCG : CONJUGATE GRADIENTS ON A, A SPD (CGHS) */
/* DCR : CONJUGATE RESIDUALS ON A, A SPD (CR) */
/* DCRIND : CR ON A, A SYMMETRIC (CRIND) */
/* DPCG : PRECONITIONED CG ON A, A AND C SPD (PCG) */
/* DCGNR : CGHS ON AT*A, A ARBITRARY (CGNR) */
/* DCGNE : CGHS ON A*AT, A ARBITRARY (CGNE) */
/* DPCGNR : CGNR ON A*C, A AND C ARBITRARY (PCGNR) */
/* DPCGNE : CGNE ON C*A, A AND C ARBITRARY (PCGNE) */
/* DPPCG : POLYNOMIAL PCG ON A, A AND C SPD (PPCG) */
/* DPCGCA : CGHS ON C(A)*A, A AND C SPD (PCGCA) */
/* ***REFERENCES HOWARD C. ELMAN, "ITERATIVE METHODS FOR LARGE, SPARSE, */
/* NONSYMMETRIC SYSTEMS OF LINEAR EQUATIONS", YALE UNIV. */
/* DCS RESEARCH REPORT NO. 229 (APRIL 1982). */
/* VANCE FABER AND THOMAS MANTEUFFEL, "NECESSARY AND */
/* SUFFICIENT CONDITIONS FOR THE EXISTENCE OF A */
/* CONJUGATE GRADIENT METHODS", SIAM J. NUM ANAL 21(2), */
/* PP. 352-362, 1984. */
/* S. ASHBY, T. MANTEUFFEL, AND P. SAYLOR, "A TAXONOMY FOR */
/* CONJUGATE GRADIENT METHODS", SIAM J. NUM ANAL 27(6), */
/* PP. 1542-1568, 1990. */
/* S. ASHBY, M. HOLST, T. MANTEUFFEL, AND P. SAYLOR, */
/* THE ROLE OF THE INNER PRODUCT IN STOPPING CRITERIA */
/* FOR CONJUGATE GRADIENT ITERATIONS", BIT 41(1), */
/* PP. 26-53, 2001. */
/* M. HOLST, "CGCODE: SOFTWARE FOR SOLVING LINEAR SYSTEMS */
/* WITH CONJUGATE GRADIENT METHODS", M.S. THESIS, UNIV. */
/* OF ILLINOIS DCS RESEARCH REPORT (MAY 1990). */
/* S. ASHBY, "POLYNOMIAL PRECONDITIONG FOR CONJUGATE */
/* GRADIENT METHODS", PH.D. THESIS, UNIV. OF ILLINOIS */
/* DCS RESEARCH REPORT NO. R-87-1355 (DECEMBER 1987). */
/* S. ASHBY, M. SEAGER, "A PROPOSED STANDARD FOR ITERATIVE */
/* LINEAR SOLVERS", LAWRENCE LIVERMORE NATIONAL */
/* LABORATORY REPORT (TO APPEAR). */
/* ***ROUTINES CALLED DONEST,D1MACH,DCGCHK,DAXPY,DNRM2 */
/* ***END PROLOGUE DCGNE */
/* *** DECLARATIONS *** */
/* ***FIRST EXECUTABLE STATEMENT DCGNE */
/* Parameter adjustments */
--h__;
--r__;
--b;
--x;
--iparam;
--rparam;
--iwork;
--d__;
--e;
--cndwk;
/* Function Body */
/* L1: */
/* *** INITIALIZE INPUT PARAMETERS *** */
iounit = iparam[5];
istop = iparam[8];
itmax = iparam[9];
icycle = iparam[31];
nce = iparam[32];
kmax = icycle * nce;
errtol = rparam[1];
conda = max(1.,rparam[31]);
/* Computing 2nd power */
d__1 = conda;
cndaat = d__1 * d__1;
/* *** CHECK THE INPUT PARAMETERS *** */
if (iounit > 0) {
io___10.ciunit = iounit;
s_wsfe(&io___10);
e_wsfe();
}
dcgchk_(&iparam[1], &rparam[1], n);
if (iounit > 0) {
io___11.ciunit = iounit;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&conda, (ftnlen)sizeof(doublereal));
e_wsfe();
}
if (iounit > 0) {
io___12.ciunit = iounit;
s_wsfe(&io___12);
e_wsfe();
}
/* *** INITIALIZE D(1), EIGMIN, EIGMAX, ITERS *** */
d__[1] = 0.;
eigmin = d1mach_(&c__2);
eigmax = d1mach_(&c__1);
iters = 0;
/* *** COMPUTE STOPPING CRITERION DENOMINATOR *** */
denom = 1.;
if (istop == 0) {
denom = dnrm2_(n, &b[1], &c__1);
}
if (istop == 2) {
denom = dnrm2_(n, &b[1], &c__1);
}
if (istop == 4) {
denom = dnrm2_(n, &b[1], &c__1);
}
/* *** TELL MDSTOP WHETHER OR NOT I AM SUPPLYING THE STOPPING QUANTITY *** */
ido = 1;
/* *** COMPUTE THE INITIAL RESIDUAL *** */
(*matvec)(&c__0, a, ia, &wdummy, &x[1], &r__[1], n);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__[i__] = b[i__] - r__[i__];
/* L20: */
}
r0norm = dnrm2_(n, &r__[1], &c__1);
if (iounit > 0) {
io___21.ciunit = iounit;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&r0norm, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* *** CHECK THE INITIAL RESIDUAL *** */
jstop = mdstop_(&istop, &iters, &itmax, &errtol, &stptst, ierror, &rdumm,
&sdumm, &zdumm, n, &r0norm, &r0norm, &r0norm, &denom, &conda, &
ido);
if (jstop == 1) {
goto L90;
}
/* *** INITIALIZE RNORM, P *** */
rnorm = r0norm;
(*matvec)(&c__1, a, ia, &wdummy, &r__[1], &b[1], n);
/* *** UPDATE ITERS AND COMPUTE A*P *** */
L30:
++iters;
(*matvec)(&c__0, a, ia, &wdummy, &b[1], &h__[1], n);
/* *** COMPUTE NEW X *** */
/* Computing 2nd power */
d__1 = rnorm / dnrm2_(n, &b[1], &c__1);
alpha = d__1 * d__1;
daxpy_(n, &alpha, &b[1], &c__1, &x[1], &c__1);
/* *** COMPUTE AND CHECK NEW R *** */
d__1 = -alpha;
daxpy_(n, &d__1, &h__[1], &c__1, &r__[1], &c__1);
oldrnm = rnorm;
rnorm = dnrm2_(n, &r__[1], &c__1);
if (iounit > 0) {
io___30.ciunit = iounit;
s_wsfe(&io___30);
do_fio(&c__1, (char *)&iters, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&rnorm, (ftnlen)sizeof(doublereal));
d__1 = rnorm / r0norm;
do_fio(&c__1, (char *)&d__1, (ftnlen)sizeof(doublereal));
e_wsfe();
}
/* *** TEST TO HALT *** */
jstop = mdstop_(&istop, &iters, &itmax, &errtol, &stptst, ierror, &rdumm,
&sdumm, &zdumm, n, &rnorm, &rnorm, &rnorm, &denom, &conda, &ido);
if (jstop == 1) {
goto L90;
}
/* *** COMPUTE NEW P *** */
(*matvec)(&c__1, a, ia, &wdummy, &r__[1], &h__[1], n);
/* Computing 2nd power */
d__1 = rnorm / oldrnm;
beta = d__1 * d__1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
b[i__] = h__[i__] + beta * b[i__];
/* L40: */
}
/* *** UPDATE CONDITION NUMBER *** */
if (iters <= kmax && istop == 0) {
/* *** UPDATE PARAMETERS *** */
isp1 = iters + 1;
ralpha = 1. / alpha;
d__[iters] += ralpha;
d__[isp1] = beta * ralpha;
e[isp1] = -sqrt(beta) * ralpha;
if (iters % icycle == 0) {
if (iounit > 0) {
io___34.ciunit = iounit;
s_wsfe(&io___34);
e_wsfe();
}
donest_(&iounit, &d__[1], &e[1], &cndwk[1], &cndwk[kmax + 1], &
iwork[1], &iters, &eigmin, &eigmax, &cndaat);
conda = sqrt(cndaat);
if (iounit > 0) {
io___35.ciunit = iounit;
s_wsfe(&io___35);
do_fio(&c__1, (char *)&conda, (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
}
/* *** RESUME CGNE ITERATION *** */
goto L30;
/* *** FINISHED: PASS BACK ITERATION INFO *** */
L90:
iparam[10] = iters;
rparam[2] = stptst;
rparam[31] = conda;
rparam[34] = rnorm / r0norm;
return 0;
} /* dcgne_ */
/* 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 DATANH */
doublereal datanh_(doublereal *x)
{
/* Initialized data */
static doublereal atnhcs[27] = { .09439510239319549230842892218633,
.04919843705578615947200034576668,
.002102593522455432763479327331752,
1.073554449776116584640731045276e-4,
5.978267249293031478642787517872e-6,
3.5050620308891348459668348862e-7,
2.126374343765340350896219314431e-8,
1.321694535715527192129801723055e-9,
8.365875501178070364623604052959e-11,
5.370503749311002163881434587772e-12,
3.48665947015710792297124578429e-13,
2.284549509603433015524024119722e-14,
1.508407105944793044874229067558e-15,
1.002418816804109126136995722837e-16,
6.698674738165069539715526882986e-18,
4.497954546494931083083327624533e-19,
3.032954474279453541682367146666e-20,
2.052702064190936826463861418666e-21,
1.393848977053837713193014613333e-22,
9.492580637224576971958954666666e-24,
6.481915448242307604982442666666e-25,
4.43673020572361527263232e-26,3.043465618543161638912e-27,
2.091881298792393474047999999999e-28,
1.440445411234050561365333333333e-29,
9.935374683141640465066666666666e-31,
6.863462444358260053333333333333e-32 };
static logical first = TRUE_;
/* System generated locals */
real r__1;
doublereal ret_val, d__1;
/* Local variables */
static doublereal y, dxrel, sqeps;
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);
static integer nterms;
/* ***BEGIN PROLOGUE DATANH */
/* ***PURPOSE Compute the arc hyperbolic tangent. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C4C */
/* ***TYPE DOUBLE PRECISION (ATANH-S, DATANH-D, CATANH-C) */
/* ***KEYWORDS ARC HYPERBOLIC TANGENT, ATANH, ELEMENTARY FUNCTIONS, */
/* FNLIB, INVERSE HYPERBOLIC TANGENT */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DATANH(X) calculates the double precision arc hyperbolic */
/* tangent for double precision argument X. */
/* Series for ATNH on the interval 0. to 2.50000E-01 */
/* with weighted error 6.86E-32 */
/* log weighted error 31.16 */
/* significant figures required 30.00 */
/* decimal places required 31.88 */
/* ***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) */
/* ***END PROLOGUE DATANH */
/* ***FIRST EXECUTABLE STATEMENT DATANH */
if (first) {
r__1 = (real) d1mach_(&c__3) * .1f;
nterms = initds_(atnhcs, &c__27, &r__1);
dxrel = sqrt(d1mach_(&c__4));
sqeps = sqrt(d1mach_(&c__3) * 3.);
}
first = FALSE_;
y = abs(*x);
if (y >= 1.) {
xermsg_("SLATEC", "DATANH", "ABS(X) GE 1", &c__2, &c__2, (ftnlen)6, (
ftnlen)6, (ftnlen)11);
}
if (1. - y < dxrel) {
xermsg_("SLATEC", "DATANH", "ANSWER LT HALF PRECISION BECAUSE ABS(X)"
" TOO NEAR 1", &c__1, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)50);
}
ret_val = *x;
if (y > sqeps && y <= .5) {
d__1 = *x * 8. * *x - 1.;
ret_val = *x * (dcsevl_(&d__1, atnhcs, &nterms) + 1.);
}
if (y > .5) {
ret_val = log((*x + 1.) / (1. - *x)) * .5;
}
return ret_val;
} /* datanh_ */
/* 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 DBSKIN */
/* Subroutine */ int dbskin_(doublereal *x, integer *n, integer *kode,
integer *m, doublereal *y, integer *nz, integer *ierr)
{
/* Initialized data */
static doublereal a[50] = { 1.,.5,.375,.3125,.2734375,.24609375,
.2255859375,.20947265625,.196380615234375,.1854705810546875,
.176197052001953125,.168188095092773438,.161180257797241211,
.154981017112731934,.149445980787277222,.144464448094367981,
.139949934091418982,.135833759559318423,.132060599571559578,
.128585320635465905,.125370687619579257,.122385671247684513,
.119604178719328047,.117004087877603524,.114566502713486784,
.112275172659217048,.110116034723462874,.108076848895250599,
.106146905164978267,.104316786110409676,.102578173008569515,
.100923686347140974,.0993467537479668965,.0978414999033007314,
.0964026543164874854,.0950254735405376642,.0937056752969190855,
.09243938238750126,.0912230747245078224,.0900535481254756708,
.0889278787739072249,.0878433924473961612,.0867976377754033498,
.0857883629175498224,.0848134951571231199,.0838711229887106408,
.0829594803475290034,.0820769326842574183,.0812219646354630702,
.0803931690779583449 };
static doublereal hrtpi = .886226925452758014;
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static doublereal h__[31];
static integer i__, k;
static doublereal w;
static integer m3;
static doublereal t1, t2;
static integer ne;
static doublereal fn;
static integer il, kk;
static doublereal hn, gr;
static integer nl, nn, np, ns, nt;
static doublereal ss, xp, ys[3];
static integer i1m;
static doublereal exi[102], tol, yss[3];
static integer nflg, nlim;
static doublereal xlim;
static integer icase;
static doublereal enlim, xnlim;
extern doublereal d1mach_(integer *);
static integer ktrms;
extern integer i1mach_(integer *);
extern /* Subroutine */ int dbkias_(doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dgamrn_(doublereal *);
extern /* Subroutine */ int dbkisr_(doublereal *, integer *, doublereal *,
integer *), dexint_(doublereal *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, integer *);
/* ***BEGIN PROLOGUE DBSKIN */
/* ***PURPOSE Compute repeated integrals of the K-zero Bessel function. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10F */
/* ***TYPE DOUBLE PRECISION (BSKIN-S, DBSKIN-D) */
/* ***KEYWORDS BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL, */
/* INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* The following definitions are used in DBSKIN: */
/* Definition 1 */
/* KI(0,X) = K-zero Bessel function. */
/* Definition 2 */
/* KI(N,X) = Bickley Function */
/* = integral from X to infinity of KI(N-1,t)dt */
/* for X .ge. 0 and N = 1,2,... */
/* _____________________________________________________________________ */
/* DBSKIN computes a sequence of Bickley functions (repeated integrals */
/* of the K0 Bessel function); i.e. for fixed X and N and for K=1,..., */
/* DBSKIN computes the sequence */
/* Y(K) = KI(N+K-1,X) for KODE=1 */
/* or */
/* Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2, */
/* for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously). */
/* INPUT X is DOUBLE PRECISION */
/* X - Argument, X .ge. 0.0D0 */
/* N - Order of first member of the sequence N .ge. 0 */
/* KODE - Selection parameter */
/* KODE = 1 returns Y(K)= KI(N+K-1,X), K=1,M */
/* = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M */
/* M - Number of members in the sequence, M.ge.1 */
/* OUTPUT Y is a DOUBLE PRECISION VECTOR */
/* Y - A vector of dimension at least M containing the */
/* sequence selected by KODE. */
/* NZ - Underflow flag */
/* NZ = 0 means computation completed */
/* = 1 means an exponential underflow occurred on */
/* KODE=1. Y(K)=0.0D0, K=1,...,M is returned */
/* KODE=1 AND Y(K)=0.0E0, K=1,...,M IS RETURNED */
/* IERR - Error flag */
/* IERR=0, Normal return, computation completed */
/* IERR=1, Input error, no computation */
/* IERR=2, Error, no computation */
/* Algorithm termination condition not met */
/* The nominal computational accuracy is the maximum of unit */
/* roundoff (=D1MACH(4)) and 1.0D-18 since critical constants */
/* are given to only 18 digits. */
/* BSKIN is the single precision version of DBSKIN. */
/* *Long Description: */
/* Numerical recurrence on */
/* (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X) */
/* is stable where recurrence is carried forward or backward */
/* away from INT(X+0.5). The power series for indices 0,1 and 2 */
/* on 0.le.X.le.2 starts a stable recurrence for indices */
/* greater than 2. If N is sufficiently large (N.gt.NLIM), the */
/* uniform asymptotic expansion for N to INFINITY is more */
/* economical. On X.gt.2 the recursion is started by evaluating */
/* the uniform expansion for the three members whose indices are */
/* closest to INT(X+0.5) within the set N,...,N+M-1. Forward */
/* recurrence, backward recurrence or both complete the */
/* sequence depending on the relation of INT(X+0.5) to the */
/* indices N,...,N+M-1. */
/* ***REFERENCES D. E. Amos, Uniform asymptotic expansions for */
/* exponential integrals E(N,X) and Bickley functions */
/* KI(N,X), ACM Transactions on Mathematical Software, */
/* 1983. */
/* D. E. Amos, A portable Fortran subroutine for the */
/* Bickley functions KI(N,X), Algorithm 609, ACM */
/* Transactions on Mathematical Software, 1983. */
/* ***ROUTINES CALLED D1MACH, DBKIAS, DBKISR, DEXINT, DGAMRN, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891006 Cosmetic changes to prologue. (WRB) */
/* 891009 Removed unreferenced statement label. (WRB) */
/* 891009 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DBSKIN */
/* ----------------------------------------------------------------------- */
/* COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS */
/* ----------------------------------------------------------------------- */
/* Parameter adjustments */
--y;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* SQRT(PI)/2 */
/* ----------------------------------------------------------------------- */
/* ***FIRST EXECUTABLE STATEMENT DBSKIN */
*ierr = 0;
*nz = 0;
if (*x < 0.) {
*ierr = 1;
}
if (*n < 0) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*m < 1) {
*ierr = 1;
}
if (*x == 0. && *n == 0) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
if (*x == 0.) {
goto L300;
}
i1m = -i1mach_(&c__15);
t1 = d1mach_(&c__5) * 2.3026 * i1m;
xlim = t1 - 3.228086;
t2 = t1 + (*n + *m - 1);
if (t2 > 1e3) {
xlim = t1 - (log(t2) - .451583) * .5;
}
if (*x > xlim && *kode == 1) {
goto L320;
}
/* Computing MAX */
d__1 = d1mach_(&c__4);
tol = max(d__1,1e-18);
i1m = i1mach_(&c__14);
/* ----------------------------------------------------------------------- */
/* LN(NLIM) = 0.125*LN(EPS), NLIM = 2*KTRMS+N */
/* ----------------------------------------------------------------------- */
xnlim = (i1m - 1) * .287823 * d1mach_(&c__5);
enlim = exp(xnlim);
nlim = (integer) enlim + 2;
nlim = min(100,nlim);
nlim = max(20,nlim);
m3 = min(*m,3);
nl = *n + *m - 1;
if (*x > 2.) {
goto L130;
}
if (*n > nlim) {
goto L280;
}
/* ----------------------------------------------------------------------- */
/* COMPUTATION BY SERIES FOR 0.LE.X.LE.2 */
/* ----------------------------------------------------------------------- */
nflg = 0;
nn = *n;
if (nl <= 2) {
goto L60;
}
m3 = 3;
nn = 0;
nflg = 1;
L60:
xp = 1.;
if (*kode == 2) {
xp = exp(*x);
}
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
dbkisr_(x, &nn, &w, ierr);
if (*ierr != 0) {
return 0;
}
w *= xp;
if (nn < *n) {
goto L70;
}
kk = nn - *n + 1;
y[kk] = w;
L70:
ys[i__ - 1] = w;
++nn;
/* L80: */
}
if (nflg == 0) {
return 0;
}
ns = nn;
xp = 1.;
L90:
/* ----------------------------------------------------------------------- */
/* FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2 */
/* ----------------------------------------------------------------------- */
fn = (doublereal) (ns - 1);
il = nl - ns + 1;
if (il <= 0) {
return 0;
}
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
t1 = ys[1];
t2 = ys[2];
ys[2] = (*x * (ys[0] - ys[2]) + (fn - 1.) * ys[1]) / fn;
ys[1] = t2;
ys[0] = t1;
fn += 1.;
if (ns < *n) {
goto L100;
}
kk = ns - *n + 1;
y[kk] = ys[2] * xp;
L100:
++ns;
/* L110: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2 */
/* ----------------------------------------------------------------------- */
L130:
w = *x + .5;
nt = (integer) w;
if (nl > nt) {
goto L270;
}
/* ----------------------------------------------------------------------- */
/* CASE NL.LE.NT, ICASE=0 */
/* ----------------------------------------------------------------------- */
icase = 0;
nn = nl;
/* Computing MIN */
i__1 = *m - m3;
nflg = min(i__1,1);
L140:
kk = (nlim - nn) / 2;
ktrms = max(0,kk);
ns = nn + 1;
np = nn - m3 + 1;
xp = 1.;
if (*kode == 1) {
xp = exp(-(*x));
}
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
kk = i__;
dbkias_(x, &np, &ktrms, a, &w, &kk, &ne, &gr, h__, ierr);
if (*ierr != 0) {
return 0;
}
ys[i__ - 1] = w;
++np;
/* L150: */
}
/* ----------------------------------------------------------------------- */
/* SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD */
/* ----------------------------------------------------------------------- */
if (ktrms == 0) {
goto L160;
}
ne = ktrms + ktrms + 1;
np = nn - m3 + 2;
dexint_(x, &np, &c__2, &ne, &tol, exi, nz, ierr);
if (*nz != 0) {
goto L320;
}
L160:
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
ss = 0.;
if (ktrms == 0) {
goto L180;
}
kk = i__ + ktrms + ktrms - 2;
il = ktrms;
i__2 = ktrms;
for (k = 1; k <= i__2; ++k) {
ss += a[il - 1] * exi[kk - 1];
kk += -2;
--il;
/* L170: */
}
L180:
ys[i__ - 1] += ss;
/* L190: */
}
if (icase == 1) {
goto L200;
}
if (nflg != 0) {
goto L220;
}
L200:
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = ys[i__ - 1] * xp;
/* L210: */
}
if (icase == 1 && nflg == 1) {
goto L90;
}
return 0;
L220:
/* ----------------------------------------------------------------------- */
/* BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2 */
/* ----------------------------------------------------------------------- */
kk = nn - *n + 1;
k = m3;
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
y[kk] = ys[k - 1] * xp;
yss[i__ - 1] = ys[i__ - 1];
--kk;
--k;
/* L230: */
}
il = kk;
if (il <= 0) {
goto L250;
}
fn = (doublereal) (nn - 3);
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
t1 = ys[1];
t2 = ys[0];
ys[0] = ys[1] + ((fn + 2.) * ys[2] - (fn + 1.) * ys[0]) / *x;
ys[1] = t2;
ys[2] = t1;
y[kk] = ys[0] * xp;
--kk;
fn += -1.;
/* L240: */
}
L250:
if (icase != 2) {
return 0;
}
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
ys[i__ - 1] = yss[i__ - 1];
/* L260: */
}
goto L90;
L270:
if (*n < nt) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION */
/* ----------------------------------------------------------------------- */
L280:
nn = *n + m3 - 1;
/* Computing MIN */
i__1 = *m - m3;
nflg = min(i__1,1);
icase = 1;
goto L140;
/* ----------------------------------------------------------------------- */
/* ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION */
/* ----------------------------------------------------------------------- */
L290:
nn = nt + 1;
/* Computing MIN */
i__1 = *m - m3;
nflg = min(i__1,1);
icase = 2;
goto L140;
/* ----------------------------------------------------------------------- */
/* X=0 CASE */
/* ----------------------------------------------------------------------- */
L300:
fn = (doublereal) (*n);
hn = fn * .5;
gr = dgamrn_(&hn);
y[1] = hrtpi * gr;
if (*m == 1) {
return 0;
}
y[2] = hrtpi / (hn * gr);
if (*m == 2) {
return 0;
}
i__1 = *m;
for (k = 3; k <= i__1; ++k) {
y[k] = fn * y[k - 2] / (fn + 1.);
fn += 1.;
/* L310: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* UNDERFLOW ON KODE=1, X.GT.XLIM */
/* ----------------------------------------------------------------------- */
L320:
*nz = *m;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L330: */
}
return 0;
} /* dbskin_ */
/* Subroutine */ int dqawfe_(D_fp f, doublereal *a, doublereal *omega,
integer *integr, doublereal *epsabs, integer *limlst, integer *limit,
integer *maxp1, doublereal *result, doublereal *abserr, integer *
neval, integer *ier, doublereal *rslst, doublereal *erlst, integer *
ierlst, integer *lst, doublereal *alist__, doublereal *blist,
doublereal *rlist, doublereal *elist, integer *iord, integer *nnlog,
doublereal *chebmo)
{
/* Initialized data */
static doublereal p = .9;
static doublereal pi = 3.1415926535897932384626433832795;
/* System generated locals */
integer chebmo_dim1, chebmo_offset, i__1;
doublereal d__1, d__2;
/* Local variables */
doublereal fact, epsa;
integer last, nres;
doublereal psum[52];
integer l;
extern /* Subroutine */ int dqelg_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *);
doublereal cycle;
integer ktmin;
doublereal c1, c2, uflow;
extern doublereal d1mach_(integer *);
doublereal p1, res3la[3];
integer numrl2;
doublereal dl, ep;
integer ll;
extern /* Subroutine */ int dqagie_(D_fp, doublereal *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *);
doublereal abseps, correc;
extern /* Subroutine */ int dqawoe_(D_fp, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *, doublereal *, doublereal *, integer *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *, doublereal *);
integer momcom;
doublereal reseps, errsum, dla, drl, eps;
integer nev;
/* ***begin prologue dqawfe */
/* ***date written 800101 (yymmdd) */
/* ***revision date 830518 (yymmdd) */
/* ***category no. h2a3a1 */
/* ***keywords automatic integrator, special-purpose, */
/* fourier integrals, */
/* integration between zeros with dqawoe, */
/* convergence acceleration with dqelg */
/* ***author piessens,robert,appl. math. & progr. div. - k.u.leuven */
/* dedoncker,elise,appl. math. & progr. div. - k.u.leuven */
/* ***purpose the routine calculates an approximation result to a */
/* given fourier integal */
/* i = integral of f(x)*w(x) over (a,infinity) */
/* where w(x)=cos(omega*x) or w(x)=sin(omega*x), */
/* hopefully satisfying following claim for accuracy */
/* abs(i-result).le.epsabs. */
/* ***description */
/* computation of fourier integrals */
/* standard fortran subroutine */
/* double precision version */
/* parameters */
/* on entry */
/* f - double precision */
/* function subprogram defining the integrand */
/* function f(x). the actual name for f needs to */
/* be declared e x t e r n a l in the driver program. */
/* a - double precision */
/* lower limit of integration */
/* omega - double precision */
/* parameter in the weight function */
/* integr - integer */
/* indicates which weight function is used */
/* integr = 1 w(x) = cos(omega*x) */
/* integr = 2 w(x) = sin(omega*x) */
/* if integr.ne.1.and.integr.ne.2, the routine will */
/* end with ier = 6. */
/* epsabs - double precision */
/* absolute accuracy requested, epsabs.gt.0 */
/* if epsabs.le.0, the routine will end with ier = 6. */
/* limlst - integer */
/* limlst gives an upper bound on the number of */
/* cycles, limlst.ge.1. */
/* if limlst.lt.3, the routine will end with ier = 6. */
/* limit - integer */
/* gives an upper bound on the number of subintervals */
/* allowed in the partition of each cycle, limit.ge.1 */
/* each cycle, limit.ge.1. */
/* maxp1 - integer */
/* gives an upper bound on the number of */
/* chebyshev moments which can be stored, i.e. */
/* for the intervals of lengths abs(b-a)*2**(-l), */
/* l=0,1, ..., maxp1-2, maxp1.ge.1 */
/* on return */
/* result - double precision */
/* approximation to the integral x */
/* abserr - double precision */
/* estimate of the modulus of the absolute error, */
/* which should equal or exceed abs(i-result) */
/* neval - integer */
/* number of integrand evaluations */
/* ier - ier = 0 normal and reliable termination of */
/* the routine. it is assumed that the */
/* requested accuracy has been achieved. */
/* ier.gt.0 abnormal termination of the routine. the */
/* estimates for integral and error are less */
/* reliable. it is assumed that the requested */
/* accuracy has not been achieved. */
/* error messages */
/* if omega.ne.0 */
/* ier = 1 maximum number of cycles allowed */
/* has been achieved., i.e. of subintervals */
/* (a+(k-1)c,a+kc) where */
/* c = (2*int(abs(omega))+1)*pi/abs(omega), */
/* for k = 1, 2, ..., lst. */
/* one can allow more cycles by increasing */
/* the value of limlst (and taking the */
/* according dimension adjustments into */
/* account). */
/* examine the array iwork which contains */
/* the error flags on the cycles, in order to */
/* look for eventual local integration */
/* difficulties. if the position of a local */
/* difficulty can be determined (e.g. */
/* singularity, discontinuity within the */
/* interval) one will probably gain from */
/* splitting up the interval at this point */
/* and calling appropriate integrators on */
/* the subranges. */
/* = 4 the extrapolation table constructed for */
/* convergence acceleration of the series */
/* formed by the integral contributions over */
/* the cycles, does not converge to within */
/* the requested accuracy. as in the case of */
/* ier = 1, it is advised to examine the */
/* array iwork which contains the error */
/* flags on the cycles. */
/* = 6 the input is invalid because */
/* (integr.ne.1 and integr.ne.2) or */
/* epsabs.le.0 or limlst.lt.3. */
/* result, abserr, neval, lst are set */
/* to zero. */
/* = 7 bad integrand behaviour occurs within one */
/* or more of the cycles. location and type */
/* of the difficulty involved can be */
/* determined from the vector ierlst. here */
/* lst is the number of cycles actually */
/* needed (see below). */
/* ierlst(k) = 1 the maximum number of */
/* subdivisions (= limit) has */
/* been achieved on the k th */
/* cycle. */
/* = 2 occurrence of roundoff error */
/* is detected and prevents the */
/* tolerance imposed on the */
/* k th cycle, from being */
/* achieved. */
/* = 3 extremely bad integrand */
/* behaviour occurs at some */
/* points of the k th cycle. */
/* = 4 the integration procedure */
/* over the k th cycle does */
/* not converge (to within the */
/* required accuracy) due to */
/* roundoff in the */
/* extrapolation procedure */
/* invoked on this cycle. it */
/* is assumed that the result */
/* on this interval is the */
/* best which can be obtained. */
/* = 5 the integral over the k th */
/* cycle is probably divergent */
/* or slowly convergent. it */
/* must be noted that */
/* divergence can occur with */
/* any other value of */
/* ierlst(k). */
/* if omega = 0 and integr = 1, */
/* the integral is calculated by means of dqagie */
/* and ier = ierlst(1) (with meaning as described */
/* for ierlst(k), k = 1). */
/* rslst - double precision */
/* vector of dimension at least limlst */
/* rslst(k) contains the integral contribution */
/* over the interval (a+(k-1)c,a+kc) where */
/* c = (2*int(abs(omega))+1)*pi/abs(omega), */
/* k = 1, 2, ..., lst. */
/* note that, if omega = 0, rslst(1) contains */
/* the value of the integral over (a,infinity). */
/* erlst - double precision */
/* vector of dimension at least limlst */
/* erlst(k) contains the error estimate corresponding */
/* with rslst(k). */
/* ierlst - integer */
/* vector of dimension at least limlst */
/* ierlst(k) contains the error flag corresponding */
/* with rslst(k). for the meaning of the local error */
/* flags see description of output parameter ier. */
/* lst - integer */
/* number of subintervals needed for the integration */
/* if omega = 0 then lst is set to 1. */
/* alist, blist, rlist, elist - double precision */
/* vector of dimension at least limit, */
/* iord, nnlog - integer */
/* vector of dimension at least limit, providing */
/* space for the quantities needed in the subdivision */
/* process of each cycle */
/* chebmo - double precision */
/* array of dimension at least (maxp1,25), providing */
/* space for the chebyshev moments needed within the */
/* cycles */
/* ***references (none) */
/* ***routines called d1mach,dqagie,dqawoe,dqelg */
/* ***end prologue dqawfe */
/* the dimension of psum is determined by the value of */
/* limexp in subroutine dqelg (psum must be of dimension */
/* (limexp+2) at least). */
/* list of major variables */
/* ----------------------- */
/* c1, c2 - end points of subinterval (of length cycle) */
/* cycle - (2*int(abs(omega))+1)*pi/abs(omega) */
/* psum - vector of dimension at least (limexp+2) */
/* (see routine dqelg) */
/* psum contains the part of the epsilon table */
/* which is still needed for further computations. */
/* each element of psum is a partial sum of the */
/* series which should sum to the value of the */
/* integral. */
/* errsum - sum of error estimates over the subintervals, */
/* calculated cumulatively */
/* epsa - absolute tolerance requested over current */
/* subinterval */
/* chebmo - array containing the modified chebyshev */
/* moments (see also routine dqc25f) */
/* Parameter adjustments */
--ierlst;
--erlst;
--rslst;
--nnlog;
--iord;
--elist;
--rlist;
--blist;
--alist__;
chebmo_dim1 = *maxp1;
chebmo_offset = 1 + chebmo_dim1 * 1;
chebmo -= chebmo_offset;
/* Function Body */
/* test on validity of parameters */
/* ------------------------------ */
/* ***first executable statement dqawfe */
*result = 0.;
*abserr = 0.;
*neval = 0;
*lst = 0;
*ier = 0;
if (*integr != 1 && *integr != 2 || *epsabs <= 0. || *limlst < 3) {
*ier = 6;
}
if (*ier == 6) {
goto L999;
}
if (*omega != 0.) {
goto L10;
}
/* integration by dqagie if omega is zero */
/* -------------------------------------- */
if (*integr == 1) {
dqagie_((D_fp)f, &c_b4, &c__1, epsabs, &c_b4, limit, result, abserr,
neval, ier, &alist__[1], &blist[1], &rlist[1], &elist[1], &
iord[1], &last);
}
rslst[1] = *result;
erlst[1] = *abserr;
ierlst[1] = *ier;
*lst = 1;
goto L999;
/* initializations */
/* --------------- */
L10:
l = (integer) abs(*omega);
dl = (doublereal) ((l << 1) + 1);
cycle = dl * pi / abs(*omega);
*ier = 0;
ktmin = 0;
*neval = 0;
numrl2 = 0;
nres = 0;
c1 = *a;
c2 = cycle + *a;
p1 = 1. - p;
uflow = d1mach_(&c__1);
eps = *epsabs;
if (*epsabs > uflow / p1) {
eps = *epsabs * p1;
}
ep = eps;
fact = 1.;
correc = 0.;
*abserr = 0.;
errsum = 0.;
/* main do-loop */
/* ------------ */
i__1 = *limlst;
for (*lst = 1; *lst <= i__1; ++(*lst)) {
/* integrate over current subinterval. */
dla = (doublereal) (*lst);
epsa = eps * fact;
dqawoe_((D_fp)f, &c1, &c2, omega, integr, &epsa, &c_b4, limit, lst,
maxp1, &rslst[*lst], &erlst[*lst], &nev, &ierlst[*lst], &last,
&alist__[1], &blist[1], &rlist[1], &elist[1], &iord[1], &
nnlog[1], &momcom, &chebmo[chebmo_offset]);
*neval += nev;
fact *= p;
errsum += erlst[*lst];
drl = (d__1 = rslst[*lst], abs(d__1)) * 50.;
/* test on accuracy with partial sum */
if (errsum + drl <= *epsabs && *lst >= 6) {
goto L80;
}
/* Computing MAX */
d__1 = correc, d__2 = erlst[*lst];
correc = max(d__1,d__2);
if (ierlst[*lst] != 0) {
/* Computing MAX */
d__1 = ep, d__2 = correc * p1;
eps = max(d__1,d__2);
}
if (ierlst[*lst] != 0) {
*ier = 7;
}
if (*ier == 7 && errsum + drl <= correc * 10. && *lst > 5) {
goto L80;
}
++numrl2;
if (*lst > 1) {
goto L20;
}
psum[0] = rslst[1];
goto L40;
L20:
psum[numrl2 - 1] = psum[ll - 1] + rslst[*lst];
if (*lst == 2) {
goto L40;
}
/* test on maximum number of subintervals */
if (*lst == *limlst) {
*ier = 1;
}
/* perform new extrapolation */
dqelg_(&numrl2, psum, &reseps, &abseps, res3la, &nres);
/* test whether extrapolated result is influenced by roundoff */
++ktmin;
if (ktmin >= 15 && *abserr <= (errsum + drl) * .001) {
*ier = 4;
}
if (abseps > *abserr && *lst != 3) {
goto L30;
}
*abserr = abseps;
*result = reseps;
ktmin = 0;
/* if ier is not 0, check whether direct result (partial sum) */
/* or extrapolated result yields the best integral */
/* approximation */
if (*abserr + correc * 10. <= *epsabs || *abserr <= *epsabs && correc
* 10. >= *epsabs) {
goto L60;
}
L30:
if (*ier != 0 && *ier != 7) {
goto L60;
}
L40:
ll = numrl2;
c1 = c2;
c2 += cycle;
/* L50: */
}
/* set final result and error estimate */
/* ----------------------------------- */
L60:
*abserr += correc * 10.;
if (*ier == 0) {
goto L999;
}
if (*result != 0. && psum[numrl2 - 1] != 0.) {
goto L70;
}
if (*abserr > errsum) {
goto L80;
}
if (psum[numrl2 - 1] == 0.) {
goto L999;
}
L70:
if (*abserr / abs(*result) > (errsum + drl) / (d__1 = psum[numrl2 - 1],
abs(d__1))) {
goto L80;
}
if (*ier >= 1 && *ier != 7) {
*abserr += drl;
}
goto L999;
L80:
*result = psum[numrl2 - 1];
*abserr = errsum + drl;
L999:
return 0;
} /* dqawfe_ */
/* DECK DQAGIE */
/* Subroutine */ int dqagie_(D_fp f, doublereal *bound, integer *inf,
doublereal *epsabs, doublereal *epsrel, integer *limit, doublereal *
result, doublereal *abserr, integer *neval, integer *ier, doublereal *
alist__, doublereal *blist, doublereal *rlist, doublereal *elist,
integer *iord, integer *last)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1, d__2;
/* Local variables */
static integer k;
static doublereal a1, a2, b1, b2;
static integer id;
static doublereal area, dres;
static integer ksgn;
static doublereal boun;
static integer nres;
static doublereal area1, area2, area12;
extern /* Subroutine */ int dqelg_(integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dqk15i_(D_fp, doublereal *
, integer *, doublereal *, doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *);
static doublereal small, erro12;
static integer ierro;
static doublereal defab1, defab2;
static integer ktmin, nrmax;
static doublereal oflow, uflow;
extern doublereal d1mach_(integer *);
static logical noext;
static integer iroff1, iroff2, iroff3;
static doublereal res3la[3], error1, error2, rlist2[52];
static integer numrl2;
static doublereal defabs, epmach, erlarg, abseps, correc, errbnd, resabs;
static integer jupbnd;
static doublereal erlast, errmax;
static integer maxerr;
static doublereal reseps;
static logical extrap;
static doublereal ertest, errsum;
extern /* Subroutine */ int dqpsrt_(integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *);
/* ***BEGIN PROLOGUE DQAGIE */
/* ***PURPOSE The routine calculates an approximation result to a given */
/* integral I = Integral of F over (BOUND,+INFINITY) */
/* or I = Integral of F over (-INFINITY,BOUND) */
/* or I = Integral of F over (-INFINITY,+INFINITY), */
/* hopefully satisfying following claim for accuracy */
/* ABS(I-RESULT).LE.MAX(EPSABS,EPSREL*ABS(I)) */
/* ***LIBRARY SLATEC (QUADPACK) */
/* ***CATEGORY H2A3A1, H2A4A1 */
/* ***TYPE DOUBLE PRECISION (QAGIE-S, DQAGIE-D) */
/* ***KEYWORDS AUTOMATIC INTEGRATOR, EXTRAPOLATION, GENERAL-PURPOSE, */
/* GLOBALLY ADAPTIVE, INFINITE INTERVALS, QUADPACK, */
/* QUADRATURE, TRANSFORMATION */
/* ***AUTHOR Piessens, Robert */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* de Doncker, Elise */
/* Applied Mathematics and Programming Division */
/* K. U. Leuven */
/* ***DESCRIPTION */
/* Integration over infinite intervals */
/* Standard fortran subroutine */
/* F - Double precision */
/* Function subprogram defining the integrand */
/* function F(X). The actual name for F needs to be */
/* declared E X T E R N A L in the driver program. */
/* BOUND - Double precision */
/* Finite bound of integration range */
/* (has no meaning if interval is doubly-infinite) */
/* INF - Double precision */
/* Indicating the kind of integration range involved */
/* INF = 1 corresponds to (BOUND,+INFINITY), */
/* INF = -1 to (-INFINITY,BOUND), */
/* INF = 2 to (-INFINITY,+INFINITY). */
/* EPSABS - Double precision */
/* Absolute accuracy requested */
/* EPSREL - Double precision */
/* Relative accuracy requested */
/* If EPSABS.LE.0 */
/* and EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), */
/* the routine will end with IER = 6. */
/* LIMIT - Integer */
/* Gives an upper bound on the number of subintervals */
/* in the partition of (A,B), LIMIT.GE.1 */
/* ON RETURN */
/* RESULT - Double precision */
/* Approximation to the integral */
/* ABSERR - Double precision */
/* Estimate of the modulus of the absolute error, */
/* which should equal or exceed ABS(I-RESULT) */
/* NEVAL - Integer */
/* Number of integrand evaluations */
/* IER - Integer */
/* IER = 0 Normal and reliable termination of the */
/* routine. It is assumed that the requested */
/* accuracy has been achieved. */
/* - IER.GT.0 Abnormal termination of the routine. The */
/* estimates for result and error are less */
/* reliable. It is assumed that the requested */
/* accuracy has not been achieved. */
/* ERROR MESSAGES */
/* IER = 1 Maximum number of subdivisions allowed */
/* has been achieved. One can allow more */
/* subdivisions by increasing the value of */
/* LIMIT (and taking the according dimension */
/* adjustments into account). However, if */
/* this yields no improvement it is advised */
/* to analyze the integrand in order to */
/* determine the integration difficulties. */
/* If the position of a local difficulty can */
/* be determined (e.g. SINGULARITY, */
/* DISCONTINUITY within the interval) one */
/* will probably gain from splitting up the */
/* interval at this point and calling the */
/* integrator on the subranges. If possible, */
/* an appropriate special-purpose integrator */
/* should be used, which is designed for */
/* handling the type of difficulty involved. */
/* = 2 The occurrence of roundoff error is */
/* detected, which prevents the requested */
/* tolerance from being achieved. */
/* The error may be under-estimated. */
/* = 3 Extremely bad integrand behaviour occurs */
/* at some points of the integration */
/* interval. */
/* = 4 The algorithm does not converge. */
/* Roundoff error is detected in the */
/* extrapolation table. */
/* It is assumed that the requested tolerance */
/* cannot be achieved, and that the returned */
/* result is the best which can be obtained. */
/* = 5 The integral is probably divergent, or */
/* slowly convergent. It must be noted that */
/* divergence can occur with any other value */
/* of IER. */
/* = 6 The input is invalid, because */
/* (EPSABS.LE.0 and */
/* EPSREL.LT.MAX(50*REL.MACH.ACC.,0.5D-28), */
/* RESULT, ABSERR, NEVAL, LAST, RLIST(1), */
/* ELIST(1) and IORD(1) are set to zero. */
/* ALIST(1) and BLIST(1) are set to 0 */
/* and 1 respectively. */
/* ALIST - Double precision */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the left */
/* end points of the subintervals in the partition */
/* of the transformed integration range (0,1). */
/* BLIST - Double precision */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the right */
/* end points of the subintervals in the partition */
/* of the transformed integration range (0,1). */
/* RLIST - Double precision */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the integral */
/* approximations on the subintervals */
/* ELIST - Double precision */
/* Vector of dimension at least LIMIT, the first */
/* LAST elements of which are the moduli of the */
/* absolute error estimates on the subintervals */
/* IORD - Integer */
/* Vector of dimension LIMIT, the first K */
/* elements of which are pointers to the */
/* error estimates over the subintervals, */
/* such that ELIST(IORD(1)), ..., ELIST(IORD(K)) */
/* form a decreasing sequence, with K = LAST */
/* If LAST.LE.(LIMIT/2+2), and K = LIMIT+1-LAST */
/* otherwise */
/* LAST - Integer */
/* Number of subintervals actually produced */
/* in the subdivision process */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED D1MACH, DQELG, DQK15I, DQPSRT */
/* ***REVISION HISTORY (YYMMDD) */
/* 800101 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) */
/* ***END PROLOGUE DQAGIE */
/* THE DIMENSION OF RLIST2 IS DETERMINED BY THE VALUE OF */
/* LIMEXP IN SUBROUTINE DQELG. */
/* LIST OF MAJOR VARIABLES */
/* ----------------------- */
/* ALIST - LIST OF LEFT END POINTS OF ALL SUBINTERVALS */
/* CONSIDERED UP TO NOW */
/* BLIST - LIST OF RIGHT END POINTS OF ALL SUBINTERVALS */
/* CONSIDERED UP TO NOW */
/* RLIST(I) - APPROXIMATION TO THE INTEGRAL OVER */
/* (ALIST(I),BLIST(I)) */
/* RLIST2 - ARRAY OF DIMENSION AT LEAST (LIMEXP+2), */
/* CONTAINING THE PART OF THE EPSILON TABLE */
/* WHICH IS STILL NEEDED FOR FURTHER COMPUTATIONS */
/* ELIST(I) - ERROR ESTIMATE APPLYING TO RLIST(I) */
/* MAXERR - POINTER TO THE INTERVAL WITH LARGEST ERROR */
/* ESTIMATE */
/* ERRMAX - ELIST(MAXERR) */
/* ERLAST - ERROR ON THE INTERVAL CURRENTLY SUBDIVIDED */
/* (BEFORE THAT SUBDIVISION HAS TAKEN PLACE) */
/* AREA - SUM OF THE INTEGRALS OVER THE SUBINTERVALS */
/* ERRSUM - SUM OF THE ERRORS OVER THE SUBINTERVALS */
/* ERRBND - REQUESTED ACCURACY MAX(EPSABS,EPSREL* */
/* ABS(RESULT)) */
/* *****1 - VARIABLE FOR THE LEFT SUBINTERVAL */
/* *****2 - VARIABLE FOR THE RIGHT SUBINTERVAL */
/* LAST - INDEX FOR SUBDIVISION */
/* NRES - NUMBER OF CALLS TO THE EXTRAPOLATION ROUTINE */
/* NUMRL2 - NUMBER OF ELEMENTS CURRENTLY IN RLIST2. IF AN */
/* APPROPRIATE APPROXIMATION TO THE COMPOUNDED */
/* INTEGRAL HAS BEEN OBTAINED, IT IS PUT IN */
/* RLIST2(NUMRL2) AFTER NUMRL2 HAS BEEN INCREASED */
/* BY ONE. */
/* SMALL - LENGTH OF THE SMALLEST INTERVAL CONSIDERED UP */
/* TO NOW, MULTIPLIED BY 1.5 */
/* ERLARG - SUM OF THE ERRORS OVER THE INTERVALS LARGER */
/* THAN THE SMALLEST INTERVAL CONSIDERED UP TO NOW */
/* EXTRAP - LOGICAL VARIABLE DENOTING THAT THE ROUTINE */
/* IS ATTEMPTING TO PERFORM EXTRAPOLATION. I.E. */
/* BEFORE SUBDIVIDING THE SMALLEST INTERVAL WE */
/* TRY TO DECREASE THE VALUE OF ERLARG. */
/* NOEXT - LOGICAL VARIABLE DENOTING THAT EXTRAPOLATION */
/* IS NO LONGER ALLOWED (TRUE-VALUE) */
/* MACHINE DEPENDENT CONSTANTS */
/* --------------------------- */
/* EPMACH IS THE LARGEST RELATIVE SPACING. */
/* UFLOW IS THE SMALLEST POSITIVE MAGNITUDE. */
/* OFLOW IS THE LARGEST POSITIVE MAGNITUDE. */
/* ***FIRST EXECUTABLE STATEMENT DQAGIE */
/* Parameter adjustments */
--iord;
--elist;
--rlist;
--blist;
--alist__;
/* Function Body */
epmach = d1mach_(&c__4);
/* TEST ON VALIDITY OF PARAMETERS */
/* ----------------------------- */
*ier = 0;
*neval = 0;
*last = 0;
*result = 0.;
*abserr = 0.;
alist__[1] = 0.;
blist[1] = 1.;
rlist[1] = 0.;
elist[1] = 0.;
iord[1] = 0;
/* Computing MAX */
d__1 = epmach * 50.;
if (*epsabs <= 0. && *epsrel < max(d__1,5e-29)) {
*ier = 6;
}
if (*ier == 6) {
goto L999;
}
/* FIRST APPROXIMATION TO THE INTEGRAL */
/* ----------------------------------- */
/* DETERMINE THE INTERVAL TO BE MAPPED ONTO (0,1). */
/* IF INF = 2 THE INTEGRAL IS COMPUTED AS I = I1+I2, WHERE */
/* I1 = INTEGRAL OF F OVER (-INFINITY,0), */
/* I2 = INTEGRAL OF F OVER (0,+INFINITY). */
boun = *bound;
if (*inf == 2) {
boun = 0.;
}
dqk15i_((D_fp)f, &boun, inf, &c_b4, &c_b5, result, abserr, &defabs, &
resabs);
/* TEST ON ACCURACY */
*last = 1;
rlist[1] = *result;
elist[1] = *abserr;
iord[1] = 1;
dres = abs(*result);
/* Computing MAX */
d__1 = *epsabs, d__2 = *epsrel * dres;
errbnd = max(d__1,d__2);
if (*abserr <= epmach * 100. * defabs && *abserr > errbnd) {
*ier = 2;
}
if (*limit == 1) {
*ier = 1;
}
if (*ier != 0 || *abserr <= errbnd && *abserr != resabs || *abserr == 0.)
{
goto L130;
}
/* INITIALIZATION */
/* -------------- */
uflow = d1mach_(&c__1);
oflow = d1mach_(&c__2);
rlist2[0] = *result;
errmax = *abserr;
maxerr = 1;
area = *result;
errsum = *abserr;
*abserr = oflow;
nrmax = 1;
nres = 0;
ktmin = 0;
numrl2 = 2;
extrap = FALSE_;
noext = FALSE_;
ierro = 0;
iroff1 = 0;
iroff2 = 0;
iroff3 = 0;
ksgn = -1;
if (dres >= (1. - epmach * 50.) * defabs) {
ksgn = 1;
}
/* MAIN DO-LOOP */
/* ------------ */
i__1 = *limit;
for (*last = 2; *last <= i__1; ++(*last)) {
/* BISECT THE SUBINTERVAL WITH NRMAX-TH LARGEST ERROR ESTIMATE. */
a1 = alist__[maxerr];
b1 = (alist__[maxerr] + blist[maxerr]) * .5;
a2 = b1;
b2 = blist[maxerr];
erlast = errmax;
dqk15i_((D_fp)f, &boun, inf, &a1, &b1, &area1, &error1, &resabs, &
defab1);
dqk15i_((D_fp)f, &boun, inf, &a2, &b2, &area2, &error2, &resabs, &
defab2);
/* IMPROVE PREVIOUS APPROXIMATIONS TO INTEGRAL */
/* AND ERROR AND TEST FOR ACCURACY. */
area12 = area1 + area2;
erro12 = error1 + error2;
errsum = errsum + erro12 - errmax;
area = area + area12 - rlist[maxerr];
if (defab1 == error1 || defab2 == error2) {
goto L15;
}
if ((d__1 = rlist[maxerr] - area12, abs(d__1)) > abs(area12) * 1e-5 ||
erro12 < errmax * .99) {
goto L10;
}
if (extrap) {
++iroff2;
}
if (! extrap) {
++iroff1;
}
L10:
if (*last > 10 && erro12 > errmax) {
++iroff3;
}
L15:
rlist[maxerr] = area1;
rlist[*last] = area2;
/* Computing MAX */
d__1 = *epsabs, d__2 = *epsrel * abs(area);
errbnd = max(d__1,d__2);
/* TEST FOR ROUNDOFF ERROR AND EVENTUALLY SET ERROR FLAG. */
if (iroff1 + iroff2 >= 10 || iroff3 >= 20) {
*ier = 2;
}
if (iroff2 >= 5) {
ierro = 3;
}
/* SET ERROR FLAG IN THE CASE THAT THE NUMBER OF */
/* SUBINTERVALS EQUALS LIMIT. */
if (*last == *limit) {
*ier = 1;
}
/* SET ERROR FLAG IN THE CASE OF BAD INTEGRAND BEHAVIOUR */
/* AT SOME POINTS OF THE INTEGRATION RANGE. */
/* Computing MAX */
d__1 = abs(a1), d__2 = abs(b2);
if (max(d__1,d__2) <= (epmach * 100. + 1.) * (abs(a2) + uflow * 1e3))
{
*ier = 4;
}
/* APPEND THE NEWLY-CREATED INTERVALS TO THE LIST. */
if (error2 > error1) {
goto L20;
}
alist__[*last] = a2;
blist[maxerr] = b1;
blist[*last] = b2;
elist[maxerr] = error1;
elist[*last] = error2;
goto L30;
L20:
alist__[maxerr] = a2;
alist__[*last] = a1;
blist[*last] = b1;
rlist[maxerr] = area2;
rlist[*last] = area1;
elist[maxerr] = error2;
elist[*last] = error1;
/* CALL SUBROUTINE DQPSRT TO MAINTAIN THE DESCENDING ORDERING */
/* IN THE LIST OF ERROR ESTIMATES AND SELECT THE SUBINTERVAL */
/* WITH NRMAX-TH LARGEST ERROR ESTIMATE (TO BE BISECTED NEXT). */
L30:
dqpsrt_(limit, last, &maxerr, &errmax, &elist[1], &iord[1], &nrmax);
if (errsum <= errbnd) {
goto L115;
}
if (*ier != 0) {
goto L100;
}
if (*last == 2) {
goto L80;
}
if (noext) {
goto L90;
}
erlarg -= erlast;
if ((d__1 = b1 - a1, abs(d__1)) > small) {
erlarg += erro12;
}
if (extrap) {
goto L40;
}
/* TEST WHETHER THE INTERVAL TO BE BISECTED NEXT IS THE */
/* SMALLEST INTERVAL. */
if ((d__1 = blist[maxerr] - alist__[maxerr], abs(d__1)) > small) {
goto L90;
}
extrap = TRUE_;
nrmax = 2;
L40:
if (ierro == 3 || erlarg <= ertest) {
goto L60;
}
/* THE SMALLEST INTERVAL HAS THE LARGEST ERROR. */
/* BEFORE BISECTING DECREASE THE SUM OF THE ERRORS OVER THE */
/* LARGER INTERVALS (ERLARG) AND PERFORM EXTRAPOLATION. */
id = nrmax;
jupbnd = *last;
if (*last > *limit / 2 + 2) {
jupbnd = *limit + 3 - *last;
}
i__2 = jupbnd;
for (k = id; k <= i__2; ++k) {
maxerr = iord[nrmax];
errmax = elist[maxerr];
if ((d__1 = blist[maxerr] - alist__[maxerr], abs(d__1)) > small) {
goto L90;
}
++nrmax;
/* L50: */
}
/* PERFORM EXTRAPOLATION. */
L60:
++numrl2;
rlist2[numrl2 - 1] = area;
dqelg_(&numrl2, rlist2, &reseps, &abseps, res3la, &nres);
++ktmin;
if (ktmin > 5 && *abserr < errsum * .001) {
*ier = 5;
}
if (abseps >= *abserr) {
goto L70;
}
ktmin = 0;
*abserr = abseps;
*result = reseps;
correc = erlarg;
/* Computing MAX */
d__1 = *epsabs, d__2 = *epsrel * abs(reseps);
ertest = max(d__1,d__2);
if (*abserr <= ertest) {
goto L100;
}
/* PREPARE BISECTION OF THE SMALLEST INTERVAL. */
L70:
if (numrl2 == 1) {
noext = TRUE_;
}
if (*ier == 5) {
goto L100;
}
maxerr = iord[1];
errmax = elist[maxerr];
nrmax = 1;
extrap = FALSE_;
small *= .5;
erlarg = errsum;
goto L90;
L80:
small = .375;
erlarg = errsum;
ertest = errbnd;
rlist2[1] = area;
L90:
;
}
/* SET FINAL RESULT AND ERROR ESTIMATE. */
/* ------------------------------------ */
L100:
if (*abserr == oflow) {
goto L115;
}
if (*ier + ierro == 0) {
goto L110;
}
if (ierro == 3) {
*abserr += correc;
}
if (*ier == 0) {
*ier = 3;
}
if (*result != 0. && area != 0.) {
goto L105;
}
if (*abserr > errsum) {
goto L115;
}
if (area == 0.) {
goto L130;
}
goto L110;
L105:
if (*abserr / abs(*result) > errsum / abs(area)) {
goto L115;
}
/* TEST ON DIVERGENCE */
L110:
/* Computing MAX */
d__1 = abs(*result), d__2 = abs(area);
if (ksgn == -1 && max(d__1,d__2) <= defabs * .01) {
goto L130;
}
if (.01 > *result / area || *result / area > 100. || errsum > abs(area)) {
*ier = 6;
}
goto L130;
/* COMPUTE GLOBAL INTEGRAL SUM. */
L115:
*result = 0.;
i__1 = *last;
for (k = 1; k <= i__1; ++k) {
*result += rlist[k];
/* L120: */
}
*abserr = errsum;
L130:
*neval = *last * 30 - 15;
if (*inf == 2) {
*neval <<= 1;
}
if (*ier > 2) {
--(*ier);
}
L999:
return 0;
} /* dqagie_ */
/* DECK ZBESK */
/* Subroutine */ int zbesk_(doublereal *zr, doublereal *zi, doublereal *fnu,
integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
nz, integer *ierr)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static integer k, k1, k2;
static doublereal aa, bb, fn, az;
static integer nn;
static doublereal rl;
static integer mr, nw;
static doublereal dig, arg, aln, r1m5, ufl;
static integer nuf;
static doublereal tol, alim, elim;
extern doublereal zabs_(doublereal *, doublereal *);
static doublereal fnul;
extern /* Subroutine */ int zacon_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), zbknu_(doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *), zbunk_(doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *);
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int zuoik_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *);
extern integer i1mach_(integer *);
/* ***BEGIN PROLOGUE ZBESK */
/* ***PURPOSE Compute a sequence of the Bessel functions K(a,z) for */
/* complex argument z and real nonnegative orders a=b,b+1, */
/* b+2,... where b>0. A scaling option is available to */
/* help avoid overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10B4 */
/* ***TYPE COMPLEX (CBESK-C, ZBESK-C) */
/* ***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, */
/* MODIFIED BESSEL FUNCTIONS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ***A DOUBLE PRECISION ROUTINE*** */
/* On KODE=1, ZBESK computes an N member sequence of complex */
/* Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative */
/* orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut */
/* plane -pi<arg(Z)<=pi where Z=ZR+i*ZI. On KODE=2, CBESJ */
/* returns the scaled functions */
/* CY(L) = exp(Z)*K(FNU+L-1,Z), L=1,...,N */
/* which remove the exponential growth in both the left and */
/* right half planes as Z goes to infinity. Definitions and */
/* notation are found in the NBS Handbook of Mathematical */
/* Functions (Ref. 1). */
/* Input */
/* ZR - DOUBLE PRECISION real part of nonzero argument Z */
/* ZI - DOUBLE PRECISION imag part of nonzero argument Z */
/* FNU - DOUBLE PRECISION initial order, FNU>=0 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* CY(L)=K(FNU+L-1,Z), L=1,...,N */
/* =2 returns */
/* CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N */
/* N - Number of terms in the sequence, N>=1 */
/* Output */
/* CYR - DOUBLE PRECISION real part of result vector */
/* CYI - DOUBLE PRECISION imag part of result vector */
/* NZ - Number of underflows set to zero */
/* NZ=0 Normal return */
/* NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 */
/* then CY(L)=0 for L=1,...,NZ; in the */
/* complementary half plane the underflows */
/* may not be in an uninterrupted sequence) */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (abs(Z) too small and/or FNU+N-1 */
/* too large) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has half precision or less */
/* because abs(Z) or FNU+N-1 is large) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision because */
/* abs(Z) or FNU+N-1 is too large) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Equations of the reference are implemented to compute K(a,z) */
/* for small orders a and a+1 in the right half plane Re(z)>=0. */
/* Forward recurrence generates higher orders. The formula */
/* K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 */
/* t = i*pi or -i*pi */
/* continues K to the left half plane. */
/* For large orders, K(a,z) is computed by means of its uniform */
/* asymptotic expansion. */
/* For negative orders, the formula */
/* K(-a,z) = K(a,z) */
/* can be used. */
/* CBESK assumes that a significant digit sinh function is */
/* available. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z or FNU+N-1 is */
/* large, losses of significance by argument reduction occur. */
/* Consequently, if either one exceeds U1=SQRT(0.5/UR), then */
/* losses exceeding half precision are likely and an error flag */
/* IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double */
/* precision unit roundoff limited to 18 digits precision. Also, */
/* if either is larger than U2=0.5/UR, then all significance is */
/* lost and IERR=4. In order to use the INT function, arguments */
/* must be further restricted not to exceed the largest machine */
/* integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 */
/* is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and */
/* U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision */
/* and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This */
/* makes U2 limiting in single precision and U3 limiting in */
/* double precision. This means that one can expect to retain, */
/* in the worst cases on IEEE machines, no digits in single pre- */
/* cision and only 6 digits in double precision. Similar con- */
/* siderations hold for other machines. */
/* The approximate relative error in the magnitude of a complex */
/* Bessel function can be expressed as P*10**S where P=MAX(UNIT */
/* ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- */
/* sents the increase in error due to argument reduction in the */
/* elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), */
/* ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF */
/* ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may */
/* have only absolute accuracy. This is most likely to occur */
/* when one component (in magnitude) is larger than the other by */
/* several orders of magnitude. If one component is 10**K larger */
/* than the other, then one can expect only MAX(ABS(LOG10(P))-K, */
/* 0) significant digits; or, stated another way, when K exceeds */
/* the exponent of P, no significant digits remain in the smaller */
/* component. However, the phase angle retains absolute accuracy */
/* because, in complex arithmetic with precision P, the smaller */
/* component will not (as a rule) decrease below P times the */
/* magnitude of the larger component. In these extreme cases, */
/* the principal phase angle is on the order of +P, -P, PI/2-P, */
/* or -PI/2+P. */
/* ***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- */
/* matical Functions, National Bureau of Standards */
/* Applied Mathematics Series 55, U. S. Department */
/* of Commerce, Tenth Printing (1972) or later. */
/* 2. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument, Report SAND83-0086, Sandia National */
/* Laboratories, Albuquerque, NM, May 1983. */
/* 3. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 4. D. E. Amos, A Subroutine Package for Bessel Functions */
/* of a Complex Argument and Nonnegative Order, Report */
/* SAND85-1018, Sandia National Laboratory, Albuquerque, */
/* NM, May 1985. */
/* 5. D. E. Amos, A portable package for Bessel functions */
/* of a complex argument and nonnegative order, ACM */
/* Transactions on Mathematical Software, 12 (September */
/* 1986), pp. 265-273. */
/* ***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 890801 REVISION DATE from Version 3.2 */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 920128 Category corrected. (WRB) */
/* 920811 Prologue revised. (DWL) */
/* ***END PROLOGUE ZBESK */
/* COMPLEX CY,Z */
/* ***FIRST EXECUTABLE STATEMENT ZBESK */
/* Parameter adjustments */
--cyi;
--cyr;
/* Function Body */
*ierr = 0;
*nz = 0;
if (*zi == 0.f && *zr == 0.f) {
*ierr = 1;
}
if (*fnu < 0.) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*n < 1) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
nn = *n;
/* ----------------------------------------------------------------------- */
/* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
/* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
/* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
/* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
/* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
/* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
/* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
/* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
/* FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU */
/* ----------------------------------------------------------------------- */
/* Computing MAX */
d__1 = d1mach_(&c__4);
tol = max(d__1,1e-18);
k1 = i1mach_(&c__15);
k2 = i1mach_(&c__16);
r1m5 = d1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.) * 2.303;
k1 = i1mach_(&c__14) - 1;
aa = r1m5 * k1;
dig = min(aa,18.);
aa *= 2.303;
/* Computing MAX */
d__1 = -aa;
alim = elim + max(d__1,-41.45);
fnul = (dig - 3.) * 6. + 10.;
rl = dig * 1.2 + 3.;
/* ----------------------------------------------------------------------- */
/* TEST FOR PROPER RANGE */
/* ----------------------------------------------------------------------- */
az = zabs_(zr, zi);
fn = *fnu + (nn - 1);
aa = .5 / tol;
bb = i1mach_(&c__9) * .5;
aa = min(aa,bb);
if (az > aa) {
goto L260;
}
if (fn > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
if (fn > aa) {
*ierr = 3;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
/* ----------------------------------------------------------------------- */
/* UFL = EXP(-ELIM) */
ufl = d1mach_(&c__1) * 1e3;
if (az < ufl) {
goto L180;
}
if (*fnu > fnul) {
goto L80;
}
if (fn <= 1.) {
goto L60;
}
if (fn > 2.) {
goto L50;
}
if (az > tol) {
goto L60;
}
arg = az * .5;
aln = -fn * log(arg);
if (aln > elim) {
goto L180;
}
goto L60;
L50:
zuoik_(zr, zi, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &elim,
&alim);
if (nuf < 0) {
goto L180;
}
*nz += nuf;
nn -= nuf;
/* ----------------------------------------------------------------------- */
/* HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
/* IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
/* ----------------------------------------------------------------------- */
if (nn == 0) {
goto L100;
}
L60:
if (*zr < 0.) {
goto L70;
}
/* ----------------------------------------------------------------------- */
/* RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. */
/* ----------------------------------------------------------------------- */
zbknu_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &alim);
if (nw < 0) {
goto L200;
}
*nz = nw;
return 0;
/* ----------------------------------------------------------------------- */
/* LEFT HALF PLANE COMPUTATION */
/* PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. */
/* ----------------------------------------------------------------------- */
L70:
if (*nz != 0) {
goto L180;
}
mr = 1;
if (*zi < 0.) {
mr = -1;
}
zacon_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul, &
tol, &elim, &alim);
if (nw < 0) {
goto L200;
}
*nz = nw;
return 0;
/* ----------------------------------------------------------------------- */
/* UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
/* ----------------------------------------------------------------------- */
L80:
mr = 0;
if (*zr >= 0.) {
goto L90;
}
mr = 1;
if (*zi < 0.) {
mr = -1;
}
L90:
zbunk_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &
alim);
if (nw < 0) {
goto L200;
}
*nz += nw;
return 0;
L100:
if (*zr < 0.) {
goto L180;
}
return 0;
L180:
*nz = 0;
*ierr = 2;
return 0;
L200:
if (nw == -1) {
goto L180;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*nz = 0;
*ierr = 4;
return 0;
} /* zbesk_ */
/* DECK DGAMRN */
doublereal dgamrn_(doublereal *x)
{
/* Initialized data */
static doublereal gr[12] = { 1.,-.015625,.0025634765625,
-.0012798309326171875,.00134351104497909546,
-.00243289663922041655,.00675423753364157164,
-.0266369606131178216,.141527455519564332,-.974384543032201613,
8.43686251229783675,-89.7258321640552515 };
/* System generated locals */
integer i__1;
doublereal ret_val, d__1;
/* Local variables */
static integer i__, k;
static doublereal s;
static integer mx, nx;
static doublereal xm, xp, fln, rln, tol, trm, xsq;
static integer i1m11;
static doublereal xinc, xmin, xdmy;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
/* ***BEGIN PROLOGUE DGAMRN */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBSKIN */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (GAMRN-S, DGAMRN-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract * A Double Precision Routine * */
/* DGAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) */
/* for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is */
/* evaluated. If X.lt.XMIN, an integer is added to X to form a */
/* new value of X.ge.XMIN and the asymptotic expansion is eval- */
/* uated for this new value of X. Successive application of the */
/* recurrence relation */
/* W(X)=W(X+1)*(1+0.5/X) */
/* reduces the argument to its original value. XMIN and comp- */
/* utational tolerances are computed as a function of the number */
/* of digits carried in a word by calls to I1MACH and D1MACH. */
/* However, the computational accuracy is limited to the max- */
/* imum of unit roundoff (=D1MACH(4)) and 1.0D-18 since critical */
/* constants are given to only 18 digits. */
/* Input X is Double Precision */
/* X - Argument, X.gt.0.0D0 */
/* Output DGAMRN is DOUBLE PRECISION */
/* DGAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) */
/* ***SEE ALSO DBSKIN */
/* ***REFERENCES Y. L. Luke, The Special Functions and Their */
/* Approximations, Vol. 1, Math In Sci. And */
/* Eng. Series 53, Academic Press, New York, 1969, */
/* pp. 34-35. */
/* ***ROUTINES CALLED D1MACH, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 910722 Updated AUTHOR section. (ALS) */
/* 920520 Added REFERENCES section. (WRB) */
/* ***END PROLOGUE DGAMRN */
/* ***FIRST EXECUTABLE STATEMENT DGAMRN */
nx = (integer) (*x);
/* Computing MAX */
d__1 = d1mach_(&c__4);
tol = max(d__1,1e-18);
i1m11 = i1mach_(&c__14);
rln = d1mach_(&c__5) * i1m11;
fln = min(rln,20.);
fln = max(fln,3.);
fln += -3.;
xm = fln * (fln * .01723 + .2366) + 2.;
mx = (integer) xm + 1;
xmin = (doublereal) mx;
xdmy = *x - .25;
xinc = 0.;
if (*x >= xmin) {
goto L10;
}
xinc = xmin - nx;
xdmy += xinc;
L10:
s = 1.;
if (xdmy * tol > 1.) {
goto L30;
}
xsq = 1. / (xdmy * xdmy);
xp = xsq;
for (k = 2; k <= 12; ++k) {
trm = gr[k - 1] * xp;
if (abs(trm) < tol) {
goto L30;
}
s += trm;
xp *= xsq;
/* L20: */
}
L30:
s /= sqrt(xdmy);
if (xinc != 0.) {
goto L40;
}
ret_val = s;
return ret_val;
L40:
nx = (integer) xinc;
xp = 0.;
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
s *= .5 / (*x + xp) + 1.;
xp += 1.;
/* L50: */
}
ret_val = s;
return ret_val;
} /* dgamrn_ */
/* DECK DBSKNU */
/* Subroutine */ int dbsknu_(doublereal *x, doublereal *fnu, integer *kode,
integer *n, doublereal *y, integer *nz)
{
/* Initialized data */
static doublereal x1 = 2.;
static doublereal x2 = 17.;
static doublereal pi = 3.14159265358979;
static doublereal rthpi = 1.2533141373155;
static doublereal cc[8] = { .577215664901533,-.0420026350340952,
-.0421977345555443,.007218943246663,-2.152416741149e-4,
-2.01348547807e-5,1.133027232e-6,6.116095e-9 };
/* System generated locals */
integer i__1;
/* Local variables */
static doublereal a[160], b[160], f;
static integer i__, j, k;
static doublereal p, q, s, a1, a2, g1, g2, p1, p2, s1, s2, t1, t2, fc, ak,
bk, ck, dk, fk;
static integer kk;
static doublereal cx;
static integer nn;
static doublereal ex, tm, pt, st, rx, fhs, fks, dnu, fmu;
static integer inu;
static doublereal sqk, tol, smu, dnu2, coef, elim, flrx;
static integer iflag, koded;
static doublereal etest;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
extern doublereal dgamma_(doublereal *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DBSKNU */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (BESKNU-S, DBSKNU-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract **** A DOUBLE PRECISION routine **** */
/* DBSKNU computes N member sequences of K Bessel functions */
/* K/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 K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). */
/* Forward recursion with the three term recursion relation */
/* generates higher orders FNU+I-1, I=1,...,N. The parameter */
/* KODE permits K/SUB(FNU+I-1)/(X) values or scaled values */
/* EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. */
/* 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,X) is implemented on X1.LT.X.LE.X2. */
/* 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. */
/* The maximum number of significant digits obtainable */
/* is the smaller of 14 and the number of digits carried in */
/* DOUBLE PRECISION arithmetic. */
/* DBSKNU assumes that a significant digit SINH function is */
/* available. */
/* Description of Arguments */
/* INPUT X,FNU are DOUBLE PRECISION */
/* X - X.GT.0.0D0 */
/* FNU - Order of initial K function, FNU.GE.0.0D0 */
/* N - Number of members of the sequence, N.GE.1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE= 1 returns */
/* Y(I)= K/SUB(FNU+I-1)/(X) */
/* I=1,...,N */
/* = 2 returns */
/* Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) */
/* I=1,...,N */
/* OUTPUT Y is DOUBLE PRECISION */
/* Y - A vector whose first N components contain values */
/* for the sequence */
/* Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or */
/* Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N */
/* depending on KODE */
/* NZ - Number of components set to zero due to */
/* underflow, */
/* NZ= 0 , normal return */
/* NZ.NE.0 , first NZ components of Y set to zero */
/* due to underflow, Y(I)=0.0D0,I=1,...,NZ */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Overflow - a fatal error */
/* Underflow with KODE=1 - a non-fatal error (NZ.NE.0) */
/* ***SEE ALSO DBESK */
/* ***REFERENCES 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 D1MACH, DGAMMA, I1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 790201 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (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 DBSKNU */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT DBSKNU */
kk = -i1mach_(&c__15);
elim = (kk * d1mach_(&c__5) - 3.) * 2.303;
ak = d1mach_(&c__3);
tol = max(ak,1e-15);
if (*x <= 0.) {
goto L350;
}
if (*fnu < 0.) {
goto L360;
}
if (*kode < 1 || *kode > 2) {
goto L370;
}
if (*n < 1) {
goto L380;
}
*nz = 0;
iflag = 0;
koded = *kode;
rx = 2. / *x;
inu = (integer) (*fnu + .5);
dnu = *fnu - inu;
if (abs(dnu) == .5) {
goto L120;
}
dnu2 = 0.;
if (abs(dnu) < tol) {
goto L10;
}
dnu2 = dnu * dnu;
L10:
if (*x > x1) {
goto L120;
}
/* SERIES FOR X.LE.X1 */
a1 = 1. - dnu;
a2 = dnu + 1.;
t1 = 1. / dgamma_(&a1);
t2 = 1. / dgamma_(&a2);
if (abs(dnu) > .1) {
goto L40;
}
/* SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
s = cc[0];
ak = 1.;
for (k = 2; k <= 8; ++k) {
ak *= dnu2;
tm = cc[k - 1] * ak;
s += tm;
if (abs(tm) < tol) {
goto L30;
}
/* L20: */
}
L30:
g1 = -s;
goto L50;
L40:
g1 = (t1 - t2) / (dnu + dnu);
L50:
g2 = (t1 + t2) * .5;
smu = 1.;
fc = 1.;
flrx = log(rx);
fmu = dnu * flrx;
if (dnu == 0.) {
goto L60;
}
fc = dnu * pi;
fc /= sin(fc);
if (fmu != 0.) {
smu = sinh(fmu) / fmu;
}
L60:
f = fc * (g1 * cosh(fmu) + g2 * flrx * smu);
fc = exp(fmu);
p = fc * .5 / t2;
q = .5 / (fc * t1);
ak = 1.;
ck = 1.;
bk = 1.;
s1 = f;
s2 = p;
if (inu > 0 || *n > 1) {
goto L90;
}
if (*x < tol) {
goto L80;
}
cx = *x * *x * .25;
L70:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
ck = ck * cx / ak;
t1 = ck * f;
s1 += t1;
bk = bk + ak + ak + 1.;
ak += 1.;
s = abs(t1) / (abs(s1) + 1.);
if (s > tol) {
goto L70;
}
L80:
y[1] = s1;
if (koded == 1) {
return 0;
}
y[1] = s1 * exp(*x);
return 0;
L90:
if (*x < tol) {
goto L110;
}
cx = *x * *x * .25;
L100:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
ck = ck * cx / ak;
t1 = ck * f;
s1 += t1;
t2 = ck * (p - ak * f);
s2 += t2;
bk = bk + ak + ak + 1.;
ak += 1.;
s = abs(t1) / (abs(s1) + 1.) + abs(t2) / (abs(s2) + 1.);
if (s > tol) {
goto L100;
}
L110:
s2 *= rx;
if (koded == 1) {
goto L170;
}
f = exp(*x);
s1 *= f;
s2 *= f;
goto L170;
L120:
coef = rthpi / sqrt(*x);
if (koded == 2) {
goto L130;
}
if (*x > elim) {
goto L330;
}
coef *= exp(-(*x));
L130:
if (abs(dnu) == .5) {
goto L340;
}
if (*x > x2) {
goto L280;
}
/* MILLER ALGORITHM FOR X1.LT.X.LE.X2 */
etest = cos(pi * dnu) / (pi * *x * tol);
fks = 1.;
fhs = .25;
fk = 0.;
ck = *x + *x + 2.;
p1 = 0.;
p2 = 1.;
k = 0;
L140:
++k;
fk += 1.;
ak = (fhs - dnu2) / (fks + fk);
bk = ck / (fk + 1.);
pt = p2;
p2 = bk * p2 - ak * p1;
p1 = pt;
a[k - 1] = ak;
b[k - 1] = bk;
ck += 2.;
fks = fks + fk + fk + 1.;
fhs = fhs + fk + fk;
if (etest > fk * p1) {
goto L140;
}
kk = k;
s = 1.;
p1 = 0.;
p2 = 1.;
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
pt = p2;
p2 = (b[kk - 1] * p2 - p1) / a[kk - 1];
p1 = pt;
s += p2;
--kk;
/* L150: */
}
s1 = coef * (p2 / s);
if (inu > 0 || *n > 1) {
goto L160;
}
goto L200;
L160:
s2 = s1 * (*x + dnu + .5 - p1 / p2) / *x;
/* FORWARD RECURSION ON THE THREE TERM RECURSION RELATION */
L170:
ck = (dnu + dnu + 2.) / *x;
if (*n == 1) {
--inu;
}
if (inu > 0) {
goto L180;
}
if (*n > 1) {
goto L200;
}
s1 = s2;
goto L200;
L180:
i__1 = inu;
for (i__ = 1; i__ <= i__1; ++i__) {
st = s2;
s2 = ck * s2 + s1;
s1 = st;
ck += rx;
/* L190: */
}
if (*n == 1) {
s1 = s2;
}
L200:
if (iflag == 1) {
goto L220;
}
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;
/* L210: */
}
return 0;
/* IFLAG=1 CASES */
L220:
s = -(*x) + log(s1);
y[1] = 0.;
*nz = 1;
if (s < -elim) {
goto L230;
}
y[1] = exp(s);
*nz = 0;
L230:
if (*n == 1) {
return 0;
}
s = -(*x) + log(s2);
y[2] = 0.;
++(*nz);
if (s < -elim) {
goto L240;
}
--(*nz);
y[2] = exp(s);
L240:
if (*n == 2) {
return 0;
}
kk = 2;
if (*nz < 2) {
goto L260;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
kk = i__;
st = s2;
s2 = ck * s2 + s1;
s1 = st;
ck += rx;
s = -(*x) + log(s2);
++(*nz);
y[i__] = 0.;
if (s < -elim) {
goto L250;
}
y[i__] = exp(s);
--(*nz);
goto L260;
L250:
;
}
return 0;
L260:
if (kk == *n) {
return 0;
}
s2 = s2 * ck + s1;
ck += rx;
++kk;
y[kk] = exp(-(*x) + log(s2));
if (kk == *n) {
return 0;
}
++kk;
i__1 = *n;
for (i__ = kk; i__ <= i__1; ++i__) {
y[i__] = ck * y[i__ - 1] + y[i__ - 2];
ck += rx;
/* L270: */
}
return 0;
/* ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 */
/* IFLAG=0 MEANS NO UNDERFLOW OCCURRED */
/* IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH */
/* KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD */
/* RECURSION */
L280:
nn = 2;
if (inu == 0 && *n == 1) {
nn = 1;
}
dnu2 = dnu + dnu;
fmu = 0.;
if (abs(dnu2) < tol) {
goto L290;
}
fmu = dnu2 * dnu2;
L290:
ex = *x * 8.;
s2 = 0.;
i__1 = nn;
for (k = 1; k <= i__1; ++k) {
s1 = s2;
s = 1.;
ak = 0.;
ck = 1.;
sqk = 1.;
dk = ex;
for (j = 1; j <= 30; ++j) {
ck = ck * (fmu - sqk) / dk;
s += ck;
dk += ex;
ak += 8.;
sqk += ak;
if (abs(ck) < tol) {
goto L310;
}
/* L300: */
}
L310:
s2 = s * coef;
fmu = fmu + dnu * 8. + 4.;
/* L320: */
}
if (nn > 1) {
goto L170;
}
s1 = s2;
goto L200;
L330:
koded = 2;
iflag = 1;
goto L120;
/* FNU=HALF ODD INTEGER CASE */
L340:
s1 = coef;
s2 = coef;
goto L170;
L350:
xermsg_("SLATEC", "DBSKNU", "X NOT GREATER THAN ZERO", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
return 0;
L360:
xermsg_("SLATEC", "DBSKNU", "FNU NOT ZERO OR POSITIVE", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)24);
return 0;
L370:
xermsg_("SLATEC", "DBSKNU", "KODE NOT 1 OR 2", &c__2, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)15);
return 0;
L380:
xermsg_("SLATEC", "DBSKNU", "N NOT GREATER THAN 0", &c__2, &c__1, (ftnlen)
6, (ftnlen)6, (ftnlen)20);
return 0;
} /* dbsknu_ */
/* DECK DBFQAD */
/* Subroutine */ int dbfqad_(D_fp f, doublereal *t, doublereal *bcoef,
integer *n, integer *k, integer *id, doublereal *x1, doublereal *x2,
doublereal *tol, doublereal *quad, integer *ierr, doublereal *work)
{
/* System generated locals */
integer i__1;
/* Local variables */
static doublereal a, b, q, aa, bb, ta, tb;
static integer il1, il2, np1;
static doublereal ans;
static integer ilo, npk, iflg, left, inbv;
static doublereal wtol;
static integer mflag;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int dbsgq8_(D_fp, doublereal *, doublereal *,
integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, integer *, doublereal *),
xermsg_(char *, char *, char *, integer *, integer *, ftnlen,
ftnlen, ftnlen), dintrv_(doublereal *, integer *, doublereal *,
integer *, integer *, integer *);
/* ***BEGIN PROLOGUE DBFQAD */
/* ***PURPOSE Compute the integral of a product of a function and a */
/* derivative of a K-th order B-spline. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY H2A2A1, E3, K6 */
/* ***TYPE DOUBLE PRECISION (BFQAD-S, DBFQAD-D) */
/* ***KEYWORDS INTEGRAL OF B-SPLINE, QUADRATURE */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract **** a double precision routine **** */
/* DBFQAD computes the integral on (X1,X2) of a product of a */
/* function F and the ID-th derivative of a K-th order B-spline, */
/* using the B-representation (T,BCOEF,N,K). (X1,X2) must be a */
/* subinterval of T(K) .LE. X .LE. T(N+1). An integration rou- */
/* tine, DBSGQ8 (a modification of GAUS8), integrates the product */
/* on subintervals of (X1,X2) formed by included (distinct) knots */
/* 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,T,BCOEF,X1,X2,TOL are double precision */
/* F - external function of one argument for the */
/* integrand BF(X)=F(X)*DBVALU(T,BCOEF,N,K,ID,X,INBV, */
/* WORK) */
/* T - knot array of length N+K */
/* BCOEF - coefficient array of length N */
/* N - length of coefficient array */
/* 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 in */
/* T(K) .LE. X .LE. T(N+1) */
/* TOL - desired accuracy for the quadrature, suggest */
/* 10.*DTOL .LT. TOL .LE. .1 where DTOL is the maximum */
/* of 1.0D-18 and double precision unit roundoff for */
/* the machine = D1MACH(4) */
/* Output QUAD,WORK are double precision */
/* QUAD - integral of BF(X) on (X1,X2) */
/* IERR - a status code */
/* IERR=1 normal return */
/* 2 some quadrature on (X1,X2) does not meet */
/* the requested tolerance. */
/* WORK - work vector of length 3*K */
/* Error Conditions */
/* Improper input is a fatal error */
/* Some quadrature fails to 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, DBSGQ8, DINTRV, 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 DBFQAD */
/* ***FIRST EXECUTABLE STATEMENT DBFQAD */
/* Parameter adjustments */
--work;
--bcoef;
--t;
/* Function Body */
*ierr = 1;
*quad = 0.;
if (*k < 1) {
goto L100;
}
if (*n < *k) {
goto L105;
}
if (*id < 0 || *id >= *k) {
goto L110;
}
wtol = d1mach_(&c__4);
wtol = max(wtol,1e-18);
if (*tol < wtol || *tol > .1) {
goto L30;
}
aa = min(*x1,*x2);
bb = max(*x1,*x2);
if (aa < t[*k]) {
goto L20;
}
np1 = *n + 1;
if (bb > t[np1]) {
goto L20;
}
if (aa == bb) {
return 0;
}
npk = *n + *k;
ilo = 1;
dintrv_(&t[1], &npk, &aa, &ilo, &il1, &mflag);
dintrv_(&t[1], &npk, &bb, &ilo, &il2, &mflag);
if (il2 >= np1) {
il2 = *n;
}
inbv = 1;
q = 0.;
i__1 = il2;
for (left = il1; left <= i__1; ++left) {
ta = t[left];
tb = t[left + 1];
if (ta == tb) {
goto L10;
}
a = max(aa,ta);
b = min(bb,tb);
dbsgq8_((D_fp)f, &t[1], &bcoef[1], n, k, id, &a, &b, &inbv, tol, &ans,
&iflg, &work[1]);
if (iflg > 1) {
*ierr = 2;
}
q += ans;
L10:
;
}
if (*x1 > *x2) {
q = -q;
}
*quad = q;
return 0;
L20:
xermsg_("SLATEC", "DBFQAD", "X1 OR X2 OR BOTH DO NOT SATISFY T(K).LE.X.L"
"E.T(N+1)", &c__2, &c__1, (ftnlen)6, (ftnlen)6, (ftnlen)51);
return 0;
L30:
xermsg_("SLATEC", "DBFQAD", "TOL IS LESS DTOL OR GREATER THAN 0.1", &c__2,
&c__1, (ftnlen)6, (ftnlen)6, (ftnlen)36);
return 0;
L100:
xermsg_("SLATEC", "DBFQAD", "K DOES NOT SATISFY K.GE.1", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)25);
return 0;
L105:
xermsg_("SLATEC", "DBFQAD", "N DOES NOT SATISFY N.GE.K", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)25);
return 0;
L110:
xermsg_("SLATEC", "DBFQAD", "ID DOES NOT SATISFY 0.LE.ID.LT.K", &c__2, &
c__1, (ftnlen)6, (ftnlen)6, (ftnlen)32);
return 0;
} /* dbfqad_ */
/* Subroutine */ int dqk31_(D_fp f, doublereal *a, doublereal *b, doublereal *
result, doublereal *abserr, doublereal *resabs, doublereal *resasc)
{
/* Initialized data */
static doublereal wg[8] = { .030753241996117268354628393577204,
.070366047488108124709267416450667,
.107159220467171935011869546685869,
.139570677926154314447804794511028,
.166269205816993933553200860481209,
.186161000015562211026800561866423,
.198431485327111576456118326443839,
.202578241925561272880620199967519 };
static doublereal xgk[16] = { .998002298693397060285172840152271,
.987992518020485428489565718586613,
.967739075679139134257347978784337,
.937273392400705904307758947710209,
.897264532344081900882509656454496,
.848206583410427216200648320774217,
.790418501442465932967649294817947,
.724417731360170047416186054613938,
.650996741297416970533735895313275,
.570972172608538847537226737253911,
.485081863640239680693655740232351,
.394151347077563369897207370981045,
.299180007153168812166780024266389,
.201194093997434522300628303394596,
.101142066918717499027074231447392,0. };
static doublereal wgk[16] = { .005377479872923348987792051430128,
.015007947329316122538374763075807,
.025460847326715320186874001019653,
.03534636079137584622203794847836,
.04458975132476487660822729937328,
.05348152469092808726534314723943,
.062009567800670640285139230960803,
.069854121318728258709520077099147,
.076849680757720378894432777482659,
.083080502823133021038289247286104,
.088564443056211770647275443693774,
.093126598170825321225486872747346,
.096642726983623678505179907627589,
.099173598721791959332393173484603,
.10076984552387559504494666261757,
.101330007014791549017374792767493 };
/* System generated locals */
doublereal d__1, d__2, d__3;
/* Builtin functions */
double pow_dd(doublereal *, doublereal *);
/* Local variables */
doublereal absc, resg, resk, fsum, fval1, fval2;
integer jtwm1, j;
doublereal hlgth, centr, reskh, uflow;
extern doublereal d1mach_(integer *);
doublereal fc, epmach, dhlgth, fv1[15], fv2[15];
integer jtw;
/* ***begin prologue dqk31 */
/* ***date written 800101 (yymmdd) */
/* ***revision date 830518 (yymmdd) */
/* ***category no. h2a1a2 */
/* ***keywords 31-point gauss-kronrod rules */
/* ***author piessens,robert,appl. math. & progr. div. - k.u.leuven */
/* de doncker,elise,appl. math. & progr. div. - k.u.leuven */
/* ***purpose to compute i = integral of f over (a,b) with error */
/* estimate */
/* j = integral of abs(f) over (a,b) */
/* ***description */
/* integration rules */
/* standard fortran subroutine */
/* double precision version */
/* parameters */
/* on entry */
/* f - double precision */
/* function subprogram defining the integrand */
/* function f(x). the actual name for f needs to be */
/* declared e x t e r n a l in the calling program. */
/* a - double precision */
/* lower limit of integration */
/* b - double precision */
/* upper limit of integration */
/* on return */
/* result - double precision */
/* approximation to the integral i */
/* result is computed by applying the 31-point */
/* gauss-kronrod rule (resk), obtained by optimal */
/* addition of abscissae to the 15-point gauss */
/* rule (resg). */
/* abserr - double precison */
/* estimate of the modulus of the modulus, */
/* which should not exceed abs(i-result) */
/* resabs - double precision */
/* approximation to the integral j */
/* resasc - double precision */
/* approximation to the integral of abs(f-i/(b-a)) */
/* over (a,b) */
/* ***references (none) */
/* ***routines called d1mach */
/* ***end prologue dqk31 */
/* the abscissae and weights are given for the interval (-1,1). */
/* because of symmetry only the positive abscissae and their */
/* corresponding weights are given. */
/* xgk - abscissae of the 31-point kronrod rule */
/* xgk(2), xgk(4), ... abscissae of the 15-point */
/* gauss rule */
/* xgk(1), xgk(3), ... abscissae which are optimally */
/* added to the 15-point gauss rule */
/* wgk - weights of the 31-point kronrod rule */
/* wg - weights of the 15-point gauss rule */
/* gauss quadrature weights and kronron quadrature abscissae and weights */
/* as evaluated with 80 decimal digit arithmetic by l. w. fullerton, */
/* bell labs, nov. 1981. */
/* list of major variables */
/* ----------------------- */
/* centr - mid point of the interval */
/* hlgth - half-length of the interval */
/* absc - abscissa */
/* fval* - function value */
/* resg - result of the 15-point gauss formula */
/* resk - result of the 31-point kronrod formula */
/* reskh - approximation to the mean value of f over (a,b), */
/* i.e. to i/(b-a) */
/* machine dependent constants */
/* --------------------------- */
/* epmach is the largest relative spacing. */
/* uflow is the smallest positive magnitude. */
/* ***first executable statement dqk31 */
epmach = d1mach_(&c__4);
uflow = d1mach_(&c__1);
centr = (*a + *b) * .5;
hlgth = (*b - *a) * .5;
dhlgth = abs(hlgth);
/* compute the 31-point kronrod approximation to */
/* the integral, and estimate the absolute error. */
fc = (*f)(¢r);
resg = wg[7] * fc;
resk = wgk[15] * fc;
*resabs = abs(resk);
for (j = 1; j <= 7; ++j) {
jtw = j << 1;
absc = hlgth * xgk[jtw - 1];
d__1 = centr - absc;
fval1 = (*f)(&d__1);
d__1 = centr + absc;
fval2 = (*f)(&d__1);
fv1[jtw - 1] = fval1;
fv2[jtw - 1] = fval2;
fsum = fval1 + fval2;
resg += wg[j - 1] * fsum;
resk += wgk[jtw - 1] * fsum;
*resabs += wgk[jtw - 1] * (abs(fval1) + abs(fval2));
/* L10: */
}
for (j = 1; j <= 8; ++j) {
jtwm1 = (j << 1) - 1;
absc = hlgth * xgk[jtwm1 - 1];
d__1 = centr - absc;
fval1 = (*f)(&d__1);
d__1 = centr + absc;
fval2 = (*f)(&d__1);
fv1[jtwm1 - 1] = fval1;
fv2[jtwm1 - 1] = fval2;
fsum = fval1 + fval2;
resk += wgk[jtwm1 - 1] * fsum;
*resabs += wgk[jtwm1 - 1] * (abs(fval1) + abs(fval2));
/* L15: */
}
reskh = resk * .5;
*resasc = wgk[15] * (d__1 = fc - reskh, abs(d__1));
for (j = 1; j <= 15; ++j) {
*resasc += wgk[j - 1] * ((d__1 = fv1[j - 1] - reskh, abs(d__1)) + (
d__2 = fv2[j - 1] - reskh, abs(d__2)));
/* L20: */
}
*result = resk * hlgth;
*resabs *= dhlgth;
*resasc *= dhlgth;
*abserr = (d__1 = (resk - resg) * hlgth, abs(d__1));
if (*resasc != 0. && *abserr != 0.) {
/* Computing MIN */
d__3 = *abserr * 200. / *resasc;
d__1 = 1., d__2 = pow_dd(&d__3, &c_b7);
*abserr = *resasc * min(d__1,d__2);
}
if (*resabs > uflow / (epmach * 50.)) {
/* Computing MAX */
d__1 = epmach * 50. * *resabs;
*abserr = max(d__1,*abserr);
}
return 0;
} /* dqk31_ */
/* DECK ZACON */
/* Subroutine */ int zacon_(doublereal *zr, doublereal *zi, doublereal *fnu,
integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
yi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol,
doublereal *elim, doublereal *alim)
{
/* Initialized data */
static doublereal pi = 3.14159265358979324;
static doublereal zeror = 0.;
static doublereal coner = 1.;
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__;
static doublereal fn;
static integer nn, nw;
static doublereal yy, c1i, c2i, c1m, as2, c1r, c2r, s1i, s2i, s1r, s2r,
cki, arg, ckr, cpn;
static integer iuf;
static doublereal cyi[2], fmr, csr, azn, sgn;
static integer inu;
static doublereal bry[3], cyr[2], pti, spn, sti, zni, rzi, ptr, str, znr,
rzr, sc1i, sc2i, sc1r, sc2r, cscl, cscr;
extern doublereal zabs_(doublereal *, doublereal *);
static doublereal csrr[3], cssr[3], razn;
extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *), zmlt_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *);
static integer kflag;
static doublereal ascle, bscle, csgni, csgnr, cspni, cspnr;
extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal
*, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), zbknu_(doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *);
extern doublereal d1mach_(integer *);
/* ***BEGIN PROLOGUE ZACON */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to ZBESH and ZBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CACON-A, ZACON-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA */
/* K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
/* MP=PI*MR*CMPLX(0.0,1.0) */
/* TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
/* HALF Z PLANE */
/* ***SEE ALSO ZBESH, ZBESK */
/* ***ROUTINES CALLED D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE ZACON */
/* COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, */
/* *S1,S2,Y,Z,ZN */
/* Parameter adjustments */
--yi;
--yr;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT ZACON */
*nz = 0;
znr = -(*zr);
zni = -(*zi);
nn = *n;
zbinu_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, fnul, tol,
elim, alim);
if (nw < 0) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
/* ----------------------------------------------------------------------- */
nn = min(2,*n);
zbknu_(&znr, &zni, fnu, kode, &nn, cyr, cyi, &nw, tol, elim, alim);
if (nw != 0) {
goto L90;
}
s1r = cyr[0];
s1i = cyi[0];
fmr = (doublereal) (*mr);
sgn = -d_sign(&pi, &fmr);
csgnr = zeror;
csgni = sgn;
if (*kode == 1) {
goto L10;
}
yy = -zni;
cpn = cos(yy);
spn = sin(yy);
zmlt_(&csgnr, &csgni, &cpn, &spn, &csgnr, &csgni);
L10:
/* ----------------------------------------------------------------------- */
/* CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
/* WHEN FNU IS LARGE */
/* ----------------------------------------------------------------------- */
inu = (integer) (*fnu);
arg = (*fnu - inu) * sgn;
cpn = cos(arg);
spn = sin(arg);
cspnr = cpn;
cspni = spn;
if (inu % 2 == 0) {
goto L20;
}
cspnr = -cspnr;
cspni = -cspni;
L20:
iuf = 0;
c1r = s1r;
c1i = s1i;
c2r = yr[1];
c2i = yi[1];
ascle = d1mach_(&c__1) * 1e3 / *tol;
if (*kode == 1) {
goto L30;
}
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
sc1r = c1r;
sc1i = c1i;
L30:
zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
yr[1] = str + ptr;
yi[1] = sti + pti;
if (*n == 1) {
return 0;
}
cspnr = -cspnr;
cspni = -cspni;
s2r = cyr[1];
s2i = cyi[1];
c1r = s2r;
c1i = s2i;
c2r = yr[2];
c2i = yi[2];
if (*kode == 1) {
goto L40;
}
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
sc2r = c1r;
sc2i = c1i;
L40:
zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
yr[2] = str + ptr;
yi[2] = sti + pti;
if (*n == 2) {
return 0;
}
cspnr = -cspnr;
cspni = -cspni;
azn = zabs_(&znr, &zni);
razn = 1. / azn;
str = znr * razn;
sti = -zni * razn;
rzr = (str + str) * razn;
rzi = (sti + sti) * razn;
fn = *fnu + 1.;
ckr = fn * rzr;
cki = fn * rzi;
/* ----------------------------------------------------------------------- */
/* SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS */
/* ----------------------------------------------------------------------- */
cscl = 1. / *tol;
cscr = *tol;
cssr[0] = cscl;
cssr[1] = coner;
cssr[2] = cscr;
csrr[0] = cscr;
csrr[1] = coner;
csrr[2] = cscl;
bry[0] = ascle;
bry[1] = 1. / ascle;
bry[2] = d1mach_(&c__2);
as2 = zabs_(&s2r, &s2i);
kflag = 2;
if (as2 > bry[0]) {
goto L50;
}
kflag = 1;
goto L60;
L50:
if (as2 < bry[1]) {
goto L60;
}
kflag = 3;
L60:
bscle = bry[kflag - 1];
s1r *= cssr[kflag - 1];
s1i *= cssr[kflag - 1];
s2r *= cssr[kflag - 1];
s2i *= cssr[kflag - 1];
csr = csrr[kflag - 1];
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
str = s2r;
sti = s2i;
s2r = ckr * str - cki * sti + s1r;
s2i = ckr * sti + cki * str + s1i;
s1r = str;
s1i = sti;
c1r = s2r * csr;
c1i = s2i * csr;
str = c1r;
sti = c1i;
c2r = yr[i__];
c2i = yi[i__];
if (*kode == 1) {
goto L70;
}
if (iuf < 0) {
goto L70;
}
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
sc1r = sc2r;
sc1i = sc2i;
sc2r = c1r;
sc2i = c1i;
if (iuf != 3) {
goto L70;
}
iuf = -4;
s1r = sc1r * cssr[kflag - 1];
s1i = sc1i * cssr[kflag - 1];
s2r = sc2r * cssr[kflag - 1];
s2i = sc2i * cssr[kflag - 1];
str = sc2r;
sti = sc2i;
L70:
ptr = cspnr * c1r - cspni * c1i;
pti = cspnr * c1i + cspni * c1r;
yr[i__] = ptr + csgnr * c2r - csgni * c2i;
yi[i__] = pti + csgnr * c2i + csgni * c2r;
ckr += rzr;
cki += rzi;
cspnr = -cspnr;
cspni = -cspni;
if (kflag >= 3) {
goto L80;
}
ptr = abs(c1r);
pti = abs(c1i);
c1m = max(ptr,pti);
if (c1m <= bscle) {
goto L80;
}
++kflag;
bscle = bry[kflag - 1];
s1r *= csr;
s1i *= csr;
s2r = str;
s2i = sti;
s1r *= cssr[kflag - 1];
s1i *= cssr[kflag - 1];
s2r *= cssr[kflag - 1];
s2i *= cssr[kflag - 1];
csr = csrr[kflag - 1];
L80:
;
}
return 0;
L90:
*nz = -1;
if (nw == -2) {
*nz = -2;
}
return 0;
} /* zacon_ */
/* DECK DFZERO */
/* Subroutine */ int dfzero_(D_fp f, doublereal *b, doublereal *c__,
doublereal *r__, doublereal *re, doublereal *ae, integer *iflag)
{
/* System generated locals */
doublereal d__1, d__2;
/* Local variables */
static doublereal a, p, q, t, z__, fa, fb, fc;
static integer ic;
static doublereal aw, er, fx, fz, rw, cmb, tol, acmb, acbs;
extern doublereal d1mach_(integer *);
static integer kount;
/* ***BEGIN PROLOGUE DFZERO */
/* ***PURPOSE Search for a zero of a function F(X) in a given interval */
/* (B,C). It is designed primarily for problems where F(B) */
/* and F(C) have opposite signs. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY F1B */
/* ***TYPE DOUBLE PRECISION (FZERO-S, DFZERO-D) */
/* ***KEYWORDS BISECTION, NONLINEAR, ROOTS, ZEROS */
/* ***AUTHOR Shampine, L. F., (SNLA) */
/* Watts, H. A., (SNLA) */
/* ***DESCRIPTION */
/* DFZERO searches for a zero of a DOUBLE PRECISION function F(X) */
/* between the given DOUBLE PRECISION values B and C until the width */
/* of the interval (B,C) has collapsed to within a tolerance */
/* specified by the stopping criterion, */
/* ABS(B-C) .LE. 2.*(RW*ABS(B)+AE). */
/* The method used is an efficient combination of bisection and the */
/* secant rule and is due to T. J. Dekker. */
/* Description Of Arguments */
/* F :EXT - Name of the DOUBLE PRECISION external function. This */
/* name must be in an EXTERNAL statement in the calling */
/* program. F must be a function of one DOUBLE */
/* PRECISION argument. */
/* B :INOUT - One end of the DOUBLE PRECISION interval (B,C). The */
/* value returned for B usually is the better */
/* approximation to a zero of F. */
/* C :INOUT - The other end of the DOUBLE PRECISION interval (B,C) */
/* R :IN - A (better) DOUBLE PRECISION guess of a zero of F */
/* which could help in speeding up convergence. If F(B) */
/* and F(R) have opposite signs, a root will be found in */
/* the interval (B,R); if not, but F(R) and F(C) have */
/* opposite signs, a root will be found in the interval */
/* (R,C); otherwise, the interval (B,C) will be */
/* searched for a possible root. When no better guess */
/* is known, it is recommended that R be set to B or C, */
/* since if R is not interior to the interval (B,C), it */
/* will be ignored. */
/* RE :IN - Relative error used for RW in the stopping criterion. */
/* If the requested RE is less than machine precision, */
/* then RW is set to approximately machine precision. */
/* AE :IN - Absolute error used in the stopping criterion. If */
/* the given interval (B,C) contains the origin, then a */
/* nonzero value should be chosen for AE. */
/* IFLAG :OUT - A status code. User must check IFLAG after each */
/* call. Control returns to the user from DFZERO in all */
/* cases. */
/* 1 B is within the requested tolerance of a zero. */
/* The interval (B,C) collapsed to the requested */
/* tolerance, the function changes sign in (B,C), and */
/* F(X) decreased in magnitude as (B,C) collapsed. */
/* 2 F(B) = 0. However, the interval (B,C) may not have */
/* collapsed to the requested tolerance. */
/* 3 B may be near a singular point of F(X). */
/* The interval (B,C) collapsed to the requested tol- */
/* erance and the function changes sign in (B,C), but */
/* F(X) increased in magnitude as (B,C) collapsed, i.e. */
/* ABS(F(B out)) .GT. MAX(ABS(F(B in)),ABS(F(C in))) */
/* 4 No change in sign of F(X) was found although the */
/* interval (B,C) collapsed to the requested tolerance. */
/* The user must examine this case and decide whether */
/* B is near a local minimum of F(X), or B is near a */
/* zero of even multiplicity, or neither of these. */
/* 5 Too many (.GT. 500) function evaluations used. */
/* ***REFERENCES L. F. Shampine and H. A. Watts, FZERO, a root-solving */
/* code, Report SC-TM-70-631, Sandia Laboratories, */
/* September 1970. */
/* T. J. Dekker, Finding a zero by means of successive */
/* linear interpolation, Constructive Aspects of the */
/* Fundamental Theorem of Algebra, edited by B. Dejon */
/* and P. Henrici, Wiley-Interscience, 1969. */
/* ***ROUTINES CALLED D1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 700901 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) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DFZERO */
/* ***FIRST EXECUTABLE STATEMENT DFZERO */
/* ER is two times the computer unit roundoff value which is defined */
/* here by the function D1MACH. */
er = d1mach_(&c__4) * 2.;
/* Initialize. */
z__ = *r__;
if (*r__ <= min(*b,*c__) || *r__ >= max(*b,*c__)) {
z__ = *c__;
}
rw = max(*re,er);
aw = max(*ae,0.);
ic = 0;
t = z__;
fz = (*f)(&t);
fc = fz;
t = *b;
fb = (*f)(&t);
kount = 2;
if (d_sign(&c_b3, &fz) == d_sign(&c_b3, &fb)) {
goto L1;
}
*c__ = z__;
goto L2;
L1:
if (z__ == *c__) {
goto L2;
}
t = *c__;
fc = (*f)(&t);
kount = 3;
if (d_sign(&c_b3, &fz) == d_sign(&c_b3, &fc)) {
goto L2;
}
*b = z__;
fb = fz;
L2:
a = *c__;
fa = fc;
acbs = (d__1 = *b - *c__, abs(d__1));
/* Computing MAX */
d__1 = abs(fb), d__2 = abs(fc);
fx = max(d__1,d__2);
L3:
if (abs(fc) >= abs(fb)) {
goto L4;
}
/* Perform interchange. */
a = *b;
fa = fb;
*b = *c__;
fb = fc;
*c__ = a;
fc = fa;
L4:
cmb = (*c__ - *b) * .5;
acmb = abs(cmb);
tol = rw * abs(*b) + aw;
/* Test stopping criterion and function count. */
if (acmb <= tol) {
goto L10;
}
if (fb == 0.) {
goto L11;
}
if (kount >= 500) {
goto L14;
}
/* Calculate new iterate implicitly as B+P/Q, where we arrange */
/* P .GE. 0. The implicit form is used to prevent overflow. */
p = (*b - a) * fb;
q = fa - fb;
if (p >= 0.) {
goto L5;
}
p = -p;
q = -q;
/* Update A and check for satisfactory reduction in the size of the */
/* bracketing interval. If not, perform bisection. */
L5:
a = *b;
fa = fb;
++ic;
if (ic < 4) {
goto L6;
}
if (acmb * 8. >= acbs) {
goto L8;
}
ic = 0;
acbs = acmb;
/* Test for too small a change. */
L6:
if (p > abs(q) * tol) {
goto L7;
}
/* Increment by TOLerance. */
*b += d_sign(&tol, &cmb);
goto L9;
/* Root ought to be between B and (C+B)/2. */
L7:
if (p >= cmb * q) {
goto L8;
}
/* Use secant rule. */
*b += p / q;
goto L9;
/* Use bisection (C+B)/2. */
L8:
*b += cmb;
/* Have completed computation for new iterate B. */
L9:
t = *b;
fb = (*f)(&t);
++kount;
/* Decide whether next step is interpolation or extrapolation. */
if (d_sign(&c_b3, &fb) != d_sign(&c_b3, &fc)) {
goto L3;
}
*c__ = a;
fc = fa;
goto L3;
/* Finished. Process results for proper setting of IFLAG. */
L10:
if (d_sign(&c_b3, &fb) == d_sign(&c_b3, &fc)) {
goto L13;
}
if (abs(fb) > fx) {
goto L12;
}
*iflag = 1;
return 0;
L11:
*iflag = 2;
return 0;
L12:
*iflag = 3;
return 0;
L13:
*iflag = 4;
return 0;
L14:
*iflag = 5;
return 0;
} /* dfzero_ */
/* 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 ZSERI */
/* Subroutine */ int zseri_(doublereal *zr, doublereal *zi, doublereal *fnu,
integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
nz, doublereal *tol, doublereal *elim, doublereal *alim)
{
/* Initialized data */
static doublereal zeror = 0.;
static doublereal zeroi = 0.;
static doublereal coner = 1.;
static doublereal conei = 0.;
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__, k, l, m;
static doublereal s, aa;
static integer ib;
static doublereal ak;
static integer il;
static doublereal az;
static integer nn;
static doublereal wi[2], rs, ss;
static integer nw;
static doublereal wr[2], s1i, s2i, s1r, s2r, cki, acz, arm, ckr, czi, hzi,
raz, czr, sti, hzr, rzi, str, rzr, ak1i, ak1r, rtr1, dfnu;
static integer idum;
static doublereal atol;
extern doublereal zabs_(doublereal *, doublereal *);
static doublereal fnup;
extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
, doublereal *, integer *), zdiv_(doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), zmlt_(
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *);
static integer iflag;
static doublereal coefi, ascle, coefr, crscr;
extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *,
doublereal *, doublereal *);
extern doublereal d1mach_(integer *), dgamln_(doublereal *, integer *);
/* ***BEGIN PROLOGUE ZSERI */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to ZBESI and ZBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CSERI-A, ZSERI-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
/* MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE */
/* REGION ABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. */
/* NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO */
/* DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE */
/* CONDITION ABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE */
/* COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). */
/* ***SEE ALSO ZBESI, ZBESK */
/* ***ROUTINES CALLED D1MACH, DGAMLN, ZABS, ZDIV, ZLOG, ZMLT, ZUCHK */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 930122 Added ZLOG to EXTERNAL statement. (RWC) */
/* ***END PROLOGUE ZSERI */
/* COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z */
/* Parameter adjustments */
--yi;
--yr;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT ZSERI */
*nz = 0;
az = zabs_(zr, zi);
if (az == 0.) {
goto L160;
}
arm = d1mach_(&c__1) * 1e3;
rtr1 = sqrt(arm);
crscr = 1.;
iflag = 0;
if (az < arm) {
goto L150;
}
hzr = *zr * .5;
hzi = *zi * .5;
czr = zeror;
czi = zeroi;
if (az <= rtr1) {
goto L10;
}
zmlt_(&hzr, &hzi, &hzr, &hzi, &czr, &czi);
L10:
acz = zabs_(&czr, &czi);
nn = *n;
zlog_(&hzr, &hzi, &ckr, &cki, &idum);
L20:
dfnu = *fnu + (nn - 1);
fnup = dfnu + 1.;
/* ----------------------------------------------------------------------- */
/* UNDERFLOW TEST */
/* ----------------------------------------------------------------------- */
ak1r = ckr * dfnu;
ak1i = cki * dfnu;
ak = dgamln_(&fnup, &idum);
ak1r -= ak;
if (*kode == 2) {
ak1r -= *zr;
}
if (ak1r > -(*elim)) {
goto L40;
}
L30:
++(*nz);
yr[nn] = zeror;
yi[nn] = zeroi;
if (acz > dfnu) {
goto L190;
}
--nn;
if (nn == 0) {
return 0;
}
goto L20;
L40:
if (ak1r > -(*alim)) {
goto L50;
}
iflag = 1;
ss = 1. / *tol;
crscr = *tol;
ascle = arm * ss;
L50:
aa = exp(ak1r);
if (iflag == 1) {
aa *= ss;
}
coefr = aa * cos(ak1i);
coefi = aa * sin(ak1i);
atol = *tol * acz / fnup;
il = min(2,nn);
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
dfnu = *fnu + (nn - i__);
fnup = dfnu + 1.;
s1r = coner;
s1i = conei;
if (acz < *tol * fnup) {
goto L70;
}
ak1r = coner;
ak1i = conei;
ak = fnup + 2.;
s = fnup;
aa = 2.;
L60:
rs = 1. / s;
str = ak1r * czr - ak1i * czi;
sti = ak1r * czi + ak1i * czr;
ak1r = str * rs;
ak1i = sti * rs;
s1r += ak1r;
s1i += ak1i;
s += ak;
ak += 2.;
aa = aa * acz * rs;
if (aa > atol) {
goto L60;
}
L70:
s2r = s1r * coefr - s1i * coefi;
s2i = s1r * coefi + s1i * coefr;
wr[i__ - 1] = s2r;
wi[i__ - 1] = s2i;
if (iflag == 0) {
goto L80;
}
zuchk_(&s2r, &s2i, &nw, &ascle, tol);
if (nw != 0) {
goto L30;
}
L80:
m = nn - i__ + 1;
yr[m] = s2r * crscr;
yi[m] = s2i * crscr;
if (i__ == il) {
goto L90;
}
zdiv_(&coefr, &coefi, &hzr, &hzi, &str, &sti);
coefr = str * dfnu;
coefi = sti * dfnu;
L90:
;
}
if (nn <= 2) {
return 0;
}
k = nn - 2;
ak = (doublereal) k;
raz = 1. / az;
str = *zr * raz;
sti = -(*zi) * raz;
rzr = (str + str) * raz;
rzi = (sti + sti) * raz;
if (iflag == 1) {
goto L120;
}
ib = 3;
L100:
i__1 = nn;
for (i__ = ib; i__ <= i__1; ++i__) {
yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
ak += -1.;
--k;
/* L110: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* RECUR BACKWARD WITH SCALED VALUES */
/* ----------------------------------------------------------------------- */
L120:
/* ----------------------------------------------------------------------- */
/* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE */
/* UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 */
/* ----------------------------------------------------------------------- */
s1r = wr[0];
s1i = wi[0];
s2r = wr[1];
s2i = wi[1];
i__1 = nn;
for (l = 3; l <= i__1; ++l) {
ckr = s2r;
cki = s2i;
s2r = s1r + (ak + *fnu) * (rzr * ckr - rzi * cki);
s2i = s1i + (ak + *fnu) * (rzr * cki + rzi * ckr);
s1r = ckr;
s1i = cki;
ckr = s2r * crscr;
cki = s2i * crscr;
yr[k] = ckr;
yi[k] = cki;
ak += -1.;
--k;
if (zabs_(&ckr, &cki) > ascle) {
goto L140;
}
/* L130: */
}
return 0;
L140:
ib = l + 1;
if (ib > nn) {
return 0;
}
goto L100;
L150:
*nz = *n;
if (*fnu == 0.) {
--(*nz);
}
L160:
yr[1] = zeror;
yi[1] = zeroi;
if (*fnu != 0.) {
goto L170;
}
yr[1] = coner;
yi[1] = conei;
L170:
if (*n == 1) {
return 0;
}
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
yr[i__] = zeror;
yi[i__] = zeroi;
/* L180: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* RETURN WITH NZ.LT.0 IF ABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE */
/* THE CALCULATION IN CBINU WITH N=N-ABS(NZ) */
/* ----------------------------------------------------------------------- */
L190:
*nz = -(*nz);
return 0;
} /* zseri_ */
/* DECK ZWRSK */
/* Subroutine */ int zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu,
integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *
elim, doublereal *alim)
{
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__, nw;
static doublereal c1i, c2i, c1r, c2r, act, acw, cti, ctr, pti, sti, ptr,
str, ract;
extern doublereal zabs_(doublereal *, doublereal *);
static doublereal ascle, csclr, cinui, cinur;
extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal
*, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *), zrati_(doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *);
extern doublereal d1mach_(integer *);
/* ***BEGIN PROLOGUE ZWRSK */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to ZBESI and ZBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CWRSK-A, ZWRSK-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY */
/* NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN */
/* ***SEE ALSO ZBESI, ZBESK */
/* ***ROUTINES CALLED D1MACH, ZABS, ZBKNU, ZRATI */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE ZWRSK */
/* COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR */
/* ***FIRST EXECUTABLE STATEMENT ZWRSK */
/* ----------------------------------------------------------------------- */
/* I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS */
/* Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE */
/* WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. */
/* ----------------------------------------------------------------------- */
/* Parameter adjustments */
--yi;
--yr;
--cwr;
--cwi;
/* Function Body */
*nz = 0;
zbknu_(zrr, zri, fnu, kode, &c__2, &cwr[1], &cwi[1], &nw, tol, elim, alim)
;
if (nw != 0) {
goto L50;
}
zrati_(zrr, zri, fnu, n, &yr[1], &yi[1], tol);
/* ----------------------------------------------------------------------- */
/* RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), */
/* R(FNU+J-1,Z)=Y(J), J=1,...,N */
/* ----------------------------------------------------------------------- */
cinur = 1.;
cinui = 0.;
if (*kode == 1) {
goto L10;
}
cinur = cos(*zri);
cinui = sin(*zri);
L10:
/* ----------------------------------------------------------------------- */
/* ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH */
/* THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE */
/* SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT */
/* THE RESULT IS ON SCALE. */
/* ----------------------------------------------------------------------- */
acw = zabs_(&cwr[2], &cwi[2]);
ascle = d1mach_(&c__1) * 1e3 / *tol;
csclr = 1.;
if (acw > ascle) {
goto L20;
}
csclr = 1. / *tol;
goto L30;
L20:
ascle = 1. / ascle;
if (acw < ascle) {
goto L30;
}
csclr = *tol;
L30:
c1r = cwr[1] * csclr;
c1i = cwi[1] * csclr;
c2r = cwr[2] * csclr;
c2i = cwi[2] * csclr;
str = yr[1];
sti = yi[1];
/* ----------------------------------------------------------------------- */
/* CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0D0/ABS(CT) PREVENTS */
/* UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT) */
/* ----------------------------------------------------------------------- */
ptr = str * c1r - sti * c1i;
pti = str * c1i + sti * c1r;
ptr += c2r;
pti += c2i;
ctr = *zrr * ptr - *zri * pti;
cti = *zrr * pti + *zri * ptr;
act = zabs_(&ctr, &cti);
ract = 1. / act;
ctr *= ract;
cti = -cti * ract;
ptr = cinur * ract;
pti = cinui * ract;
cinur = ptr * ctr - pti * cti;
cinui = ptr * cti + pti * ctr;
yr[1] = cinur * csclr;
yi[1] = cinui * csclr;
if (*n == 1) {
return 0;
}
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
ptr = str * cinur - sti * cinui;
cinui = str * cinui + sti * cinur;
cinur = ptr;
str = yr[i__];
sti = yi[i__];
yr[i__] = cinur * csclr;
yi[i__] = cinui * csclr;
/* L40: */
}
return 0;
L50:
*nz = -1;
if (nw == -2) {
*nz = -2;
}
return 0;
} /* zwrsk_ */
/* DECK DGAMIC */
doublereal dgamic_(doublereal *a, doublereal *x)
{
/* Initialized data */
static logical first = TRUE_;
/* System generated locals */
doublereal ret_val, d__1;
/* Local variables */
static doublereal e, h__, t, sga, alx, bot, eps, aeps, sgng, ainta, alngs,
gstar, sgngs;
static integer izero;
static doublereal sqeps;
extern doublereal d1mach_(integer *);
static doublereal algap1;
extern doublereal d9lgic_(doublereal *, doublereal *, doublereal *),
d9gmic_(doublereal *, doublereal *, doublereal *), d9lgit_(
doublereal *, doublereal *, doublereal *), d9gmit_(doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *), dlngam_(
doublereal *);
extern /* Subroutine */ int dlgams_(doublereal *, doublereal *,
doublereal *);
static doublereal sgngam, alneps;
extern /* Subroutine */ int xerclr_(void), xermsg_(char *, char *, char *,
integer *, integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DGAMIC */
/* ***PURPOSE Calculate the complementary incomplete Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7E */
/* ***TYPE DOUBLE PRECISION (GAMIC-S, DGAMIC-D) */
/* ***KEYWORDS COMPLEMENTARY INCOMPLETE GAMMA FUNCTION, FNLIB, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* Evaluate the complementary incomplete Gamma function */
/* DGAMIC = integral from X to infinity of EXP(-T) * T**(A-1.) . */
/* DGAMIC is evaluated for arbitrary real values of A and for non- */
/* negative values of X (even though DGAMIC is defined for X .LT. */
/* 0.0), except that for X = 0 and A .LE. 0.0, DGAMIC is undefined. */
/* DGAMIC, A, and X are DOUBLE PRECISION. */
/* A slight deterioration of 2 or 3 digits accuracy will occur when */
/* DGAMIC is very large or very small in absolute value, because log- */
/* arithmic variables are used. Also, if the parameter A is very close */
/* to a negative INTEGER (but not a negative integer), there is a loss */
/* of accuracy, which is reported if the result is less than half */
/* machine precision. */
/* ***REFERENCES W. Gautschi, A computational procedure for incomplete */
/* gamma functions, ACM Transactions on Mathematical */
/* Software 5, 4 (December 1979), pp. 466-481. */
/* W. Gautschi, Incomplete gamma functions, Algorithm 542, */
/* ACM Transactions on Mathematical Software 5, 4 */
/* (December 1979), pp. 482-489. */
/* ***ROUTINES CALLED D1MACH, D9GMIC, D9GMIT, D9LGIC, D9LGIT, DLGAMS, */
/* DLNGAM, XERCLR, 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) */
/* 920528 DESCRIPTION and REFERENCES sections revised. (WRB) */
/* ***END PROLOGUE DGAMIC */
/* ***FIRST EXECUTABLE STATEMENT DGAMIC */
if (first) {
eps = d1mach_(&c__3) * .5;
sqeps = sqrt(d1mach_(&c__4));
alneps = -log(d1mach_(&c__3));
bot = log(d1mach_(&c__1));
}
first = FALSE_;
if (*x < 0.) {
xermsg_("SLATEC", "DGAMIC", "X IS NEGATIVE", &c__2, &c__2, (ftnlen)6,
(ftnlen)6, (ftnlen)13);
}
if (*x > 0.) {
goto L20;
}
if (*a <= 0.) {
xermsg_("SLATEC", "DGAMIC", "X = 0 AND A LE 0 SO DGAMIC IS UNDEFINED",
&c__3, &c__2, (ftnlen)6, (ftnlen)6, (ftnlen)39);
}
d__1 = *a + 1.;
ret_val = exp(dlngam_(&d__1) - log(*a));
return ret_val;
L20:
alx = log(*x);
sga = 1.;
if (*a != 0.) {
sga = d_sign(&c_b17, a);
}
d__1 = *a + sga * .5;
ainta = d_int(&d__1);
aeps = *a - ainta;
izero = 0;
if (*x >= 1.) {
goto L40;
}
if (*a > .5 || abs(aeps) > .001) {
goto L30;
}
e = 2.;
if (-ainta > 1.) {
e = (-ainta + 2.) * 2. / (ainta * ainta - 1.);
}
e -= alx * pow_dd(x, &c_b20);
if (e * abs(aeps) > eps) {
goto L30;
}
ret_val = d9gmic_(a, x, &alx);
return ret_val;
L30:
d__1 = *a + 1.;
dlgams_(&d__1, &algap1, &sgngam);
gstar = d9gmit_(a, x, &algap1, &sgngam, &alx);
if (gstar == 0.) {
izero = 1;
}
if (gstar != 0.) {
alngs = log((abs(gstar)));
}
if (gstar != 0.) {
sgngs = d_sign(&c_b17, &gstar);
}
goto L50;
L40:
if (*a < *x) {
ret_val = exp(d9lgic_(a, x, &alx));
}
if (*a < *x) {
return ret_val;
}
sgngam = 1.;
d__1 = *a + 1.;
algap1 = dlngam_(&d__1);
sgngs = 1.;
alngs = d9lgit_(a, x, &algap1);
/* EVALUATION OF DGAMIC(A,X) IN TERMS OF TRICOMI-S INCOMPLETE GAMMA FN. */
L50:
h__ = 1.;
if (izero == 1) {
goto L60;
}
t = *a * alx + alngs;
if (t > alneps) {
goto L70;
}
if (t > -alneps) {
h__ = 1. - sgngs * exp(t);
}
if (abs(h__) < sqeps) {
xerclr_();
}
if (abs(h__) < sqeps) {
xermsg_("SLATEC", "DGAMIC", "RESULT LT HALF PRECISION", &c__1, &c__1,
(ftnlen)6, (ftnlen)6, (ftnlen)24);
}
L60:
sgng = d_sign(&c_b17, &h__) * sga * sgngam;
t = log((abs(h__))) + algap1 - log((abs(*a)));
if (t < bot) {
xerclr_();
}
ret_val = sgng * exp(t);
return ret_val;
L70:
sgng = -sgngs * sga * sgngam;
t = t + algap1 - log((abs(*a)));
if (t < bot) {
xerclr_();
}
ret_val = sgng * exp(t);
return ret_val;
} /* dgamic_ */
/* 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 ISDCGN */
integer isdcgn_(integer *n, doublereal *b, doublereal *x, integer *nelt,
integer *ia, integer *ja, doublereal *a, integer *isym, U_fp matvec,
S_fp mttvec, S_fp msolve, integer *itol, doublereal *tol, integer *
itmax, integer *iter, doublereal *err, integer *ierr, integer *iunit,
doublereal *r__, doublereal *z__, doublereal *p, doublereal *atp,
doublereal *atz, doublereal *dz, doublereal *atdz, doublereal *rwork,
integer *iwork, doublereal *ak, doublereal *bk, doublereal *bnrm,
doublereal *solnrm)
{
/* Format strings */
static char fmt_1000[] = "(\002 PCG Applied to the Normal Equations for"
" \002,\002N, ITOL = \002,i5,i5,/\002 ITER\002,\002 Error Estim"
"ate\002,\002 Alpha\002,\002 Beta\002)";
static char fmt_1010[] = "(1x,i4,1x,d16.7,1x,d16.7,1x,d16.7)";
/* System generated locals */
integer ret_val, i__1;
/* Local variables */
static integer i__;
extern doublereal dnrm2_(integer *, doublereal *, integer *), d1mach_(
integer *);
/* Fortran I/O blocks */
static cilist io___2 = { 0, 0, 0, fmt_1000, 0 };
static cilist io___3 = { 0, 0, 0, fmt_1010, 0 };
static cilist io___4 = { 0, 0, 0, fmt_1010, 0 };
/* ***BEGIN PROLOGUE ISDCGN */
/* ***SUBSIDIARY */
/* ***PURPOSE Preconditioned CG on Normal Equations Stop Test. */
/* This routine calculates the stop test for the Conjugate */
/* Gradient iteration scheme applied to the normal equations. */
/* It returns a non-zero if the error estimate (the type of */
/* which is determined by ITOL) is less than the user */
/* specified tolerance TOL. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY D2A4, D2B4 */
/* ***TYPE DOUBLE PRECISION (ISSCGN-S, ISDCGN-D) */
/* ***KEYWORDS ITERATIVE PRECONDITION, NON-SYMMETRIC LINEAR SYSTEM, */
/* NORMAL EQUATIONS, SLAP, SPARSE */
/* ***AUTHOR Greenbaum, Anne, (Courant Institute) */
/* Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER */
/* INTEGER IERR, IUNIT, IWORK(USER DEFINED) */
/* DOUBLE PRECISION B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N) */
/* DOUBLE PRECISION ATP(N), ATZ(N), DZ(N), ATDZ(N) */
/* DOUBLE PRECISION RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM */
/* EXTERNAL MATVEC, MTTVEC, MSOLVE */
/* IF( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, */
/* $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, */
/* $ ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) */
/* $ .NE. 0 ) THEN ITERATION DONE */
/* *Arguments: */
/* N :IN Integer */
/* Order of the Matrix. */
/* B :IN Double Precision B(N). */
/* Right-hand side vector. */
/* X :IN Double Precision X(N). */
/* The current approximate solution vector. */
/* NELT :IN Integer. */
/* Number of Non-Zeros stored in A. */
/* IA :IN Integer IA(NELT). */
/* JA :IN Integer JA(NELT). */
/* A :IN Double Precision A(NELT). */
/* These arrays contain the matrix data structure for A. */
/* It could take any form. See "Description" in the */
/* DCGN routine. */
/* ISYM :IN Integer. */
/* Flag to indicate symmetric storage format. */
/* If ISYM=0, all non-zero entries of the matrix are stored. */
/* If ISYM=1, the matrix is symmetric, and only the upper */
/* or lower triangle of the matrix is stored. */
/* MATVEC :EXT External. */
/* Name of a routine which performs the matrix vector multiply */
/* Y = A*X given A and X. The name of the MATVEC routine must */
/* be declared external in the calling program. The calling */
/* sequence to MATVEC is: */
/* CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A*X */
/* upon return X is an input vector, NELT is the number of */
/* non-zeros in the SLAP-Column IA, JA, A storage for the matrix */
/* A. ISYM is a flag which, if non-zero, denotes that A is */
/* symmetric and only the lower or upper triangle is stored. */
/* MTTVEC :EXT External. */
/* Name of a routine which performs the matrix transpose vector */
/* multiply y = A'*X given A and X (where ' denotes transpose). */
/* The name of the MTTVEC routine must be declared external in */
/* the calling program. The calling sequence to MTTVEC is the */
/* same as that for MATVEC, viz.: */
/* CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A'*X */
/* upon return X is an input vector, NELT is the number of */
/* non-zeros in the SLAP-Column IA, JA, A storage for the matrix */
/* A. ISYM is a flag which, if non-zero, denotes that A is */
/* symmetric and only the lower or upper triangle is stored. */
/* MSOLVE :EXT External. */
/* Name of a routine which solves a linear system MZ = R for */
/* Z given R with the preconditioning matrix M (M is supplied via */
/* RWORK and IWORK arrays). The name of the MSOLVE routine must */
/* be declared external in the calling program. The calling */
/* sequence to MSOLVE is: */
/* CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) */
/* Where N is the number of unknowns, R is the right-hand side */
/* vector and Z is the solution upon return. NELT, IA, JA, A and */
/* ISYM are defined as above. RWORK is a double precision array */
/* that can be used to pass necessary preconditioning information */
/* and/or workspace to MSOLVE. IWORK is an integer work array */
/* for the same purpose as RWORK. */
/* ITOL :IN Integer. */
/* Flag to indicate type of convergence criterion. */
/* If ITOL=1, iteration stops when the 2-norm of the residual */
/* divided by the 2-norm of the right-hand side is less than TOL. */
/* If ITOL=2, iteration stops when the 2-norm of M-inv times the */
/* residual divided by the 2-norm of M-inv times the right hand */
/* side is less than TOL, where M-inv is the inverse of the */
/* diagonal of A. */
/* ITOL=11 is often useful for checking and comparing different */
/* routines. For this case, the user must supply the "exact" */
/* solution or a very accurate approximation (one with an error */
/* much less than TOL) through a common block, */
/* COMMON /DSLBLK/ SOLN( ) */
/* If ITOL=11, iteration stops when the 2-norm of the difference */
/* between the iterative approximation and the user-supplied */
/* solution divided by the 2-norm of the user-supplied solution */
/* is less than TOL. Note that this requires the user to set up */
/* the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. */
/* The routine with this declaration should be loaded before the */
/* stop test so that the correct length is used by the loader. */
/* This procedure is not standard Fortran and may not work */
/* correctly on your system (although it has worked on every */
/* system the authors have tried). If ITOL is not 11 then this */
/* common block is indeed standard Fortran. */
/* TOL :IN Double Precision. */
/* Convergence criterion, as described above. */
/* ITMAX :IN Integer. */
/* Maximum number of iterations. */
/* ITER :IN Integer. */
/* Current iteration count. (Must be zero on first call.) */
/* ERR :OUT Double Precision. */
/* Error estimate of error in the X(N) approximate solution, as */
/* defined by ITOL. */
/* IERR :OUT Integer. */
/* Error flag. IERR is set to 3 if ITOL is not one of the */
/* acceptable values, see above. */
/* IUNIT :IN Integer. */
/* Unit number on which to write the error at each iteration, */
/* if this is desired for monitoring convergence. If unit */
/* number is 0, no writing will occur. */
/* R :IN Double Precision R(N). */
/* The residual R = B-AX. */
/* Z :WORK Double Precision Z(N). */
/* Double Precision array used for workspace. */
/* P :IN Double Precision P(N). */
/* The conjugate direction vector. */
/* ATP :IN Double Precision ATP(N). */
/* A-transpose times the conjugate direction vector. */
/* ATZ :IN Double Precision ATZ(N). */
/* A-transpose times the pseudo-residual. */
/* DZ :IN Double Precision DZ(N). */
/* Workspace used to hold temporary vector(s). */
/* ATDZ :WORK Double Precision ATDZ(N). */
/* Workspace. */
/* RWORK :WORK Double Precision RWORK(USER DEFINED). */
/* Double Precision array that can be used by MSOLVE. */
/* IWORK :WORK Integer IWORK(USER DEFINED). */
/* Integer array that can be used by MSOLVE. */
/* AK :IN Double Precision. */
/* BK :IN Double Precision. */
/* Current conjugate gradient parameters alpha and beta. */
/* BNRM :INOUT Double Precision. */
/* Norm of the right hand side. Type of norm depends on ITOL. */
/* Calculated only on the first call. */
/* SOLNRM :INOUT Double Precision. */
/* 2-Norm of the true solution, SOLN. Only computed and used */
/* if ITOL = 11. */
/* *Function Return Values: */
/* 0 : Error estimate (determined by ITOL) is *NOT* less than the */
/* specified tolerance, TOL. The iteration must continue. */
/* 1 : Error estimate (determined by ITOL) is less than the */
/* specified tolerance, TOL. The iteration can be considered */
/* complete. */
/* *Cautions: */
/* This routine will attempt to write to the Fortran logical output */
/* unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that */
/* this logical unit is attached to a file or terminal before calling */
/* this routine with a non-zero value for IUNIT. This routine does */
/* not check for the validity of a non-zero IUNIT unit number. */
/* ***SEE ALSO DCGN */
/* ***ROUTINES CALLED D1MACH, DNRM2 */
/* ***COMMON BLOCKS DSLBLK */
/* ***REVISION HISTORY (YYMMDD) */
/* 890404 DATE WRITTEN */
/* 890404 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 891003 Removed C***REFER TO line, per MKS. */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Removed MATVEC, MTTVEC and MSOLVE from ROUTINES CALLED */
/* list. (FNF) */
/* 910506 Made subsidiary to DCGN. (FNF) */
/* 920407 COMMON BLOCK renamed DSLBLK. (WRB) */
/* 920511 Added complete declaration section. (WRB) */
/* 920930 Corrected to not print AK,BK when ITER=0. (FNF) */
/* 921026 Changed 1.0E10 to D1MACH(2) and corrected D to E in */
/* output format. (FNF) */
/* 921113 Corrected C***CATEGORY line. (FNF) */
/* ***END PROLOGUE ISDCGN */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Subroutine Arguments .. */
/* .. Arrays in Common .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. Common blocks .. */
/* ***FIRST EXECUTABLE STATEMENT ISDCGN */
/* Parameter adjustments */
--atdz;
--dz;
--atz;
--atp;
--p;
--z__;
--r__;
--a;
--x;
--b;
--ja;
--ia;
--rwork;
--iwork;
/* Function Body */
ret_val = 0;
if (*itol == 1) {
/* err = ||Residual||/||RightHandSide|| (2-Norms). */
if (*iter == 0) {
*bnrm = dnrm2_(n, &b[1], &c__1);
}
*err = dnrm2_(n, &r__[1], &c__1) / *bnrm;
} else if (*itol == 2) {
/* -1 -1 */
/* err = ||M Residual||/||M RightHandSide|| (2-Norms). */
if (*iter == 0) {
(*msolve)(n, &b[1], &dz[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
(*mttvec)(n, &dz[1], &atdz[1], nelt, &ia[1], &ja[1], &a[1], isym);
*bnrm = dnrm2_(n, &atdz[1], &c__1);
}
*err = dnrm2_(n, &atz[1], &c__1) / *bnrm;
} else if (*itol == 11) {
/* err = ||x-TrueSolution||/||TrueSolution|| (2-Norms). */
if (*iter == 0) {
*solnrm = dnrm2_(n, dslblk_1.soln, &c__1);
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
dz[i__] = x[i__] - dslblk_1.soln[i__ - 1];
/* L10: */
}
*err = dnrm2_(n, &dz[1], &c__1) / *solnrm;
} else {
/* If we get here ITOL is not one of the acceptable values. */
*err = d1mach_(&c__2);
*ierr = 3;
}
if (*iunit != 0) {
if (*iter == 0) {
io___2.ciunit = *iunit;
s_wsfe(&io___2);
do_fio(&c__1, (char *)&(*n), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*itol), (ftnlen)sizeof(integer));
e_wsfe();
io___3.ciunit = *iunit;
s_wsfe(&io___3);
do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*err), (ftnlen)sizeof(doublereal));
e_wsfe();
} else {
io___4.ciunit = *iunit;
s_wsfe(&io___4);
do_fio(&c__1, (char *)&(*iter), (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&(*err), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*ak), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&(*bk), (ftnlen)sizeof(doublereal));
e_wsfe();
}
}
if (*err <= *tol) {
ret_val = 1;
}
return ret_val;
/* ------------- LAST LINE OF ISDCGN FOLLOWS ---------------------------- */
} /* isdcgn_ */
int dnls1_general_driver(DNLS1_STORAGE * pStorage, void * pGeop, double * x, double * fit, double *st_err,
double * max_diff, char * message) {
int iw = 4, i, err = 0;
double dummy_fit = 0.;
if(!pGeop) return 0;
if(!pStorage) return 0;
if(pStorage->err) return -1;
if(pStorage->iopt==-1) pStorage->iopt=1;
if(pStorage->ftol==-1.) pStorage->ftol= sqrt(d1mach_(&iw));
if(pStorage->xtol==-1.) pStorage->xtol= sqrt(d1mach_(&iw));
if(pStorage->gtol==-1.) pStorage->gtol= 0.;
if(pStorage->maxfev==-1) pStorage->maxfev= 40000;
if(pStorage->epsfcn==-1) pStorage->epsfcn= 0.;
if(pStorage->mode ==-1) pStorage->mode= 1;
if(pStorage->factor==-1) pStorage->factor = 100;
if(pStorage->nprint==-1) pStorage->nprint = 1;
pStorage->ldfjac = pStorage->m;
pStorage->n_iterations = 0;
memcpy(pStorage->x, x, sizeof(double)*pStorage->n);
FCN_PARAMS params;
params.pData = pStorage;
params.pFcnParams = pGeop;
/* if(pStorage->iopt==1) { // forward differencing for jackobian
int iflag=1;
memset(pStorage->fjac, sizeof(double)*pStorage->n*pStorage->m, 0);
(*pStorage->fcn)(&iflag, &pStorage->m, &pStorage->n, pStorage->x, // need to compute fvec
pStorage->fvec, pStorage->fjac, &pStorage->ldfjac, (void *)¶ms);
dfdjc3_(pStorage->fcn, &pStorage->m, &pStorage->n, pStorage->x,
pStorage->fvec, pStorage->fjac, &pStorage->ldfjac, &iflag, &pStorage->epsfcn,
pStorage->wa4, (void *)¶ms);
fprintf(stderr,"%d %d %d\n", pStorage->m, pStorage->n, pStorage->ldfjac);
}
else {
int iflag=2;
int ldfjac = 1;
(*pStorage->fcn)(&iflag, &pStorage->m, &pStorage->n, pStorage->x,
pStorage->fvec, pStorage->fjac, &pStorage->ldfjac, (void *)¶ms);
}
fprintf(stderr,"pStorage->n=%d pStorage->m=%d\n", pStorage->n, pStorage->m);
for(i=0; i<pStorage->m; i++) {
fprintf(stdout,"%d " ,i);
for(int j=0; j<pStorage->n; j++)
fprintf(stdout,"%lg ", pStorage->fjac[pStorage->m*j+i]);
fprintf(stdout,"\n");
}
exit(0); */
/*fprintf(stderr,"Before---------------------\n");
fprintf(stderr,"pStorage->ldfjac=%d\n", pStorage->ldfjac);
fprintf(stderr,"pStorage->ftol=%lg\n", pStorage->ftol);
fprintf(stderr,"pStorage->xtol=%lg\n", pStorage->xtol);
fprintf(stderr,"pStorage->gtol=%lg\n", pStorage->gtol);
fprintf(stderr,"pStorage->maxfev=%d\n", pStorage->maxfev);
fprintf(stderr,"pStorage->epsfcn=%lg\n", pStorage->epsfcn);
fprintf(stderr,"pStorage->mode=%d\n", pStorage->mode);
fprintf(stderr,"pStorage->factor=%lg\n", pStorage->factor);
fprintf(stderr,"pStorage->nprint=%d\n", pStorage->nprint);*/
if(!pStorage->compute_only_stdev) {
dnls1_(pStorage->fcn, &pStorage->iopt, &pStorage->m, &pStorage->n, pStorage->x,
pStorage->fvec, pStorage->fjac, &pStorage->ldfjac, &pStorage->ftol, &pStorage->xtol,
&pStorage->gtol, &pStorage->maxfev, &pStorage->epsfcn, pStorage->diag,
&pStorage->mode, &pStorage->factor, &pStorage->nprint, &pStorage->info,
&pStorage->nfev, &pStorage->njev, pStorage->ipvt, pStorage->qtf,
pStorage->wa1, pStorage->wa2, pStorage->wa3, pStorage->wa4, (void *)¶ms);
if(message) {
switch(pStorage->info) {
case 0:
strcpy(message, "DNLS1: improper input parameters.");
break;
case 1:
sprintf(message, "DNLS1: both actual and predicted relative reductions in the sum of squares are at most FTOL=%lg",pStorage->ftol);
break;
case 2:
sprintf(message, "DNLS1: relative error between two consecutive iterates is at most XTOL=%lg",pStorage->xtol);
break;
case 3:
sprintf(message, "DNLS1: both actual and predicted relative reductions in the sum of squares are at most FTOL=%lg and relative error between two consecutive iterates is at most XTOL=%lg", pStorage->ftol, pStorage->xtol);
break;
case 4:
sprintf(message, "DNLS1: the cosine of the angle between FVEC and any column of the Jacobian is at most GTOL=%lg in absolute value.",pStorage->gtol);
break;
case 5:
strcpy(message, "DNLS1: number of calls to FCN for function evaluation has reached its limit or executaion has been cancelled");
break;
case 6:
sprintf(message, "DNLS1: FTOL=%lg is too small. No further reduction in the sum of squares is possible.", pStorage->ftol);
break;
case 7:
sprintf(message, "DNLS1: XTOL=%lg is too small. No further improvement in the approximate solution X is possible",pStorage->xtol);
break;
case 8:
sprintf(message, "DNLS1: GTOL=%lg is too small. FVEC is orthogonal to the columns of the Jacobian to machine precision.", pStorage->xtol);
break;
default:
strcpy(message, "DNLS1: No information is available.");
}
}
*fit = discrep(pStorage->fvec,pStorage->m, pStorage->n);
// find max. difference
*max_diff = fabs(pStorage->fvec[0]);
double am;
for(i=0; i<pStorage->m; i++) {
am = fabs(pStorage->fvec[i]);
if(am > *max_diff) *max_diff = am;
}
}
else { // only estimate std. dev
//*fit = 0.;
//*max_diff = 0.;
}
memcpy(x, pStorage->x, sizeof(double)*pStorage->n);
//fprintf(stdout,"-----------------scov matrix ---------------\n");
//for(i=0; i<pStorage->n; i++) {
// for(int j=0; j<pStorage->n; j++) {
// fprintf(stdout,"%10e ", r[ldr*j+i]/((*fit)*(*fit)));
// }
// fprintf(stdout,"\n");
//}
//fprintf(stdout,"-----------------end of scov matrix ---------------\n");
// old way how to compute covariance
#ifndef OLD_COVARIANCE
// compute standard covariance matrix
int ldr = (pStorage->iopt == 3) ? pStorage->n : pStorage->m;
int info;
int iflag=1;
dcov_(pStorage->fcn, &pStorage->iopt, &pStorage->m, &pStorage->n,
pStorage->x, pStorage->fvec, pStorage->fjac, &ldr, &info,
pStorage->wa1, pStorage->wa2, pStorage->wa3, pStorage->wa4, (void *)¶ms);
if(pStorage->compute_only_stdev) { // only could find discr AFTER dcov_
dummy_fit = discrep(pStorage->fvec,pStorage->m, pStorage->n);
for(i=0; i<pStorage->n; i++) st_err[i] = sqrt(fabs(pStorage->fjac[ldr*i+i]))/(dummy_fit);
}
else
for(i=0; i<pStorage->n; i++) {
//fprintf(stderr,"Jc %lf\n", pStorage->fjac[ldr*i+i]);
st_err[i] = sqrt(fabs(pStorage->fjac[ldr*i+i]));
}
for(i=0; i<pStorage->n; i++) {
for(int j=0; j<pStorage->n; j++) {
//fprintf(stderr, "Jc %d %d %6.2lf ", i, j, pStorage->fjac[ldr*i+j]);
pStorage->fjac[ldr*i+j] /= (st_err[i]*st_err[j]);
}
//fprintf(stderr, "\n");
}
#else
// compute jackobian
int pack = 1;
if(pStorage->iopt==1) { // forward differencing for jackobian
int iflag=1;
pack =1;
(*pStorage->fcn)(&iflag, &pStorage->m, &pStorage->n, pStorage->x, // need to compute fvec
pStorage->fvec, pStorage->fjac, &pStorage->ldfjac, (void *)¶ms);
dfdjc3_(pStorage->fcn, &pStorage->m, &pStorage->n, pStorage->x,
pStorage->fvec, pStorage->fjac, &pStorage->ldfjac, &iflag, &pStorage->epsfcn,
pStorage->wa4, (void *)¶ms);
}
else {
int iflag=2;
int ldfjac = 1;
(*pStorage->fcn)(&iflag, &pStorage->m, &pStorage->n, pStorage->x,
pStorage->fvec, pStorage->fjac, &ldfjac, (void *)¶ms);
}
compute_standard_errors(pStorage->fjac, pStorage->m, pStorage->n, pStorage->ipvt,
pStorage->wa1, pack, *fit, st_err);
//compute_standard_errors_svd(pStorage->fjac, pStorage->m, pStorage->n, *fit,
// st_err);
#endif
return 1;
}
/* DECK DPSIXN */
doublereal dpsixn_(integer *n)
{
/* Initialized data */
static doublereal c__[100] = { -.577215664901532861,.422784335098467139,
.922784335098467139,1.25611766843180047,1.50611766843180047,
1.70611766843180047,1.87278433509846714,2.01564147795561,
2.14064147795561,2.25175258906672111,2.35175258906672111,
2.44266167997581202,2.52599501330914535,2.60291809023222227,
2.6743466616607937,2.74101332832746037,2.80351332832746037,
2.86233685773922507,2.91789241329478063,2.97052399224214905,
3.02052399224214905,3.06814303986119667,3.11359758531574212,
3.15707584618530734,3.19874251285197401,3.23874251285197401,
3.27720405131351247,3.31424108835054951,3.34995537406483522,
3.38443813268552488,3.41777146601885821,3.45002953053498724,
3.48127953053498724,3.51158256083801755,3.5409943255438999,
3.56956575411532847,3.59734353189310625,3.62437055892013327,
3.65068634839381748,3.67632737403484313,3.70132737403484313,
3.72571761793728215,3.74952714174680596,3.77278295570029433,
3.79551022842756706,3.81773245064978928,3.83947158108457189,
3.86074817682925274,3.88158151016258607,3.9019896734278922,
3.9219896734278922,3.9415975165651471,3.96082828579591633,
3.97969621032421822,3.99821472884273674,4.01639654702455492,
4.03425368988169777,4.05179754953082058,4.06903892884116541,
4.08598808138353829,4.10265474805020496,4.11904819067315578,
4.13517722293122029,4.15105023880423617,4.16667523880423617,
4.18205985418885155,4.1972113693403667,4.21213674247469506,
4.22684262482763624,4.24133537845082464,4.25562109273653893,
4.26970559977879245,4.28359448866768134,4.29729311880466764,
4.31080663231818115,4.32413996565151449,4.33729786038835659,
4.35028487337536958,4.3631053861958824,4.37576361404398366,
4.38826361404398366,4.40060929305632934,4.41280441500754886,
4.42485260777863319,4.4367573696833951,4.44852207556574804,
4.46014998254249223,4.47164423541605544,4.48300787177969181,
4.49424382683587158,4.50535493794698269,4.51634394893599368,
4.52721351415338499,4.537966202325428,4.54860450019776842,
4.55913081598724211,4.56954748265390877,4.57985676100442424,
4.5900608426370773,4.6001618527380874 };
static doublereal b[6] = { .0833333333333333333,-.00833333333333333333,
.00396825396825396825,-.00416666666666666666,
.00757575757575757576,-.0210927960927960928 };
/* System generated locals */
doublereal ret_val, d__1;
/* Local variables */
static integer k;
static doublereal s, fn, ax, trm, rfn2, wdtol;
extern doublereal d1mach_(integer *);
/* ***BEGIN PROLOGUE DPSIXN */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DEXINT */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (PSIXN-S, DPSIXN-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* This subroutine returns values of PSI(X)=derivative of log */
/* GAMMA(X), X.GT.0.0 at integer arguments. A table look-up is */
/* performed for N .LE. 100, and the asymptotic expansion is */
/* evaluated for N.GT.100. */
/* ***SEE ALSO DEXINT */
/* ***ROUTINES CALLED D1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 800501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 910722 Updated AUTHOR section. (ALS) */
/* ***END PROLOGUE DPSIXN */
/* DPSIXN(N), N = 1,100 */
/* COEFFICIENTS OF ASYMPTOTIC EXPANSION */
/* ***FIRST EXECUTABLE STATEMENT DPSIXN */
if (*n > 100) {
goto L10;
}
ret_val = c__[*n - 1];
return ret_val;
L10:
/* Computing MAX */
d__1 = d1mach_(&c__4);
wdtol = max(d__1,1e-18);
fn = (doublereal) (*n);
ax = 1.;
s = -.5 / fn;
if (abs(s) <= wdtol) {
goto L30;
}
rfn2 = 1. / (fn * fn);
for (k = 1; k <= 6; ++k) {
ax *= rfn2;
trm = -b[k - 1] * ax;
if (abs(trm) < wdtol) {
goto L30;
}
s += trm;
/* L20: */
}
L30:
ret_val = s + log(fn);
return ret_val;
} /* dpsixn_ */
/* DECK DCGS */
/* Subroutine */ int dcgs_(integer *n, doublereal *b, doublereal *x, integer *
nelt, integer *ia, integer *ja, doublereal *a, integer *isym, S_fp
matvec, S_fp msolve, integer *itol, doublereal *tol, integer *itmax,
integer *iter, doublereal *err, integer *ierr, integer *iunit,
doublereal *r__, doublereal *r0, doublereal *p, doublereal *q,
doublereal *u, doublereal *v1, doublereal *v2, doublereal *rwork,
integer *iwork)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static integer i__, k;
static doublereal ak, bk, akm;
extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *,
integer *);
static doublereal bnrm, rhon, fuzz, sigma;
extern /* Subroutine */ int daxpy_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
extern doublereal d1mach_(integer *);
static doublereal rhonm1;
extern integer isdcgs_(integer *, doublereal *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, S_fp, S_fp,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
doublereal *);
static doublereal tolmin, solnrm;
/* ***BEGIN PROLOGUE DCGS */
/* ***PURPOSE Preconditioned BiConjugate Gradient Squared Ax=b Solver. */
/* Routine to solve a Non-Symmetric linear system Ax = b */
/* using the Preconditioned BiConjugate Gradient Squared */
/* method. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY D2A4, D2B4 */
/* ***TYPE DOUBLE PRECISION (SCGS-S, DCGS-D) */
/* ***KEYWORDS BICONJUGATE GRADIENT, ITERATIVE PRECONDITION, */
/* NON-SYMMETRIC LINEAR SYSTEM, SLAP, SPARSE */
/* ***AUTHOR Greenbaum, Anne, (Courant Institute) */
/* Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX */
/* INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) */
/* DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), R0(N), P(N) */
/* DOUBLE PRECISION Q(N), U(N), V1(N), V2(N), RWORK(USER DEFINED) */
/* EXTERNAL MATVEC, MSOLVE */
/* CALL DCGS(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, */
/* $ MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, */
/* $ R, R0, P, Q, U, V1, V2, RWORK, IWORK) */
/* *Arguments: */
/* N :IN Integer */
/* Order of the Matrix. */
/* B :IN Double Precision B(N). */
/* Right-hand side vector. */
/* X :INOUT Double Precision X(N). */
/* On input X is your initial guess for solution vector. */
/* On output X is the final approximate solution. */
/* NELT :IN Integer. */
/* Number of Non-Zeros stored in A. */
/* IA :IN Integer IA(NELT). */
/* JA :IN Integer JA(NELT). */
/* A :IN Double Precision A(NELT). */
/* These arrays contain the matrix data structure for A. */
/* It could take any form. See "Description", below, */
/* for more details. */
/* ISYM :IN Integer. */
/* Flag to indicate symmetric storage format. */
/* If ISYM=0, all non-zero entries of the matrix are stored. */
/* If ISYM=1, the matrix is symmetric, and only the upper */
/* or lower triangle of the matrix is stored. */
/* MATVEC :EXT External. */
/* Name of a routine which performs the matrix vector multiply */
/* operation Y = A*X given A and X. The name of the MATVEC */
/* routine must be declared external in the calling program. */
/* The calling sequence of MATVEC is: */
/* CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A*X upon */
/* return, X is an input vector. NELT, IA, JA, A and ISYM */
/* define the SLAP matrix data structure: see Description,below. */
/* MSOLVE :EXT External. */
/* Name of a routine which solves a linear system MZ = R for Z */
/* given R with the preconditioning matrix M (M is supplied via */
/* RWORK and IWORK arrays). The name of the MSOLVE routine */
/* must be declared external in the calling program. The */
/* calling sequence of MSOLVE is: */
/* CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) */
/* Where N is the number of unknowns, R is the right-hand side */
/* vector, and Z is the solution upon return. NELT, IA, JA, A */
/* and ISYM define the SLAP matrix data structure: see */
/* Description, below. RWORK is a double precision array that */
/* can be used to pass necessary preconditioning information and/ */
/* or workspace to MSOLVE. IWORK is an integer work array for */
/* the same purpose as RWORK. */
/* ITOL :IN Integer. */
/* Flag to indicate type of convergence criterion. */
/* If ITOL=1, iteration stops when the 2-norm of the residual */
/* divided by the 2-norm of the right-hand side is less than TOL. */
/* This routine must calculate the residual from R = A*X - B. */
/* This is unnatural and hence expensive for this type of iter- */
/* ative method. ITOL=2 is *STRONGLY* recommended. */
/* If ITOL=2, iteration stops when the 2-norm of M-inv times the */
/* residual divided by the 2-norm of M-inv times the right hand */
/* side is less than TOL, where M-inv time a vector is the pre- */
/* conditioning step. This is the *NATURAL* stopping for this */
/* iterative method and is *STRONGLY* recommended. */
/* ITOL=11 is often useful for checking and comparing different */
/* routines. For this case, the user must supply the "exact" */
/* solution or a very accurate approximation (one with an error */
/* much less than TOL) through a common block, */
/* COMMON /DSLBLK/ SOLN( ) */
/* If ITOL=11, iteration stops when the 2-norm of the difference */
/* between the iterative approximation and the user-supplied */
/* solution divided by the 2-norm of the user-supplied solution */
/* is less than TOL. */
/* TOL :INOUT Double Precision. */
/* Convergence criterion, as described above. (Reset if IERR=4.) */
/* ITMAX :IN Integer. */
/* Maximum number of iterations. */
/* ITER :OUT Integer. */
/* Number of iterations required to reach convergence, or */
/* ITMAX+1 if convergence criterion could not be achieved in */
/* ITMAX iterations. */
/* ERR :OUT Double Precision. */
/* Error estimate of error in final approximate solution, as */
/* defined by ITOL. */
/* IERR :OUT Integer. */
/* Return error flag. */
/* IERR = 0 => All went well. */
/* IERR = 1 => Insufficient space allocated for WORK or IWORK. */
/* IERR = 2 => Method failed to converge in ITMAX steps. */
/* IERR = 3 => Error in user input. */
/* Check input values of N, ITOL. */
/* IERR = 4 => User error tolerance set too tight. */
/* Reset to 500*D1MACH(3). Iteration proceeded. */
/* IERR = 5 => Breakdown of the method detected. */
/* (r0,r) approximately 0. */
/* IERR = 6 => Stagnation of the method detected. */
/* (r0,v) approximately 0. */
/* IUNIT :IN Integer. */
/* Unit number on which to write the error at each iteration, */
/* if this is desired for monitoring convergence. If unit */
/* number is 0, no writing will occur. */
/* R :WORK Double Precision R(N). */
/* R0 :WORK Double Precision R0(N). */
/* P :WORK Double Precision P(N). */
/* Q :WORK Double Precision Q(N). */
/* U :WORK Double Precision U(N). */
/* V1 :WORK Double Precision V1(N). */
/* V2 :WORK Double Precision V2(N). */
/* Double Precision arrays used for workspace. */
/* RWORK :WORK Double Precision RWORK(USER DEFINED). */
/* Double Precision array that can be used for workspace in */
/* MSOLVE. */
/* IWORK :WORK Integer IWORK(USER DEFINED). */
/* Integer array that can be used for workspace in MSOLVE. */
/* *Description */
/* This routine does not care what matrix data structure is */
/* used for A and M. It simply calls the MATVEC and MSOLVE */
/* routines, with the arguments as described above. The user */
/* could write any type of structure and the appropriate MATVEC */
/* and MSOLVE routines. It is assumed that A is stored in the */
/* IA, JA, A arrays in some fashion and that M (or INV(M)) is */
/* stored in IWORK and RWORK in some fashion. The SLAP */
/* routines DSDBCG and DSLUCS are examples of this procedure. */
/* Two examples of matrix data structures are the: 1) SLAP */
/* Triad format and 2) SLAP Column format. */
/* =================== S L A P Triad format =================== */
/* In this format only the non-zeros are stored. They may */
/* appear in *ANY* order. The user supplies three arrays of */
/* length NELT, where NELT is the number of non-zeros in the */
/* matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero */
/* the user puts the row and column index of that matrix */
/* element in the IA and JA arrays. The value of the non-zero */
/* matrix element is placed in the corresponding location of */
/* the A array. This is an extremely easy data structure to */
/* generate. On the other hand it is not too efficient on */
/* vector computers for the iterative solution of linear */
/* systems. Hence, SLAP changes this input data structure to */
/* the SLAP Column format for the iteration (but does not */
/* change it back). */
/* Here is an example of the SLAP Triad storage format for a */
/* 5x5 Matrix. Recall that the entries may appear in any order. */
/* 5x5 Matrix SLAP Triad format for 5x5 matrix on left. */
/* 1 2 3 4 5 6 7 8 9 10 11 */
/* |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 */
/* |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 */
/* | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 */
/* | 0 0 0 44 0| */
/* |51 0 53 0 55| */
/* =================== S L A P Column format ================== */
/* In this format the non-zeros are stored counting down */
/* columns (except for the diagonal entry, which must appear */
/* first in each "column") and are stored in the double pre- */
/* cision array A. In other words, for each column in the */
/* matrix first put the diagonal entry in A. Then put in the */
/* other non-zero elements going down the column (except the */
/* diagonal) in order. The IA array holds the row index for */
/* each non-zero. The JA array holds the offsets into the IA, */
/* A arrays for the beginning of each column. That is, */
/* IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- */
/* th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) */
/* are the last elements of the ICOL-th column. Note that we */
/* always have JA(N+1)=NELT+1, where N is the number of columns */
/* in the matrix and NELT is the number of non-zeros in the */
/* matrix. */
/* Here is an example of the SLAP Column storage format for a */
/* 5x5 Matrix (in the A and IA arrays '|' denotes the end of a */
/* column): */
/* 5x5 Matrix SLAP Column format for 5x5 matrix on left. */
/* 1 2 3 4 5 6 7 8 9 10 11 */
/* |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 */
/* |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 */
/* | 0 0 33 0 35| JA: 1 4 6 8 9 12 */
/* | 0 0 0 44 0| */
/* |51 0 53 0 55| */
/* *Cautions: */
/* This routine will attempt to write to the Fortran logical output */
/* unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that */
/* this logical unit is attached to a file or terminal before calling */
/* this routine with a non-zero value for IUNIT. This routine does */
/* not check for the validity of a non-zero IUNIT unit number. */
/* ***SEE ALSO DSDCGS, DSLUCS */
/* ***REFERENCES 1. P. Sonneveld, CGS, a fast Lanczos-type solver */
/* for nonsymmetric linear systems, Delft University */
/* of Technology Report 84-16, Department of Mathe- */
/* matics and Informatics, Delft, The Netherlands. */
/* 2. E. F. Kaasschieter, The solution of non-symmetric */
/* linear systems by biconjugate gradients or conjugate */
/* gradients squared, Delft University of Technology */
/* Report 86-21, Department of Mathematics and Informa- */
/* tics, Delft, The Netherlands. */
/* 3. Mark K. Seager, A SLAP for the Masses, in */
/* G. F. Carey, Ed., Parallel Supercomputing: Methods, */
/* Algorithms and Applications, Wiley, 1989, pp.135-155. */
/* ***ROUTINES CALLED D1MACH, DAXPY, DDOT, ISDCGS */
/* ***REVISION HISTORY (YYMMDD) */
/* 890404 DATE WRITTEN */
/* 890404 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890921 Removed TeX from comments. (FNF) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 891004 Added new reference. */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) */
/* 920407 COMMON BLOCK renamed DSLBLK. (WRB) */
/* 920511 Added complete declaration section. (WRB) */
/* 920929 Corrected format of references. (FNF) */
/* 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) */
/* 921113 Corrected C***CATEGORY line. (FNF) */
/* ***END PROLOGUE DCGS */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Subroutine Arguments .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* .. External Subroutines .. */
/* .. Intrinsic Functions .. */
/* ***FIRST EXECUTABLE STATEMENT DCGS */
/* Check some of the input data. */
/* Parameter adjustments */
--v2;
--v1;
--u;
--q;
--p;
--r0;
--r__;
--x;
--b;
--a;
--ja;
--ia;
--rwork;
--iwork;
/* Function Body */
*iter = 0;
*ierr = 0;
if (*n < 1) {
*ierr = 3;
return 0;
}
tolmin = d1mach_(&c__3) * 500;
if (*tol < tolmin) {
*tol = tolmin;
*ierr = 4;
}
/* Calculate initial residual and pseudo-residual, and check */
/* stopping criterion. */
(*matvec)(n, &x[1], &r__[1], nelt, &ia[1], &ja[1], &a[1], isym);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
v1[i__] = r__[i__] - b[i__];
/* L10: */
}
(*msolve)(n, &v1[1], &r__[1], nelt, &ia[1], &ja[1], &a[1], isym, &rwork[1]
, &iwork[1]);
if (isdcgs_(n, &b[1], &x[1], nelt, &ia[1], &ja[1], &a[1], isym, (S_fp)
matvec, (S_fp)msolve, itol, tol, itmax, iter, err, ierr, iunit, &
r__[1], &r0[1], &p[1], &q[1], &u[1], &v1[1], &v2[1], &rwork[1], &
iwork[1], &ak, &bk, &bnrm, &solnrm) != 0) {
goto L200;
}
if (*ierr != 0) {
return 0;
}
/* Set initial values. */
/* Computing 2nd power */
d__1 = d1mach_(&c__3);
fuzz = d__1 * d__1;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r0[i__] = r__[i__];
/* L20: */
}
rhonm1 = 1.;
/* ***** ITERATION LOOP ***** */
i__1 = *itmax;
for (k = 1; k <= i__1; ++k) {
*iter = k;
/* Calculate coefficient BK and direction vectors U, V and P. */
rhon = ddot_(n, &r0[1], &c__1, &r__[1], &c__1);
if (abs(rhonm1) < fuzz) {
goto L998;
}
bk = rhon / rhonm1;
if (*iter == 1) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__] = r__[i__];
p[i__] = r__[i__];
/* L30: */
}
} else {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
u[i__] = r__[i__] + bk * q[i__];
v1[i__] = q[i__] + bk * p[i__];
/* L40: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
p[i__] = u[i__] + bk * v1[i__];
/* L50: */
}
}
/* Calculate coefficient AK, new iterate X, Q */
(*matvec)(n, &p[1], &v2[1], nelt, &ia[1], &ja[1], &a[1], isym);
(*msolve)(n, &v2[1], &v1[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
sigma = ddot_(n, &r0[1], &c__1, &v1[1], &c__1);
if (abs(sigma) < fuzz) {
goto L999;
}
ak = rhon / sigma;
akm = -ak;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
q[i__] = u[i__] + akm * v1[i__];
/* L60: */
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
v1[i__] = u[i__] + q[i__];
/* L70: */
}
/* X = X - ak*V1. */
daxpy_(n, &akm, &v1[1], &c__1, &x[1], &c__1);
/* -1 */
/* R = R - ak*M *A*V1 */
(*matvec)(n, &v1[1], &v2[1], nelt, &ia[1], &ja[1], &a[1], isym);
(*msolve)(n, &v2[1], &v1[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
daxpy_(n, &akm, &v1[1], &c__1, &r__[1], &c__1);
/* check stopping criterion. */
if (isdcgs_(n, &b[1], &x[1], nelt, &ia[1], &ja[1], &a[1], isym, (S_fp)
matvec, (S_fp)msolve, itol, tol, itmax, iter, err, ierr,
iunit, &r__[1], &r0[1], &p[1], &q[1], &u[1], &v1[1], &v2[1], &
rwork[1], &iwork[1], &ak, &bk, &bnrm, &solnrm) != 0) {
goto L200;
}
/* Update RHO. */
rhonm1 = rhon;
/* L100: */
}
/* ***** end of loop ***** */
/* Stopping criterion not satisfied. */
*iter = *itmax + 1;
*ierr = 2;
L200:
return 0;
/* Breakdown of method detected. */
L998:
*ierr = 5;
return 0;
/* Stagnation of method detected. */
L999:
*ierr = 6;
return 0;
/* ------------- LAST LINE OF DCGS FOLLOWS ---------------------------- */
} /* dcgs_ */
/* DECK DCHU */
doublereal dchu_(doublereal *a, doublereal *b, doublereal *x)
{
/* Initialized data */
static doublereal pi = 3.141592653589793238462643383279503;
static doublereal eps = 0.;
/* System generated locals */
integer i__1;
doublereal ret_val, d__1, d__2, d__3;
/* Local variables */
static integer i__, m, n;
static doublereal t, a0, b0, c0, xi, xn, xi1, sum, beps, alnx, pch1i;
extern doublereal d9chu_(doublereal *, doublereal *, doublereal *);
static doublereal xeps1;
extern doublereal dgamr_(doublereal *);
static doublereal aintb;
extern doublereal dpoch_(doublereal *, doublereal *), d1mach_(integer *);
static doublereal pch1ai;
static integer istrt;
extern doublereal dpoch1_(doublereal *, doublereal *);
static doublereal gamri1;
extern doublereal dgamma_(doublereal *);
static doublereal pochai, gamrni, factor;
extern doublereal dexprl_(doublereal *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static doublereal xtoeps;
/* ***BEGIN PROLOGUE DCHU */
/* ***PURPOSE Compute the logarithmic confluent hypergeometric function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C11 */
/* ***TYPE DOUBLE PRECISION (CHU-S, DCHU-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* DCHU(A,B,X) calculates the double precision logarithmic confluent */
/* hypergeometric function U(A,B,X) for double precision arguments */
/* A, B, and X. */
/* This routine is not valid when 1+A-B is close to zero if X is small. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED D1MACH, D9CHU, DEXPRL, DGAMMA, DGAMR, DPOCH, */
/* DPOCH1, 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 DCHU */
/* ***FIRST EXECUTABLE STATEMENT DCHU */
if (eps == 0.) {
eps = d1mach_(&c__3);
}
if (*x == 0.) {
xermsg_("SLATEC", "DCHU", "X IS ZERO SO DCHU IS INFINITE", &c__1, &
c__2, (ftnlen)6, (ftnlen)4, (ftnlen)29);
}
if (*x < 0.) {
xermsg_("SLATEC", "DCHU", "X IS NEGATIVE, USE CCHU", &c__2, &c__2, (
ftnlen)6, (ftnlen)4, (ftnlen)23);
}
/* Computing MAX */
d__2 = abs(*a);
/* Computing MAX */
d__3 = (d__1 = *a + 1. - *b, abs(d__1));
if (max(d__2,1.) * max(d__3,1.) < abs(*x) * .99) {
goto L120;
}
/* THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL */
/* APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. */
if ((d__1 = *a + 1. - *b, abs(d__1)) < sqrt(eps)) {
xermsg_("SLATEC", "DCHU", "ALGORITHMIS BAD WHEN 1+A-B IS NEAR ZERO F"
"OR SMALL X", &c__10, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)51);
}
if (*b >= 0.) {
d__1 = *b + .5;
aintb = d_int(&d__1);
}
if (*b < 0.) {
d__1 = *b - .5;
aintb = d_int(&d__1);
}
beps = *b - aintb;
n = (integer) 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.;
if (n == 0) {
goto L30;
}
t = 1.;
m = -n;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi1 = (doublereal) (i__ - 1);
t = t * (*a + xi1) * *x / ((*b + xi1) * (xi1 + 1.));
sum += t;
/* L20: */
}
L30:
d__1 = *a + 1. - *b;
d__2 = -(*a);
sum = dpoch_(&d__1, &d__2) * sum;
goto L70;
/* NOW CONSIDER THE CASE B .GE. 1.0. */
L40:
sum = 0.;
m = n - 2;
if (m < 0) {
goto L70;
}
t = 1.;
sum = 1.;
if (m == 0) {
goto L60;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (doublereal) i__;
t = t * (*a - *b + xi) * *x / ((1. - *b + xi) * xi);
sum += t;
/* L50: */
}
L60:
d__1 = *b - 1.;
i__1 = 1 - n;
sum = dgamma_(&d__1) * dgamr_(a) * pow_di(x, &i__1) * xtoeps * sum;
/* NEXT EVALUATE THE INFINITE SUM. ---------------------------------- */
L70:
istrt = 0;
if (n < 1) {
istrt = 1 - n;
}
xi = (doublereal) istrt;
d__1 = *a + 1. - *b;
factor = pow_di(&c_b25, &n) * dgamr_(&d__1) * pow_di(x, &istrt);
if (beps != 0.) {
factor = factor * beps * pi / sin(beps * pi);
}
pochai = dpoch_(a, &xi);
d__1 = xi + 1.;
gamri1 = dgamr_(&d__1);
d__1 = aintb + xi;
gamrni = dgamr_(&d__1);
d__1 = xi - beps;
d__2 = xi + 1. - beps;
b0 = factor * dpoch_(a, &d__1) * gamrni * dgamr_(&d__2);
if ((d__1 = xtoeps - 1., abs(d__1)) > .5) {
goto L90;
}
/* X**(-BEPS) IS CLOSE TO 1.0D0, SO WE MUST BE CAREFUL IN EVALUATING THE */
/* DIFFERENCES. */
d__1 = *a + xi;
d__2 = -beps;
pch1ai = dpoch1_(&d__1, &d__2);
d__1 = xi + 1. - beps;
pch1i = dpoch1_(&d__1, &beps);
d__1 = *b + xi;
d__2 = -beps;
c0 = factor * pochai * gamrni * gamri1 * (-dpoch1_(&d__1, &d__2) + pch1ai
- pch1i + beps * pch1ai * pch1i);
/* XEPS1 = (1.0 - X**(-BEPS))/BEPS = (X**(-BEPS) - 1.0)/(-BEPS) */
d__1 = -beps * alnx;
xeps1 = alnx * dexprl_(&d__1);
ret_val = sum + c0 + xeps1 * b0;
xn = (doublereal) n;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (doublereal) (istrt + i__);
xi1 = (doublereal) (istrt + i__ - 1);
b0 = (*a + xi1 - beps) * b0 * *x / ((xn + xi1) * (xi - beps));
c0 = (*a + xi1) * c0 * *x / ((*b + xi1) * xi) - ((*a - 1.) * (xn + xi
* 2. - 1.) + xi * (xi - beps)) * b0 / (xi * (*b + xi1) * (*a
+ xi1 - beps));
t = c0 + xeps1 * b0;
ret_val += t;
if (abs(t) < eps * abs(ret_val)) {
goto L130;
}
/* L80: */
}
xermsg_("SLATEC", "DCHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING"
" SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)52);
/* X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD */
/* FORMULATION IS STABLE. */
L90:
d__1 = *b + xi;
a0 = factor * pochai * dgamr_(&d__1) * gamri1 / beps;
b0 = xtoeps * b0 / beps;
ret_val = sum + a0 - b0;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (doublereal) (istrt + i__);
xi1 = (doublereal) (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 (abs(t) < eps * abs(ret_val)) {
goto L130;
}
/* L100: */
}
xermsg_("SLATEC", "DCHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING"
" SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)4, (ftnlen)52);
/* USE LUKE-S RATIONAL APPROXIMATION IN THE ASYMPTOTIC REGION. */
L120:
d__1 = -(*a);
ret_val = pow_dd(x, &d__1) * d9chu_(a, b, x);
L130:
return ret_val;
} /* dchu_ */
/* 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 DIR */
/* Subroutine */ int dir_(integer *n, doublereal *b, doublereal *x, integer *
nelt, integer *ia, integer *ja, doublereal *a, integer *isym, S_fp
matvec, S_fp msolve, integer *itol, doublereal *tol, integer *itmax,
integer *iter, doublereal *err, integer *ierr, integer *iunit,
doublereal *r__, doublereal *z__, doublereal *dz, doublereal *rwork,
integer *iwork)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer i__, k;
static doublereal bnrm;
extern integer isdir_(integer *, doublereal *, doublereal *, integer *,
integer *, integer *, doublereal *, integer *, S_fp, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *);
extern doublereal d1mach_(integer *);
static doublereal tolmin, solnrm;
/* ***BEGIN PROLOGUE DIR */
/* ***PURPOSE Preconditioned Iterative Refinement Sparse Ax = b Solver. */
/* Routine to solve a general linear system Ax = b using */
/* iterative refinement with a matrix splitting. */
/* ***LIBRARY SLATEC (SLAP) */
/* ***CATEGORY D2A4, D2B4 */
/* ***TYPE DOUBLE PRECISION (SIR-S, DIR-D) */
/* ***KEYWORDS ITERATIVE PRECONDITION, LINEAR SYSTEM, SLAP, SPARSE */
/* ***AUTHOR Greenbaum, Anne, (Courant Institute) */
/* Seager, Mark K., (LLNL) */
/* Lawrence Livermore National Laboratory */
/* PO BOX 808, L-60 */
/* Livermore, CA 94550 (510) 423-3141 */
/* [email protected] */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX */
/* INTEGER ITER, IERR, IUNIT, IWORK(USER DEFINED) */
/* DOUBLE PRECISION B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), DZ(N) */
/* DOUBLE PRECISION RWORK(USER DEFINED) */
/* EXTERNAL MATVEC, MSOLVE */
/* CALL DIR(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MSOLVE, ITOL, */
/* $ TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, DZ, RWORK, IWORK) */
/* *Arguments: */
/* N :IN Integer. */
/* Order of the Matrix. */
/* B :IN Double Precision B(N). */
/* Right-hand side vector. */
/* X :INOUT Double Precision X(N). */
/* On input X is your initial guess for solution vector. */
/* On output X is the final approximate solution. */
/* NELT :IN Integer. */
/* Number of Non-Zeros stored in A. */
/* IA :IN Integer IA(NELT). */
/* JA :IN Integer JA(NELT). */
/* A :IN Double Precision A(NELT). */
/* These arrays contain the matrix data structure for A. */
/* It could take any form. See "Description", below, */
/* for more details. */
/* ISYM :IN Integer. */
/* Flag to indicate symmetric storage format. */
/* If ISYM=0, all non-zero entries of the matrix are stored. */
/* If ISYM=1, the matrix is symmetric, and only the upper */
/* or lower triangle of the matrix is stored. */
/* MATVEC :EXT External. */
/* Name of a routine which performs the matrix vector multiply */
/* Y = A*X given A and X. The name of the MATVEC routine must */
/* be declared external in the calling program. The calling */
/* sequence to MATVEC is: */
/* CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM ) */
/* Where N is the number of unknowns, Y is the product A*X */
/* upon return, X is an input vector, NELT is the number of */
/* non-zeros in the SLAP IA, JA, A storage for the matrix A. */
/* ISYM is a flag which, if non-zero, denotes that A is */
/* symmetric and only the lower or upper triangle is stored. */
/* MSOLVE :EXT External. */
/* Name of a routine which solves a linear system MZ = R for */
/* Z given R with the preconditioning matrix M (M is supplied via */
/* RWORK and IWORK arrays). The name of the MSOLVE routine must */
/* be declared external in the calling program. The calling */
/* sequence to MSOLVE is: */
/* CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK) */
/* Where N is the number of unknowns, R is the right-hand side */
/* vector and Z is the solution upon return. NELT, IA, JA, A and */
/* ISYM are defined as above. RWORK is a double precision array */
/* that can be used to pass necessary preconditioning information */
/* and/or workspace to MSOLVE. IWORK is an integer work array */
/* for the same purpose as RWORK. */
/* ITOL :IN Integer. */
/* Flag to indicate type of convergence criterion. */
/* If ITOL=1, iteration stops when the 2-norm of the residual */
/* divided by the 2-norm of the right-hand side is less than TOL. */
/* If ITOL=2, iteration stops when the 2-norm of M-inv times the */
/* residual divided by the 2-norm of M-inv times the right hand */
/* side is less than TOL, where M-inv is the inverse of the */
/* diagonal of A. */
/* ITOL=11 is often useful for checking and comparing different */
/* routines. For this case, the user must supply the "exact" */
/* solution or a very accurate approximation (one with an error */
/* much less than TOL) through a common block, */
/* COMMON /DSLBLK/ SOLN( ) */
/* If ITOL=11, iteration stops when the 2-norm of the difference */
/* between the iterative approximation and the user-supplied */
/* solution divided by the 2-norm of the user-supplied solution */
/* is less than TOL. Note that this requires the user to set up */
/* the "COMMON /DSLBLK/ SOLN(LENGTH)" in the calling routine. */
/* The routine with this declaration should be loaded before the */
/* stop test so that the correct length is used by the loader. */
/* This procedure is not standard Fortran and may not work */
/* correctly on your system (although it has worked on every */
/* system the authors have tried). If ITOL is not 11 then this */
/* common block is indeed standard Fortran. */
/* TOL :INOUT Double Precision. */
/* Convergence criterion, as described above. (Reset if IERR=4.) */
/* ITMAX :IN Integer. */
/* Maximum number of iterations. */
/* ITER :OUT Integer. */
/* Number of iterations required to reach convergence, or */
/* ITMAX+1 if convergence criterion could not be achieved in */
/* ITMAX iterations. */
/* ERR :OUT Double Precision. */
/* Error estimate of error in final approximate solution, as */
/* defined by ITOL. */
/* IERR :OUT Integer. */
/* Return error flag. */
/* IERR = 0 => All went well. */
/* IERR = 1 => Insufficient space allocated for WORK or IWORK. */
/* IERR = 2 => Method failed to converge in ITMAX steps. */
/* IERR = 3 => Error in user input. */
/* Check input values of N, ITOL. */
/* IERR = 4 => User error tolerance set too tight. */
/* Reset to 500*D1MACH(3). Iteration proceeded. */
/* IERR = 5 => Preconditioning matrix, M, is not positive */
/* definite. (r,z) < 0. */
/* IERR = 6 => Matrix A is not positive definite. (p,Ap) < 0. */
/* IUNIT :IN Integer. */
/* Unit number on which to write the error at each iteration, */
/* if this is desired for monitoring convergence. If unit */
/* number is 0, no writing will occur. */
/* R :WORK Double Precision R(N). */
/* Z :WORK Double Precision Z(N). */
/* DZ :WORK Double Precision DZ(N). */
/* Double Precision arrays used for workspace. */
/* RWORK :WORK Double Precision RWORK(USER DEFINED). */
/* Double Precision array that can be used by MSOLVE. */
/* IWORK :WORK Integer IWORK(USER DEFINED). */
/* Integer array that can be used by MSOLVE. */
/* *Description: */
/* The basic algorithm for iterative refinement (also known as */
/* iterative improvement) is: */
/* n+1 n -1 n */
/* X = X + M (B - AX ). */
/* -1 -1 */
/* If M = A then this is the standard iterative refinement */
/* algorithm and the "subtraction" in the residual calculation */
/* should be done in double precision (which it is not in this */
/* routine). */
/* If M = DIAG(A), the diagonal of A, then iterative refinement */
/* is known as Jacobi's method. The SLAP routine DSJAC */
/* implements this iterative strategy. */
/* If M = L, the lower triangle of A, then iterative refinement */
/* is known as Gauss-Seidel. The SLAP routine DSGS implements */
/* this iterative strategy. */
/* This routine does not care what matrix data structure is */
/* used for A and M. It simply calls the MATVEC and MSOLVE */
/* routines, with the arguments as described above. The user */
/* could write any type of structure and the appropriate MATVEC */
/* and MSOLVE routines. It is assumed that A is stored in the */
/* IA, JA, A arrays in some fashion and that M (or INV(M)) is */
/* stored in IWORK and RWORK) in some fashion. The SLAP */
/* routines DSJAC and DSGS are examples of this procedure. */
/* Two examples of matrix data structures are the: 1) SLAP */
/* Triad format and 2) SLAP Column format. */
/* =================== S L A P Triad format =================== */
/* In this format only the non-zeros are stored. They may */
/* appear in *ANY* order. The user supplies three arrays of */
/* length NELT, where NELT is the number of non-zeros in the */
/* matrix: (IA(NELT), JA(NELT), A(NELT)). For each non-zero */
/* the user puts the row and column index of that matrix */
/* element in the IA and JA arrays. The value of the non-zero */
/* matrix element is placed in the corresponding location of */
/* the A array. This is an extremely easy data structure to */
/* generate. On the other hand it is not too efficient on */
/* vector computers for the iterative solution of linear */
/* systems. Hence, SLAP changes this input data structure to */
/* the SLAP Column format for the iteration (but does not */
/* change it back). */
/* Here is an example of the SLAP Triad storage format for a */
/* 5x5 Matrix. Recall that the entries may appear in any order. */
/* 5x5 Matrix SLAP Triad format for 5x5 matrix on left. */
/* 1 2 3 4 5 6 7 8 9 10 11 */
/* |11 12 0 0 15| A: 51 12 11 33 15 53 55 22 35 44 21 */
/* |21 22 0 0 0| IA: 5 1 1 3 1 5 5 2 3 4 2 */
/* | 0 0 33 0 35| JA: 1 2 1 3 5 3 5 2 5 4 1 */
/* | 0 0 0 44 0| */
/* |51 0 53 0 55| */
/* =================== S L A P Column format ================== */
/* In this format the non-zeros are stored counting down */
/* columns (except for the diagonal entry, which must appear */
/* first in each "column") and are stored in the double pre- */
/* cision array A. In other words, for each column in the */
/* matrix first put the diagonal entry in A. Then put in the */
/* other non-zero elements going down the column (except the */
/* diagonal) in order. The IA array holds the row index for */
/* each non-zero. The JA array holds the offsets into the IA, */
/* A arrays for the beginning of each column. That is, */
/* IA(JA(ICOL)),A(JA(ICOL)) are the first elements of the ICOL- */
/* th column in IA and A, and IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1) */
/* are the last elements of the ICOL-th column. Note that we */
/* always have JA(N+1)=NELT+1, where N is the number of columns */
/* in the matrix and NELT is the number of non-zeros in the */
/* matrix. */
/* Here is an example of the SLAP Column storage format for a */
/* 5x5 Matrix (in the A and IA arrays '|' denotes the end of a */
/* column): */
/* 5x5 Matrix SLAP Column format for 5x5 matrix on left. */
/* 1 2 3 4 5 6 7 8 9 10 11 */
/* |11 12 0 0 15| A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35 */
/* |21 22 0 0 0| IA: 1 2 5 | 2 1 | 3 5 | 4 | 5 1 3 */
/* | 0 0 33 0 35| JA: 1 4 6 8 9 12 */
/* | 0 0 0 44 0| */
/* |51 0 53 0 55| */
/* *Examples: */
/* See the SLAP routines DSJAC, DSGS */
/* *Cautions: */
/* This routine will attempt to write to the Fortran logical output */
/* unit IUNIT, if IUNIT .ne. 0. Thus, the user must make sure that */
/* this logical unit is attached to a file or terminal before calling */
/* this routine with a non-zero value for IUNIT. This routine does */
/* not check for the validity of a non-zero IUNIT unit number. */
/* ***SEE ALSO DSJAC, DSGS */
/* ***REFERENCES 1. Gene Golub and Charles Van Loan, Matrix Computations, */
/* Johns Hopkins University Press, Baltimore, Maryland, */
/* 1983. */
/* 2. Mark K. Seager, A SLAP for the Masses, in */
/* G. F. Carey, Ed., Parallel Supercomputing: Methods, */
/* Algorithms and Applications, Wiley, 1989, pp.135-155. */
/* ***ROUTINES CALLED D1MACH, ISDIR */
/* ***REVISION HISTORY (YYMMDD) */
/* 890404 DATE WRITTEN */
/* 890404 Previous REVISION DATE */
/* 890915 Made changes requested at July 1989 CML Meeting. (MKS) */
/* 890921 Removed TeX from comments. (FNF) */
/* 890922 Numerous changes to prologue to make closer to SLATEC */
/* standard. (FNF) */
/* 890929 Numerous changes to reduce SP/DP differences. (FNF) */
/* 891004 Added new reference. */
/* 910411 Prologue converted to Version 4.0 format. (BAB) */
/* 910502 Removed MATVEC and MSOLVE from ROUTINES CALLED list. (FNF) */
/* 920407 COMMON BLOCK renamed DSLBLK. (WRB) */
/* 920511 Added complete declaration section. (WRB) */
/* 920929 Corrected format of references. (FNF) */
/* 921019 Changed 500.0 to 500 to reduce SP/DP differences. (FNF) */
/* ***END PROLOGUE DIR */
/* .. Scalar Arguments .. */
/* .. Array Arguments .. */
/* .. Subroutine Arguments .. */
/* .. Local Scalars .. */
/* .. External Functions .. */
/* ***FIRST EXECUTABLE STATEMENT DIR */
/* Check some of the input data. */
/* Parameter adjustments */
--dz;
--z__;
--r__;
--x;
--b;
--a;
--ja;
--ia;
--rwork;
--iwork;
/* Function Body */
*iter = 0;
*ierr = 0;
if (*n < 1) {
*ierr = 3;
return 0;
}
tolmin = d1mach_(&c__3) * 500;
if (*tol < tolmin) {
*tol = tolmin;
*ierr = 4;
}
/* Calculate initial residual and pseudo-residual, and check */
/* stopping criterion. */
(*matvec)(n, &x[1], &r__[1], nelt, &ia[1], &ja[1], &a[1], isym);
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
r__[i__] = b[i__] - r__[i__];
/* L10: */
}
(*msolve)(n, &r__[1], &z__[1], nelt, &ia[1], &ja[1], &a[1], isym, &rwork[
1], &iwork[1]);
if (isdir_(n, &b[1], &x[1], nelt, &ia[1], &ja[1], &a[1], isym, (S_fp)
msolve, itol, tol, itmax, iter, err, ierr, iunit, &r__[1], &z__[1]
, &dz[1], &rwork[1], &iwork[1], &bnrm, &solnrm) != 0) {
goto L200;
}
if (*ierr != 0) {
return 0;
}
/* ***** iteration loop ***** */
i__1 = *itmax;
for (k = 1; k <= i__1; ++k) {
*iter = k;
/* Calculate new iterate x, new residual r, and new */
/* pseudo-residual z. */
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
x[i__] += z__[i__];
/* L20: */
}
(*matvec)(n, &x[1], &r__[1], nelt, &ia[1], &ja[1], &a[1], isym);
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
r__[i__] = b[i__] - r__[i__];
/* L30: */
}
(*msolve)(n, &r__[1], &z__[1], nelt, &ia[1], &ja[1], &a[1], isym, &
rwork[1], &iwork[1]);
/* check stopping criterion. */
if (isdir_(n, &b[1], &x[1], nelt, &ia[1], &ja[1], &a[1], isym, (S_fp)
msolve, itol, tol, itmax, iter, err, ierr, iunit, &r__[1], &
z__[1], &dz[1], &rwork[1], &iwork[1], &bnrm, &solnrm) != 0) {
goto L200;
}
/* L100: */
}
/* ***** end of loop ***** */
/* Stopping criterion not satisfied. */
*iter = *itmax + 1;
*ierr = 2;
L200:
return 0;
/* ------------- LAST LINE OF DIR FOLLOWS ------------------------------- */
} /* dir_ */
/* DECK ZACAI */
/* Subroutine */ int zacai_(doublereal *zr, doublereal *zi, doublereal *fnu,
integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
yi, integer *nz, doublereal *rl, doublereal *tol, doublereal *elim,
doublereal *alim)
{
/* Initialized data */
static doublereal pi = 3.14159265358979324;
/* Local variables */
static doublereal az;
static integer nn, nw;
static doublereal yy, c1i, c2i, c1r, c2r, arg;
static integer iuf;
static doublereal cyi[2], fmr, sgn;
static integer inu;
static doublereal cyr[2], zni, znr, dfnu;
extern doublereal zabs_(doublereal *, doublereal *);
extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal
*, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
static doublereal ascle, csgni, csgnr, cspni, cspnr;
extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal
*, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *), zseri_(doublereal *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *)
;
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int zmlri_(doublereal *, doublereal *, doublereal
*, integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *), zasyi_(doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, doublereal *);
/* ***BEGIN PROLOGUE ZACAI */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to ZAIRY */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (CACAI-A, ZACAI-A) */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA */
/* K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
/* MP=PI*MR*CMPLX(0.0,1.0) */
/* TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
/* HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. */
/* ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND */
/* RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON */
/* IS CALLED FROM ZAIRY. */
/* ***SEE ALSO ZAIRY */
/* ***ROUTINES CALLED D1MACH, ZABS, ZASYI, ZBKNU, ZMLRI, ZS1S2, ZSERI */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* ***END PROLOGUE ZACAI */
/* COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY */
/* Parameter adjustments */
--yi;
--yr;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT ZACAI */
*nz = 0;
znr = -(*zr);
zni = -(*zi);
az = zabs_(zr, zi);
nn = *n;
dfnu = *fnu + (*n - 1);
if (az <= 2.) {
goto L10;
}
if (az * az * .25 > dfnu + 1.) {
goto L20;
}
L10:
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR THE I FUNCTION */
/* ----------------------------------------------------------------------- */
zseri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol, elim, alim);
goto L40;
L20:
if (az < *rl) {
goto L30;
}
/* ----------------------------------------------------------------------- */
/* ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION */
/* ----------------------------------------------------------------------- */
zasyi_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, tol, elim,
alim);
if (nw < 0) {
goto L80;
}
goto L40;
L30:
/* ----------------------------------------------------------------------- */
/* MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION */
/* ----------------------------------------------------------------------- */
zmlri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol);
if (nw < 0) {
goto L80;
}
L40:
/* ----------------------------------------------------------------------- */
/* ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
/* ----------------------------------------------------------------------- */
zbknu_(&znr, &zni, fnu, kode, &c__1, cyr, cyi, &nw, tol, elim, alim);
if (nw != 0) {
goto L80;
}
fmr = (doublereal) (*mr);
sgn = -d_sign(&pi, &fmr);
csgnr = 0.;
csgni = sgn;
if (*kode == 1) {
goto L50;
}
yy = -zni;
csgnr = -csgni * sin(yy);
csgni *= cos(yy);
L50:
/* ----------------------------------------------------------------------- */
/* CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
/* WHEN FNU IS LARGE */
/* ----------------------------------------------------------------------- */
inu = (integer) (*fnu);
arg = (*fnu - inu) * sgn;
cspnr = cos(arg);
cspni = sin(arg);
if (inu % 2 == 0) {
goto L60;
}
cspnr = -cspnr;
cspni = -cspni;
L60:
c1r = cyr[0];
c1i = cyi[0];
c2r = yr[1];
c2i = yi[1];
if (*kode == 1) {
goto L70;
}
iuf = 0;
ascle = d1mach_(&c__1) * 1e3 / *tol;
zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
*nz += nw;
L70:
yr[1] = cspnr * c1r - cspni * c1i + csgnr * c2r - csgni * c2i;
yi[1] = cspnr * c1i + cspni * c1r + csgnr * c2i + csgni * c2r;
return 0;
L80:
*nz = -1;
if (nw == -2) {
*nz = -2;
}
return 0;
} /* zacai_ */
/* DECK DSOSEQ */
/* Subroutine */ int dsoseq_(D_fp fnc, integer *n, doublereal *s, doublereal *
rtolx, doublereal *atolx, doublereal *tolf, integer *iflag, integer *
mxit, integer *ncjs, integer *nsrrc, integer *nsri, integer *iprint,
doublereal *fmax, doublereal *c__, integer *nc, doublereal *b,
doublereal *p, doublereal *temp, doublereal *x, doublereal *y,
doublereal *fac, integer *is)
{
/* Format strings */
static char fmt_210[] = "(\0020RESIDUAL NORM =\002,d9.2,/1x,\002SOLUTION"
" ITERATE (\002,i3,\002)\002,/(1x,5d26.14))";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Local variables */
static doublereal f, h__;
static integer j, k, l, m, ic, kd, jk, kj, kk;
static doublereal fp;
static integer kn, mm;
static doublereal re;
static integer it, js, ls;
static doublereal hx, yj, fn1, fn2;
static integer km1, np1;
static doublereal yn1, yn2, yn3;
static integer icr, isj, mit;
static doublereal csv;
static integer isv, ksv;
static doublereal uro, yns, fdif, fact, fmin;
static integer item;
static doublereal pmax;
static integer loun;
static doublereal fmxs, test, zero;
static integer itry;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
static doublereal xnorm, ynorm, sruro;
extern /* Subroutine */ int dsossl_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_210, 0 };
/* ***BEGIN PROLOGUE DSOSEQ */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSOS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SOSEQS-S, DSOSEQ-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* DSOSEQ solves a system of N simultaneous nonlinear equations. */
/* See the comments in the interfacing routine DSOS for a more */
/* detailed description of some of the items in the calling list. */
/* ********************************************************************** */
/* -Input- */
/* FNC- Function subprogram which evaluates the equations */
/* N -number of equations */
/* S -Solution vector of initial guesses */
/* RTOLX-Relative error tolerance on solution components */
/* ATOLX-Absolute error tolerance on solution components */
/* TOLF-Residual error tolerance */
/* MXIT-Maximum number of allowable iterations. */
/* NCJS-Maximum number of consecutive iterative steps to perform */
/* using the same triangular Jacobian matrix approximation. */
/* NSRRC-Number of consecutive iterative steps for which the */
/* limiting precision accuracy test must be satisfied */
/* before the routine exits with IFLAG=4. */
/* NSRI-Number of consecutive iterative steps for which the */
/* diverging condition test must be satisfied before */
/* the routine exits with IFLAG=7. */
/* IPRINT-Internal printing parameter. You must set IPRINT=-1 if you */
/* want the intermediate solution iterates and a residual norm */
/* to be printed. */
/* C -Internal work array, dimensioned at least N*(N+1)/2. */
/* NC -Dimension of C array. NC .GE. N*(N+1)/2. */
/* B -Internal work array, dimensioned N. */
/* P -Internal work array, dimensioned N. */
/* TEMP-Internal work array, dimensioned N. */
/* X -Internal work array, dimensioned N. */
/* Y -Internal work array, dimensioned N. */
/* FAC -Internal work array, dimensioned N. */
/* IS -Internal work array, dimensioned N. */
/* -Output- */
/* S -Solution vector */
/* IFLAG-Status indicator flag */
/* MXIT-The actual number of iterations performed */
/* FMAX-Residual norm */
/* C -Upper unit triangular matrix which approximates the */
/* forward triangularization of the full Jacobian matrix. */
/* Stored in a vector with dimension at least N*(N+1)/2. */
/* B -Contains the residuals (function values) divided */
/* by the corresponding components of the P vector */
/* P -Array used to store the partial derivatives. After */
/* each iteration P(K) contains the maximal derivative */
/* occurring in the K-th reduced equation. */
/* TEMP-Array used to store the previous solution iterate. */
/* X -Solution vector. Contains the values achieved on the */
/* last iteration loop upon exit from DSOS. */
/* Y -Array containing the solution increments. */
/* FAC -Array containing factors used in computing numerical */
/* derivatives. */
/* IS -Records the pivotal information (column interchanges) */
/* ********************************************************************** */
/* *** Three machine dependent parameters appear in this subroutine. */
/* *** The smallest positive magnitude, zero, is defined by the function */
/* *** routine D1MACH(1). */
/* *** URO, the computer unit roundoff value, is defined by D1MACH(3) for */
/* *** machines that round or D1MACH(4) for machines that truncate. */
/* *** URO is the smallest positive number such that 1.+URO .GT. 1. */
/* *** The output tape unit number, LOUN, is defined by the function */
/* *** I1MACH(2). */
/* ********************************************************************** */
/* ***SEE ALSO DSOS */
/* ***ROUTINES CALLED D1MACH, DSOSSL, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 801001 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* ***END PROLOGUE DSOSEQ */
/* BEGIN BLOCK PERMITTING ...EXITS TO 430 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 410 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 390 */
/* ***FIRST EXECUTABLE STATEMENT DSOSEQ */
/* Parameter adjustments */
--is;
--fac;
--y;
--x;
--temp;
--p;
--b;
--c__;
--s;
/* Function Body */
uro = d1mach_(&c__4);
loun = i1mach_(&c__2);
zero = d1mach_(&c__1);
re = max(*rtolx,uro);
sruro = sqrt(uro);
*iflag = 0;
np1 = *n + 1;
icr = 0;
ic = 0;
itry = *ncjs;
yn1 = 0.;
yn2 = 0.;
yn3 = 0.;
yns = 0.;
mit = 0;
fn1 = 0.;
fn2 = 0.;
fmxs = 0.;
/* INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND */
/* SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
is[k] = k;
x[k] = s[k];
temp[k] = x[k];
/* L10: */
}
/* ********************************************************* */
/* **** BEGIN PRINCIPAL ITERATION LOOP **** */
/* ********************************************************* */
i__1 = *mxit;
for (m = 1; m <= i__1; ++m) {
/* BEGIN BLOCK PERMITTING ...EXITS TO 350 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 240 */
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
fac[k] = sruro;
/* L20: */
}
L30:
/* BEGIN BLOCK PERMITTING ...EXITS TO 180 */
kn = 1;
*fmax = 0.;
/* ******** BEGIN SUBITERATION LOOP DEFINING */
/* THE LINEARIZATION OF EACH ******** */
/* EQUATION WHICH RESULTS IN THE CONSTRUCTION */
/* OF AN UPPER ******** TRIANGULAR MATRIX */
/* APPROXIMATING THE FORWARD ******** */
/* TRIANGULARIZATION OF THE FULL JACOBIAN */
/* MATRIX */
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* BEGIN BLOCK PERMITTING ...EXITS TO 160 */
km1 = k - 1;
/* BACK-SOLVE A TRIANGULAR LINEAR */
/* SYSTEM OBTAINING IMPROVED SOLUTION */
/* VALUES FOR K-1 OF THE VARIABLES FROM */
/* THE FIRST K-1 EQUATIONS. THESE */
/* VARIABLES ARE THEN ELIMINATED FROM */
/* THE K-TH EQUATION. */
if (km1 == 0) {
goto L50;
}
dsossl_(&k, n, &km1, &y[1], &c__[1], &b[1], &kn);
i__3 = km1;
for (j = 1; j <= i__3; ++j) {
js = is[j];
x[js] = temp[js] + y[j];
/* L40: */
}
L50:
/* EVALUATE THE K-TH EQUATION AND THE */
/* INTERMEDIATE COMPUTATION FOR THE MAX */
/* NORM OF THE RESIDUAL VECTOR. */
f = (*fnc)(&x[1], &k);
/* Computing MAX */
d__1 = *fmax, d__2 = abs(f);
*fmax = max(d__1,d__2);
/* IF WE WISH TO PERFORM SEVERAL */
/* ITERATIONS USING A FIXED */
/* FACTORIZATION OF AN APPROXIMATE */
/* JACOBIAN,WE NEED ONLY UPDATE THE */
/* CONSTANT VECTOR. */
/* ...EXIT */
if (itry < *ncjs) {
goto L160;
}
it = 0;
/* COMPUTE PARTIAL DERIVATIVES THAT ARE */
/* REQUIRED IN THE LINEARIZATION OF THE */
/* K-TH REDUCED EQUATION */
i__3 = *n;
for (j = k; j <= i__3; ++j) {
item = is[j];
hx = x[item];
h__ = fac[item] * hx;
if (abs(h__) <= zero) {
h__ = fac[item];
}
x[item] = hx + h__;
if (km1 == 0) {
goto L70;
}
y[j] = h__;
dsossl_(&k, n, &j, &y[1], &c__[1], &b[1], &kn);
i__4 = km1;
for (l = 1; l <= i__4; ++l) {
ls = is[l];
x[ls] = temp[ls] + y[l];
/* L60: */
}
L70:
fp = (*fnc)(&x[1], &k);
x[item] = hx;
fdif = fp - f;
if (abs(fdif) > uro * abs(f)) {
goto L80;
}
fdif = 0.;
++it;
L80:
p[j] = fdif / h__;
/* L90: */
}
if (it <= *n - k) {
goto L110;
}
/* ALL COMPUTED PARTIAL DERIVATIVES */
/* OF THE K-TH EQUATION ARE */
/* EFFECTIVELY ZERO.TRY LARGER */
/* PERTURBATIONS OF THE INDEPENDENT */
/* VARIABLES. */
i__3 = *n;
for (j = k; j <= i__3; ++j) {
isj = is[j];
fact = fac[isj] * 100.;
/* ..............................EXIT */
if (fact > 1e10) {
goto L390;
}
fac[isj] = fact;
/* L100: */
}
/* ............EXIT */
goto L180;
L110:
/* ...EXIT */
if (k == *n) {
goto L160;
}
/* ACHIEVE A PIVOTING EFFECT BY */
/* CHOOSING THE MAXIMAL DERIVATIVE */
/* ELEMENT */
pmax = 0.;
i__3 = *n;
for (j = k; j <= i__3; ++j) {
test = (d__1 = p[j], abs(d__1));
if (test <= pmax) {
goto L120;
}
pmax = test;
isv = j;
L120:
/* L130: */
;
}
/* ........................EXIT */
if (pmax == 0.) {
goto L390;
}
/* SET UP THE COEFFICIENTS FOR THE K-TH */
/* ROW OF THE TRIANGULAR LINEAR SYSTEM */
/* AND SAVE THE PARTIAL DERIVATIVE OF */
/* LARGEST MAGNITUDE */
pmax = p[isv];
kk = kn;
i__3 = *n;
for (j = k; j <= i__3; ++j) {
if (j != isv) {
c__[kk] = -p[j] / pmax;
}
++kk;
/* L140: */
}
p[k] = pmax;
/* ...EXIT */
if (isv == k) {
goto L160;
}
/* INTERCHANGE THE TWO COLUMNS OF C */
/* DETERMINED BY THE PIVOTAL STRATEGY */
ksv = is[k];
is[k] = is[isv];
is[isv] = ksv;
kd = isv - k;
kj = k;
i__3 = k;
for (j = 1; j <= i__3; ++j) {
csv = c__[kj];
jk = kj + kd;
c__[kj] = c__[jk];
c__[jk] = csv;
kj = kj + *n - j;
/* L150: */
}
L160:
kn = kn + np1 - k;
/* STORE THE COMPONENTS FOR THE CONSTANT */
/* VECTOR */
b[k] = -f / p[k];
/* L170: */
}
/* ......EXIT */
goto L190;
L180:
goto L30;
L190:
/* ******** */
/* ******** END OF LOOP CREATING THE TRIANGULAR */
/* LINEARIZATION MATRIX */
/* ******** */
/* SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW */
/* SOLUTION APPROXIMATION AND OBTAIN THE SOLUTION */
/* INCREMENT NORM. */
--kn;
y[*n] = b[*n];
if (*n > 1) {
dsossl_(n, n, n, &y[1], &c__[1], &b[1], &kn);
}
xnorm = 0.;
ynorm = 0.;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
yj = y[j];
/* Computing MAX */
d__1 = ynorm, d__2 = abs(yj);
ynorm = max(d__1,d__2);
js = is[j];
x[js] = temp[js] + yj;
/* Computing MAX */
d__2 = xnorm, d__3 = (d__1 = x[js], abs(d__1));
xnorm = max(d__2,d__3);
/* L200: */
}
/* PRINT INTERMEDIATE SOLUTION ITERATES AND */
/* RESIDUAL NORM IF DESIRED */
if (*iprint != -1) {
goto L220;
}
mm = m - 1;
io___48.ciunit = loun;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&(*fmax), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&mm, (ftnlen)sizeof(integer));
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&x[j], (ftnlen)sizeof(doublereal));
}
e_wsfe();
L220:
/* TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE */
/* AND/OR ABSOLUTE ERROR COMPARISON ON SUCCESSIVE */
/* APPROXIMATIONS OF EACH SOLUTION VARIABLE) */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
js = is[j];
/* ......EXIT */
if ((d__2 = y[j], abs(d__2)) > re * (d__1 = x[js], abs(d__1)) + *
atolx) {
goto L240;
}
/* L230: */
}
if (*fmax <= fmxs) {
*iflag = 1;
}
L240:
/* TEST FOR CONVERGENCE TO A SOLUTION BASED ON */
/* RESIDUALS */
if (*fmax <= *tolf) {
*iflag += 2;
}
/* ............EXIT */
if (*iflag > 0) {
goto L410;
}
if (m > 1) {
goto L250;
}
fmin = *fmax;
goto L330;
L250:
/* BEGIN BLOCK PERMITTING ...EXITS TO 320 */
/* SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. */
if (*fmax >= fmin) {
goto L270;
}
mit = m + 1;
yn1 = ynorm;
yn2 = yns;
fn1 = fmxs;
fmin = *fmax;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
s[j] = x[j];
/* L260: */
}
ic = 0;
L270:
/* TEST FOR LIMITING PRECISION CONVERGENCE. VERY */
/* SLOWLY CONVERGENT PROBLEMS MAY ALSO BE */
/* DETECTED. */
if (ynorm > sruro * xnorm) {
goto L290;
}
if (*fmax < fmxs * .2 || *fmax > fmxs * 5.) {
goto L290;
}
if (ynorm < yns * .2 || ynorm > yns * 5.) {
goto L290;
}
++icr;
if (icr >= *nsrrc) {
goto L280;
}
ic = 0;
/* .........EXIT */
goto L320;
L280:
*iflag = 4;
*fmax = fmin;
/* ........................EXIT */
goto L430;
L290:
icr = 0;
/* TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. */
if (ynorm > yns * 2. || *fmax > fmxs * 2.) {
goto L300;
}
ic = 0;
goto L310;
L300:
++ic;
/* ......EXIT */
if (ic < *nsri) {
goto L320;
}
*iflag = 7;
/* .....................EXIT */
goto L410;
L310:
L320:
L330:
/* CHECK TO SEE IF NEXT ITERATION CAN USE THE OLD */
/* JACOBIAN FACTORIZATION */
--itry;
if (itry == 0) {
goto L340;
}
if (ynorm * 20. > xnorm) {
goto L340;
}
if (ynorm > yns * 2.) {
goto L340;
}
/* ......EXIT */
if (*fmax < fmxs * 2.) {
goto L350;
}
L340:
itry = *ncjs;
L350:
/* SAVE THE CURRENT SOLUTION APPROXIMATION AND THE */
/* RESIDUAL AND SOLUTION INCREMENT NORMS FOR USE IN THE */
/* NEXT ITERATION. */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
temp[j] = x[j];
/* L360: */
}
if (m != mit) {
goto L370;
}
fn2 = *fmax;
yn3 = ynorm;
L370:
fmxs = *fmax;
yns = ynorm;
/* L380: */
}
/* ********************************************************* */
/* **** END OF PRINCIPAL ITERATION LOOP **** */
/* ********************************************************* */
/* TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. */
m = *mxit;
*iflag = 5;
if (yn1 > yn2 * 10. || yn3 > yn1 * 10.) {
*iflag = 6;
}
if (fn1 > fmin * 5. || fn2 > fmin * 5.) {
*iflag = 6;
}
if (*fmax > fmin * 5.) {
*iflag = 6;
}
/* ......EXIT */
goto L410;
L390:
/* A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. */
*iflag = 8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = temp[j];
/* L400: */
}
/* ......EXIT */
goto L430;
L410:
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = x[j];
/* L420: */
}
L430:
*mxit = m;
return 0;
} /* dsoseq_ */
