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