/* Subroutine */ int cgesvx_(char *fact, char *trans, integer *n, integer *
nrhs, complex *a, integer *lda, complex *af, integer *ldaf, integer *
ipiv, char *equed, real *r__, real *c__, complex *b, integer *ldb,
complex *x, integer *ldx, real *rcond, real *ferr, real *berr,
complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
complex q__1;
/* Local variables */
integer i__, j;
real amax;
char norm[1];
extern logical lsame_(char *, char *);
real rcmin, rcmax, anorm;
logical equil;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *);
extern /* Subroutine */ int claqge_(integer *, integer *, complex *,
integer *, real *, real *, real *, real *, real *, char *)
, cgecon_(char *, integer *, complex *, integer *, real *, real *,
complex *, real *, integer *);
real colcnd;
extern doublereal slamch_(char *);
extern /* Subroutine */ int cgeequ_(integer *, integer *, complex *,
integer *, real *, real *, real *, real *, real *, integer *);
logical nofact;
extern /* Subroutine */ int cgerfs_(char *, integer *, integer *, complex
*, integer *, complex *, integer *, integer *, complex *, integer
*, complex *, integer *, real *, real *, complex *, real *,
integer *), cgetrf_(integer *, integer *, complex *,
integer *, integer *, integer *), clacpy_(char *, integer *,
integer *, complex *, integer *, complex *, integer *),
xerbla_(char *, integer *);
real bignum;
extern doublereal clantr_(char *, char *, char *, integer *, integer *,
complex *, integer *, real *);
integer infequ;
logical colequ;
extern /* Subroutine */ int cgetrs_(char *, integer *, integer *, complex
*, integer *, integer *, complex *, integer *, integer *);
real rowcnd;
logical notran;
real smlnum;
logical rowequ;
real rpvgrw;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CGESVX uses the LU factorization to compute the solution to a complex */
/* system of linear equations */
/* A * X = B, */
/* where A is an N-by-N matrix and X and B are N-by-NRHS matrices. */
/* Error bounds on the solution and a condition estimate are also */
/* provided. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B */
/* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B */
/* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N') */
/* or diag(C)*B (if TRANS = 'T' or 'C'). */
/* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the */
/* matrix A (after equilibration if FACT = 'E') as */
/* A = P * L * U, */
/* where P is a permutation matrix, L is a unit lower triangular */
/* matrix, and U is upper triangular. */
/* 3. If some U(i,i)=0, so that U is exactly singular, then the routine */
/* returns with INFO = i. Otherwise, the factored form of A is used */
/* to estimate the condition number of the matrix A. If the */
/* reciprocal of the condition number is less than machine precision, */
/* INFO = N+1 is returned as a warning, but the routine still goes on */
/* to solve for X and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. Iterative refinement is applied to improve the computed solution */
/* matrix and calculate error bounds and backward error estimates */
/* for it. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so */
/* that it solves the original system before equilibration. */
/* Arguments */
/* ========= */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AF and IPIV contain the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by R and C. */
/* A, AF, and IPIV are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations: */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A**T * X = B (Transpose) */
/* = 'C': A**H * X = B (Conjugate transpose) */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) COMPLEX array, dimension (LDA,N) */
/* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is */
/* not 'N', then A must have been equilibrated by the scaling */
/* factors in R and/or C. A is not modified if FACT = 'F' or */
/* 'N', or if FACT = 'E' and EQUED = 'N' on exit. */
/* On exit, if EQUED .ne. 'N', A is scaled as follows: */
/* EQUED = 'R': A := diag(R) * A */
/* EQUED = 'C': A := A * diag(C) */
/* EQUED = 'B': A := diag(R) * A * diag(C). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) COMPLEX array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the factors L and U from the factorization */
/* A = P*L*U as computed by CGETRF. If EQUED .ne. 'N', then */
/* AF is the factored form of the equilibrated matrix A. */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the factors L and U from the factorization A = P*L*U */
/* of the original matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the factors L and U from the factorization A = P*L*U */
/* of the equilibrated matrix A (see the description of A for */
/* the form of the equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* IPIV (input or output) INTEGER array, dimension (N) */
/* If FACT = 'F', then IPIV is an input argument and on entry */
/* contains the pivot indices from the factorization A = P*L*U */
/* as computed by CGETRF; row i of the matrix was interchanged */
/* with row IPIV(i). */
/* If FACT = 'N', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = P*L*U */
/* of the original matrix A. */
/* If FACT = 'E', then IPIV is an output argument and on exit */
/* contains the pivot indices from the factorization A = P*L*U */
/* of the equilibrated matrix A. */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'R': Row equilibration, i.e., A has been premultiplied by */
/* diag(R). */
/* = 'C': Column equilibration, i.e., A has been postmultiplied */
/* by diag(C). */
/* = 'B': Both row and column equilibration, i.e., A has been */
/* replaced by diag(R) * A * diag(C). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* R (input or output) REAL array, dimension (N) */
/* The row scale factors for A. If EQUED = 'R' or 'B', A is */
/* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R */
/* is not accessed. R is an input argument if FACT = 'F'; */
/* otherwise, R is an output argument. If FACT = 'F' and */
/* EQUED = 'R' or 'B', each element of R must be positive. */
/* C (input or output) REAL array, dimension (N) */
/* The column scale factors for A. If EQUED = 'C' or 'B', A is */
/* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C */
/* is not accessed. C is an input argument if FACT = 'F'; */
/* otherwise, C is an output argument. If FACT = 'F' and */
/* EQUED = 'C' or 'B', each element of C must be positive. */
/* B (input/output) COMPLEX array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by */
/* diag(R)*B; */
/* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is */
/* overwritten by diag(C)*B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) COMPLEX array, dimension (LDX,NRHS) */
/* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X */
/* to the original system of equations. Note that A and B are */
/* modified on exit if EQUED .ne. 'N', and the solution to the */
/* equilibrated system is inv(diag(C))*X if TRANS = 'N' and */
/* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C' */
/* and EQUED = 'R' or 'B'. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* The estimate of the reciprocal condition number of the matrix */
/* A after equilibration (if done). If RCOND is less than the */
/* machine precision (in particular, if RCOND = 0), the matrix */
/* is singular to working precision. This condition is */
/* indicated by a return code of INFO > 0. */
/* FERR (output) REAL array, dimension (NRHS) */
/* The estimated forward error bound for each solution vector */
/* X(j) (the j-th column of the solution matrix X). */
/* If XTRUE is the true solution corresponding to X(j), FERR(j) */
/* is an estimated upper bound for the magnitude of the largest */
/* element in (X(j) - XTRUE) divided by the magnitude of the */
/* largest element in X(j). The estimate is as reliable as */
/* the estimate for RCOND, and is almost always a slight */
/* overestimate of the true error. */
/* BERR (output) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector X(j) (i.e., the smallest relative change in */
/* any element of A or B that makes X(j) an exact solution). */
/* WORK (workspace) COMPLEX array, dimension (2*N) */
/* RWORK (workspace/output) REAL array, dimension (2*N) */
/* On exit, RWORK(1) contains the reciprocal pivot growth */
/* factor norm(A)/norm(U). The "max absolute element" norm is */
/* used. If RWORK(1) is much less than 1, then the stability */
/* of the LU factorization of the (equilibrated) matrix A */
/* could be poor. This also means that the solution X, condition */
/* estimator RCOND, and forward error bound FERR could be */
/* unreliable. If factorization fails with 0<INFO<=N, then */
/* RWORK(1) contains the reciprocal pivot growth factor for the */
/* leading INFO columns of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, and i is */
/* <= N: U(i,i) is exactly zero. The factorization has */
/* been completed, but the factor U is exactly */
/* singular, so the solution and error bounds */
/* could not be computed. RCOND = 0 is returned. */
/* = N+1: U is nonsingular, but RCOND is less than machine */
/* precision, meaning that the matrix is singular */
/* to working precision. Nevertheless, the */
/* solution and error bounds are computed because */
/* there are a number of situations where the */
/* computed solution can be more accurate than the */
/* value of RCOND would suggest. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--ipiv;
--r__;
--c__;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--ferr;
--berr;
--work;
--rwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
notran = lsame_(trans, "N");
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rowequ = FALSE_;
colequ = FALSE_;
} else {
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
}
/* Test the input parameters. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rowequ || colequ
|| lsame_(equed, "N"))) {
*info = -10;
} else {
if (rowequ) {
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = r__[j];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = r__[j];
rcmax = dmax(r__1,r__2);
/* L10: */
}
if (rcmin <= 0.f) {
*info = -11;
} else if (*n > 0) {
rowcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
} else {
rowcnd = 1.f;
}
}
if (colequ && *info == 0) {
rcmin = bignum;
rcmax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = rcmin, r__2 = c__[j];
rcmin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = rcmax, r__2 = c__[j];
rcmax = dmax(r__1,r__2);
/* L20: */
}
if (rcmin <= 0.f) {
*info = -12;
} else if (*n > 0) {
colcnd = dmax(rcmin,smlnum) / dmin(rcmax,bignum);
} else {
colcnd = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -14;
} else if (*ldx < max(1,*n)) {
*info = -16;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CGESVX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
cgeequ_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &colcnd, &
amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
claqge_(n, n, &a[a_offset], lda, &r__[1], &c__[1], &rowcnd, &
colcnd, &amax, equed);
rowequ = lsame_(equed, "R") || lsame_(equed,
"B");
colequ = lsame_(equed, "C") || lsame_(equed,
"B");
}
}
/* Scale the right hand side. */
if (notran) {
if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = r__[i__4] * b[i__5].r, q__1.i = r__[i__4] * b[
i__5].i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L30: */
}
/* L40: */
}
}
} else if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * b_dim1;
i__4 = i__;
i__5 = i__ + j * b_dim1;
q__1.r = c__[i__4] * b[i__5].r, q__1.i = c__[i__4] * b[i__5]
.i;
b[i__3].r = q__1.r, b[i__3].i = q__1.i;
/* L50: */
}
/* L60: */
}
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
clacpy_("Full", n, n, &a[a_offset], lda, &af[af_offset], ldaf);
cgetrf_(n, n, &af[af_offset], ldaf, &ipiv[1], info);
/* Return if INFO is non-zero. */
if (*info > 0) {
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
rpvgrw = clantr_("M", "U", "N", info, info, &af[af_offset], ldaf,
&rwork[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = clange_("M", n, info, &a[a_offset], lda, &rwork[1]) / rpvgrw;
}
rwork[1] = rpvgrw;
*rcond = 0.f;
return 0;
}
}
/* Compute the norm of the matrix A and the */
/* reciprocal pivot growth factor RPVGRW. */
if (notran) {
*(unsigned char *)norm = '1';
} else {
*(unsigned char *)norm = 'I';
}
anorm = clange_(norm, n, n, &a[a_offset], lda, &rwork[1]);
rpvgrw = clantr_("M", "U", "N", n, n, &af[af_offset], ldaf, &rwork[1]);
if (rpvgrw == 0.f) {
rpvgrw = 1.f;
} else {
rpvgrw = clange_("M", n, n, &a[a_offset], lda, &rwork[1]) /
rpvgrw;
}
/* Compute the reciprocal of the condition number of A. */
cgecon_(norm, n, &af[af_offset], ldaf, &anorm, rcond, &work[1], &rwork[1],
info);
/* Compute the solution matrix X. */
clacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
cgetrs_(trans, n, nrhs, &af[af_offset], ldaf, &ipiv[1], &x[x_offset], ldx,
info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
cgerfs_(trans, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &ipiv[1],
&b[b_offset], ldb, &x[x_offset], ldx, &ferr[1], &berr[1], &work[
1], &rwork[1], info);
/* Transform the solution matrix X to a solution of the original */
/* system. */
if (notran) {
if (colequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = c__[i__4] * x[i__5].r, q__1.i = c__[i__4] * x[
i__5].i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L70: */
}
/* L80: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= colcnd;
/* L90: */
}
}
} else if (rowequ) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__;
i__5 = i__ + j * x_dim1;
q__1.r = r__[i__4] * x[i__5].r, q__1.i = r__[i__4] * x[i__5]
.i;
x[i__3].r = q__1.r, x[i__3].i = q__1.i;
/* L100: */
}
/* L110: */
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
ferr[j] /= rowcnd;
/* L120: */
}
}
/* Set INFO = N+1 if the matrix is singular to working precision. */
if (*rcond < slamch_("Epsilon")) {
*info = *n + 1;
}
rwork[1] = rpvgrw;
return 0;
/* End of CGESVX */
} /* cgesvx_ */
/* Subroutine */ int ssyt22_(integer *itype, char *uplo, integer *n, integer *
m, integer *kband, real *a, integer *lda, real *d__, real *e, real *u,
integer *ldu, real *v, integer *ldv, real *tau, real *work, real *
result)
{
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1;
real r__1, r__2;
/* Local variables */
static real unfl;
static integer j;
extern /* Subroutine */ int sgemm_(char *, char *, integer *, integer *,
integer *, real *, real *, integer *, real *, integer *, real *,
real *, integer *);
static real anorm;
extern /* Subroutine */ int sort01_(char *, integer *, integer *, real *,
integer *, real *, integer *, real *);
static real wnorm;
extern /* Subroutine */ int ssymm_(char *, char *, integer *, integer *,
real *, real *, integer *, real *, integer *, real *, real *,
integer *);
static integer jj, nn;
extern doublereal slamch_(char *);
static integer jj1, jj2;
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
static real ulp;
static integer nnp1;
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
SSYT22 generally checks a decomposition of the form
A U = U S
where A is symmetric, the columns of U are orthonormal, and S
is diagonal (if KBAND=0) or symmetric tridiagonal (if
KBAND=1). If ITYPE=1, then U is represented as a dense matrix,
otherwise the U is expressed as a product of Householder
transformations, whose vectors are stored in the array "V" and
whose scaling constants are in "TAU"; we shall use the letter
"V" to refer to the product of Householder transformations
(which should be equal to U).
Specifically, if ITYPE=1, then:
RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and*
RESULT(2) = | I - U'U | / ( m ulp )
Arguments
=========
ITYPE INTEGER
Specifies the type of tests to be performed.
1: U expressed as a dense orthogonal matrix:
RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
RESULT(2) = | I - UU' | / ( n ulp )
UPLO CHARACTER
If UPLO='U', the upper triangle of A will be used and the
(strictly) lower triangle will not be referenced. If
UPLO='L', the lower triangle of A will be used and the
(strictly) upper triangle will not be referenced.
Not modified.
N INTEGER
The size of the matrix. If it is zero, SSYT22 does nothing.
It must be at least zero.
Not modified.
M INTEGER
The number of columns of U. If it is zero, SSYT22 does
nothing. It must be at least zero.
Not modified.
KBAND INTEGER
The bandwidth of the matrix. It may only be zero or one.
If zero, then S is diagonal, and E is not referenced. If
one, then S is symmetric tri-diagonal.
Not modified.
A REAL array, dimension (LDA , N)
The original (unfactored) matrix. It is assumed to be
symmetric, and only the upper (UPLO='U') or only the lower
(UPLO='L') will be referenced.
Not modified.
LDA INTEGER
The leading dimension of A. It must be at least 1
and at least N.
Not modified.
D REAL array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix.
Not modified.
E REAL array, dimension (N)
The off-diagonal of the (symmetric tri-) diagonal matrix.
E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
Not referenced if KBAND=0.
Not modified.
U REAL array, dimension (LDU, N)
If ITYPE=1 or 3, this contains the orthogonal matrix in
the decomposition, expressed as a dense matrix. If ITYPE=2,
then it is not referenced.
Not modified.
LDU INTEGER
The leading dimension of U. LDU must be at least N and
at least 1.
Not modified.
V REAL array, dimension (LDV, N)
If ITYPE=2 or 3, the lower triangle of this array contains
the Householder vectors used to describe the orthogonal
matrix in the decomposition. If ITYPE=1, then it is not
referenced.
Not modified.
LDV INTEGER
The leading dimension of V. LDV must be at least N and
at least 1.
Not modified.
TAU REAL array, dimension (N)
If ITYPE >= 2, then TAU(j) is the scalar factor of
v(j) v(j)' in the Householder transformation H(j) of
the product U = H(1)...H(n-2)
If ITYPE < 2, then TAU is not referenced.
Not modified.
WORK REAL array, dimension (2*N**2)
Workspace.
Modified.
RESULT REAL array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified. RESULT(2) is modified only
if LDU is at least N.
Modified.
=====================================================================
Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--d__;
--e;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
v_dim1 = *ldv;
v_offset = 1 + v_dim1 * 1;
v -= v_offset;
--tau;
--work;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0 || *m <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
/* Do Test 1
Norm of A:
Computing MAX */
r__1 = slansy_("1", uplo, n, &a[a_offset], lda, &work[1]);
anorm = dmax(r__1,unfl);
/* Compute error matrix:
ITYPE=1: error = U' A U - S */
ssymm_("L", uplo, n, m, &c_b6, &a[a_offset], lda, &u[u_offset], ldu, &
c_b7, &work[1], n);
nn = *n * *n;
nnp1 = nn + 1;
sgemm_("T", "N", m, m, n, &c_b6, &u[u_offset], ldu, &work[1], n, &c_b7, &
work[nnp1], n);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
jj = nn + (j - 1) * *n + j;
work[jj] -= d__[j];
/* L10: */
}
if (*kband == 1 && *n > 1) {
i__1 = *m;
for (j = 2; j <= i__1; ++j) {
jj1 = nn + (j - 1) * *n + j - 1;
jj2 = nn + (j - 2) * *n + j;
work[jj1] -= e[j - 1];
work[jj2] -= e[j - 1];
/* L20: */
}
}
wnorm = slansy_("1", uplo, m, &work[nnp1], n, &work[1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*m * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *m * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*m);
result[1] = dmin(r__1,r__2) / (*m * ulp);
}
}
/* Do Test 2
Compute U'U - I */
if (*itype == 1) {
i__1 = (*n << 1) * *n;
sort01_("Columns", n, m, &u[u_offset], ldu, &work[1], &i__1, &result[
2]);
}
return 0;
/* End of SSYT22 */
} /* ssyt22_ */
/* Subroutine */ int slahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, real *h__, integer *ldh, real *wr, real *
wi, integer *iloz, integer *ihiz, real *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3;
real r__1, r__2, r__3, r__4;
/* Local variables */
integer i__, j, k, l, m;
real s, v[3];
integer i1, i2;
real t1, t2, t3, v2, v3, aa, ab, ba, bb, h11, h12, h21, h22, cs;
integer nh;
real sn;
integer nr;
real tr;
integer nz;
real det, h21s;
integer its;
real ulp, sum, tst, rt1i, rt2i, rt1r, rt2r;
real safmin;
real safmax, rtdisc, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SLAHQR is an auxiliary routine called by SHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by SHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper quasi-triangular in */
/* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless */
/* ILO = 1). SLAHQR works primarily with the Hessenberg */
/* submatrix in rows and columns ILO to IHI, but applies */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) REAL array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., H is upper */
/* quasi-triangular in rows and columns ILO:IHI, with any */
/* 2-by-2 diagonal blocks in standard form. If INFO is zero */
/* and WANTT is .FALSE., the contents of H are unspecified on */
/* exit. The output state of H if INFO is nonzero is given */
/* below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* WR (output) REAL array, dimension (N) */
/* WI (output) REAL array, dimension (N) */
/* The real and imaginary parts, respectively, of the computed */
/* eigenvalues ILO to IHI are stored in the corresponding */
/* elements of WR and WI. If two eigenvalues are computed as a */
/* complex conjugate pair, they are stored in consecutive */
/* elements of WR and WI, say the i-th and (i+1)th, with */
/* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with WR(i) = H(i,i), and, if */
/* H(i:i+1,i:i+1) is a 2-by-2 diagonal block, */
/* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) REAL array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by SHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: If INFO = i, SLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of WR and WI */
/* contain those eigenvalues which have been */
/* successfully computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix rows */
/* and columns ILO thorugh INFO of the final, output */
/* value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of SLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--wr;
--wi;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
wr[*ilo] = h__[*ilo + *ilo * h_dim1];
wi[*ilo] = 0.f;
return 0;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
h__[j + 2 + j * h_dim1] = 0.f;
h__[j + 3 + j * h_dim1] = 0.f;
}
if (*ilo <= *ihi - 2) {
h__[*ihi + (*ihi - 2) * h_dim1] = 0.f;
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1 or 2. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L20:
l = *ilo;
if (i__ < *ilo) {
goto L160;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 or 2 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= smlnum) {
goto L40;
}
tst = (r__1 = h__[k - 1 + (k - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[k + k * h_dim1], dabs(r__2));
if (tst == 0.f) {
if (k - 2 >= *ilo) {
tst += (r__1 = h__[k - 1 + (k - 2) * h_dim1], dabs(r__1));
}
if (k + 1 <= *ihi) {
tst += (r__1 = h__[k + 1 + k * h_dim1], dabs(r__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some cases. ==== */
if ((r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)) <= ulp * tst) {
/* Computing MAX */
r__3 = (r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)), r__4 =
(r__2 = h__[k - 1 + k * h_dim1], dabs(r__2));
ab = dmax(r__3,r__4);
/* Computing MIN */
r__3 = (r__1 = h__[k + (k - 1) * h_dim1], dabs(r__1)), r__4 =
(r__2 = h__[k - 1 + k * h_dim1], dabs(r__2));
ba = dmin(r__3,r__4);
/* Computing MAX */
r__3 = (r__1 = h__[k + k * h_dim1], dabs(r__1)), r__4 = (r__2
= h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
dabs(r__2));
aa = dmax(r__3,r__4);
/* Computing MIN */
r__3 = (r__1 = h__[k + k * h_dim1], dabs(r__1)), r__4 = (r__2
= h__[k - 1 + (k - 1) * h_dim1] - h__[k + k * h_dim1],
dabs(r__2));
bb = dmin(r__3,r__4);
s = aa + ab;
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= dmax(r__1,r__2)) {
goto L40;
}
}
}
L40:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
h__[l + (l - 1) * h_dim1] = 0.f;
}
/* Exit from loop if a submatrix of order 1 or 2 has split off. */
if (l >= i__ - 1) {
goto L150;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10) {
/* Exceptional shift. */
s = (r__1 = h__[l + 1 + l * h_dim1], dabs(r__1)) + (r__2 = h__[l
+ 2 + (l + 1) * h_dim1], dabs(r__2));
h11 = s * .75f + h__[l + l * h_dim1];
h12 = s * -.4375f;
h21 = s;
h22 = h11;
} else if (its == 20) {
/* Exceptional shift. */
s = (r__1 = h__[i__ + (i__ - 1) * h_dim1], dabs(r__1)) + (r__2 =
h__[i__ - 1 + (i__ - 2) * h_dim1], dabs(r__2));
h11 = s * .75f + h__[i__ + i__ * h_dim1];
h12 = s * -.4375f;
h21 = s;
h22 = h11;
} else {
/* Prepare to use Francis' double shift */
/* (i.e. 2nd degree generalized Rayleigh quotient) */
h11 = h__[i__ - 1 + (i__ - 1) * h_dim1];
h21 = h__[i__ + (i__ - 1) * h_dim1];
h12 = h__[i__ - 1 + i__ * h_dim1];
h22 = h__[i__ + i__ * h_dim1];
}
s = dabs(h11) + dabs(h12) + dabs(h21) + dabs(h22);
if (s == 0.f) {
rt1r = 0.f;
rt1i = 0.f;
rt2r = 0.f;
rt2i = 0.f;
} else {
h11 /= s;
h21 /= s;
h12 /= s;
h22 /= s;
tr = (h11 + h22) / 2.f;
det = (h11 - tr) * (h22 - tr) - h12 * h21;
rtdisc = sqrt((dabs(det)));
if (det >= 0.f) {
/* ==== complex conjugate shifts ==== */
rt1r = tr * s;
rt2r = rt1r;
rt1i = rtdisc * s;
rt2i = -rt1i;
} else {
/* ==== real shifts (use only one of them) ==== */
rt1r = tr + rtdisc;
rt2r = tr - rtdisc;
if ((r__1 = rt1r - h22, dabs(r__1)) <= (r__2 = rt2r - h22,
dabs(r__2))) {
rt1r *= s;
rt2r = rt1r;
} else {
rt2r *= s;
rt1r = rt2r;
}
rt1i = 0.f;
rt2i = 0.f;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l;
for (m = i__ - 2; m >= i__1; --m) {
/* Determine the effect of starting the double-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. (The following uses scaling to avoid */
/* overflows and most underflows.) */
h21s = h__[m + 1 + m * h_dim1];
s = (r__1 = h__[m + m * h_dim1] - rt2r, dabs(r__1)) + dabs(rt2i)
+ dabs(h21s);
h21s = h__[m + 1 + m * h_dim1] / s;
v[0] = h21s * h__[m + (m + 1) * h_dim1] + (h__[m + m * h_dim1] -
rt1r) * ((h__[m + m * h_dim1] - rt2r) / s) - rt1i * (rt2i
/ s);
v[1] = h21s * (h__[m + m * h_dim1] + h__[m + 1 + (m + 1) * h_dim1]
- rt1r - rt2r);
v[2] = h21s * h__[m + 2 + (m + 1) * h_dim1];
s = dabs(v[0]) + dabs(v[1]) + dabs(v[2]);
v[0] /= s;
v[1] /= s;
v[2] /= s;
if (m == l) {
goto L60;
}
if ((r__1 = h__[m + (m - 1) * h_dim1], dabs(r__1)) * (dabs(v[1])
+ dabs(v[2])) <= ulp * dabs(v[0]) * ((r__2 = h__[m - 1 + (
m - 1) * h_dim1], dabs(r__2)) + (r__3 = h__[m + m *
h_dim1], dabs(r__3)) + (r__4 = h__[m + 1 + (m + 1) *
h_dim1], dabs(r__4)))) {
goto L60;
}
}
L60:
/* Double-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. NR is the order of G. */
/* Computing MIN */
i__2 = 3, i__3 = i__ - k + 1;
nr = min(i__2,i__3);
if (k > m) {
scopy_(&nr, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
slarfg_(&nr, v, &v[1], &c__1, &t1);
if (k > m) {
h__[k + (k - 1) * h_dim1] = v[0];
h__[k + 1 + (k - 1) * h_dim1] = 0.f;
if (k < i__ - 1) {
h__[k + 2 + (k - 1) * h_dim1] = 0.f;
}
} else if (m > l) {
/* ==== Use the following instead of */
/* . H( K, K-1 ) = -H( K, K-1 ) to */
/* . avoid a bug when v(2) and v(3) */
/* . underflow. ==== */
h__[k + (k - 1) * h_dim1] *= 1.f - t1;
}
v2 = v[1];
t2 = t1 * v2;
if (nr == 3) {
v3 = v[2];
t3 = t1 * v3;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1]
+ v3 * h__[k + 2 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
h__[k + 2 + j * h_dim1] -= sum * t3;
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
/* Computing MIN */
i__3 = k + 3;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
+ v3 * h__[j + (k + 2) * h_dim1];
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
h__[j + (k + 2) * h_dim1] -= sum * t3;
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1] + v3 * z__[j + (k + 2) * z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
z__[j + (k + 2) * z_dim1] -= sum * t3;
}
}
} else if (nr == 2) {
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
sum = h__[k + j * h_dim1] + v2 * h__[k + 1 + j * h_dim1];
h__[k + j * h_dim1] -= sum * t1;
h__[k + 1 + j * h_dim1] -= sum * t2;
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+3,I). */
i__2 = i__;
for (j = i1; j <= i__2; ++j) {
sum = h__[j + k * h_dim1] + v2 * h__[j + (k + 1) * h_dim1]
;
h__[j + k * h_dim1] -= sum * t1;
h__[j + (k + 1) * h_dim1] -= sum * t2;
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
sum = z__[j + k * z_dim1] + v2 * z__[j + (k + 1) *
z_dim1];
z__[j + k * z_dim1] -= sum * t1;
z__[j + (k + 1) * z_dim1] -= sum * t2;
}
}
}
}
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L150:
if (l == i__) {
/* H(I,I-1) is negligible: one eigenvalue has converged. */
wr[i__] = h__[i__ + i__ * h_dim1];
wi[i__] = 0.f;
} else if (l == i__ - 1) {
/* H(I-1,I-2) is negligible: a pair of eigenvalues have converged. */
/* Transform the 2-by-2 submatrix to standard Schur form, */
/* and compute and store the eigenvalues. */
slanv2_(&h__[i__ - 1 + (i__ - 1) * h_dim1], &h__[i__ - 1 + i__ *
h_dim1], &h__[i__ + (i__ - 1) * h_dim1], &h__[i__ + i__ *
h_dim1], &wr[i__ - 1], &wi[i__ - 1], &wr[i__], &wi[i__], &cs,
&sn);
if (*wantt) {
/* Apply the transformation to the rest of H. */
if (i2 > i__) {
i__1 = i2 - i__;
srot_(&i__1, &h__[i__ - 1 + (i__ + 1) * h_dim1], ldh, &h__[
i__ + (i__ + 1) * h_dim1], ldh, &cs, &sn);
}
i__1 = i__ - i1 - 1;
srot_(&i__1, &h__[i1 + (i__ - 1) * h_dim1], &c__1, &h__[i1 + i__ *
h_dim1], &c__1, &cs, &sn);
}
if (*wantz) {
/* Apply the transformation to Z. */
srot_(&nz, &z__[*iloz + (i__ - 1) * z_dim1], &c__1, &z__[*iloz +
i__ * z_dim1], &c__1, &cs, &sn);
}
}
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L20;
L160:
return 0;
/* End of SLAHQR */
} /* slahqr_ */
/** Calculate cell grid dimensions, cell sizes and number of cells.
* Calculates the cell grid, based on \ref local_box_l and \ref
* max_range. If the number of cells is larger than \ref
* max_num_cells, it increases max_range until the number of cells is
* smaller or equal \ref max_num_cells. It sets: \ref
* DomainDecomposition::cell_grid, \ref
* DomainDecomposition::ghost_cell_grid, \ref
* DomainDecomposition::cell_size, \ref
* DomainDecomposition::inv_cell_size, and \ref n_cells.
*/
void dd_create_cell_grid()
{
int i,n_local_cells,new_cells,min_ind;
double cell_range[3], min_size, scale, volume;
CELL_TRACE(fprintf(stderr, "%d: dd_create_cell_grid: max_range %f\n",this_node,max_range));
CELL_TRACE(fprintf(stderr, "%d: dd_create_cell_grid: local_box %f-%f, %f-%f, %f-%f,\n",this_node,my_left[0],my_right[0],my_left[1],my_right[1],my_left[2],my_right[2]));
/* initialize */
cell_range[0]=cell_range[1]=cell_range[2] = max_range;
if (max_range < ROUND_ERROR_PREC*box_l[0]) {
/* this is the initialization case */
n_local_cells = dd.cell_grid[0] = dd.cell_grid[1] = dd.cell_grid[2]=1;
}
else {
/* Calculate initial cell grid */
volume = local_box_l[0];
for(i=1;i<3;i++) volume *= local_box_l[i];
scale = pow(max_num_cells/volume, 1./3.);
for(i=0;i<3;i++) {
/* this is at least 1 */
dd.cell_grid[i] = (int)ceil(local_box_l[i]*scale);
cell_range[i] = local_box_l[i]/dd.cell_grid[i];
if ( cell_range[i] < max_range ) {
/* ok, too many cells for this direction, set to minimum */
dd.cell_grid[i] = (int)floor(local_box_l[i]/max_range);
if ( dd.cell_grid[i] < 1 ) {
char *error_msg = runtime_error(ES_INTEGER_SPACE + 2*ES_DOUBLE_SPACE + 128);
ERROR_SPRINTF(error_msg, "{002 interaction range %g in direction %d is larger than the local box size %g} ",
max_range, i, local_box_l[i]);
dd.cell_grid[i] = 1;
}
cell_range[i] = local_box_l[i]/dd.cell_grid[i];
}
}
/* It may be necessary to asymmetrically assign the scaling to the coordinates, which the above approach will not do.
For a symmetric box, it gives a symmetric result. Here we correct that. */
for (;;) {
n_local_cells = dd.cell_grid[0];
for (i = 1; i < 3; i++)
n_local_cells *= dd.cell_grid[i];
/* done */
if (n_local_cells <= max_num_cells)
break;
/* find coordinate with the smallest cell range */
min_ind = 0;
min_size = cell_range[0];
for (i = 1; i < 3; i++)
if (dd.cell_grid[i] > 1 && cell_range[i] < min_size) {
min_ind = i;
min_size = cell_range[i];
}
CELL_TRACE(fprintf(stderr, "%d: minimal coordinate %d, size %f, grid %d\n", this_node,min_ind, min_size, dd.cell_grid[min_ind]));
dd.cell_grid[min_ind]--;
cell_range[min_ind] = local_box_l[min_ind]/dd.cell_grid[min_ind];
}
CELL_TRACE(fprintf(stderr, "%d: final %d %d %d\n", this_node, dd.cell_grid[0], dd.cell_grid[1], dd.cell_grid[2]));
/* sanity check */
if (n_local_cells < min_num_cells) {
char *error_msg = runtime_error(ES_INTEGER_SPACE + 2*ES_DOUBLE_SPACE + 128);
ERROR_SPRINTF(error_msg, "{001 number of cells %d is smaller than minimum %d (interaction range too large or min_num_cells too large)} ",
n_local_cells, min_num_cells);
}
}
/* quit program if unsuccesful */
if(n_local_cells > max_num_cells) {
char *error_msg = runtime_error(128);
ERROR_SPRINTF(error_msg, "{003 no suitable cell grid found} ");
}
/* now set all dependent variables */
new_cells=1;
for(i=0;i<3;i++) {
dd.ghost_cell_grid[i] = dd.cell_grid[i]+2;
new_cells *= dd.ghost_cell_grid[i];
dd.cell_size[i] = local_box_l[i]/(double)dd.cell_grid[i];
dd.inv_cell_size[i] = 1.0 / dd.cell_size[i];
}
max_skin = dmin(dmin(dd.cell_size[0],dd.cell_size[1]),dd.cell_size[2]) - max_cut;
/* allocate cell array and cell pointer arrays */
realloc_cells(new_cells);
realloc_cellplist(&local_cells, local_cells.n = n_local_cells);
realloc_cellplist(&ghost_cells, ghost_cells.n = new_cells-n_local_cells);
CELL_TRACE(fprintf(stderr, "%d: dd_create_cell_grid, n_cells=%d, local_cells.n=%d, ghost_cells.n=%d, dd.ghost_cell_grid=(%d,%d,%d)\n", this_node, n_cells,local_cells.n,ghost_cells.n,dd.ghost_cell_grid[0],dd.ghost_cell_grid[1],dd.ghost_cell_grid[2]));
}
/* Subroutine */ int slasq4_(integer *i0, integer *n0, real *z__, integer *pp,
integer *n0in, real *dmin__, real *dmin1, real *dmin2, real *dn,
real *dn1, real *dn2, real *tau, integer *ttype, real *g)
{
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Local variables */
real s, a2, b1, b2;
integer i4, nn, np;
real gam, gap1, gap2;
/* -- LAPACK routine (version 3.2) -- */
/* -- Contributed by Osni Marques of the Lawrence Berkeley National -- */
/* -- Laboratory and Beresford Parlett of the Univ. of California at -- */
/* -- Berkeley -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* Purpose */
/* ======= */
/* SLASQ4 computes an approximation TAU to the smallest eigenvalue */
/* using values of d from the previous transform. */
/* I0 (input) INTEGER */
/* First index. */
/* N0 (input) INTEGER */
/* Last index. */
/* Z (input) REAL array, dimension ( 4*N ) */
/* Z holds the qd array. */
/* PP (input) INTEGER */
/* PP=0 for ping, PP=1 for pong. */
/* NOIN (input) INTEGER */
/* The value of N0 at start of EIGTEST. */
/* DMIN (input) REAL */
/* Minimum value of d. */
/* DMIN1 (input) REAL */
/* Minimum value of d, excluding D( N0 ). */
/* DMIN2 (input) REAL */
/* Minimum value of d, excluding D( N0 ) and D( N0-1 ). */
/* DN (input) REAL */
/* d(N) */
/* DN1 (input) REAL */
/* d(N-1) */
/* DN2 (input) REAL */
/* d(N-2) */
/* TAU (output) REAL */
/* This is the shift. */
/* TTYPE (output) INTEGER */
/* Shift type. */
/* G (input/output) REAL */
/* G is passed as an argument in order to save its value between */
/* calls to SLASQ4. */
/* Further Details */
/* =============== */
/* CNST1 = 9/16 */
/* ===================================================================== */
/* A negative DMIN forces the shift to take that absolute value */
/* TTYPE records the type of shift. */
/* Parameter adjustments */
--z__;
/* Function Body */
if (*dmin__ <= 0.f) {
*tau = -(*dmin__);
*ttype = -1;
return 0;
}
nn = (*n0 << 2) + *pp;
if (*n0in == *n0) {
/* No eigenvalues deflated. */
if (*dmin__ == *dn || *dmin__ == *dn1) {
b1 = sqrt(z__[nn - 3]) * sqrt(z__[nn - 5]);
b2 = sqrt(z__[nn - 7]) * sqrt(z__[nn - 9]);
a2 = z__[nn - 7] + z__[nn - 5];
/* Cases 2 and 3. */
if (*dmin__ == *dn && *dmin1 == *dn1) {
gap2 = *dmin2 - a2 - *dmin2 * .25f;
if (gap2 > 0.f && gap2 > b2) {
gap1 = a2 - *dn - b2 / gap2 * b2;
} else {
gap1 = a2 - *dn - (b1 + b2);
}
if (gap1 > 0.f && gap1 > b1) {
/* Computing MAX */
r__1 = *dn - b1 / gap1 * b1, r__2 = *dmin__ * .5f;
s = dmax(r__1,r__2);
*ttype = -2;
} else {
s = 0.f;
if (*dn > b1) {
s = *dn - b1;
}
if (a2 > b1 + b2) {
/* Computing MIN */
r__1 = s, r__2 = a2 - (b1 + b2);
s = dmin(r__1,r__2);
}
/* Computing MAX */
r__1 = s, r__2 = *dmin__ * .333f;
s = dmax(r__1,r__2);
*ttype = -3;
}
} else {
/* Case 4. */
*ttype = -4;
s = *dmin__ * .25f;
if (*dmin__ == *dn) {
gam = *dn;
a2 = 0.f;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b2 = z__[nn - 5] / z__[nn - 7];
np = nn - 9;
} else {
np = nn - (*pp << 1);
b2 = z__[np - 2];
gam = *dn1;
if (z__[np - 4] > z__[np - 2]) {
return 0;
}
a2 = z__[np - 4] / z__[np - 2];
if (z__[nn - 9] > z__[nn - 11]) {
return 0;
}
b2 = z__[nn - 9] / z__[nn - 11];
np = nn - 13;
}
/* Approximate contribution to norm squared from I < NN-1. */
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = np; i4 >= i__1; i4 += -4) {
if (b2 == 0.f) {
goto L20;
}
b1 = b2;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
goto L20;
}
}
L20:
a2 *= 1.05f;
/* Rayleigh quotient residual bound. */
if (a2 < .563f) {
s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
}
}
} else if (*dmin__ == *dn2) {
/* Case 5. */
*ttype = -5;
s = *dmin__ * .25f;
/* Compute contribution to norm squared from I > NN-2. */
np = nn - (*pp << 1);
b1 = z__[np - 2];
b2 = z__[np - 6];
gam = *dn2;
if (z__[np - 8] > b2 || z__[np - 4] > b1) {
return 0;
}
a2 = z__[np - 8] / b2 * (z__[np - 4] / b1 + 1.f);
/* Approximate contribution to norm squared from I < NN-2. */
if (*n0 - *i0 > 2) {
b2 = z__[nn - 13] / z__[nn - 15];
a2 += b2;
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = nn - 17; i4 >= i__1; i4 += -4) {
if (b2 == 0.f) {
goto L40;
}
b1 = b2;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b2 *= z__[i4] / z__[i4 - 2];
a2 += b2;
if (dmax(b2,b1) * 100.f < a2 || .563f < a2) {
goto L40;
}
}
L40:
a2 *= 1.05f;
}
if (a2 < .563f) {
s = gam * (1.f - sqrt(a2)) / (a2 + 1.f);
}
} else {
/* Case 6, no information to guide us. */
if (*ttype == -6) {
*g += (1.f - *g) * .333f;
} else if (*ttype == -18) {
*g = .083250000000000005f;
} else {
*g = .25f;
}
s = *g * *dmin__;
*ttype = -6;
}
} else if (*n0in == *n0 + 1) {
/* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN. */
if (*dmin1 == *dn1 && *dmin2 == *dn2) {
/* Cases 7 and 8. */
*ttype = -7;
s = *dmin1 * .333f;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1;
if (b2 == 0.f) {
goto L60;
}
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
a2 = b1;
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (dmax(b1,a2) * 100.f < b2) {
goto L60;
}
}
L60:
b2 = sqrt(b2 * 1.05f);
/* Computing 2nd power */
r__1 = b2;
a2 = *dmin1 / (r__1 * r__1 + 1.f);
gap2 = *dmin2 * .5f - a2;
if (gap2 > 0.f && gap2 > b2 * a2) {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
s = dmax(r__1,r__2);
} else {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
s = dmax(r__1,r__2);
*ttype = -8;
}
} else {
/* Case 9. */
s = *dmin1 * .25f;
if (*dmin1 == *dn1) {
s = *dmin1 * .5f;
}
*ttype = -9;
}
} else if (*n0in == *n0 + 2) {
/* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN. */
/* Cases 10 and 11. */
if (*dmin2 == *dn2 && z__[nn - 5] * 2.f < z__[nn - 7]) {
*ttype = -10;
s = *dmin2 * .333f;
if (z__[nn - 5] > z__[nn - 7]) {
return 0;
}
b1 = z__[nn - 5] / z__[nn - 7];
b2 = b1;
if (b2 == 0.f) {
goto L80;
}
i__1 = (*i0 << 2) - 1 + *pp;
for (i4 = (*n0 << 2) - 9 + *pp; i4 >= i__1; i4 += -4) {
if (z__[i4] > z__[i4 - 2]) {
return 0;
}
b1 *= z__[i4] / z__[i4 - 2];
b2 += b1;
if (b1 * 100.f < b2) {
goto L80;
}
}
L80:
b2 = sqrt(b2 * 1.05f);
/* Computing 2nd power */
r__1 = b2;
a2 = *dmin2 / (r__1 * r__1 + 1.f);
gap2 = z__[nn - 7] + z__[nn - 9] - sqrt(z__[nn - 11]) * sqrt(z__[
nn - 9]) - a2;
if (gap2 > 0.f && gap2 > b2 * a2) {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - a2 * 1.01f * (b2 / gap2) * b2);
s = dmax(r__1,r__2);
} else {
/* Computing MAX */
r__1 = s, r__2 = a2 * (1.f - b2 * 1.01f);
s = dmax(r__1,r__2);
}
} else {
s = *dmin2 * .25f;
*ttype = -11;
}
} else if (*n0in > *n0 + 2) {
/* Case 12, more than two eigenvalues deflated. No information. */
s = 0.f;
*ttype = -12;
}
*tau = s;
return 0;
/* End of SLASQ4 */
} /* slasq4_ */
/* Subroutine */ int cbdt02_(integer *m, integer *n, complex *b, integer *ldb,
complex *c__, integer *ldc, complex *u, integer *ldu, complex *work,
real *rwork, real *resid)
{
/* System generated locals */
integer b_dim1, b_offset, c_dim1, c_offset, u_dim1, u_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real eps;
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
real bnorm;
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *);
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *);
real realmn;
extern doublereal scasum_(integer *, complex *, integer *);
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CBDT02 tests the change of basis C = U' * B by computing the residual */
/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
/* where B and C are M by N matrices, U is an M by M orthogonal matrix, */
/* and EPS is the machine precision. */
/* Arguments */
/* ========= */
/* M (input) INTEGER */
/* The number of rows of the matrices B and C and the order of */
/* the matrix Q. */
/* N (input) INTEGER */
/* The number of columns of the matrices B and C. */
/* B (input) COMPLEX array, dimension (LDB,N) */
/* The m by n matrix B. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,M). */
/* C (input) COMPLEX array, dimension (LDC,N) */
/* The m by n matrix C, assumed to contain U' * B. */
/* LDC (input) INTEGER */
/* The leading dimension of the array C. LDC >= max(1,M). */
/* U (input) COMPLEX array, dimension (LDU,M) */
/* The m by m orthogonal matrix U. */
/* LDU (input) INTEGER */
/* The leading dimension of the array U. LDU >= max(1,M). */
/* WORK (workspace) COMPLEX array, dimension (M) */
/* RWORK (workspace) REAL array, dimension (M) */
/* RESID (output) REAL */
/* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ), */
/* ====================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick return if possible */
/* Parameter adjustments */
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
/* Function Body */
*resid = 0.f;
if (*m <= 0 || *n <= 0) {
return 0;
}
realmn = (real) max(*m,*n);
eps = slamch_("Precision");
/* Compute norm( B - U * C ) */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
ccopy_(m, &b[j * b_dim1 + 1], &c__1, &work[1], &c__1);
cgemv_("No transpose", m, m, &c_b7, &u[u_offset], ldu, &c__[j *
c_dim1 + 1], &c__1, &c_b10, &work[1], &c__1);
/* Computing MAX */
r__1 = *resid, r__2 = scasum_(m, &work[1], &c__1);
*resid = dmax(r__1,r__2);
/* L10: */
}
/* Compute norm of B. */
bnorm = clange_("1", m, n, &b[b_offset], ldb, &rwork[1]);
if (bnorm <= 0.f) {
if (*resid != 0.f) {
*resid = 1.f / eps;
}
} else {
if (bnorm >= *resid) {
*resid = *resid / bnorm / (realmn * eps);
} else {
if (bnorm < 1.f) {
/* Computing MIN */
r__1 = *resid, r__2 = realmn * bnorm;
*resid = dmin(r__1,r__2) / bnorm / (realmn * eps);
} else {
/* Computing MIN */
r__1 = *resid / bnorm;
*resid = dmin(r__1,realmn) / (realmn * eps);
}
}
}
return 0;
/* End of CBDT02 */
} /* cbdt02_ */
/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl,
real *vu, integer *il, integer *iu, real *abstol, real *d__, real *e,
integer *m, integer *nsplit, real *w, integer *iblock, integer *
isplit, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
integer j, ib, jb, ie, je, nb;
real gl;
integer im, in;
real gu;
integer iw;
real wl, wu;
integer nwl;
real ulp, wlu, wul;
integer nwu;
real tmp1, tmp2;
integer iend, ioff, iout, itmp1, jdisc;
extern logical lsame_(char *, char *);
integer iinfo;
real atoli;
integer iwoff;
real bnorm;
integer itmax;
real wkill, rtoli, tnorm;
integer ibegin, irange, idiscl;
extern doublereal slamch_(char *);
real safemn;
integer idumma[1];
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer idiscu;
extern /* Subroutine */ int slaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
real *, real *, integer *, real *, real *, integer *, integer *,
real *, integer *, integer *);
integer iorder;
logical ncnvrg;
real pivmin;
logical toofew;
/* -- LAPACK routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* 8-18-00: Increase FUDGE factor for T3E (eca) */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSTEBZ computes the eigenvalues of a symmetric tridiagonal */
/* matrix T. The user may ask for all eigenvalues, all eigenvalues */
/* in the half-open interval (VL, VU], or the IL-th through IU-th */
/* eigenvalues. */
/* To avoid overflow, the matrix must be scaled so that its */
/* largest element is no greater than overflow**(1/2) * */
/* underflow**(1/4) in absolute value, and for greatest */
/* accuracy, it should not be much smaller than that. */
/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
/* Matrix", Report CS41, Computer Science Dept., Stanford */
/* University, July 21, 1966. */
/* Arguments */
/* ========= */
/* RANGE (input) CHARACTER*1 */
/* = 'A': ("All") all eigenvalues will be found. */
/* = 'V': ("Value") all eigenvalues in the half-open interval */
/* (VL, VU] will be found. */
/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
/* entire matrix) will be found. */
/* ORDER (input) CHARACTER*1 */
/* = 'B': ("By Block") the eigenvalues will be grouped by */
/* split-off block (see IBLOCK, ISPLIT) and */
/* ordered from smallest to largest within */
/* the block. */
/* = 'E': ("Entire matrix") */
/* the eigenvalues for the entire matrix */
/* will be ordered from smallest to */
/* largest. */
/* N (input) INTEGER */
/* The order of the tridiagonal matrix T. N >= 0. */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. Eigenvalues less than or equal */
/* to VL, or greater than VU, will not be returned. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute tolerance for the eigenvalues. An eigenvalue */
/* (or cluster) is considered to be located if it has been */
/* determined to lie in an interval whose width is ABSTOL or */
/* less. If ABSTOL is less than or equal to zero, then ULP*|T| */
/* will be used, where |T| means the 1-norm of T. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix T. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */
/* M (output) INTEGER */
/* The actual number of eigenvalues found. 0 <= M <= N. */
/* (See also the description of INFO=2,3.) */
/* NSPLIT (output) INTEGER */
/* The number of diagonal blocks in the matrix T. */
/* 1 <= NSPLIT <= N. */
/* W (output) REAL array, dimension (N) */
/* On exit, the first M elements of W will contain the */
/* eigenvalues. (SSTEBZ may use the remaining N-M elements as */
/* workspace.) */
/* IBLOCK (output) INTEGER array, dimension (N) */
/* At each row/column j where E(j) is zero or small, the */
/* matrix T is considered to split into a block diagonal */
/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */
/* block (from 1 to the number of blocks) the eigenvalue W(i) */
/* belongs. (SSTEBZ may use the remaining N-M elements as */
/* workspace.) */
/* ISPLIT (output) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into submatrices. */
/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */
/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
/* etc., and the NSPLIT-th consists of rows/columns */
/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
/* (Only the first NSPLIT elements will actually be used, but */
/* since the user cannot know a priori what value NSPLIT will */
/* have, N words must be reserved for ISPLIT.) */
/* WORK (workspace) REAL array, dimension (4*N) */
/* IWORK (workspace) INTEGER array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: some or all of the eigenvalues failed to converge or */
/* were not computed: */
/* =1 or 3: Bisection failed to converge for some */
/* eigenvalues; these eigenvalues are flagged by a */
/* negative block number. The effect is that the */
/* eigenvalues may not be as accurate as the */
/* absolute and relative tolerances. This is */
/* generally caused by unexpectedly inaccurate */
/* arithmetic. */
/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */
/* IL:IU were found. */
/* Effect: M < IU+1-IL */
/* Cause: non-monotonic arithmetic, causing the */
/* Sturm sequence to be non-monotonic. */
/* Cure: recalculate, using RANGE='A', and pick */
/* out eigenvalues IL:IU. In some cases, */
/* increasing the PARAMETER "FUDGE" may */
/* make things work. */
/* = 4: RANGE='I', and the Gershgorin interval */
/* initially used was too small. No eigenvalues */
/* were computed. */
/* Probable cause: your machine has sloppy */
/* floating-point arithmetic. */
/* Cure: Increase the PARAMETER "FUDGE", */
/* recompile, and try again. */
/* Internal Parameters */
/* =================== */
/* RELFAC REAL, default = 2.0e0 */
/* The relative tolerance. An interval (a,b] lies within */
/* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|), */
/* where "ulp" is the machine precision (distance from 1 to */
/* the next larger floating point number.) */
/* FUDGE REAL, default = 2 */
/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */
/* a value of 1 should work, but on machines with sloppy */
/* arithmetic, this needs to be larger. The default for */
/* publicly released versions should be large enough to handle */
/* the worst machine around. Note that this has no effect */
/* on accuracy of the solution. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iwork;
--work;
--isplit;
--iblock;
--w;
--e;
--d__;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (lsame_(range, "A")) {
irange = 1;
} else if (lsame_(range, "V")) {
irange = 2;
} else if (lsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (lsame_(order, "B")) {
iorder = 2;
} else if (lsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2) {
if (*vl >= *vu) {
*info = -5;
}
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEBZ", &i__1);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants */
/* NB is the minimum vector length for vector bisection, or 0 */
/* if only scalar is to be done. */
safemn = slamch_("S");
ulp = slamch_("P");
rtoli = ulp * 2.f;
nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
isplit[1] = 1;
if (irange == 2 && (*vl >= d__[1] || *vu < d__[1])) {
*m = 0;
} else {
w[1] = d__[1];
iblock[1] = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
work[*n] = 0.f;
pivmin = 1.f;
/* DIR$ NOVECTOR */
i__1 = *n;
for (j = 2; j <= i__1; ++j) {
/* Computing 2nd power */
r__1 = e[j - 1];
tmp1 = r__1 * r__1;
/* Computing 2nd power */
r__2 = ulp;
if ((r__1 = d__[j] * d__[j - 1], dabs(r__1)) * (r__2 * r__2) + safemn
> tmp1) {
isplit[*nsplit] = j - 1;
++(*nsplit);
work[j - 1] = 0.f;
} else {
work[j - 1] = tmp1;
pivmin = dmax(pivmin,tmp1);
}
/* L10: */
}
isplit[*nsplit] = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues */
/* IL through IU. */
/* Compute Gershgorin interval for entire (split) matrix */
/* and use it as the initial interval */
gu = d__[1];
gl = d__[1];
tmp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
tmp2 = sqrt(work[j]);
/* Computing MAX */
r__1 = gu, r__2 = d__[j] + tmp1 + tmp2;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = d__[j] - tmp1 - tmp2;
gl = dmin(r__1,r__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
r__1 = gu, r__2 = d__[*n] + tmp1;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = d__[*n] - tmp1;
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
tnorm = dmax(r__1,r__2);
gl = gl - tnorm * 2.1f * ulp * *n - pivmin * 4.2000000000000002f;
gu = gu + tnorm * 2.1f * ulp * *n + pivmin * 2.1f;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.f)) +
2;
if (*abstol <= 0.f) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
work[*n + 1] = gl;
work[*n + 2] = gl;
work[*n + 3] = gu;
work[*n + 4] = gu;
work[*n + 5] = gl;
work[*n + 6] = gu;
iwork[1] = -1;
iwork[2] = -1;
iwork[3] = *n + 1;
iwork[4] = *n + 1;
iwork[5] = *il - 1;
iwork[6] = *iu;
slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&d__[1], &e[1], &work[1], &iwork[5], &work[*n + 1], &work[*n
+ 5], &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
if (iwork[6] == *iu) {
wl = work[*n + 1];
wlu = work[*n + 3];
nwl = iwork[1];
wu = work[*n + 4];
wul = work[*n + 2];
nwu = iwork[4];
} else {
wl = work[*n + 2];
wlu = work[*n + 4];
nwl = iwork[2];
wu = work[*n + 3];
wul = work[*n + 1];
nwu = iwork[3];
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI */
/* Computing MAX */
r__3 = dabs(d__[1]) + dabs(e[1]), r__4 = (r__1 = d__[*n], dabs(r__1))
+ (r__2 = e[*n - 1], dabs(r__2));
tnorm = dmax(r__3,r__4);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
r__4 = tnorm, r__5 = (r__1 = d__[j], dabs(r__1)) + (r__2 = e[j -
1], dabs(r__2)) + (r__3 = e[j], dabs(r__3));
tnorm = dmax(r__4,r__5);
/* L30: */
}
if (*abstol <= 0.f) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
} else {
wl = 0.f;
wu = 0.f;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU. */
/* NWL accumulates the number of eigenvalues .le. WL, */
/* NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= i__1; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = isplit[jb];
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= d__[ibegin] - pivmin) {
++nwl;
}
if (irange == 1 || wu >= d__[ibegin] - pivmin) {
++nwu;
}
if (irange == 1 || wl < d__[ibegin] - pivmin && wu >= d__[ibegin]
- pivmin) {
++(*m);
w[*m] = d__[ibegin];
iblock[*m] = jb;
}
} else {
/* General Case -- IN > 1 */
/* Compute Gershgorin Interval */
/* and use it as the initial interval */
gu = d__[ibegin];
gl = d__[ibegin];
tmp1 = 0.f;
i__2 = iend - 1;
for (j = ibegin; j <= i__2; ++j) {
tmp2 = (r__1 = e[j], dabs(r__1));
/* Computing MAX */
r__1 = gu, r__2 = d__[j] + tmp1 + tmp2;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = d__[j] - tmp1 - tmp2;
gl = dmin(r__1,r__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
r__1 = gu, r__2 = d__[iend] + tmp1;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = d__[iend] - tmp1;
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
bnorm = dmax(r__1,r__2);
gl = gl - bnorm * 2.1f * ulp * in - pivmin * 2.1f;
gu = gu + bnorm * 2.1f * ulp * in + pivmin * 2.1f;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.f) {
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
atoli = ulp * dmax(r__1,r__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = dmax(gl,wl);
gu = dmin(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
work[*n + 1] = gl;
work[*n + in + 1] = gu;
slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
w[*m + 1], &iblock[*m + 1], &iinfo);
nwl += iwork[1];
nwu += iwork[in + 1];
iwoff = *m - iwork[1];
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(
2.f)) + 2;
slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &d__[ibegin], &e[ibegin], &work[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
&w[*m + 1], &iblock[*m + 1], &iinfo);
/* Copy Eigenvalues Into W and IBLOCK */
/* Use -JB for block number for unconverged eigenvalues. */
i__2 = iout;
for (j = 1; j <= i__2; ++j) {
tmp1 = (work[j + *n] + work[j + in + *n]) * .5f;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = iwork[j + in] + iwoff;
for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
w[je] = tmp1;
iblock[je] = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (w[je] <= wlu && idiscl > 0) {
--idiscl;
} else if (w[je] >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic: */
/* Some low eigenvalues to be discarded are not in (WL,WLU], */
/* or high eigenvalues to be discarded are not in (WUL,WU] */
/* so just kill off the smallest IDISCL/largest IDISCU */
/* eigenvalues, by simply finding the smallest/largest */
/* eigenvalue(s). */
/* (If N(w) is monotone non-decreasing, this should never */
/* happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L90: */
}
iblock[iw] = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] > wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L110: */
}
iblock[iw] = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (iblock[je] != 0) {
++im;
w[im] = w[je];
iblock[im] = iblock[je];
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted */
/* by block. */
/* If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= i__1; ++je) {
ie = 0;
tmp1 = w[je];
i__2 = *m;
for (j = je + 1; j <= i__2; ++j) {
if (w[j] < tmp1) {
ie = j;
tmp1 = w[j];
}
/* L140: */
}
if (ie != 0) {
itmp1 = iblock[ie];
w[ie] = w[je];
iblock[ie] = iblock[je];
w[je] = tmp1;
iblock[je] = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of SSTEBZ */
} /* sstebz_ */
/* Subroutine */ int cpoequ_(integer *n, complex *a, integer *lda, real *s,
real *scond, real *amax, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
CPOEQU computes row and column scalings intended to equilibrate a
Hermitian positive definite matrix A and reduce its condition number
(with respect to the two-norm). S contains the scale factors,
S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
choice of S puts the condition number of B within a factor N of the
smallest possible condition number over all possible diagonal
scalings.
Arguments
=========
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input) COMPLEX array, dimension (LDA,N)
The N-by-N Hermitian positive definite matrix whose scaling
factors are to be computed. Only the diagonal elements of A
are referenced.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
S (output) REAL array, dimension (N)
If INFO = 0, S contains the scale factors for A.
SCOND (output) REAL
If INFO = 0, S contains the ratio of the smallest S(i) to
the largest S(i). If SCOND >= 0.1 and AMAX is neither too
large nor too small, it is not worth scaling by S.
AMAX (output) REAL
Absolute value of largest matrix element. If AMAX is very
close to overflow or very close to underflow, the matrix
should be scaled.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, the i-th diagonal element is nonpositive.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real smin;
static integer i__;
extern /* Subroutine */ int xerbla_(char *, integer *);
#define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1
#define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--s;
/* Function Body */
*info = 0;
if (*n < 0) {
*info = -1;
} else if (*lda < max(1,*n)) {
*info = -3;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CPOEQU", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
*scond = 1.f;
*amax = 0.f;
return 0;
}
/* Find the minimum and maximum diagonal elements. */
i__1 = a_subscr(1, 1);
s[1] = a[i__1].r;
smin = s[1];
*amax = s[1];
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__) {
i__2 = a_subscr(i__, i__);
s[i__] = a[i__2].r;
/* Computing MIN */
r__1 = smin, r__2 = s[i__];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = *amax, r__2 = s[i__];
*amax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
/* Find the first non-positive diagonal element and return. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s[i__] <= 0.f) {
*info = i__;
return 0;
}
/* L20: */
}
} else {
/* Set the scale factors to the reciprocals
of the diagonal elements. */
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
s[i__] = 1.f / sqrt(s[i__]);
/* L30: */
}
/* Compute SCOND = min(S(I)) / max(S(I)) */
*scond = sqrt(smin) / sqrt(*amax);
}
return 0;
/* End of CPOEQU */
} /* cpoequ_ */
/*! This function is the 'core' of the SPH force computation. A target
* particle is specified which may either be local, or reside in the
* communication buffer.
*/
void hydro_evaluate(int target, int mode)
{
int j, k, n, timestep, startnode, numngb;
FLOAT *pos, *vel;
FLOAT mass, h_i, dhsmlDensityFactor, rho, pressure, f1, f2;
#ifdef MORRIS97VISC
FLOAT alpha_visc, alpha_visc_j;
#endif
double acc[3], dtEntropy, maxSignalVel;
double dx, dy, dz, dvx, dvy, dvz;
double h_i2, hinv, hinv4;
double p_over_rho2_i, p_over_rho2_j, soundspeed_i, soundspeed_j;
#ifdef MONAGHAN83VISC
double soundspeed_ij, h_ij;
#endif
double hfc, dwk_i, vdotr, vdotr2, visc, mu_ij, rho_ij, vsig;
double h_j, dwk_j, r, r2, u, hfc_visc;
#ifndef NOVISCOSITYLIMITER
double dt;
#endif
if(mode == 0)
{
pos = P[target].Pos;
vel = SphP[target].VelPred;
h_i = SphP[target].Hsml;
mass = P[target].Mass;
dhsmlDensityFactor = SphP[target].DhsmlDensityFactor;
rho = SphP[target].Density;
pressure = SphP[target].Pressure;
timestep = P[target].Ti_endstep - P[target].Ti_begstep;
soundspeed_i = sqrt(GAMMA * pressure / rho);
#ifdef MORRIS97VISC
alpha_visc = SphP[target].Alpha;
#else
f1 = fabs(SphP[target].DivVel) /
(fabs(SphP[target].DivVel) + SphP[target].CurlVel +
0.0001 * soundspeed_i / SphP[target].Hsml / fac_mu);
#endif
}
else
{
pos = HydroDataGet[target].Pos;
vel = HydroDataGet[target].Vel;
h_i = HydroDataGet[target].Hsml;
mass = HydroDataGet[target].Mass;
dhsmlDensityFactor = HydroDataGet[target].DhsmlDensityFactor;
rho = HydroDataGet[target].Density;
pressure = HydroDataGet[target].Pressure;
timestep = HydroDataGet[target].Timestep;
soundspeed_i = sqrt(GAMMA * pressure / rho);
f1 = HydroDataGet[target].F1;
#ifdef MORRIS97VISC
alpha_visc = HydroDataGet[target].Alpha;
#endif
}
/* initialize variables before SPH loop is started */
acc[0] = acc[1] = acc[2] = dtEntropy = 0;
maxSignalVel = 0;
p_over_rho2_i = pressure / (rho * rho) * dhsmlDensityFactor;
h_i2 = h_i * h_i;
/* Now start the actual SPH computation for this particle */
startnode = All.MaxPart;
do
{
numngb = ngb_treefind_pairs(&pos[0], h_i, &startnode);
for(n = 0; n < numngb; n++)
{
j = Ngblist[n];
dx = pos[0] - P[j].Pos[0];
dy = pos[1] - P[j].Pos[1];
dz = pos[2] - P[j].Pos[2];
#ifdef MORRIS97VISC
alpha_visc_j = SphP[j].Alpha;
#endif
#ifdef PERIODIC /* find the closest image in the given box size */
if(dx > boxHalf_X)
dx -= boxSize_X;
if(dx < -boxHalf_X)
dx += boxSize_X;
if(dy > boxHalf_Y)
dy -= boxSize_Y;
if(dy < -boxHalf_Y)
dy += boxSize_Y;
if(dz > boxHalf_Z)
dz -= boxSize_Z;
if(dz < -boxHalf_Z)
dz += boxSize_Z;
#endif
r2 = dx * dx + dy * dy + dz * dz;
h_j = SphP[j].Hsml;
if(r2 < h_i2 || r2 < h_j * h_j)
{
r = sqrt(r2);
if(r > 0)
{
p_over_rho2_j = SphP[j].Pressure / (SphP[j].Density * SphP[j].Density);
soundspeed_j = sqrt(GAMMA * p_over_rho2_j * SphP[j].Density);
dvx = vel[0] - SphP[j].VelPred[0];
dvy = vel[1] - SphP[j].VelPred[1];
dvz = vel[2] - SphP[j].VelPred[2];
vdotr = dx * dvx + dy * dvy + dz * dvz;
if(All.ComovingIntegrationOn)
vdotr2 = vdotr + hubble_a2 * r2;
else
vdotr2 = vdotr;
if(r2 < h_i2)
{
hinv = 1.0 / h_i;
#ifndef TWODIMS
hinv4 = hinv * hinv * hinv * hinv;
#else
hinv4 = hinv * hinv * hinv / boxSize_Z;
#endif
u = r * hinv;
if(u < 0.5)
dwk_i = hinv4 * u * (KERNEL_COEFF_3 * u - KERNEL_COEFF_4);
else
dwk_i = hinv4 * KERNEL_COEFF_6 * (1.0 - u) * (1.0 - u);
}
else
{
dwk_i = 0;
}
if(r2 < h_j * h_j)
{
hinv = 1.0 / h_j;
#ifndef TWODIMS
hinv4 = hinv * hinv * hinv * hinv;
#else
hinv4 = hinv * hinv * hinv / boxSize_Z;
#endif
u = r * hinv;
if(u < 0.5)
dwk_j = hinv4 * u * (KERNEL_COEFF_3 * u - KERNEL_COEFF_4);
else
dwk_j = hinv4 * KERNEL_COEFF_6 * (1.0 - u) * (1.0 - u);
}
else
{
dwk_j = 0;
}
if(soundspeed_i + soundspeed_j > maxSignalVel)
maxSignalVel = soundspeed_i + soundspeed_j;
if(vdotr2 < 0) /* ... artificial viscosity */
{
#ifndef MONAGHAN83VISC
mu_ij = fac_mu * vdotr2 / r; /* note: this is negative! */
#else
h_ij = 0.5 * (h_i + h_j);
mu_ij = fac_mu * h_ij * vdotr2 / (r2 + 0.0001 * h_ij * h_ij);
#endif
vsig = soundspeed_i + soundspeed_j - 3 * mu_ij;
if(vsig > maxSignalVel)
maxSignalVel = vsig;
rho_ij = 0.5 * (rho + SphP[j].Density);
#ifdef MORRIS97VISC
visc = 0.25 * (alpha_visc + alpha_visc_j) * vsig * (-mu_ij) / rho_ij;
#else
f2 =
fabs(SphP[j].DivVel) / (fabs(SphP[j].DivVel) + SphP[j].CurlVel +
0.0001 * soundspeed_j / fac_mu / SphP[j].Hsml);
#ifndef MONAGHAN83VISC
visc = 0.25 * All.ArtBulkViscConst * vsig * (-mu_ij) / rho_ij * (f1 + f2);
#else
soundspeed_ij = (soundspeed_i+soundspeed_j) * 0.5;
visc = ((-All.ArtBulkViscConst) * soundspeed_ij * mu_ij + All.ArtBulkViscBeta * mu_ij * mu_ij) / rho_ij;
#endif //MONAGHAN83VISC
#endif //MORRIS97VISC
/* .... end artificial viscosity evaluation */
#ifndef NOVISCOSITYLIMITER
/* make sure that viscous acceleration is not too large */
dt = imax(timestep, (P[j].Ti_endstep - P[j].Ti_begstep)) * All.Timebase_interval;
if(dt > 0 && (dwk_i + dwk_j) < 0)
{
visc = dmin(visc, 0.5 * fac_vsic_fix * vdotr2 /
(0.5 * (mass + P[j].Mass) * (dwk_i + dwk_j) * r * dt));
}
#endif
}
else
visc = 0;
p_over_rho2_j *= SphP[j].DhsmlDensityFactor;
hfc_visc = 0.5 * P[j].Mass * visc * (dwk_i + dwk_j) / r;
hfc = hfc_visc + P[j].Mass * (p_over_rho2_i * dwk_i + p_over_rho2_j * dwk_j) / r;
acc[0] -= hfc * dx;
acc[1] -= hfc * dy;
acc[2] -= hfc * dz;
dtEntropy += 0.5 * hfc_visc * vdotr2;
}
}
}
}
while(startnode >= 0);
/* Now collect the result at the right place */
if(mode == 0)
{
for(k = 0; k < 3; k++)
SphP[target].HydroAccel[k] = acc[k];
SphP[target].DtEntropy = dtEntropy;
SphP[target].MaxSignalVel = maxSignalVel;
}
else
{
for(k = 0; k < 3; k++)
HydroDataResult[target].Acc[k] = acc[k];
HydroDataResult[target].DtEntropy = dtEntropy;
HydroDataResult[target].MaxSignalVel = maxSignalVel;
}
}
/* DECK CAIRY */
/* Subroutine */ int cairy_(complex *z__, integer *id, integer *kode, complex
*ai, integer *nz, integer *ierr)
{
/* Initialized data */
static real tth = .666666666666666667f;
static real c1 = .35502805388781724f;
static real c2 = .258819403792806799f;
static real coef = .183776298473930683f;
static complex cone = {1.f,0.f};
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer k;
static real d1, d2;
static integer k1, k2;
static complex s1, s2, z3;
static real aa, bb, ad, ak, bk, ck, dk, az;
static complex cy[1];
static integer nn;
static real rl;
static integer mr;
static real zi, zr, az3, z3i, z3r, fid, dig, r1m5;
static complex csq;
static real fnu;
static complex zta;
static real tol;
static complex trm1, trm2;
static real sfac, alim, elim, alaz, atrm;
extern /* Subroutine */ int cacai_(complex *, real *, integer *, integer *
, integer *, complex *, integer *, real *, real *, real *, real *)
;
static integer iflag;
extern /* Subroutine */ int cbknu_(complex *, real *, integer *, integer *
, complex *, integer *, real *, real *, real *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CAIRY */
/* ***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz */
/* for complex argument z. A scaling option is available */
/* to help avoid underflow and overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10D */
/* ***TYPE COMPLEX (CAIRY-C, ZAIRY-C) */
/* ***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, */
/* BESSEL FUNCTION OF ORDER TWO THIRDS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* On KODE=1, CAIRY computes the complex Airy function Ai(z) */
/* or its derivative dAi/dz on ID=0 or ID=1 respectively. On */
/* KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz */
/* is provided to remove the exponential decay in -pi/3<arg(z) */
/* <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where */
/* zeta=(2/3)*z**(3/2). */
/* While the Airy functions Ai(z) and dAi/dz are analytic in */
/* the whole z-plane, the corresponding scaled functions defined */
/* for KODE=2 have a cut along the negative real axis. */
/* Input */
/* Z - Argument of type COMPLEX */
/* ID - Order of derivative, ID=0 or ID=1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* AI=Ai(z) on ID=0 */
/* AI=dAi/dz on ID=1 */
/* at z=Z */
/* =2 returns */
/* AI=exp(zeta)*Ai(z) on ID=0 */
/* AI=exp(zeta)*dAi/dz on ID=1 */
/* at z=Z where zeta=(2/3)*z**(3/2) */
/* Output */
/* AI - Result of type COMPLEX */
/* NZ - Underflow indicator */
/* NZ=0 Normal return */
/* NZ=1 AI=0 due to underflow in */
/* -pi/3<arg(Z)<pi/3 on KODE=1 */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (Re(Z) too large with KODE=1) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has less than half precision) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Ai(z) and dAi/dz are computed from K Bessel functions by */
/* Ai(z) = c*sqrt(z)*K(1/3,zeta) */
/* dAi/dz = -c* z *K(2/3,zeta) */
/* c = 1/(pi*sqrt(3)) */
/* zeta = (2/3)*z**(3/2) */
/* when abs(z)>1 and from power series when abs(z)<=1. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z is large, losses */
/* of significance by argument reduction occur. Consequently, if */
/* the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), */
/* then losses exceeding half precision are likely and an error */
/* flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. */
/* Also, if the magnitude of ZETA is larger than U2=0.5/UR, then */
/* all significance is lost and IERR=4. In order to use the INT */
/* function, ZETA must be further restricted not to exceed */
/* U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA */
/* must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, */
/* and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single */
/* precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. */
/* This makes U2 limiting is single precision and U3 limiting */
/* in double precision. This means that the magnitude of Z */
/* cannot exceed approximately 3.4E+4 in single precision and */
/* 2.1E+6 in double precision. This also means that one can */
/* expect to retain, in the worst cases on 32-bit machines, */
/* no digits in single precision and only 6 digits in double */
/* precision. */
/* 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 and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 3. 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. */
/* 4. 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 CACAI, CBKNU, I1MACH, R1MACH */
/* ***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 CAIRY */
/* ***FIRST EXECUTABLE STATEMENT CAIRY */
*ierr = 0;
*nz = 0;
if (*id < 0 || *id > 1) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
az = c_abs(z__);
/* Computing MAX */
r__1 = r1mach_(&c__4);
tol = dmax(r__1,1e-18f);
fid = (real) (*id);
if (az > 1.f) {
goto L60;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(Z).LE.1. */
/* ----------------------------------------------------------------------- */
s1.r = cone.r, s1.i = cone.i;
s2.r = cone.r, s2.i = cone.i;
if (az < tol) {
goto L160;
}
aa = az * az;
if (aa < tol / az) {
goto L40;
}
trm1.r = cone.r, trm1.i = cone.i;
trm2.r = cone.r, trm2.i = cone.i;
atrm = 1.f;
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i +
z__->i * z__->r;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
z3.r = q__1.r, z3.i = q__1.i;
az3 = az * aa;
ak = fid + 2.f;
bk = 3.f - fid - fid;
ck = 4.f - fid;
dk = fid + 3.f + fid;
d1 = ak * dk;
d2 = bk * ck;
ad = dmin(d1,d2);
ak = fid * 9.f + 24.f;
bk = 30.f - fid * 9.f;
z3r = z3.r;
z3i = r_imag(&z3);
for (k = 1; k <= 25; ++k) {
r__1 = z3r / d1;
r__2 = z3i / d1;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm1.r * q__2.r - trm1.i * q__2.i, q__1.i = trm1.r * q__2.i
+ trm1.i * q__2.r;
trm1.r = q__1.r, trm1.i = q__1.i;
q__1.r = s1.r + trm1.r, q__1.i = s1.i + trm1.i;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = z3r / d2;
r__2 = z3i / d2;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm2.r * q__2.r - trm2.i * q__2.i, q__1.i = trm2.r * q__2.i
+ trm2.i * q__2.r;
trm2.r = q__1.r, trm2.i = q__1.i;
q__1.r = s2.r + trm2.r, q__1.i = s2.i + trm2.i;
s2.r = q__1.r, s2.i = q__1.i;
atrm = atrm * az3 / ad;
d1 += ak;
d2 += bk;
ad = dmin(d1,d2);
if (atrm < tol * ad) {
goto L40;
}
ak += 18.f;
bk += 18.f;
/* L30: */
}
L40:
if (*id == 1) {
goto L50;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__5.r = z__->r * s2.r - z__->i * s2.i, q__5.i = z__->r * s2.i + z__->i *
s2.r;
q__6.r = c2, q__6.i = 0.f;
q__4.r = q__5.r * q__6.r - q__5.i * q__6.i, q__4.i = q__5.r * q__6.i +
q__5.i * q__6.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
ai->r = q__1.r, ai->i = q__1.i;
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L50:
q__2.r = -s2.r, q__2.i = -s2.i;
q__3.r = c2, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
ai->r = q__1.r, ai->i = q__1.i;
if (az > tol) {
q__4.r = z__->r * z__->r - z__->i * z__->i, q__4.i = z__->r * z__->i
+ z__->i * z__->r;
q__3.r = q__4.r * s1.r - q__4.i * s1.i, q__3.i = q__4.r * s1.i +
q__4.i * s1.r;
r__1 = c1 / (fid + 1.f);
q__5.r = r__1, q__5.i = 0.f;
q__2.r = q__3.r * q__5.r - q__3.i * q__5.i, q__2.i = q__3.r * q__5.i
+ q__3.i * q__5.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
}
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
/* ----------------------------------------------------------------------- */
/* CASE FOR ABS(Z).GT.1.0 */
/* ----------------------------------------------------------------------- */
L60:
fnu = (fid + 1.f) / 3.f;
/* ----------------------------------------------------------------------- */
/* 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). */
/* ----------------------------------------------------------------------- */
k1 = i1mach_(&c__12);
k2 = i1mach_(&c__13);
r1m5 = r1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.f) * 2.303f;
k1 = i1mach_(&c__11) - 1;
aa = r1m5 * k1;
dig = dmin(aa,18.f);
aa *= 2.303f;
/* Computing MAX */
r__1 = -aa;
alim = elim + dmax(r__1,-41.45f);
rl = dig * 1.2f + 3.f;
alaz = log(az);
/* ----------------------------------------------------------------------- */
/* TEST FOR RANGE */
/* ----------------------------------------------------------------------- */
aa = .5f / tol;
bb = i1mach_(&c__9) * .5f;
aa = dmin(aa,bb);
d__1 = (doublereal) aa;
d__2 = (doublereal) tth;
aa = pow_dd(&d__1, &d__2);
if (az > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
c_sqrt(&q__1, z__);
csq.r = q__1.r, csq.i = q__1.i;
q__2.r = z__->r * csq.r - z__->i * csq.i, q__2.i = z__->r * csq.i +
z__->i * csq.r;
q__3.r = tth, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
zta.r = q__1.r, zta.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
/* ----------------------------------------------------------------------- */
iflag = 0;
sfac = 1.f;
zi = r_imag(z__);
zr = z__->r;
ak = r_imag(&zta);
if (zr >= 0.f) {
goto L70;
}
bk = zta.r;
ck = -dabs(bk);
q__1.r = ck, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L70:
if (zi != 0.f) {
goto L80;
}
if (zr > 0.f) {
goto L80;
}
q__1.r = 0.f, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L80:
aa = zta.r;
if (aa >= 0.f && zr > 0.f) {
goto L100;
}
if (*kode == 2) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa > -alim) {
goto L90;
}
aa = -aa + alaz * .25f;
iflag = 1;
sfac = tol;
if (aa > elim) {
goto L240;
}
L90:
/* ----------------------------------------------------------------------- */
/* CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
/* ----------------------------------------------------------------------- */
mr = 1;
if (zi < 0.f) {
mr = -1;
}
cacai_(&zta, &fnu, kode, &mr, &c__1, cy, &nn, &rl, &tol, &elim, &alim);
if (nn < 0) {
goto L250;
}
*nz += nn;
goto L120;
L100:
if (*kode == 2) {
goto L110;
}
/* ----------------------------------------------------------------------- */
/* UNDERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa < alim) {
goto L110;
}
aa = -aa - alaz * .25f;
iflag = 2;
sfac = 1.f / tol;
if (aa < -elim) {
goto L180;
}
L110:
cbknu_(&zta, &fnu, kode, &c__1, cy, nz, &tol, &elim, &alim);
L120:
q__2.r = coef, q__2.i = 0.f;
q__1.r = cy[0].r * q__2.r - cy[0].i * q__2.i, q__1.i = cy[0].r * q__2.i +
cy[0].i * q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (iflag != 0) {
goto L140;
}
if (*id == 1) {
goto L130;
}
q__1.r = csq.r * s1.r - csq.i * s1.i, q__1.i = csq.r * s1.i + csq.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L130:
q__2.r = -z__->r, q__2.i = -z__->i;
q__1.r = q__2.r * s1.r - q__2.i * s1.i, q__1.i = q__2.r * s1.i + q__2.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L140:
q__2.r = sfac, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (*id == 1) {
goto L150;
}
q__1.r = s1.r * csq.r - s1.i * csq.i, q__1.i = s1.r * csq.i + s1.i *
csq.r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L150:
q__2.r = -s1.r, q__2.i = -s1.i;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L160:
aa = r1mach_(&c__1) * 1e3f;
s1.r = 0.f, s1.i = 0.f;
if (*id == 1) {
goto L170;
}
if (az > aa) {
q__2.r = c2, q__2.i = 0.f;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i
+ q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
}
q__2.r = c1, q__2.i = 0.f;
q__1.r = q__2.r - s1.r, q__1.i = q__2.i - s1.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L170:
q__2.r = c2, q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
aa = sqrt(aa);
if (az > aa) {
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i
+ z__->i * z__->r;
q__1.r = q__2.r * .5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
.5f;
s1.r = q__1.r, s1.i = q__1.i;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L180:
*nz = 1;
ai->r = 0.f, ai->i = 0.f;
return 0;
L240:
*nz = 0;
*ierr = 2;
return 0;
L250:
if (nn == -1) {
goto L240;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*ierr = 4;
*nz = 0;
return 0;
} /* cairy_ */
/* DECK BESJ */
/* Subroutine */ int besj_(real *x, real *alpha, integer *n, real *y, integer
*nz)
{
/* Initialized data */
static real rtwo = 1.34839972492648f;
static real pdf = .785398163397448f;
static real rttp = .797884560802865f;
static real pidt = 1.5707963267949f;
static real pp[4] = { 8.72909153935547f,.26569393226503f,
.124578576865586f,7.70133747430388e-4f };
static integer inlim = 150;
static real fnulim[2] = { 100.f,60.f };
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer i__, k;
static real s, t;
static integer i1, i2;
static real s1, s2, t1, t2, ak, ap, fn, sa;
static integer kk, in, km;
static real sb, ta, tb;
static integer is, nn, kt, ns;
static real tm, wk[7], tx, xo2, dfn, akm, arg, fnf, fni, gln, ans, dtm,
tfn, fnu, tau, tol, etx, rtx, trx, fnp1, xo2l, sxo2, coef, earg,
relb;
static integer ialp;
static real rden;
static integer iflw;
static real slim, temp[3], rtol, elim1, fidal;
static integer idalp;
static real flgjy;
extern /* Subroutine */ int jairy_();
static real rzden, tolln;
extern /* Subroutine */ int asyjy_(U_fp, real *, real *, real *, integer *
, real *, real *, integer *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
static real dalpha;
extern doublereal alngam_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESJ */
/* ***PURPOSE Compute an N member sequence of J Bessel functions */
/* J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA */
/* and X. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10A3 */
/* ***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) */
/* ***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* Daniel, S. L., (SNLA) */
/* Weston, M. K., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESJ computes an N member sequence of J Bessel functions */
/* J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. */
/* A combination of the power series, the asymptotic expansion */
/* for X to infinity and the uniform asymptotic expansion for */
/* NU to infinity are applied over subdivisions of the (NU,X) */
/* plane. For values of (NU,X) not covered by one of these */
/* formulae, the order is incremented or decremented by integer */
/* values into a region where one of the formulae apply. Backward */
/* recursion is applied to reduce orders by integer values except */
/* where the entire sequence lies in the oscillatory region. In */
/* this case forward recursion is stable and values from the */
/* asymptotic expansion for X to infinity start the recursion */
/* when it is efficient to do so. Leading terms of the series */
/* and uniform expansion are tested for underflow. If a sequence */
/* is requested and the last member would underflow, the result */
/* is set to zero and the next lower order tried, etc., until a */
/* member comes on scale or all members are set to zero. */
/* Overflow cannot occur. */
/* Description of Arguments */
/* Input */
/* X - X .GE. 0.0E0 */
/* ALPHA - order of first member of the sequence, */
/* ALPHA .GE. 0.0E0 */
/* N - number of members in the sequence, N .GE. 1 */
/* Output */
/* Y - a vector whose first N components contain */
/* values for J/sub(ALPHA+K-1)/(X), K=1,...,N */
/* NZ - number of components of Y set to zero due to */
/* underflow, */
/* NZ=0 , normal return, computation completed */
/* NZ .NE. 0, last NZ components of Y set to zero, */
/* Y(K)=0.0E0, K=N-NZ+1,...,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Underflow - a non-fatal error (NZ .NE. 0) */
/* ***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 */
/* subroutines IBESS and JBESS for Bessel functions */
/* I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM */
/* Transactions on Mathematical Software 3, (1977), */
/* pp. 76-92. */
/* F. W. J. Olver, Tables of Bessel Functions of Moderate */
/* or Large Orders, NPL Mathematical Tables 6, Her */
/* Majesty's Stationery Office, London, 1962. */
/* ***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESJ */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESJ */
*nz = 0;
kt = 1;
ns = 0;
/* I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE */
/* I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE */
ta = r1mach_(&c__3);
tol = dmax(ta,1e-15f);
i1 = i1mach_(&c__11) + 1;
i2 = i1mach_(&c__12);
tb = r1mach_(&c__5);
elim1 = (i2 * tb + 3.f) * -2.303f;
rtol = 1.f / tol;
slim = r1mach_(&c__1) * 1e3f * rtol;
/* TOLLN = -LN(TOL) */
tolln = tb * 2.303f * i1;
tolln = dmin(tolln,34.5388f);
if ((i__1 = *n - 1) < 0) {
goto L720;
} else if (i__1 == 0) {
goto L10;
} else {
goto L20;
}
L10:
kt = 2;
L20:
nn = *n;
if (*x < 0.f) {
goto L730;
} else if (*x == 0) {
goto L30;
} else {
goto L80;
}
L30:
if (*alpha < 0.f) {
goto L710;
} else if (*alpha == 0) {
goto L40;
} else {
goto L50;
}
L40:
y[1] = 1.f;
if (*n == 1) {
return 0;
}
i1 = 2;
goto L60;
L50:
i1 = 1;
L60:
i__1 = *n;
for (i__ = i1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L70: */
}
return 0;
L80:
if (*alpha < 0.f) {
goto L710;
}
ialp = (integer) (*alpha);
fni = (real) (ialp + *n - 1);
fnf = *alpha - ialp;
dfn = fni + fnf;
fnu = dfn;
xo2 = *x * .5f;
sxo2 = xo2 * xo2;
/* DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X */
/* TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE */
/* APPLIED. */
if (sxo2 <= fnu + 1.f) {
goto L90;
}
ta = dmax(20.f,fnu);
if (*x > ta) {
goto L120;
}
if (*x > 12.f) {
goto L110;
}
xo2l = log(xo2);
ns = (integer) (sxo2 - fnu) + 1;
goto L100;
L90:
fn = fnu;
fnp1 = fn + 1.f;
xo2l = log(xo2);
is = kt;
if (*x <= .5f) {
goto L330;
}
ns = 0;
L100:
fni += ns;
dfn = fni + fnf;
fn = dfn;
fnp1 = fn + 1.f;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L330;
L110:
/* Computing MAX */
r__1 = 36.f - fnu;
ans = dmax(r__1,0.f);
ns = (integer) ans;
fni += ns;
dfn = fni + fnf;
fn = dfn;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L130;
L120:
rtx = sqrt(*x);
tau = rtwo * rtx;
ta = tau + fnulim[kt - 1];
if (fnu <= ta) {
goto L480;
}
fn = fnu;
is = kt;
/* UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY */
L130:
i1 = (i__1 = 3 - is, abs(i__1));
i1 = max(i1,1);
flgjy = 1.f;
asyjy_((U_fp)jairy_, x, &fn, &flgjy, &i1, &temp[is - 1], wk, &iflw);
if (iflw != 0) {
goto L380;
}
switch (is) {
case 1: goto L320;
case 2: goto L450;
case 3: goto L620;
}
L310:
temp[0] = temp[2];
kt = 1;
L320:
is = 2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if (i1 == 2) {
goto L450;
}
goto L130;
/* SERIES FOR (X/2)**2.LE.NU+1 */
L330:
gln = alngam_(&fnp1);
arg = fn * xo2l - gln;
if (arg < -elim1) {
goto L400;
}
earg = exp(arg);
L340:
s = 1.f;
if (*x < tol) {
goto L360;
}
ak = 3.f;
t2 = 1.f;
t = 1.f;
s1 = fn;
for (k = 1; k <= 17; ++k) {
s2 = t2 + s1;
t = -t * sxo2 / s2;
s += t;
if (dabs(t) < tol) {
goto L360;
}
t2 += ak;
ak += 2.f;
s1 += fn;
/* L350: */
}
L360:
temp[is - 1] = s * earg;
switch (is) {
case 1: goto L370;
case 2: goto L450;
case 3: goto L610;
}
L370:
earg = earg * fn / xo2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
is = 2;
goto L340;
/* SET UNDERFLOW VALUE AND UPDATE PARAMETERS */
/* UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE */
/* LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. */
L380:
y[nn] = 0.f;
--nn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L390;
} else {
goto L130;
}
L390:
kt = 2;
is = 2;
goto L130;
L400:
y[nn] = 0.f;
--nn;
fnp1 = fn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L410;
} else {
goto L420;
}
L410:
kt = 2;
is = 2;
L420:
if (sxo2 <= fnp1) {
goto L430;
}
goto L130;
L430:
arg = arg - xo2l + log(fnp1);
if (arg < -elim1) {
goto L400;
}
goto L330;
L440:
*nz = *n - nn;
return 0;
/* BACKWARD RECURSION SECTION */
L450:
if (ns != 0) {
goto L451;
}
*nz = *n - nn;
if (kt == 2) {
goto L470;
}
/* BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA */
y[nn] = temp[0];
y[nn - 1] = temp[1];
if (nn == 2) {
return 0;
}
L451:
trx = 2.f / *x;
dtm = fni;
tm = (dtm + fnf) * trx;
ak = 1.f;
ta = temp[0];
tb = temp[1];
if (dabs(ta) > slim) {
goto L455;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L455:
kk = 2;
in = ns - 1;
if (in == 0) {
goto L690;
}
if (ns != 0) {
goto L670;
}
k = nn - 2;
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
--k;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L460: */
}
return 0;
L470:
y[1] = temp[1];
return 0;
/* ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN */
/* OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER */
/* OF THE SEQUENCE IS ALSO IN THE REGION. */
L480:
in = (integer) (*alpha - tau + 2.f);
if (in <= 0) {
goto L490;
}
idalp = ialp - in - 1;
kt = 1;
goto L500;
L490:
idalp = ialp;
in = 0;
L500:
is = kt;
fidal = (real) idalp;
dalpha = fidal + fnf;
arg = *x - pidt * dalpha - pdf;
sa = sin(arg);
sb = cos(arg);
coef = rttp / rtx;
etx = *x * 8.f;
L510:
dtm = fidal + fidal;
dtm *= dtm;
tm = 0.f;
if (fidal == 0.f && dabs(fnf) < tol) {
goto L520;
}
tm = fnf * 4.f * (fidal + fidal + fnf);
L520:
trx = dtm - 1.f;
t2 = (trx + tm) / etx;
s2 = t2;
relb = tol * dabs(t2);
t1 = etx;
s1 = 1.f;
fn = 1.f;
ak = 8.f;
for (k = 1; k <= 13; ++k) {
t1 += etx;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = -t2 * ap / t1;
s1 += t2;
t1 += etx;
ak += 8.f;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = t2 * ap / t1;
s2 += t2;
if (dabs(t2) <= relb) {
goto L540;
}
ak += 8.f;
/* L530: */
}
L540:
temp[is - 1] = coef * (s1 * sb - s2 * sa);
if (is == 2) {
goto L560;
}
fidal += 1.f;
dalpha = fidal + fnf;
is = 2;
tb = sa;
sa = -sb;
sb = tb;
goto L510;
/* FORWARD RECURSION SECTION */
L560:
if (kt == 2) {
goto L470;
}
s1 = temp[0];
s2 = temp[1];
tx = 2.f / *x;
tm = dalpha * tx;
if (in == 0) {
goto L580;
}
/* FORWARD RECUR TO INDEX ALPHA */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
/* L570: */
}
if (nn == 1) {
goto L600;
}
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
L580:
/* FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 */
y[1] = s1;
y[2] = s2;
if (nn == 2) {
return 0;
}
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = tm * y[i__ - 1] - y[i__ - 2];
tm += tx;
/* L590: */
}
return 0;
L600:
y[1] = s2;
return 0;
/* BACKWARD RECURSION WITH NORMALIZATION BY */
/* ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. */
L610:
/* COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION */
/* Computing MAX */
r__1 = 3.f - fn;
akm = dmax(r__1,0.f);
km = (integer) akm;
tfn = fn + km;
ta = (gln + tfn - .9189385332f - .0833333333f / tfn) / (tfn + .5f);
ta = xo2l - ta;
tb = -(1.f - 1.5f / tfn) / tfn;
akm = tolln / (-ta + sqrt(ta * ta - tolln * tb)) + 1.5f;
in = km + (integer) akm;
goto L660;
L620:
/* COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION */
gln = wk[2] + wk[1];
if (wk[5] > 30.f) {
goto L640;
}
rden = (pp[3] * wk[5] + pp[2]) * wk[5] + 1.f;
rzden = pp[0] + pp[1] * wk[5];
ta = rzden / rden;
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
goto L650;
L630:
tb = ((wk[0] * .0887944358f + .167989473f) * wk[0] + 1.259921049f) / wk[6]
;
goto L650;
L640:
ta = tolln * .5f / wk[3];
ta = ((ta * .049382716f - .1111111111f) * ta + .6666666667f) * ta * wk[5];
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
L650:
in = (integer) (ta / tb + 1.5f);
if (in > inlim) {
goto L310;
}
L660:
dtm = fni + in;
trx = 2.f / *x;
tm = (dtm + fnf) * trx;
ta = 0.f;
tb = tol;
kk = 1;
ak = 1.f;
L670:
/* BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO */
/* UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L680: */
}
/* NORMALIZATION */
if (kk != 1) {
goto L690;
}
s = temp[2];
sa = ta / tb;
ta = s;
tb = s;
if (dabs(s) > slim) {
goto L685;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L685:
ta *= sa;
kk = 2;
in = ns;
if (ns != 0) {
goto L670;
}
L690:
y[nn] = tb * ak;
*nz = *n - nn;
if (nn == 1) {
return 0;
}
k = nn - 1;
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
if (nn == 2) {
return 0;
}
dtm += -1.f;
tm = (dtm + fnf) * trx;
k = nn - 2;
/* BACKWARD RECUR INDEXED */
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
dtm += -1.f;
tm = (dtm + fnf) * trx;
--k;
/* L700: */
}
return 0;
L710:
xermsg_("SLATEC", "BESJ", "ORDER, ALPHA, LESS THAN ZERO.", &c__2, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)29);
return 0;
L720:
xermsg_("SLATEC", "BESJ", "N LESS THAN ONE.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)16);
return 0;
L730:
xermsg_("SLATEC", "BESJ", "X LESS THAN ZERO.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)17);
return 0;
} /* besj_ */
/* Subroutine */ int sstebz_(char *range, char *order, integer *n, real *vl,
real *vu, integer *il, integer *iu, real *abstol, real *d, real *e,
integer *m, integer *nsplit, real *w, integer *iblock, integer *
isplit, real *work, integer *iwork, integer *info)
{
/* -- LAPACK routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTEBZ computes the eigenvalues of a symmetric tridiagonal
matrix T. The user may ask for all eigenvalues, all eigenvalues
in the half-open interval (VL, VU], or the IL-th through IU-th
eigenvalues.
To avoid overflow, the matrix must be scaled so that its
largest element is no greater than overflow**(1/2) *
underflow**(1/4) in absolute value, and for greatest
accuracy, it should not be much smaller than that.
See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
Matrix", Report CS41, Computer Science Dept., Stanford
University, July 21, 1966.
Arguments
=========
RANGE (input) CHARACTER
= 'A': ("All") all eigenvalues will be found.
= 'V': ("Value") all eigenvalues in the half-open interval
(VL, VU] will be found.
= 'I': ("Index") the IL-th through IU-th eigenvalues (of the
entire matrix) will be found.
ORDER (input) CHARACTER
= 'B': ("By Block") the eigenvalues will be grouped by
split-off block (see IBLOCK, ISPLIT) and
ordered from smallest to largest within
the block.
= 'E': ("Entire matrix")
the eigenvalues for the entire matrix
will be ordered from smallest to
largest.
N (input) INTEGER
The order of the tridiagonal matrix T. N >= 0.
VL (input) REAL
VU (input) REAL
If RANGE='V', the lower and upper bounds of the interval to
be searched for eigenvalues. Eigenvalues less than or equal
to VL, or greater than VU, will not be returned. VL < VU.
Not referenced if RANGE = 'A' or 'I'.
IL (input) INTEGER
IU (input) INTEGER
If RANGE='I', the indices (in ascending order) of the
smallest and largest eigenvalues to be returned.
1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
Not referenced if RANGE = 'A' or 'V'.
ABSTOL (input) REAL
The absolute tolerance for the eigenvalues. An eigenvalue
(or cluster) is considered to be located if it has been
determined to lie in an interval whose width is ABSTOL or
less. If ABSTOL is less than or equal to zero, then ULP*|T|
will be used, where |T| means the 1-norm of T.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*SLAMCH('S'), not zero.
D (input) REAL array, dimension (N)
The n diagonal elements of the tridiagonal matrix T.
E (input) REAL array, dimension (N-1)
The (n-1) off-diagonal elements of the tridiagonal matrix T.
M (output) INTEGER
The actual number of eigenvalues found. 0 <= M <= N.
(See also the description of INFO=2,3.)
NSPLIT (output) INTEGER
The number of diagonal blocks in the matrix T.
1 <= NSPLIT <= N.
W (output) REAL array, dimension (N)
On exit, the first M elements of W will contain the
eigenvalues. (SSTEBZ may use the remaining N-M elements as
workspace.)
IBLOCK (output) INTEGER array, dimension (N)
At each row/column j where E(j) is zero or small, the
matrix T is considered to split into a block diagonal
matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
block (from 1 to the number of blocks) the eigenvalue W(i)
belongs. (SSTEBZ may use the remaining N-M elements as
workspace.)
ISPLIT (output) INTEGER array, dimension (N)
The splitting points, at which T breaks up into submatrices.
The first submatrix consists of rows/columns 1 to ISPLIT(1),
the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
etc., and the NSPLIT-th consists of rows/columns
ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
(Only the first NSPLIT elements will actually be used, but
since the user cannot know a priori what value NSPLIT will
have, N words must be reserved for ISPLIT.)
WORK (workspace) REAL array, dimension (4*N)
IWORK (workspace) INTEGER array, dimension (3*N)
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: some or all of the eigenvalues failed to converge or
were not computed:
=1 or 3: Bisection failed to converge for some
eigenvalues; these eigenvalues are flagged by a
negative block number. The effect is that the
eigenvalues may not be as accurate as the
absolute and relative tolerances. This is
generally caused by unexpectedly inaccurate
arithmetic.
=2 or 3: RANGE='I' only: Not all of the eigenvalues
IL:IU were found.
Effect: M < IU+1-IL
Cause: non-monotonic arithmetic, causing the
Sturm sequence to be non-monotonic.
Cure: recalculate, using RANGE='A', and pick
out eigenvalues IL:IU. In some cases,
increasing the PARAMETER "FUDGE" may
make things work.
= 4: RANGE='I', and the Gershgorin interval
initially used was too small. No eigenvalues
were computed.
Probable cause: your machine has sloppy
floating-point arithmetic.
Cure: Increase the PARAMETER "FUDGE",
recompile, and try again.
Internal Parameters
===================
RELFAC REAL, default = 2.0e0
The relative tolerance. An interval (a,b] lies within
"relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
where "ulp" is the machine precision (distance from 1 to
the next larger floating point number.)
FUDGE REAL, default = 2
A "fudge factor" to widen the Gershgorin intervals. Ideally,
a value of 1 should work, but on machines with sloppy
arithmetic, this needs to be larger. The default for
publicly released versions should be large enough to handle
the worst machine around. Note that this has no effect
on accuracy of the solution.
=====================================================================
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__3 = 3;
static integer c__2 = 2;
static integer c__0 = 0;
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2, r__3, r__4, r__5;
/* Builtin functions */
double sqrt(doublereal), log(doublereal);
/* Local variables */
static integer iend, ioff, iout, itmp1, j, jdisc;
extern logical lsame_(char *, char *);
static integer iinfo;
static real atoli;
static integer iwoff;
static real bnorm;
static integer itmax;
static real wkill, rtoli, tnorm;
static integer ib, jb, ie, je, nb;
static real gl;
static integer im, in, ibegin;
static real gu;
static integer iw;
static real wl;
static integer irange, idiscl;
extern doublereal slamch_(char *);
static real safemn, wu;
static integer idumma[1];
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer idiscu;
extern /* Subroutine */ int slaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
real *, real *, integer *, real *, real *, integer *, integer *,
real *, integer *, integer *);
static integer iorder;
static logical ncnvrg;
static real pivmin;
static logical toofew;
static integer nwl;
static real ulp, wlu, wul;
static integer nwu;
static real tmp1, tmp2;
#define IDUMMA(I) idumma[(I)]
#define IWORK(I) iwork[(I)-1]
#define WORK(I) work[(I)-1]
#define ISPLIT(I) isplit[(I)-1]
#define IBLOCK(I) iblock[(I)-1]
#define W(I) w[(I)-1]
#define E(I) e[(I)-1]
#define D(I) d[(I)-1]
*info = 0;
/* Decode RANGE */
if (lsame_(range, "A")) {
irange = 1;
} else if (lsame_(range, "V")) {
irange = 2;
} else if (lsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Decode ORDER */
if (lsame_(order, "B")) {
iorder = 2;
} else if (lsame_(order, "E")) {
iorder = 1;
} else {
iorder = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (iorder <= 0) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2 && *vl >= *vu) {
*info = -5;
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSTEBZ", &i__1);
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplifications: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants
NB is the minimum vector length for vector bisection, or 0
if only scalar is to be done. */
safemn = slamch_("S");
ulp = slamch_("P");
rtoli = ulp * 2.f;
nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1, 6L, 1L);
if (nb <= 1) {
nb = 0;
}
/* Special Case when N=1 */
if (*n == 1) {
*nsplit = 1;
ISPLIT(1) = 1;
if (irange == 2 && (*vl >= D(1) || *vu < D(1))) {
*m = 0;
} else {
W(1) = D(1);
IBLOCK(1) = 1;
*m = 1;
}
return 0;
}
/* Compute Splitting Points */
*nsplit = 1;
WORK(*n) = 0.f;
pivmin = 1.f;
i__1 = *n;
for (j = 2; j <= *n; ++j) {
/* Computing 2nd power */
r__1 = E(j - 1);
tmp1 = r__1 * r__1;
/* Computing 2nd power */
r__2 = ulp;
if ((r__1 = D(j) * D(j - 1), dabs(r__1)) * (r__2 * r__2) + safemn >
tmp1) {
ISPLIT(*nsplit) = j - 1;
++(*nsplit);
WORK(j - 1) = 0.f;
} else {
WORK(j - 1) = tmp1;
pivmin = dmax(pivmin,tmp1);
}
/* L10: */
}
ISPLIT(*nsplit) = *n;
pivmin *= safemn;
/* Compute Interval and ATOLI */
if (irange == 3) {
/* RANGE='I': Compute the interval containing eigenvalues
IL through IU.
Compute Gershgorin interval for entire (split) matrix
and use it as the initial interval */
gu = D(1);
gl = D(1);
tmp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= *n-1; ++j) {
tmp2 = sqrt(WORK(j));
/* Computing MAX */
r__1 = gu, r__2 = D(j) + tmp1 + tmp2;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(j) - tmp1 - tmp2;
gl = dmin(r__1,r__2);
tmp1 = tmp2;
/* L20: */
}
/* Computing MAX */
r__1 = gu, r__2 = D(*n) + tmp1;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(*n) - tmp1;
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
tnorm = dmax(r__1,r__2);
gl = gl - tnorm * 2.f * ulp * *n - pivmin * 4.f;
gu = gu + tnorm * 2.f * ulp * *n + pivmin * 2.f;
/* Compute Iteration parameters */
itmax = (integer) ((log(tnorm + pivmin) - log(pivmin)) / log(2.f)) +
2;
if (*abstol <= 0.f) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
WORK(*n + 1) = gl;
WORK(*n + 2) = gl;
WORK(*n + 3) = gu;
WORK(*n + 4) = gu;
WORK(*n + 5) = gl;
WORK(*n + 6) = gu;
IWORK(1) = -1;
IWORK(2) = -1;
IWORK(3) = *n + 1;
IWORK(4) = *n + 1;
IWORK(5) = *il - 1;
IWORK(6) = *iu;
slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, &pivmin,
&D(1), &E(1), &WORK(1), &IWORK(5), &WORK(*n + 1), &WORK(*n +
5), &iout, &IWORK(1), &W(1), &IBLOCK(1), &iinfo);
if (IWORK(6) == *iu) {
wl = WORK(*n + 1);
wlu = WORK(*n + 3);
nwl = IWORK(1);
wu = WORK(*n + 4);
wul = WORK(*n + 2);
nwu = IWORK(4);
} else {
wl = WORK(*n + 2);
wlu = WORK(*n + 4);
nwl = IWORK(2);
wu = WORK(*n + 3);
wul = WORK(*n + 1);
nwu = IWORK(3);
}
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else {
/* RANGE='A' or 'V' -- Set ATOLI
Computing MAX */
r__3 = dabs(D(1)) + dabs(E(1)), r__4 = (r__1 = D(*n), dabs(r__1)) + (
r__2 = E(*n - 1), dabs(r__2));
tnorm = dmax(r__3,r__4);
i__1 = *n - 1;
for (j = 2; j <= *n-1; ++j) {
/* Computing MAX */
r__4 = tnorm, r__5 = (r__1 = D(j), dabs(r__1)) + (r__2 = E(j - 1),
dabs(r__2)) + (r__3 = E(j), dabs(r__3));
tnorm = dmax(r__4,r__5);
/* L30: */
}
if (*abstol <= 0.f) {
atoli = ulp * tnorm;
} else {
atoli = *abstol;
}
if (irange == 2) {
wl = *vl;
wu = *vu;
}
}
/* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
NWL accumulates the number of eigenvalues .le. WL,
NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jb = 1; jb <= *nsplit; ++jb) {
ioff = iend;
ibegin = ioff + 1;
iend = ISPLIT(jb);
in = iend - ioff;
if (in == 1) {
/* Special Case -- IN=1 */
if (irange == 1 || wl >= D(ibegin) - pivmin) {
++nwl;
}
if (irange == 1 || wu >= D(ibegin) - pivmin) {
++nwu;
}
if (irange == 1 || wl < D(ibegin) - pivmin && wu >= D(ibegin) -
pivmin) {
++(*m);
W(*m) = D(ibegin);
IBLOCK(*m) = jb;
}
} else {
/* General Case -- IN > 1
Compute Gershgorin Interval
and use it as the initial interval */
gu = D(ibegin);
gl = D(ibegin);
tmp1 = 0.f;
i__2 = iend - 1;
for (j = ibegin; j <= iend-1; ++j) {
tmp2 = (r__1 = E(j), dabs(r__1));
/* Computing MAX */
r__1 = gu, r__2 = D(j) + tmp1 + tmp2;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(j) - tmp1 - tmp2;
gl = dmin(r__1,r__2);
tmp1 = tmp2;
/* L40: */
}
/* Computing MAX */
r__1 = gu, r__2 = D(iend) + tmp1;
gu = dmax(r__1,r__2);
/* Computing MIN */
r__1 = gl, r__2 = D(iend) - tmp1;
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
bnorm = dmax(r__1,r__2);
gl = gl - bnorm * 2.f * ulp * in - pivmin * 2.f;
gu = gu + bnorm * 2.f * ulp * in + pivmin * 2.f;
/* Compute ATOLI for the current submatrix */
if (*abstol <= 0.f) {
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
atoli = ulp * dmax(r__1,r__2);
} else {
atoli = *abstol;
}
if (irange > 1) {
if (gu < wl) {
nwl += in;
nwu += in;
goto L70;
}
gl = dmax(gl,wl);
gu = dmin(gu,wu);
if (gl >= gu) {
goto L70;
}
}
/* Set Up Initial Interval */
WORK(*n + 1) = gl;
WORK(*n + in + 1) = gu;
slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &D(ibegin), &E(ibegin), &WORK(ibegin), idumma, &
WORK(*n + 1), &WORK(*n + (in << 1) + 1), &im, &IWORK(1), &
W(*m + 1), &IBLOCK(*m + 1), &iinfo);
nwl += IWORK(1);
nwu += IWORK(in + 1);
iwoff = *m - IWORK(1);
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + pivmin) - log(pivmin)) / log(
2.f)) + 2;
slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli, &
pivmin, &D(ibegin), &E(ibegin), &WORK(ibegin), idumma, &
WORK(*n + 1), &WORK(*n + (in << 1) + 1), &iout, &IWORK(1),
&W(*m + 1), &IBLOCK(*m + 1), &iinfo);
/* Copy Eigenvalues Into W and IBLOCK
Use -JB for block number for unconverged eigenvalues.
*/
i__2 = iout;
for (j = 1; j <= iout; ++j) {
tmp1 = (WORK(j + *n) + WORK(j + in + *n)) * .5f;
/* Flag non-convergence. */
if (j > iout - iinfo) {
ncnvrg = TRUE_;
ib = -jb;
} else {
ib = jb;
}
i__3 = IWORK(j + in) + iwoff;
for (je = IWORK(j) + 1 + iwoff; je <= IWORK(j+in)+iwoff; ++je) {
W(je) = tmp1;
IBLOCK(je) = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
im = 0;
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0 || idiscu > 0) {
i__1 = *m;
for (je = 1; je <= *m; ++je) {
if (W(je) <= wlu && idiscl > 0) {
--idiscl;
} else if (W(je) >= wul && idiscu > 0) {
--idiscu;
} else {
++im;
W(im) = W(je);
IBLOCK(im) = IBLOCK(je);
}
/* L80: */
}
*m = im;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic:
Some low eigenvalues to be discarded are not in (WL,W
LU],
or high eigenvalues to be discarded are not in (WUL,W
U]
so just kill off the smallest IDISCL/largest IDISCU
eigenvalues, by simply finding the smallest/largest
eigenvalue(s).
(If N(w) is monotone non-decreasing, this should neve
r
happen.) */
if (idiscl > 0) {
wkill = wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= idiscl; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= *m; ++je) {
if (IBLOCK(je) != 0 && (W(je) < wkill || iw == 0)) {
iw = je;
wkill = W(je);
}
/* L90: */
}
IBLOCK(iw) = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= idiscu; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= *m; ++je) {
if (IBLOCK(je) != 0 && (W(je) > wkill || iw == 0)) {
iw = je;
wkill = W(je);
}
/* L110: */
}
IBLOCK(iw) = 0;
/* L120: */
}
}
im = 0;
i__1 = *m;
for (je = 1; je <= *m; ++je) {
if (IBLOCK(je) != 0) {
++im;
W(im) = W(je);
IBLOCK(im) = IBLOCK(je);
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
/* If ORDER='B', do nothing -- the eigenvalues are already sorted
by block.
If ORDER='E', sort the eigenvalues from smallest to largest */
if (iorder == 1 && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= *m-1; ++je) {
ie = 0;
tmp1 = W(je);
i__2 = *m;
for (j = je + 1; j <= *m; ++j) {
if (W(j) < tmp1) {
ie = j;
tmp1 = W(j);
}
/* L140: */
}
if (ie != 0) {
itmp1 = IBLOCK(ie);
W(ie) = W(je);
IBLOCK(ie) = IBLOCK(je);
W(je) = tmp1;
IBLOCK(je) = itmp1;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of SSTEBZ */
} /* sstebz_ */
/* Subroutine */ int slaed4_(integer *n, integer *i__, real *d__, real *z__,
real *delta, real *rho, real *dlam, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Oak Ridge National Lab, Argonne National Lab,
Courant Institute, NAG Ltd., and Rice University
December 23, 1999
Purpose
=======
This subroutine computes the I-th updated eigenvalue of a symmetric
rank-one modification to a diagonal matrix whose elements are
given in the array d, and that
D(i) < D(j) for i < j
and that RHO > 0. This is arranged by the calling routine, and is
no loss in generality. The rank-one modified system is thus
diag( D ) + RHO * Z * Z_transpose.
where we assume the Euclidean norm of Z is 1.
The method consists of approximating the rational functions in the
secular equation by simpler interpolating rational functions.
Arguments
=========
N (input) INTEGER
The length of all arrays.
I (input) INTEGER
The index of the eigenvalue to be computed. 1 <= I <= N.
D (input) REAL array, dimension (N)
The original eigenvalues. It is assumed that they are in
order, D(I) < D(J) for I < J.
Z (input) REAL array, dimension (N)
The components of the updating vector.
DELTA (output) REAL array, dimension (N)
If N .ne. 1, DELTA contains (D(j) - lambda_I) in its j-th
component. If N = 1, then DELTA(1) = 1. The vector DELTA
contains the information necessary to construct the
eigenvectors.
RHO (input) REAL
The scalar in the symmetric updating formula.
DLAM (output) REAL
The computed lambda_I, the I-th updated eigenvalue.
INFO (output) INTEGER
= 0: successful exit
> 0: if INFO = 1, the updating process failed.
Internal Parameters
===================
Logical variable ORGATI (origin-at-i?) is used for distinguishing
whether D(i) or D(i+1) is treated as the origin.
ORGATI = .true. origin at i
ORGATI = .false. origin at i+1
Logical variable SWTCH3 (switch-for-3-poles?) is for noting
if we are working with THREE poles!
MAXIT is the maximum number of iterations allowed for each
eigenvalue.
Further Details
===============
Based on contributions by
Ren-Cang Li, Computer Science Division, University of California
at Berkeley, USA
=====================================================================
Since this routine is called in an inner loop, we do no argument
checking.
Quick return for N=1 and 2.
Parameter adjustments */
/* System generated locals */
integer i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static real dphi, dpsi;
static integer iter;
static real temp, prew, temp1, a, b, c__;
static integer j;
static real w, dltlb, dltub, midpt;
static integer niter;
static logical swtch;
extern /* Subroutine */ int slaed5_(integer *, real *, real *, real *,
real *, real *), slaed6_(integer *, logical *, real *, real *,
real *, real *, real *, integer *);
static logical swtch3;
static integer ii;
static real dw;
extern doublereal slamch_(char *);
static real zz[3];
static logical orgati;
static real erretm, rhoinv;
static integer ip1;
static real del, eta, phi, eps, tau, psi;
static integer iim1, iip1;
--delta;
--z__;
--d__;
/* Function Body */
*info = 0;
if (*n == 1) {
/* Presumably, I=1 upon entry */
*dlam = d__[1] + *rho * z__[1] * z__[1];
delta[1] = 1.f;
return 0;
}
if (*n == 2) {
slaed5_(i__, &d__[1], &z__[1], &delta[1], rho, dlam);
return 0;
}
/* Compute machine epsilon */
eps = slamch_("Epsilon");
rhoinv = 1.f / *rho;
/* The case I = N */
if (*i__ == *n) {
/* Initialize some basic variables */
ii = *n - 1;
niter = 1;
/* Calculate initial guess */
midpt = *rho / 2.f;
/* If ||Z||_2 is not one, then TEMP should be set to
RHO * ||Z||_2^2 / TWO */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] = d__[j] - d__[*i__] - midpt;
/* L10: */
}
psi = 0.f;
i__1 = *n - 2;
for (j = 1; j <= i__1; ++j) {
psi += z__[j] * z__[j] / delta[j];
/* L20: */
}
c__ = rhoinv + psi;
w = c__ + z__[ii] * z__[ii] / delta[ii] + z__[*n] * z__[*n] / delta[*
n];
if (w <= 0.f) {
temp = z__[*n - 1] * z__[*n - 1] / (d__[*n] - d__[*n - 1] + *rho)
+ z__[*n] * z__[*n] / *rho;
if (c__ <= temp) {
tau = *rho;
} else {
del = d__[*n] - d__[*n - 1];
a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n]
;
b = z__[*n] * z__[*n] * del;
if (a < 0.f) {
tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
} else {
tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
}
}
/* It can be proved that
D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO */
dltlb = midpt;
dltub = *rho;
} else {
del = d__[*n] - d__[*n - 1];
a = -c__ * del + z__[*n - 1] * z__[*n - 1] + z__[*n] * z__[*n];
b = z__[*n] * z__[*n] * del;
if (a < 0.f) {
tau = b * 2.f / (sqrt(a * a + b * 4.f * c__) - a);
} else {
tau = (a + sqrt(a * a + b * 4.f * c__)) / (c__ * 2.f);
}
/* It can be proved that
D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2 */
dltlb = 0.f;
dltub = midpt;
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] = d__[j] - d__[*i__] - tau;
/* L30: */
}
/* Evaluate PSI and the derivative DPSI */
dpsi = 0.f;
psi = 0.f;
erretm = 0.f;
i__1 = ii;
for (j = 1; j <= i__1; ++j) {
temp = z__[j] / delta[j];
psi += z__[j] * temp;
dpsi += temp * temp;
erretm += psi;
/* L40: */
}
erretm = dabs(erretm);
/* Evaluate PHI and the derivative DPHI */
temp = z__[*n] / delta[*n];
phi = z__[*n] * temp;
dphi = temp * temp;
erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
dpsi + dphi);
w = rhoinv + phi + psi;
/* Test for convergence */
if (dabs(w) <= eps * erretm) {
*dlam = d__[*i__] + tau;
goto L250;
}
if (w <= 0.f) {
dltlb = dmax(dltlb,tau);
} else {
dltub = dmin(dltub,tau);
}
/* Calculate the new step */
++niter;
c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] * (
dpsi + dphi);
b = delta[*n - 1] * delta[*n] * w;
if (c__ < 0.f) {
c__ = dabs(c__);
}
if (c__ == 0.f) {
/* ETA = B/A
ETA = RHO - TAU */
eta = dltub - tau;
} else if (a >= 0.f) {
eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) / (
c__ * 2.f);
} else {
eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
r__1))));
}
/* Note, eta should be positive if w is negative, and
eta should be negative otherwise. However,
if for some reason caused by roundoff, eta*w > 0,
we simply use one Newton step instead. This way
will guarantee eta*w < 0. */
if (w * eta > 0.f) {
eta = -w / (dpsi + dphi);
}
temp = tau + eta;
if (temp > dltub || temp < dltlb) {
if (w < 0.f) {
eta = (dltub - tau) / 2.f;
} else {
eta = (dltlb - tau) / 2.f;
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] -= eta;
/* L50: */
}
tau += eta;
/* Evaluate PSI and the derivative DPSI */
dpsi = 0.f;
psi = 0.f;
erretm = 0.f;
i__1 = ii;
for (j = 1; j <= i__1; ++j) {
temp = z__[j] / delta[j];
psi += z__[j] * temp;
dpsi += temp * temp;
erretm += psi;
/* L60: */
}
erretm = dabs(erretm);
/* Evaluate PHI and the derivative DPHI */
temp = z__[*n] / delta[*n];
phi = z__[*n] * temp;
dphi = temp * temp;
erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) * (
dpsi + dphi);
w = rhoinv + phi + psi;
/* Main loop to update the values of the array DELTA */
iter = niter + 1;
for (niter = iter; niter <= 30; ++niter) {
/* Test for convergence */
if (dabs(w) <= eps * erretm) {
*dlam = d__[*i__] + tau;
goto L250;
}
if (w <= 0.f) {
dltlb = dmax(dltlb,tau);
} else {
dltub = dmin(dltub,tau);
}
/* Calculate the new step */
c__ = w - delta[*n - 1] * dpsi - delta[*n] * dphi;
a = (delta[*n - 1] + delta[*n]) * w - delta[*n - 1] * delta[*n] *
(dpsi + dphi);
b = delta[*n - 1] * delta[*n] * w;
if (a >= 0.f) {
eta = (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
(c__ * 2.f);
} else {
eta = b * 2.f / (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(
r__1))));
}
/* Note, eta should be positive if w is negative, and
eta should be negative otherwise. However,
if for some reason caused by roundoff, eta*w > 0,
we simply use one Newton step instead. This way
will guarantee eta*w < 0. */
if (w * eta > 0.f) {
eta = -w / (dpsi + dphi);
}
temp = tau + eta;
if (temp > dltub || temp < dltlb) {
if (w < 0.f) {
eta = (dltub - tau) / 2.f;
} else {
eta = (dltlb - tau) / 2.f;
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] -= eta;
/* L70: */
}
tau += eta;
/* Evaluate PSI and the derivative DPSI */
dpsi = 0.f;
psi = 0.f;
erretm = 0.f;
i__1 = ii;
for (j = 1; j <= i__1; ++j) {
temp = z__[j] / delta[j];
psi += z__[j] * temp;
dpsi += temp * temp;
erretm += psi;
/* L80: */
}
erretm = dabs(erretm);
/* Evaluate PHI and the derivative DPHI */
temp = z__[*n] / delta[*n];
phi = z__[*n] * temp;
dphi = temp * temp;
erretm = (-phi - psi) * 8.f + erretm - phi + rhoinv + dabs(tau) *
(dpsi + dphi);
w = rhoinv + phi + psi;
/* L90: */
}
/* Return with INFO = 1, NITER = MAXIT and not converged */
*info = 1;
*dlam = d__[*i__] + tau;
goto L250;
/* End for the case I = N */
} else {
/* The case for I < N */
niter = 1;
ip1 = *i__ + 1;
/* Calculate initial guess */
del = d__[ip1] - d__[*i__];
midpt = del / 2.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] = d__[j] - d__[*i__] - midpt;
/* L100: */
}
psi = 0.f;
i__1 = *i__ - 1;
for (j = 1; j <= i__1; ++j) {
psi += z__[j] * z__[j] / delta[j];
/* L110: */
}
phi = 0.f;
i__1 = *i__ + 2;
for (j = *n; j >= i__1; --j) {
phi += z__[j] * z__[j] / delta[j];
/* L120: */
}
c__ = rhoinv + psi + phi;
w = c__ + z__[*i__] * z__[*i__] / delta[*i__] + z__[ip1] * z__[ip1] /
delta[ip1];
if (w > 0.f) {
/* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
We choose d(i) as origin. */
orgati = TRUE_;
a = c__ * del + z__[*i__] * z__[*i__] + z__[ip1] * z__[ip1];
b = z__[*i__] * z__[*i__] * del;
if (a > 0.f) {
tau = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
r__1))));
} else {
tau = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
(c__ * 2.f);
}
dltlb = 0.f;
dltub = midpt;
} else {
/* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
We choose d(i+1) as origin. */
orgati = FALSE_;
a = c__ * del - z__[*i__] * z__[*i__] - z__[ip1] * z__[ip1];
b = z__[ip1] * z__[ip1] * del;
if (a < 0.f) {
tau = b * 2.f / (a - sqrt((r__1 = a * a + b * 4.f * c__, dabs(
r__1))));
} else {
tau = -(a + sqrt((r__1 = a * a + b * 4.f * c__, dabs(r__1))))
/ (c__ * 2.f);
}
dltlb = -midpt;
dltub = 0.f;
}
if (orgati) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] = d__[j] - d__[*i__] - tau;
/* L130: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] = d__[j] - d__[ip1] - tau;
/* L140: */
}
}
if (orgati) {
ii = *i__;
} else {
ii = *i__ + 1;
}
iim1 = ii - 1;
iip1 = ii + 1;
/* Evaluate PSI and the derivative DPSI */
dpsi = 0.f;
psi = 0.f;
erretm = 0.f;
i__1 = iim1;
for (j = 1; j <= i__1; ++j) {
temp = z__[j] / delta[j];
psi += z__[j] * temp;
dpsi += temp * temp;
erretm += psi;
/* L150: */
}
erretm = dabs(erretm);
/* Evaluate PHI and the derivative DPHI */
dphi = 0.f;
phi = 0.f;
i__1 = iip1;
for (j = *n; j >= i__1; --j) {
temp = z__[j] / delta[j];
phi += z__[j] * temp;
dphi += temp * temp;
erretm += phi;
/* L160: */
}
w = rhoinv + phi + psi;
/* W is the value of the secular function with
its ii-th element removed. */
swtch3 = FALSE_;
if (orgati) {
if (w < 0.f) {
swtch3 = TRUE_;
}
} else {
if (w > 0.f) {
swtch3 = TRUE_;
}
}
if (ii == 1 || ii == *n) {
swtch3 = FALSE_;
}
temp = z__[ii] / delta[ii];
dw = dpsi + dphi + temp * temp;
temp = z__[ii] * temp;
w += temp;
erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
+ dabs(tau) * dw;
/* Test for convergence */
if (dabs(w) <= eps * erretm) {
if (orgati) {
*dlam = d__[*i__] + tau;
} else {
*dlam = d__[ip1] + tau;
}
goto L250;
}
if (w <= 0.f) {
dltlb = dmax(dltlb,tau);
} else {
dltub = dmin(dltub,tau);
}
/* Calculate the new step */
++niter;
if (! swtch3) {
if (orgati) {
/* Computing 2nd power */
r__1 = z__[*i__] / delta[*i__];
c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (r__1 *
r__1);
} else {
/* Computing 2nd power */
r__1 = z__[ip1] / delta[ip1];
c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) * (r__1 *
r__1);
}
a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1] *
dw;
b = delta[*i__] * delta[ip1] * w;
if (c__ == 0.f) {
if (a == 0.f) {
if (orgati) {
a = z__[*i__] * z__[*i__] + delta[ip1] * delta[ip1] *
(dpsi + dphi);
} else {
a = z__[ip1] * z__[ip1] + delta[*i__] * delta[*i__] *
(dpsi + dphi);
}
}
eta = b / a;
} else if (a <= 0.f) {
eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1)))) /
(c__ * 2.f);
} else {
eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__, dabs(
r__1))));
}
} else {
/* Interpolation using THREE most relevant poles */
temp = rhoinv + psi + phi;
if (orgati) {
temp1 = z__[iim1] / delta[iim1];
temp1 *= temp1;
c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1] - d__[
iip1]) * temp1;
zz[0] = z__[iim1] * z__[iim1];
zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 + dphi);
} else {
temp1 = z__[iip1] / delta[iip1];
temp1 *= temp1;
c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1] - d__[
iim1]) * temp1;
zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi - temp1));
zz[2] = z__[iip1] * z__[iip1];
}
zz[1] = z__[ii] * z__[ii];
slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta, info);
if (*info != 0) {
goto L250;
}
}
/* Note, eta should be positive if w is negative, and
eta should be negative otherwise. However,
if for some reason caused by roundoff, eta*w > 0,
we simply use one Newton step instead. This way
will guarantee eta*w < 0. */
if (w * eta >= 0.f) {
eta = -w / dw;
}
temp = tau + eta;
if (temp > dltub || temp < dltlb) {
if (w < 0.f) {
eta = (dltub - tau) / 2.f;
} else {
eta = (dltlb - tau) / 2.f;
}
}
prew = w;
/* L170: */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] -= eta;
/* L180: */
}
/* Evaluate PSI and the derivative DPSI */
dpsi = 0.f;
psi = 0.f;
erretm = 0.f;
i__1 = iim1;
for (j = 1; j <= i__1; ++j) {
temp = z__[j] / delta[j];
psi += z__[j] * temp;
dpsi += temp * temp;
erretm += psi;
/* L190: */
}
erretm = dabs(erretm);
/* Evaluate PHI and the derivative DPHI */
dphi = 0.f;
phi = 0.f;
i__1 = iip1;
for (j = *n; j >= i__1; --j) {
temp = z__[j] / delta[j];
phi += z__[j] * temp;
dphi += temp * temp;
erretm += phi;
/* L200: */
}
temp = z__[ii] / delta[ii];
dw = dpsi + dphi + temp * temp;
temp = z__[ii] * temp;
w = rhoinv + phi + psi + temp;
erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) * 3.f
+ (r__1 = tau + eta, dabs(r__1)) * dw;
swtch = FALSE_;
if (orgati) {
if (-w > dabs(prew) / 10.f) {
swtch = TRUE_;
}
} else {
if (w > dabs(prew) / 10.f) {
swtch = TRUE_;
}
}
tau += eta;
/* Main loop to update the values of the array DELTA */
iter = niter + 1;
for (niter = iter; niter <= 30; ++niter) {
/* Test for convergence */
if (dabs(w) <= eps * erretm) {
if (orgati) {
*dlam = d__[*i__] + tau;
} else {
*dlam = d__[ip1] + tau;
}
goto L250;
}
if (w <= 0.f) {
dltlb = dmax(dltlb,tau);
} else {
dltub = dmin(dltub,tau);
}
/* Calculate the new step */
if (! swtch3) {
if (! swtch) {
if (orgati) {
/* Computing 2nd power */
r__1 = z__[*i__] / delta[*i__];
c__ = w - delta[ip1] * dw - (d__[*i__] - d__[ip1]) * (
r__1 * r__1);
} else {
/* Computing 2nd power */
r__1 = z__[ip1] / delta[ip1];
c__ = w - delta[*i__] * dw - (d__[ip1] - d__[*i__]) *
(r__1 * r__1);
}
} else {
temp = z__[ii] / delta[ii];
if (orgati) {
dpsi += temp * temp;
} else {
dphi += temp * temp;
}
c__ = w - delta[*i__] * dpsi - delta[ip1] * dphi;
}
a = (delta[*i__] + delta[ip1]) * w - delta[*i__] * delta[ip1]
* dw;
b = delta[*i__] * delta[ip1] * w;
if (c__ == 0.f) {
if (a == 0.f) {
if (! swtch) {
if (orgati) {
a = z__[*i__] * z__[*i__] + delta[ip1] *
delta[ip1] * (dpsi + dphi);
} else {
a = z__[ip1] * z__[ip1] + delta[*i__] * delta[
*i__] * (dpsi + dphi);
}
} else {
a = delta[*i__] * delta[*i__] * dpsi + delta[ip1]
* delta[ip1] * dphi;
}
}
eta = b / a;
} else if (a <= 0.f) {
eta = (a - sqrt((r__1 = a * a - b * 4.f * c__, dabs(r__1))
)) / (c__ * 2.f);
} else {
eta = b * 2.f / (a + sqrt((r__1 = a * a - b * 4.f * c__,
dabs(r__1))));
}
} else {
/* Interpolation using THREE most relevant poles */
temp = rhoinv + psi + phi;
if (swtch) {
c__ = temp - delta[iim1] * dpsi - delta[iip1] * dphi;
zz[0] = delta[iim1] * delta[iim1] * dpsi;
zz[2] = delta[iip1] * delta[iip1] * dphi;
} else {
if (orgati) {
temp1 = z__[iim1] / delta[iim1];
temp1 *= temp1;
c__ = temp - delta[iip1] * (dpsi + dphi) - (d__[iim1]
- d__[iip1]) * temp1;
zz[0] = z__[iim1] * z__[iim1];
zz[2] = delta[iip1] * delta[iip1] * (dpsi - temp1 +
dphi);
} else {
temp1 = z__[iip1] / delta[iip1];
temp1 *= temp1;
c__ = temp - delta[iim1] * (dpsi + dphi) - (d__[iip1]
- d__[iim1]) * temp1;
zz[0] = delta[iim1] * delta[iim1] * (dpsi + (dphi -
temp1));
zz[2] = z__[iip1] * z__[iip1];
}
}
slaed6_(&niter, &orgati, &c__, &delta[iim1], zz, &w, &eta,
info);
if (*info != 0) {
goto L250;
}
}
/* Note, eta should be positive if w is negative, and
eta should be negative otherwise. However,
if for some reason caused by roundoff, eta*w > 0,
we simply use one Newton step instead. This way
will guarantee eta*w < 0. */
if (w * eta >= 0.f) {
eta = -w / dw;
}
temp = tau + eta;
if (temp > dltub || temp < dltlb) {
if (w < 0.f) {
eta = (dltub - tau) / 2.f;
} else {
eta = (dltlb - tau) / 2.f;
}
}
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
delta[j] -= eta;
/* L210: */
}
tau += eta;
prew = w;
/* Evaluate PSI and the derivative DPSI */
dpsi = 0.f;
psi = 0.f;
erretm = 0.f;
i__1 = iim1;
for (j = 1; j <= i__1; ++j) {
temp = z__[j] / delta[j];
psi += z__[j] * temp;
dpsi += temp * temp;
erretm += psi;
/* L220: */
}
erretm = dabs(erretm);
/* Evaluate PHI and the derivative DPHI */
dphi = 0.f;
phi = 0.f;
i__1 = iip1;
for (j = *n; j >= i__1; --j) {
temp = z__[j] / delta[j];
phi += z__[j] * temp;
dphi += temp * temp;
erretm += phi;
/* L230: */
}
temp = z__[ii] / delta[ii];
dw = dpsi + dphi + temp * temp;
temp = z__[ii] * temp;
w = rhoinv + phi + psi + temp;
erretm = (phi - psi) * 8.f + erretm + rhoinv * 2.f + dabs(temp) *
3.f + dabs(tau) * dw;
if (w * prew > 0.f && dabs(w) > dabs(prew) / 10.f) {
swtch = ! swtch;
}
/* L240: */
}
/* Return with INFO = 1, NITER = MAXIT and not converged */
*info = 1;
if (orgati) {
*dlam = d__[*i__] + tau;
} else {
*dlam = d__[ip1] + tau;
}
}
L250:
return 0;
/* End of SLAED4 */
} /* slaed4_ */
/* Subroutine */ int ssyevx_(char *jobz, char *range, char *uplo, integer *n,
real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu,
real *abstol, integer *m, real *w, real *z__, integer *ldz, real *
work, integer *lwork, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, nb, jj;
real eps, vll, vuu, tmp1;
integer indd, inde;
real anrm;
integer imax;
real rmin, rmax;
logical test;
integer itmp1, indee;
real sigma;
integer iinfo;
char order[1];
logical lower;
logical wantz, alleig, indeig;
integer iscale, indibl;
logical valeig;
real safmin;
real abstll, bignum;
integer indtau, indisp, indiwo, indwkn;
integer indwrk, lwkmin;
integer llwrkn, llwork, nsplit;
real smlnum;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SSYEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric matrix A. Eigenvalues and eigenvectors can be */
/* selected by specifying either a range of values or a range of indices */
/* for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* A (input/output) REAL array, dimension (LDA, N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, the lower triangle (if UPLO='L') or the upper */
/* triangle (if UPLO='U') of A, including the diagonal, is */
/* destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*SLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* On normal exit, the first M elements contain the selected */
/* eigenvalues in ascending order. */
/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and the */
/* index of the eigenvector is returned in IFAIL. */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= 1, when N <= 1; */
/* otherwise 8*N. */
/* For optimal efficiency, LWORK >= (NB+3)*N, */
/* where NB is the max of the blocksize for SSYTRD and SORMTR */
/* returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -8;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -9;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -10;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
}
}
if (*info == 0) {
if (*n <= 1) {
lwkmin = 1;
work[1] = (real) lwkmin;
} else {
lwkmin = *n << 3;
nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "SORMTR", uplo, n, &c_n1, &c_n1,
&c_n1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = lwkmin, i__2 = (nb + 3) * *n;
lwkopt = max(i__1,i__2);
work[1] = (real) lwkopt;
}
if (*lwork < lwkmin && ! lquery) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSYEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = a[a_dim1 + 1];
} else {
if (*vl < a[a_dim1 + 1] && *vu >= a[a_dim1 + 1]) {
*m = 1;
w[1] = a[a_dim1 + 1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = slansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
i__2 = *n - j + 1;
sscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
sscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
}
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call SSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
ssytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwrk], &llwork, &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal to */
/* zero, then call SSTERF or SORGTR and SSTEQR. If this fails for */
/* some eigenvalue, then try SSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.f) {
scopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssterf_(n, &w[1], &work[indee], info);
} else {
slacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
sorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
, &llwork, &iinfo);
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwrk], &iwork[indiwo], info);
if (wantz) {
sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by SSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
sormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[
z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (real) lwkopt;
return 0;
/* End of SSYEVX */
} /* ssyevx_ */
/* DECK CDSTP */
/* Subroutine */ int cdstp_(real *eps, S_fp f, U_fp fa, real *hmax, integer *
impl, integer *ierror, U_fp jacobn, integer *matdim, integer *maxord,
integer *mint, integer *miter, integer *ml, integer *mu, integer *n,
integer *nde, complex *ywt, real *uround, U_fp users, real *avgh,
real *avgord, real *h__, real *hused, integer *jtask, integer *mntold,
integer *mtrold, integer *nfe, integer *nje, integer *nqused,
integer *nstep, real *t, complex *y, complex *yh, complex *a, logical
*convrg, complex *dfdy, real *el, complex *fac, real *hold, integer *
ipvt, integer *jstate, integer *jstepl, integer *nq, integer *nwait,
real *rc, real *rmax, complex *save1, complex *save2, real *tq, real *
trend, integer *iswflg, integer *mtrsv, integer *mxrdsv)
{
/* Initialized data */
static logical ier = FALSE_;
/* System generated locals */
integer a_dim1, a_offset, dfdy_dim1, dfdy_offset, yh_dim1, yh_offset,
i__1, i__2, i__3, i__4, i__5, i__6;
real r__1, r__2, r__3;
doublereal d__1, d__2;
complex q__1, q__2;
/* Local variables */
static real d__;
static integer i__, j;
static real d1, hn, rh, hs, rh1, rh2, rh3, bnd;
static integer nsv;
static real erdn, told;
static integer iter;
static real erup;
static integer ntry;
static real y0nrm;
extern /* Subroutine */ int cdscl_(real *, integer *, integer *, real *,
real *, real *, real *, complex *);
static integer nfail;
extern /* Subroutine */ int cdcor_(complex *, real *, U_fp, real *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, real *, U_fp, complex
*, complex *, complex *, logical *, complex *, complex *, complex
*, real *, integer *), cdpsc_(integer *, integer *, integer *,
complex *), cdcst_(integer *, integer *, integer *, real *, real *
);
static real denom;
extern /* Subroutine */ int cdntl_(real *, S_fp, U_fp, real *, real *,
integer *, integer *, integer *, integer *, integer *, integer *,
integer *, integer *, integer *, integer *, complex *, real *,
real *, U_fp, complex *, complex *, real *, integer *, integer *,
integer *, real *, complex *, complex *, logical *, real *,
complex *, logical *, integer *, integer *, integer *, real *,
real *, complex *, real *, real *, integer *, integer *), cdpst_(
real *, S_fp, U_fp, real *, integer *, U_fp, integer *, integer *,
integer *, integer *, integer *, integer *, integer *, complex *,
real *, U_fp, complex *, complex *, complex *, real *, integer *,
integer *, complex *, complex *, complex *, logical *, integer *,
complex *, integer *, real *, integer *);
static real ctest, etest, numer;
extern doublereal scnrm2_(integer *, complex *, integer *);
static logical evalfa, evaljc, switch__;
/* ***BEGIN PROLOGUE CDSTP */
/* ***SUBSIDIARY */
/* ***PURPOSE CDSTP performs one step of the integration of an initial */
/* value problem for a system of ordinary differential */
/* equations. */
/* ***LIBRARY SLATEC (SDRIVE) */
/* ***TYPE COMPLEX (SDSTP-S, DDSTP-D, CDSTP-C) */
/* ***AUTHOR Kahaner, D. K., (NIST) */
/* National Institute of Standards and Technology */
/* Gaithersburg, MD 20899 */
/* Sutherland, C. D., (LANL) */
/* Mail Stop D466 */
/* Los Alamos National Laboratory */
/* Los Alamos, NM 87545 */
/* ***DESCRIPTION */
/* Communication with CDSTP is done with the following variables: */
/* YH An N by MAXORD+1 array containing the dependent variables */
/* and their scaled derivatives. MAXORD, the maximum order */
/* used, is currently 12 for the Adams methods and 5 for the */
/* Gear methods. YH(I,J+1) contains the J-th derivative of */
/* Y(I), scaled by H**J/factorial(J). Only Y(I), */
/* 1 .LE. I .LE. N, need be set by the calling program on */
/* the first entry. The YH array should not be altered by */
/* the calling program. When referencing YH as a */
/* 2-dimensional array, use a column length of N, as this is */
/* the value used in CDSTP. */
/* DFDY A block of locations used for partial derivatives if MITER */
/* is not 0. If MITER is 1 or 2 its length must be at least */
/* N*N. If MITER is 4 or 5 its length must be at least */
/* (2*ML+MU+1)*N. */
/* YWT An array of N locations used in convergence and error tests */
/* SAVE1 */
/* SAVE2 Arrays of length N used for temporary storage. */
/* IPVT An integer array of length N used by the linear system */
/* solvers for the storage of row interchange information. */
/* A A block of locations used to store the matrix A, when using */
/* the implicit method. If IMPL is 1, A is a MATDIM by N */
/* array. If MITER is 1 or 2 MATDIM is N, and if MITER is 4 */
/* or 5 MATDIM is 2*ML+MU+1. If IMPL is 2 its length is N. */
/* If IMPL is 3, A is a MATDIM by NDE array. */
/* JTASK An integer used on input. */
/* It has the following values and meanings: */
/* .EQ. 0 Perform the first step. This value enables */
/* the subroutine to initialize itself. */
/* .GT. 0 Take a new step continuing from the last. */
/* Assumes the last step was successful and */
/* user has not changed any parameters. */
/* .LT. 0 Take a new step with a new value of H and/or */
/* MINT and/or MITER. */
/* JSTATE A completion code with the following meanings: */
/* 1 The step was successful. */
/* 2 A solution could not be obtained with H .NE. 0. */
/* 3 A solution was not obtained in MXTRY attempts. */
/* 4 For IMPL .NE. 0, the matrix A is singular. */
/* On a return with JSTATE .GT. 1, the values of T and */
/* the YH array are as of the beginning of the last */
/* step, and H is the last step size attempted. */
/* ***ROUTINES CALLED CDCOR, CDCST, CDNTL, CDPSC, CDPST, CDSCL, SCNRM2 */
/* ***REVISION HISTORY (YYMMDD) */
/* 790601 DATE WRITTEN */
/* 900329 Initial submission to SLATEC. */
/* ***END PROLOGUE CDSTP */
/* Parameter adjustments */
dfdy_dim1 = *matdim;
dfdy_offset = 1 + dfdy_dim1;
dfdy -= dfdy_offset;
a_dim1 = *matdim;
a_offset = 1 + a_dim1;
a -= a_offset;
yh_dim1 = *n;
yh_offset = 1 + yh_dim1;
yh -= yh_offset;
--ywt;
--y;
el -= 14;
--fac;
--ipvt;
--save1;
--save2;
tq -= 4;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT CDSTP */
nsv = *n;
bnd = 0.f;
switch__ = FALSE_;
ntry = 0;
told = *t;
nfail = 0;
if (*jtask <= 0) {
cdntl_(eps, (S_fp)f, (U_fp)fa, hmax, hold, impl, jtask, matdim,
maxord, mint, miter, ml, mu, n, nde, &save1[1], t, uround, (
U_fp)users, &y[1], &ywt[1], h__, mntold, mtrold, nfe, rc, &yh[
yh_offset], &a[a_offset], convrg, &el[14], &fac[1], &ier, &
ipvt[1], nq, nwait, &rh, rmax, &save2[1], &tq[4], trend,
iswflg, jstate);
if (*n == 0) {
goto L440;
}
if (*h__ == 0.f) {
goto L400;
}
if (ier) {
goto L420;
}
}
L100:
++ntry;
if (ntry > 50) {
goto L410;
}
*t += *h__;
cdpsc_(&c__1, n, nq, &yh[yh_offset]);
evaljc = ((r__1 = *rc - 1.f, dabs(r__1)) > .3f || *nstep >= *jstepl + 10)
&& *miter != 0;
evalfa = ! evaljc;
L110:
iter = 0;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L115: */
i__2 = i__;
i__3 = i__ + yh_dim1;
y[i__2].r = yh[i__3].r, y[i__2].i = yh[i__3].i;
}
(*f)(n, t, &y[1], &save2[1]);
if (*n == 0) {
*jstate = 6;
goto L430;
}
++(*nfe);
if (evaljc || ier) {
cdpst_(&el[14], (S_fp)f, (U_fp)fa, h__, impl, (U_fp)jacobn, matdim,
miter, ml, mu, n, nde, nq, &save2[1], t, (U_fp)users, &y[1], &
yh[yh_offset], &ywt[1], uround, nfe, nje, &a[a_offset], &dfdy[
dfdy_offset], &fac[1], &ier, &ipvt[1], &save1[1], iswflg, &
bnd, jstate);
if (*n == 0) {
goto L430;
}
if (ier) {
goto L160;
}
*convrg = FALSE_;
*rc = 1.f;
*jstepl = *nstep;
}
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L125: */
i__3 = i__;
save1[i__3].r = 0.f, save1[i__3].i = 0.f;
}
/* Up to MXITER corrector iterations are taken. */
/* Convergence is tested by requiring the r.m.s. */
/* norm of changes to be less than EPS. The sum of */
/* the corrections is accumulated in the vector */
/* SAVE1(I). It is approximately equal to the L-th */
/* derivative of Y multiplied by */
/* H**L/(factorial(L-1)*EL(L,NQ)), and is thus */
/* proportional to the actual errors to the lowest */
/* power of H present (H**L). The YH array is not */
/* altered in the correction loop. The norm of the */
/* iterate difference is stored in D. If */
/* ITER .GT. 0, an estimate of the convergence rate */
/* constant is stored in TREND, and this is used in */
/* the convergence test. */
L130:
cdcor_(&dfdy[dfdy_offset], &el[14], (U_fp)fa, h__, ierror, impl, &ipvt[1],
matdim, miter, ml, mu, n, nde, nq, t, (U_fp)users, &y[1], &yh[
yh_offset], &ywt[1], &evalfa, &save1[1], &save2[1], &a[a_offset],
&d__, jstate);
if (*n == 0) {
goto L430;
}
if (*iswflg == 3 && *mint == 1) {
if (iter == 0) {
numer = scnrm2_(n, &save1[1], &c__1);
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L132: */
i__2 = i__ * dfdy_dim1 + 1;
i__1 = i__;
dfdy[i__2].r = save1[i__1].r, dfdy[i__2].i = save1[i__1].i;
}
y0nrm = scnrm2_(n, &yh[yh_offset], &c__1);
} else {
denom = numer;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L134: */
i__1 = i__ * dfdy_dim1 + 1;
i__3 = i__;
i__4 = i__ * dfdy_dim1 + 1;
q__1.r = save1[i__3].r - dfdy[i__4].r, q__1.i = save1[i__3].i
- dfdy[i__4].i;
dfdy[i__1].r = q__1.r, dfdy[i__1].i = q__1.i;
}
numer = scnrm2_(n, &dfdy[dfdy_offset], matdim);
if (el[*nq * 13 + 1] * numer <= *uround * 100.f * y0nrm) {
if (*rmax == 2.f) {
switch__ = TRUE_;
goto L170;
}
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L136: */
i__3 = i__ * dfdy_dim1 + 1;
i__4 = i__;
dfdy[i__3].r = save1[i__4].r, dfdy[i__3].i = save1[i__4].i;
}
if (denom != 0.f) {
/* Computing MAX */
r__1 = bnd, r__2 = numer / (denom * dabs(*h__) * el[*nq * 13
+ 1]);
bnd = dmax(r__1,r__2);
}
}
}
if (iter > 0) {
/* Computing MAX */
r__1 = *trend * .9f, r__2 = d__ / d1;
*trend = dmax(r__1,r__2);
}
d1 = d__;
/* Computing MIN */
r__1 = *trend * 2.f;
ctest = dmin(r__1,1.f) * d__;
if (ctest <= *eps) {
goto L170;
}
++iter;
if (iter < 3) {
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L140: */
i__4 = i__;
i__1 = i__ + yh_dim1;
i__2 = *nq * 13 + 1;
i__5 = i__;
q__2.r = el[i__2] * save1[i__5].r, q__2.i = el[i__2] * save1[i__5]
.i;
q__1.r = yh[i__1].r + q__2.r, q__1.i = yh[i__1].i + q__2.i;
y[i__4].r = q__1.r, y[i__4].i = q__1.i;
}
(*f)(n, t, &y[1], &save2[1]);
if (*n == 0) {
*jstate = 6;
goto L430;
}
++(*nfe);
goto L130;
}
/* The corrector iteration failed to converge in */
/* MXITER tries. If partials are involved but are */
/* not up to date, they are reevaluated for the next */
/* try. Otherwise the YH array is retracted to its */
/* values before prediction, and H is reduced, if */
/* possible. If not, a no-convergence exit is taken. */
if (*convrg) {
evaljc = TRUE_;
evalfa = FALSE_;
goto L110;
}
L160:
*t = told;
cdpsc_(&c_n1, n, nq, &yh[yh_offset]);
*nwait = *nq + 2;
if (*jtask != 0 && *jtask != 2) {
*rmax = 2.f;
}
if (iter == 0) {
rh = .3f;
} else {
d__1 = (doublereal) (*eps / ctest);
rh = pow_dd(&d__1, &c_b22) * .9f;
}
if (rh * *h__ == 0.f) {
goto L400;
}
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
goto L100;
/* The corrector has converged. CONVRG is set */
/* to .TRUE. if partial derivatives were used, */
/* to indicate that they may need updating on */
/* subsequent steps. The error test is made. */
L170:
*convrg = *miter != 0;
if (*ierror == 1 || *ierror == 5) {
i__4 = *nde;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L180: */
i__1 = i__;
c_div(&q__1, &save1[i__], &ywt[i__]);
save2[i__1].r = q__1.r, save2[i__1].i = q__1.i;
}
} else {
i__1 = *nde;
for (i__ = 1; i__ <= i__1; ++i__) {
/* L185: */
i__4 = i__;
i__2 = i__;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = save1[i__2].r / r__1, q__1.i = save1[i__2].i / r__1;
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
}
}
etest = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 2] * sqrt((real) (*
nde)));
/* The error test failed. NFAIL keeps track of */
/* multiple failures. Restore T and the YH */
/* array to their previous values, and prepare */
/* to try the step again. Compute the optimum */
/* step size for this or one lower order. */
if (etest > *eps) {
*t = told;
cdpsc_(&c_n1, n, nq, &yh[yh_offset]);
++nfail;
if (nfail < 3 || *nq == 1) {
if (*jtask != 0 && *jtask != 2) {
*rmax = 2.f;
}
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
rh2 = 1.f / (pow_dd(&d__1, &d__2) * 1.2f);
if (*nq > 1) {
if (*ierror == 1 || *ierror == 5) {
i__4 = *nde;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L190: */
i__2 = i__;
c_div(&q__1, &yh[i__ + (*nq + 1) * yh_dim1], &ywt[i__]
);
save2[i__2].r = q__1.r, save2[i__2].i = q__1.i;
}
} else {
i__2 = *nde;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L195: */
i__4 = i__;
i__1 = i__ + (*nq + 1) * yh_dim1;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = yh[i__1].r / r__1, q__1.i = yh[i__1].i /
r__1;
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
}
}
erdn = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 1] *
sqrt((real) (*nde)));
/* Computing MAX */
d__1 = (doublereal) (erdn / *eps);
d__2 = (doublereal) (1.f / *nq);
r__1 = 1.f, r__2 = pow_dd(&d__1, &d__2) * 1.3f;
rh1 = 1.f / dmax(r__1,r__2);
if (rh2 < rh1) {
--(*nq);
*rc = *rc * el[*nq * 13 + 1] / el[(*nq + 1) * 13 + 1];
rh = rh1;
} else {
rh = rh2;
}
} else {
rh = rh2;
}
*nwait = *nq + 2;
if (rh * *h__ == 0.f) {
goto L400;
}
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
goto L100;
}
/* Control reaches this section if the error test has */
/* failed MXFAIL or more times. It is assumed that the */
/* derivatives that have accumulated in the YH array have */
/* errors of the wrong order. Hence the first derivative */
/* is recomputed, the order is set to 1, and the step is */
/* retried. */
nfail = 0;
*jtask = 2;
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L215: */
i__1 = i__;
i__2 = i__ + yh_dim1;
y[i__1].r = yh[i__2].r, y[i__1].i = yh[i__2].i;
}
cdntl_(eps, (S_fp)f, (U_fp)fa, hmax, hold, impl, jtask, matdim,
maxord, mint, miter, ml, mu, n, nde, &save1[1], t, uround, (
U_fp)users, &y[1], &ywt[1], h__, mntold, mtrold, nfe, rc, &yh[
yh_offset], &a[a_offset], convrg, &el[14], &fac[1], &ier, &
ipvt[1], nq, nwait, &rh, rmax, &save2[1], &tq[4], trend,
iswflg, jstate);
*rmax = 10.f;
if (*n == 0) {
goto L440;
}
if (*h__ == 0.f) {
goto L400;
}
if (ier) {
goto L420;
}
goto L100;
}
/* After a successful step, update the YH array. */
++(*nstep);
*hused = *h__;
*nqused = *nq;
*avgh = ((*nstep - 1) * *avgh + *h__) / *nstep;
*avgord = ((*nstep - 1) * *avgord + *nq) / *nstep;
i__1 = *nq + 1;
for (j = 1; j <= i__1; ++j) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
/* L230: */
i__4 = i__ + j * yh_dim1;
i__5 = i__ + j * yh_dim1;
i__3 = j + *nq * 13;
i__6 = i__;
q__2.r = el[i__3] * save1[i__6].r, q__2.i = el[i__3] * save1[i__6]
.i;
q__1.r = yh[i__5].r + q__2.r, q__1.i = yh[i__5].i + q__2.i;
yh[i__4].r = q__1.r, yh[i__4].i = q__1.i;
}
}
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L235: */
i__5 = i__;
i__3 = i__ + yh_dim1;
y[i__5].r = yh[i__3].r, y[i__5].i = yh[i__3].i;
}
/* If ISWFLG is 3, consider */
/* changing integration methods. */
if (*iswflg == 3) {
if (bnd != 0.f) {
if (*mint == 1 && *nq <= 5) {
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hn = dabs(*h__) / dmax(r__1,r__2);
/* Computing MIN */
r__1 = hn, r__2 = 1.f / (el[*nq * 13 + 1] * 2.f * bnd);
hn = dmin(r__1,r__2);
/* Computing MAX */
d__1 = (doublereal) (etest / (*eps * el[*nq + 14]));
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hs = dabs(*h__) / dmax(r__1,r__2);
if (hs > hn * 1.2f) {
*mint = 2;
*mntold = *mint;
*miter = *mtrsv;
*mtrold = *miter;
*maxord = min(*mxrdsv,5);
*rc = 0.f;
*rmax = 10.f;
*trend = 1.f;
cdcst_(maxord, mint, iswflg, &el[14], &tq[4]);
*nwait = *nq + 2;
}
} else if (*mint == 2) {
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hs = dabs(*h__) / dmax(r__1,r__2);
/* Computing MAX */
d__1 = (doublereal) (etest * el[*nq + 14] / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2);
hn = dabs(*h__) / dmax(r__1,r__2);
/* Computing MIN */
r__1 = hn, r__2 = 1.f / (el[*nq * 13 + 1] * 2.f * bnd);
hn = dmin(r__1,r__2);
if (hn >= hs) {
*mint = 1;
*mntold = *mint;
*miter = 0;
*mtrold = *miter;
*maxord = min(*mxrdsv,12);
*rmax = 10.f;
*trend = 1.f;
*convrg = FALSE_;
cdcst_(maxord, mint, iswflg, &el[14], &tq[4]);
*nwait = *nq + 2;
}
}
}
}
if (switch__) {
*mint = 2;
*mntold = *mint;
*miter = *mtrsv;
*mtrold = *miter;
*maxord = min(*mxrdsv,5);
*nq = min(*nq,*maxord);
*rc = 0.f;
*rmax = 10.f;
*trend = 1.f;
cdcst_(maxord, mint, iswflg, &el[14], &tq[4]);
*nwait = *nq + 2;
}
/* Consider changing H if NWAIT = 1. Otherwise */
/* decrease NWAIT by 1. If NWAIT is then 1 and */
/* NQ.LT.MAXORD, then SAVE1 is saved for use in */
/* a possible order increase on the next step. */
if (*jtask == 0 || *jtask == 2) {
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.2f;
rh = 1.f / dmax(r__1,r__2);
if (rh > 1.f) {
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
}
} else if (*nwait > 1) {
--(*nwait);
if (*nwait == 1 && *nq < *maxord) {
i__5 = *nde;
for (i__ = 1; i__ <= i__5; ++i__) {
/* L250: */
i__3 = i__ + (*maxord + 1) * yh_dim1;
i__4 = i__;
yh[i__3].r = save1[i__4].r, yh[i__3].i = save1[i__4].i;
}
}
/* If a change in H is considered, an increase or decrease in */
/* order by one is considered also. A change in H is made */
/* only if it is by a factor of at least TRSHLD. Factors */
/* RH1, RH2, and RH3 are computed, by which H could be */
/* multiplied at order NQ - 1, order NQ, or order NQ + 1, */
/* respectively. The largest of these is determined and the */
/* new order chosen accordingly. If the order is to be */
/* increased, we compute one additional scaled derivative. */
/* If there is a change of order, reset NQ and the */
/* coefficients. In any case H is reset according to RH and */
/* the YH array is rescaled. */
} else {
if (*nq == 1) {
rh1 = 0.f;
} else {
if (*ierror == 1 || *ierror == 5) {
i__3 = *nde;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L270: */
i__4 = i__;
c_div(&q__1, &yh[i__ + (*nq + 1) * yh_dim1], &ywt[i__]);
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
}
} else {
i__4 = *nde;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L275: */
i__3 = i__;
i__5 = i__ + (*nq + 1) * yh_dim1;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = yh[i__5].r / r__1, q__1.i = yh[i__5].i / r__1;
save2[i__3].r = q__1.r, save2[i__3].i = q__1.i;
}
}
erdn = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 1] * sqrt((
real) (*nde)));
/* Computing MAX */
d__1 = (doublereal) (erdn / *eps);
d__2 = (doublereal) (1.f / *nq);
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.3f;
rh1 = 1.f / dmax(r__1,r__2);
}
/* Computing MAX */
d__1 = (doublereal) (etest / *eps);
d__2 = (doublereal) (1.f / (*nq + 1));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.2f;
rh2 = 1.f / dmax(r__1,r__2);
if (*nq == *maxord) {
rh3 = 0.f;
} else {
if (*ierror == 1 || *ierror == 5) {
i__3 = *nde;
for (i__ = 1; i__ <= i__3; ++i__) {
/* L290: */
i__5 = i__;
i__4 = i__;
i__6 = i__ + (*maxord + 1) * yh_dim1;
q__2.r = save1[i__4].r - yh[i__6].r, q__2.i = save1[i__4]
.i - yh[i__6].i;
c_div(&q__1, &q__2, &ywt[i__]);
save2[i__5].r = q__1.r, save2[i__5].i = q__1.i;
}
} else {
i__5 = *nde;
for (i__ = 1; i__ <= i__5; ++i__) {
i__4 = i__;
i__6 = i__;
i__3 = i__ + (*maxord + 1) * yh_dim1;
q__2.r = save1[i__6].r - yh[i__3].r, q__2.i = save1[i__6]
.i - yh[i__3].i;
/* Computing MAX */
r__2 = c_abs(&y[i__]), r__3 = c_abs(&ywt[i__]);
r__1 = dmax(r__2,r__3);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
save2[i__4].r = q__1.r, save2[i__4].i = q__1.i;
/* L295: */
}
}
erup = scnrm2_(nde, &save2[1], &c__1) / (tq[*nq * 3 + 3] * sqrt((
real) (*nde)));
/* Computing MAX */
d__1 = (doublereal) (erup / *eps);
d__2 = (doublereal) (1.f / (*nq + 2));
r__1 = *uround, r__2 = pow_dd(&d__1, &d__2) * 1.4f;
rh3 = 1.f / dmax(r__1,r__2);
}
if (rh1 > rh2 && rh1 >= rh3) {
rh = rh1;
if (rh <= 1.f) {
goto L380;
}
--(*nq);
*rc = *rc * el[*nq * 13 + 1] / el[(*nq + 1) * 13 + 1];
} else if (rh2 >= rh1 && rh2 >= rh3) {
rh = rh2;
if (rh <= 1.f) {
goto L380;
}
} else {
rh = rh3;
if (rh <= 1.f) {
goto L380;
}
i__5 = *n;
for (i__ = 1; i__ <= i__5; ++i__) {
/* L360: */
i__4 = i__ + (*nq + 2) * yh_dim1;
i__6 = i__;
i__3 = *nq + 1 + *nq * 13;
q__2.r = el[i__3] * save1[i__6].r, q__2.i = el[i__3] * save1[
i__6].i;
i__2 = *nq + 1;
d__1 = (doublereal) i__2;
q__1.r = q__2.r / d__1, q__1.i = q__2.i / d__1;
yh[i__4].r = q__1.r, yh[i__4].i = q__1.i;
}
++(*nq);
*rc = *rc * el[*nq * 13 + 1] / el[(*nq - 1) * 13 + 1];
}
if (*iswflg == 3 && *mint == 1) {
if (bnd != 0.f) {
/* Computing MIN */
r__1 = rh, r__2 = 1.f / (el[*nq * 13 + 1] * 2.f * bnd * dabs(*
h__));
rh = dmin(r__1,r__2);
}
}
cdscl_(hmax, n, nq, rmax, h__, rc, &rh, &yh[yh_offset]);
*rmax = 10.f;
L380:
*nwait = *nq + 2;
}
/* All returns are made through this section. H is saved */
/* in HOLD to allow the caller to change H on the next step */
*jstate = 1;
*hold = *h__;
return 0;
L400:
*jstate = 2;
*hold = *h__;
i__4 = *n;
for (i__ = 1; i__ <= i__4; ++i__) {
/* L405: */
i__6 = i__;
i__3 = i__ + yh_dim1;
y[i__6].r = yh[i__3].r, y[i__6].i = yh[i__3].i;
}
return 0;
L410:
*jstate = 3;
*hold = *h__;
return 0;
L420:
*jstate = 4;
*hold = *h__;
return 0;
L430:
*t = told;
cdpsc_(&c_n1, &nsv, nq, &yh[yh_offset]);
i__6 = nsv;
for (i__ = 1; i__ <= i__6; ++i__) {
/* L435: */
i__3 = i__;
i__4 = i__ + yh_dim1;
y[i__3].r = yh[i__4].r, y[i__3].i = yh[i__4].i;
}
L440:
*hold = *h__;
return 0;
} /* cdstp_ */
/* Subroutine */ int slatbs_(char *uplo, char *trans, char *diag, char *
normin, integer *n, integer *kd, real *ab, integer *ldab, real *x,
real *scale, real *cnorm, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3;
/* Local variables */
integer i__, j;
real xj, rec, tjj;
integer jinc, jlen;
real xbnd;
integer imax;
real tmax, tjjs;
extern doublereal sdot_(integer *, real *, integer *, real *, integer *);
real xmax, grow, sumj;
integer maind;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
real tscal, uscal;
integer jlast;
extern doublereal sasum_(integer *, real *, integer *);
logical upper;
extern /* Subroutine */ int stbsv_(char *, char *, char *, integer *,
integer *, real *, integer *, real *, integer *), saxpy_(integer *, real *, real *, integer *, real *,
integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
extern integer isamax_(integer *, real *, integer *);
logical notran;
integer jfirst;
real smlnum;
logical nounit;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLATBS solves one of the triangular systems */
/* A *x = s*b or A'*x = s*b */
/* with scaling to prevent overflow, where A is an upper or lower */
/* triangular band matrix. Here A' denotes the transpose of A, x and b */
/* are n-element vectors, and s is a scaling factor, usually less than */
/* or equal to 1, chosen so that the components of x will be less than */
/* the overflow threshold. If the unscaled problem will not cause */
/* overflow, the Level 2 BLAS routine STBSV is called. If the matrix A */
/* is singular (A(j,j) = 0 for some j), then s is set to 0 and a */
/* non-trivial solution to A*x = 0 is returned. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to A. */
/* = 'N': Solve A * x = s*b (No transpose) */
/* = 'T': Solve A'* x = s*b (Transpose) */
/* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* NORMIN (input) CHARACTER*1 */
/* Specifies whether CNORM has been set or not. */
/* = 'Y': CNORM contains the column norms on entry */
/* = 'N': CNORM is not set on entry. On exit, the norms will */
/* be computed and stored in CNORM. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of subdiagonals or superdiagonals in the */
/* triangular matrix A. KD >= 0. */
/* AB (input) REAL array, dimension (LDAB,N) */
/* The upper or lower triangular band matrix A, stored in the */
/* first KD+1 rows of the array. The j-th column of A is stored */
/* in the j-th column of the array AB as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD+1. */
/* X (input/output) REAL array, dimension (N) */
/* On entry, the right hand side b of the triangular system. */
/* On exit, X is overwritten by the solution vector x. */
/* SCALE (output) REAL */
/* The scaling factor s for the triangular system */
/* A * x = s*b or A'* x = s*b. */
/* If SCALE = 0, the matrix A is singular or badly scaled, and */
/* the vector x is an exact or approximate solution to A*x = 0. */
/* CNORM (input or output) REAL array, dimension (N) */
/* If NORMIN = 'Y', CNORM is an input argument and CNORM(j) */
/* contains the norm of the off-diagonal part of the j-th column */
/* of A. If TRANS = 'N', CNORM(j) must be greater than or equal */
/* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j) */
/* must be greater than or equal to the 1-norm. */
/* If NORMIN = 'N', CNORM is an output argument and CNORM(j) */
/* returns the 1-norm of the offdiagonal part of the j-th column */
/* of A. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* Further Details */
/* ======= ======= */
/* A rough bound on x is computed; if that is less than overflow, STBSV */
/* is called, otherwise, specific code is used which checks for possible */
/* overflow or divide-by-zero at every operation. */
/* A columnwise scheme is used for solving A*x = b. The basic algorithm */
/* if A is lower triangular is */
/* x[1:n] := b[1:n] */
/* for j = 1, ..., n */
/* x(j) := x(j) / A(j,j) */
/* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j] */
/* end */
/* Define bounds on the components of x after j iterations of the loop: */
/* M(j) = bound on x[1:j] */
/* G(j) = bound on x[j+1:n] */
/* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}. */
/* Then for iteration j+1 we have */
/* M(j+1) <= G(j) / | A(j+1,j+1) | */
/* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] | */
/* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | ) */
/* where CNORM(j+1) is greater than or equal to the infinity-norm of */
/* column j+1 of A, not counting the diagonal. Hence */
/* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | ) */
/* 1<=i<=j */
/* and */
/* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| ) */
/* 1<=i< j */
/* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the */
/* reciprocal of the largest M(j), j=1,..,n, is larger than */
/* max(underflow, 1/overflow). */
/* The bound on x(j) is also used to determine when a step in the */
/* columnwise method can be performed without fear of overflow. If */
/* the computed bound is greater than a large constant, x is scaled to */
/* prevent overflow, but if the bound overflows, x is set to 0, x(j) to */
/* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found. */
/* Similarly, a row-wise scheme is used to solve A'*x = b. The basic */
/* algorithm for A upper triangular is */
/* for j = 1, ..., n */
/* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j) */
/* end */
/* We simultaneously compute two bounds */
/* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j */
/* M(j) = bound on x(i), 1<=i<=j */
/* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we */
/* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1. */
/* Then the bound on x(j) is */
/* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) | */
/* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| ) */
/* 1<=i<=j */
/* and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater */
/* than max(underflow, 1/overflow). */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--x;
--cnorm;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
nounit = lsame_(diag, "N");
/* Test the input parameters. */
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! notran && ! lsame_(trans, "T") && !
lsame_(trans, "C")) {
*info = -2;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -3;
} else if (! lsame_(normin, "Y") && ! lsame_(normin,
"N")) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*kd < 0) {
*info = -6;
} else if (*ldab < *kd + 1) {
*info = -8;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SLATBS", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine machine dependent parameters to control overflow. */
smlnum = slamch_("Safe minimum") / slamch_("Precision");
bignum = 1.f / smlnum;
*scale = 1.f;
if (lsame_(normin, "N")) {
/* Compute the 1-norm of each column, not including the diagonal. */
if (upper) {
/* A is upper triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = j - 1;
jlen = min(i__2,i__3);
cnorm[j] = sasum_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1], &
c__1);
/* L10: */
}
} else {
/* A is lower triangular. */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
i__2 = *kd, i__3 = *n - j;
jlen = min(i__2,i__3);
if (jlen > 0) {
cnorm[j] = sasum_(&jlen, &ab[j * ab_dim1 + 2], &c__1);
} else {
cnorm[j] = 0.f;
}
/* L20: */
}
}
}
/* Scale the column norms by TSCAL if the maximum element in CNORM is */
/* greater than BIGNUM. */
imax = isamax_(n, &cnorm[1], &c__1);
tmax = cnorm[imax];
if (tmax <= bignum) {
tscal = 1.f;
} else {
tscal = 1.f / (smlnum * tmax);
sscal_(n, &tscal, &cnorm[1], &c__1);
}
/* Compute a bound on the computed solution vector to see if the */
/* Level 2 BLAS routine STBSV can be used. */
j = isamax_(n, &x[1], &c__1);
xmax = (r__1 = x[j], dabs(r__1));
xbnd = xmax;
if (notran) {
/* Compute the growth in A * x = b. */
if (upper) {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = *kd + 1;
} else {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L50;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, G(0) = max{x(i), i=1,...,n}. */
grow = 1.f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L50;
}
/* M(j) = G(j-1) / abs(A(j,j)) */
tjj = (r__1 = ab[maind + j * ab_dim1], dabs(r__1));
/* Computing MIN */
r__1 = xbnd, r__2 = dmin(1.f,tjj) * grow;
xbnd = dmin(r__1,r__2);
if (tjj + cnorm[j] >= smlnum) {
/* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) ) */
grow *= tjj / (tjj + cnorm[j]);
} else {
/* G(j) could overflow, set GROW to 0. */
grow = 0.f;
}
/* L30: */
}
grow = xbnd;
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L50;
}
/* G(j) = G(j-1)*( 1 + CNORM(j) ) */
grow *= 1.f / (cnorm[j] + 1.f);
/* L40: */
}
}
L50:
;
} else {
/* Compute the growth in A' * x = b. */
if (upper) {
jfirst = 1;
jlast = *n;
jinc = 1;
maind = *kd + 1;
} else {
jfirst = *n;
jlast = 1;
jinc = -1;
maind = 1;
}
if (tscal != 1.f) {
grow = 0.f;
goto L80;
}
if (nounit) {
/* A is non-unit triangular. */
/* Compute GROW = 1/G(j) and XBND = 1/M(j). */
/* Initially, M(0) = max{x(i), i=1,...,n}. */
grow = 1.f / dmax(xbnd,smlnum);
xbnd = grow;
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) ) */
xj = cnorm[j] + 1.f;
/* Computing MIN */
r__1 = grow, r__2 = xbnd / xj;
grow = dmin(r__1,r__2);
/* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j)) */
tjj = (r__1 = ab[maind + j * ab_dim1], dabs(r__1));
if (xj > tjj) {
xbnd *= tjj / xj;
}
/* L60: */
}
grow = dmin(grow,xbnd);
} else {
/* A is unit triangular. */
/* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}. */
/* Computing MIN */
r__1 = 1.f, r__2 = 1.f / dmax(xbnd,smlnum);
grow = dmin(r__1,r__2);
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Exit the loop if the growth factor is too small. */
if (grow <= smlnum) {
goto L80;
}
/* G(j) = ( 1 + CNORM(j) )*G(j-1) */
xj = cnorm[j] + 1.f;
grow /= xj;
/* L70: */
}
}
L80:
;
}
if (grow * tscal > smlnum) {
/* Use the Level 2 BLAS solve if the reciprocal of the bound on */
/* elements of X is not too small. */
stbsv_(uplo, trans, diag, n, kd, &ab[ab_offset], ldab, &x[1], &c__1);
} else {
/* Use a Level 1 BLAS solve, scaling intermediate results. */
if (xmax > bignum) {
/* Scale X so that its components are less than or equal to */
/* BIGNUM in absolute value. */
*scale = bignum / xmax;
sscal_(n, scale, &x[1], &c__1);
xmax = bignum;
}
if (notran) {
/* Solve A * x = b */
i__1 = jlast;
i__2 = jinc;
for (j = jfirst; i__2 < 0 ? j >= i__1 : j <= i__1; j += i__2) {
/* Compute x(j) = b(j) / A(j,j), scaling x if necessary. */
xj = (r__1 = x[j], dabs(r__1));
if (nounit) {
tjjs = ab[maind + j * ab_dim1] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.f) {
goto L95;
}
}
tjj = dabs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale x by 1/b(j). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
xj = (r__1 = x[j], dabs(r__1));
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM */
/* to avoid overflow when dividing by A(j,j). */
rec = tjj * bignum / xj;
if (cnorm[j] > 1.f) {
/* Scale by 1/CNORM(j) to avoid overflow when */
/* multiplying x(j) times column j. */
rec /= cnorm[j];
}
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
xj = (r__1 = x[j], dabs(r__1));
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__] = 0.f;
/* L90: */
}
x[j] = 1.f;
xj = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L95:
/* Scale x if necessary to avoid overflow when adding a */
/* multiple of column j of A. */
if (xj > 1.f) {
rec = 1.f / xj;
if (cnorm[j] > (bignum - xmax) * rec) {
/* Scale x by 1/(2*abs(x(j))). */
rec *= .5f;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
}
} else if (xj * cnorm[j] > bignum - xmax) {
/* Scale x by 1/2. */
sscal_(n, &c_b36, &x[1], &c__1);
*scale *= .5f;
}
if (upper) {
if (j > 1) {
/* Compute the update */
/* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) - */
/* x(j)* A(max(1,j-kd):j-1,j) */
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
r__1 = -x[j] * tscal;
saxpy_(&jlen, &r__1, &ab[*kd + 1 - jlen + j * ab_dim1]
, &c__1, &x[j - jlen], &c__1);
i__3 = j - 1;
i__ = isamax_(&i__3, &x[1], &c__1);
xmax = (r__1 = x[i__], dabs(r__1));
}
} else if (j < *n) {
/* Compute the update */
/* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) - */
/* x(j) * A(j+1:min(j+kd,n),j) */
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
r__1 = -x[j] * tscal;
saxpy_(&jlen, &r__1, &ab[j * ab_dim1 + 2], &c__1, &x[
j + 1], &c__1);
}
i__3 = *n - j;
i__ = j + isamax_(&i__3, &x[j + 1], &c__1);
xmax = (r__1 = x[i__], dabs(r__1));
}
/* L100: */
}
} else {
/* Solve A' * x = b */
i__2 = jlast;
i__1 = jinc;
for (j = jfirst; i__1 < 0 ? j >= i__2 : j <= i__2; j += i__1) {
/* Compute x(j) = b(j) - sum A(k,j)*x(k). */
/* k<>j */
xj = (r__1 = x[j], dabs(r__1));
uscal = tscal;
rec = 1.f / dmax(xmax,1.f);
if (cnorm[j] > (bignum - xj) * rec) {
/* If x(j) could overflow, scale x by 1/(2*XMAX). */
rec *= .5f;
if (nounit) {
tjjs = ab[maind + j * ab_dim1] * tscal;
} else {
tjjs = tscal;
}
tjj = dabs(tjjs);
if (tjj > 1.f) {
/* Divide by A(j,j) when scaling x if A(j,j) > 1. */
/* Computing MIN */
r__1 = 1.f, r__2 = rec * tjj;
rec = dmin(r__1,r__2);
uscal /= tjjs;
}
if (rec < 1.f) {
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
sumj = 0.f;
if (uscal == 1.f) {
/* If the scaling needed for A in the dot product is 1, */
/* call SDOT to perform the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
sumj = sdot_(&jlen, &ab[*kd + 1 - jlen + j * ab_dim1],
&c__1, &x[j - jlen], &c__1);
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
if (jlen > 0) {
sumj = sdot_(&jlen, &ab[j * ab_dim1 + 2], &c__1, &
x[j + 1], &c__1);
}
}
} else {
/* Otherwise, use in-line code for the dot product. */
if (upper) {
/* Computing MIN */
i__3 = *kd, i__4 = j - 1;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ab[*kd + i__ - jlen + j * ab_dim1] *
uscal * x[j - jlen - 1 + i__];
/* L110: */
}
} else {
/* Computing MIN */
i__3 = *kd, i__4 = *n - j;
jlen = min(i__3,i__4);
i__3 = jlen;
for (i__ = 1; i__ <= i__3; ++i__) {
sumj += ab[i__ + 1 + j * ab_dim1] * uscal * x[j +
i__];
/* L120: */
}
}
}
if (uscal == tscal) {
/* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j) */
/* was not used to scale the dotproduct. */
x[j] -= sumj;
xj = (r__1 = x[j], dabs(r__1));
if (nounit) {
/* Compute x(j) = x(j) / A(j,j), scaling if necessary. */
tjjs = ab[maind + j * ab_dim1] * tscal;
} else {
tjjs = tscal;
if (tscal == 1.f) {
goto L135;
}
}
tjj = dabs(tjjs);
if (tjj > smlnum) {
/* abs(A(j,j)) > SMLNUM: */
if (tjj < 1.f) {
if (xj > tjj * bignum) {
/* Scale X by 1/abs(x(j)). */
rec = 1.f / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
}
x[j] /= tjjs;
} else if (tjj > 0.f) {
/* 0 < abs(A(j,j)) <= SMLNUM: */
if (xj > tjj * bignum) {
/* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM. */
rec = tjj * bignum / xj;
sscal_(n, &rec, &x[1], &c__1);
*scale *= rec;
xmax *= rec;
}
x[j] /= tjjs;
} else {
/* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and */
/* scale = 0, and compute a solution to A'*x = 0. */
i__3 = *n;
for (i__ = 1; i__ <= i__3; ++i__) {
x[i__] = 0.f;
/* L130: */
}
x[j] = 1.f;
*scale = 0.f;
xmax = 0.f;
}
L135:
;
} else {
/* Compute x(j) := x(j) / A(j,j) - sumj if the dot */
/* product has already been divided by 1/A(j,j). */
x[j] = x[j] / tjjs - sumj;
}
/* Computing MAX */
r__2 = xmax, r__3 = (r__1 = x[j], dabs(r__1));
xmax = dmax(r__2,r__3);
/* L140: */
}
}
*scale /= tscal;
}
/* Scale the column norms by 1/TSCAL for return. */
if (tscal != 1.f) {
r__1 = 1.f / tscal;
sscal_(n, &r__1, &cnorm[1], &c__1);
}
return 0;
/* End of SLATBS */
} /* slatbs_ */
/* Subroutine */ int CPraxis::min_(C_INT *n, C_INT *j, C_INT *nits, C_FLOAT64 *
d2, C_FLOAT64 *x1, C_FLOAT64 *f1, bool *fk, FPraxis *f, C_FLOAT64 *
x, C_FLOAT64 *t, C_FLOAT64 *machep, C_FLOAT64 *h__)
{
/* System generated locals */
C_INT i__1;
C_FLOAT64 d__1, d__2;
/* Local variables */
static C_FLOAT64 temp;
static C_INT i__, k;
static C_FLOAT64 s, small, d1, f0, f2, m2, m4, t2, x2, fm;
static bool dz;
static C_FLOAT64 xm, sf1, sx1;
/* ...THE SUBROUTINE MIN MINIMIZES F FROM X IN THE DIRECTION V(*,J) UNLESS */
/* J IS LESS THAN 1, WHEN A QUADRATIC SEARCH IS MADE IN THE PLANE */
/* DEFINED BY Q0,Q1,X. */
/* D2 IS EITHER ZERO OR AN APPROXIMATION TO HALF F". */
/* ON ENTRY, X1 IS AN ESTIMATE OF THE DISTANCE FROM X TO THE MINIMUM */
/* ALONG V(*,J) (OR, IF J=0, A CURVE). ON RETURN, X1 IS THE DISTANCE */
/* FOUND. */
/* IF FK=.TRUE., THEN F1 IS FLIN(X1). OTHERWISE X1 AND F1 ARE IGNORED */
/* ON ENTRY UNLESS FINAL FX IS GREATER THAN F1. */
/* NITS CONTROLS THE NUMBER OF TIMES AN ATTEMPT WILL BE MADE TO HALVE */
/* THE INTERVAL. */
/* Parameter adjustments */
--x;
/* Function Body */
/* Computing 2nd power */
d__1 = *machep;
small = d__1 * d__1;
m2 = sqrt(*machep);
m4 = sqrt(m2);
sf1 = *f1;
sx1 = *x1;
k = 0;
xm = 0.;
fm = global_1.fx;
f0 = global_1.fx;
dz = *d2 < *machep;
/* ...FIND THE STEP SIZE... */
s = 0.;
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__)
{
/* L1: */
/* Computing 2nd power */
d__1 = x[i__];
s += d__1 * d__1;
}
s = sqrt(s);
temp = *d2;
if (dz)
{
temp = global_1.dmin__;
}
t2 = m4 * sqrt(fabs(global_1.fx) / temp + s * global_1.ldt) + m2 *
global_1.ldt;
s = m4 * s + *t;
if (dz && t2 > s)
{
t2 = s;
}
t2 = dmax(t2, small);
/* Computing MIN */
d__1 = t2, d__2 = *h__ * .01;
t2 = dmin(d__1, d__2);
if (!(*fk) || *f1 > fm)
{
goto L2;
}
xm = *x1;
fm = *f1;
L2:
if (*fk && fabs(*x1) >= t2)
{
goto L3;
}
temp = 1.;
if (*x1 < 0.)
{
temp = -1.;
}
*x1 = temp * t2;
*f1 = flin_(n, j, x1, f, &x[1], &global_1.nf);
L3:
if (*f1 > fm)
{
goto L4;
}
xm = *x1;
fm = *f1;
L4:
if (! dz)
{
goto L6;
}
/* ...EVALUATE FLIN AT ANOTHER POINT AND ESTIMATE THE SECOND DERIVATIVE...
*/
x2 = -(*x1);
if (f0 >= *f1)
{
x2 = *x1 * 2.;
}
f2 = flin_(n, j, &x2, f, &x[1], &global_1.nf);
if (f2 > fm)
{
goto L5;
}
xm = x2;
fm = f2;
L5:
*d2 = (x2 * (*f1 - f0) - *x1 * (f2 - f0)) / (*x1 * x2 * (*x1 - x2));
/* ...ESTIMATE THE FIRST DERIVATIVE AT 0... */
L6:
d1 = (*f1 - f0) / *x1 - *x1 * *d2;
dz = TRUE_;
/* ...PREDICT THE MINIMUM... */
if (*d2 > small)
{
goto L7;
}
x2 = *h__;
if (d1 >= 0.)
{
x2 = -x2;
}
goto L8;
L7:
x2 = d1 * -.5 / *d2;
L8:
if (fabs(x2) <= *h__)
{
goto L11;
}
if (x2 <= 0.)
{
goto L9;
}
else
{
goto L10;
}
L9:
x2 = -(*h__);
goto L11;
L10:
x2 = *h__;
/* ...EVALUATE F AT THE PREDICTED MINIMUM... */
L11:
f2 = flin_(n, j, &x2, f, &x[1], &global_1.nf);
if (k >= *nits || f2 <= f0)
{
goto L12;
}
/* ...NO SUCCESS, SO TRY AGAIN... */
++k;
if (f0 < *f1 && *x1 * x2 > 0.)
{
goto L4;
}
x2 *= .5;
goto L11;
/* ...INCREMENT THE ONE-DIMENSIONAL SEARCH COUNTER... */
L12:
++global_1.nl;
if (f2 <= fm)
{
goto L13;
}
x2 = xm;
goto L14;
L13:
fm = f2;
/* ...GET A NEW ESTIMATE OF THE SECOND DERIVATIVE... */
L14:
if ((d__1 = x2 * (x2 - *x1), fabs(d__1)) <= small)
{
goto L15;
}
*d2 = (x2 * (*f1 - f0) - *x1 * (fm - f0)) / (*x1 * x2 * (*x1 - x2));
goto L16;
L15:
if (k > 0)
{
*d2 = 0.;
}
L16:
if (*d2 <= small)
{
*d2 = small;
}
*x1 = x2;
global_1.fx = fm;
if (sf1 >= global_1.fx)
{
goto L17;
}
global_1.fx = sf1;
*x1 = sx1;
/* ...UPDATE X FOR LINEAR BUT NOT PARABOLIC SEARCH... */
L17:
if (*j == 0)
{
return 0;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__)
{
/* L18: */
x[i__] += *x1 * q_1.v[i__ + *j * 100 - 101];
}
return 0;
} /* min_ */
/* Subroutine */ int sstt21_(integer *n, integer *kband, real *ad, real *ae,
real *sd, real *se, real *u, integer *ldu, real *work, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, i__1;
real r__1, r__2, r__3;
/* Local variables */
static real unfl;
extern /* Subroutine */ int ssyr_(char *, integer *, real *, real *,
integer *, real *, integer *);
static real temp1, temp2;
static integer j;
extern /* Subroutine */ int ssyr2_(char *, integer *, real *, real *,
integer *, real *, integer *, real *, integer *), sgemm_(
char *, char *, integer *, integer *, integer *, real *, real *,
integer *, real *, integer *, real *, real *, integer *);
static real anorm, wnorm;
extern doublereal slamch_(char *), slange_(char *, integer *,
integer *, real *, integer *, real *);
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
extern doublereal slansy_(char *, char *, integer *, real *, integer *,
real *);
static real ulp;
#define u_ref(a_1,a_2) u[(a_2)*u_dim1 + a_1]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSTT21 checks a decomposition of the form
A = U S U'
where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
Two tests are performed:
RESULT(1) = | A - U S U' | / ( |A| n ulp )
RESULT(2) = | I - UU' | / ( n ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, SSTT21 does nothing.
It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is symmetric tri-diagonal.
AD (input) REAL array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be symmetric tridiagonal.
AE (input) REAL array, dimension (N-1)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
SD (input) REAL array, dimension (N)
The diagonal of the (symmetric tri-) diagonal matrix S.
SE (input) REAL array, dimension (N-1)
The off-diagonal of the (symmetric tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
(1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
element, etc.
U (input) REAL array, dimension (LDU, N)
The orthogonal matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) REAL array, dimension (N*(N+1))
RESULT (output) REAL array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
RESULT(1) is always modified.
=====================================================================
1) Constants
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
--work;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Precision");
/* Do Test 1
Copy A & Compute its 1-Norm: */
slaset_("Full", n, n, &c_b5, &c_b5, &work[1], n);
anorm = 0.f;
temp1 = 0.f;
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] = ad[j];
work[(*n + 1) * (j - 1) + 2] = ae[j];
temp2 = (r__1 = ae[j], dabs(r__1));
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[j], dabs(r__1)) + temp1 + temp2;
anorm = dmax(r__2,r__3);
temp1 = temp2;
/* L10: */
}
/* Computing 2nd power */
i__1 = *n;
work[i__1 * i__1] = ad[*n];
/* Computing MAX */
r__2 = anorm, r__3 = (r__1 = ad[*n], dabs(r__1)) + temp1, r__2 = max(r__2,
r__3);
anorm = dmax(r__2,unfl);
/* Norm of A - USU' */
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
r__1 = -sd[j];
ssyr_("L", n, &r__1, &u_ref(1, j), &c__1, &work[1], n);
/* L20: */
}
if (*n > 1 && *kband == 1) {
i__1 = *n - 1;
for (j = 1; j <= i__1; ++j) {
r__1 = -se[j];
ssyr2_("L", n, &r__1, &u_ref(1, j), &c__1, &u_ref(1, j + 1), &
c__1, &work[1], n);
/* L30: */
}
}
/* Computing 2nd power */
i__1 = *n;
wnorm = slansy_("1", "L", n, &work[1], n, &work[i__1 * i__1 + 1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*n * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *n * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*n * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*n);
result[1] = dmin(r__1,r__2) / (*n * ulp);
}
}
/* Do Test 2
Compute UU' - I */
sgemm_("N", "C", n, n, n, &c_b19, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b5, &work[1], n);
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
work[(*n + 1) * (j - 1) + 1] += -1.f;
/* L40: */
}
/* Computing MIN
Computing 2nd power */
i__1 = *n;
r__1 = (real) (*n), r__2 = slange_("1", n, n, &work[1], n, &work[i__1 *
i__1 + 1]);
result[2] = dmin(r__1,r__2) / (*n * ulp);
return 0;
/* End of SSTT21 */
} /* sstt21_ */
/* Subroutine */ int cstt22_(integer *n, integer *m, integer *kband, real *ad,
real *ae, real *sd, real *se, complex *u, integer *ldu, complex *
work, integer *ldwork, real *rwork, real *result)
{
/* System generated locals */
integer u_dim1, u_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1, r__2, r__3, r__4, r__5;
complex q__1, q__2;
/* Local variables */
static complex aukj;
static real unfl;
static integer i__, j, k;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
static real anorm, wnorm;
extern doublereal clange_(char *, integer *, integer *, complex *,
integer *, real *), slamch_(char *), clansy_(char
*, char *, integer *, complex *, integer *, real *);
static real ulp;
#define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1
#define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)]
#define u_subscr(a_1,a_2) (a_2)*u_dim1 + a_1
#define u_ref(a_1,a_2) u[u_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Purpose
=======
CSTT22 checks a set of M eigenvalues and eigenvectors,
A U = U S
where A is Hermitian tridiagonal, the columns of U are unitary,
and S is diagonal (if KBAND=0) or Hermitian tridiagonal (if KBAND=1).
Two tests are performed:
RESULT(1) = | U* A U - S | / ( |A| m ulp )
RESULT(2) = | I - U*U | / ( m ulp )
Arguments
=========
N (input) INTEGER
The size of the matrix. If it is zero, CSTT22 does nothing.
It must be at least zero.
M (input) INTEGER
The number of eigenpairs to check. If it is zero, CSTT22
does nothing. It must be at least zero.
KBAND (input) INTEGER
The bandwidth of the matrix S. It may only be zero or one.
If zero, then S is diagonal, and SE is not referenced. If
one, then S is Hermitian tri-diagonal.
AD (input) REAL array, dimension (N)
The diagonal of the original (unfactored) matrix A. A is
assumed to be Hermitian tridiagonal.
AE (input) REAL array, dimension (N)
The off-diagonal of the original (unfactored) matrix A. A
is assumed to be Hermitian tridiagonal. AE(1) is ignored,
AE(2) is the (1,2) and (2,1) element, etc.
SD (input) REAL array, dimension (N)
The diagonal of the (Hermitian tri-) diagonal matrix S.
SE (input) REAL array, dimension (N)
The off-diagonal of the (Hermitian tri-) diagonal matrix S.
Not referenced if KBSND=0. If KBAND=1, then AE(1) is
ignored, SE(2) is the (1,2) and (2,1) element, etc.
U (input) REAL array, dimension (LDU, N)
The unitary matrix in the decomposition.
LDU (input) INTEGER
The leading dimension of U. LDU must be at least N.
WORK (workspace) COMPLEX array, dimension (LDWORK, M+1)
LDWORK (input) INTEGER
The leading dimension of WORK. LDWORK must be at least
max(1,M).
RWORK (workspace) REAL array, dimension (N)
RESULT (output) REAL array, dimension (2)
The values computed by the two tests described above. The
values are currently limited to 1/ulp, to avoid overflow.
=====================================================================
Parameter adjustments */
--ad;
--ae;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1 * 1;
u -= u_offset;
work_dim1 = *ldwork;
work_offset = 1 + work_dim1 * 1;
work -= work_offset;
--rwork;
--result;
/* Function Body */
result[1] = 0.f;
result[2] = 0.f;
if (*n <= 0 || *m <= 0) {
return 0;
}
unfl = slamch_("Safe minimum");
ulp = slamch_("Epsilon");
/* Do Test 1
Compute the 1-norm of A. */
if (*n > 1) {
anorm = dabs(ad[1]) + dabs(ae[1]);
i__1 = *n - 1;
for (j = 2; j <= i__1; ++j) {
/* Computing MAX */
r__4 = anorm, r__5 = (r__1 = ad[j], dabs(r__1)) + (r__2 = ae[j],
dabs(r__2)) + (r__3 = ae[j - 1], dabs(r__3));
anorm = dmax(r__4,r__5);
/* L10: */
}
/* Computing MAX */
r__3 = anorm, r__4 = (r__1 = ad[*n], dabs(r__1)) + (r__2 = ae[*n - 1],
dabs(r__2));
anorm = dmax(r__3,r__4);
} else {
anorm = dabs(ad[1]);
}
anorm = dmax(anorm,unfl);
/* Norm of U*AU - S */
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = *m;
for (j = 1; j <= i__2; ++j) {
i__3 = work_subscr(i__, j);
work[i__3].r = 0.f, work[i__3].i = 0.f;
i__3 = *n;
for (k = 1; k <= i__3; ++k) {
i__4 = k;
i__5 = u_subscr(k, j);
q__1.r = ad[i__4] * u[i__5].r, q__1.i = ad[i__4] * u[i__5].i;
aukj.r = q__1.r, aukj.i = q__1.i;
if (k != *n) {
i__4 = k;
i__5 = u_subscr(k + 1, j);
q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
.i;
q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
aukj.r = q__1.r, aukj.i = q__1.i;
}
if (k != 1) {
i__4 = k - 1;
i__5 = u_subscr(k - 1, j);
q__2.r = ae[i__4] * u[i__5].r, q__2.i = ae[i__4] * u[i__5]
.i;
q__1.r = aukj.r + q__2.r, q__1.i = aukj.i + q__2.i;
aukj.r = q__1.r, aukj.i = q__1.i;
}
i__4 = work_subscr(i__, j);
i__5 = work_subscr(i__, j);
i__6 = u_subscr(k, i__);
q__2.r = u[i__6].r * aukj.r - u[i__6].i * aukj.i, q__2.i = u[
i__6].r * aukj.i + u[i__6].i * aukj.r;
q__1.r = work[i__5].r + q__2.r, q__1.i = work[i__5].i +
q__2.i;
work[i__4].r = q__1.r, work[i__4].i = q__1.i;
/* L20: */
}
/* L30: */
}
i__2 = work_subscr(i__, i__);
i__3 = work_subscr(i__, i__);
i__4 = i__;
q__1.r = work[i__3].r - sd[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
if (*kband == 1) {
if (i__ != 1) {
i__2 = work_subscr(i__, i__ - 1);
i__3 = work_subscr(i__, i__ - 1);
i__4 = i__ - 1;
q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
if (i__ != *n) {
i__2 = work_subscr(i__, i__ + 1);
i__3 = work_subscr(i__, i__ + 1);
i__4 = i__;
q__1.r = work[i__3].r - se[i__4], q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
}
}
/* L40: */
}
wnorm = clansy_("1", "L", m, &work[work_offset], m, &rwork[1]);
if (anorm > wnorm) {
result[1] = wnorm / anorm / (*m * ulp);
} else {
if (anorm < 1.f) {
/* Computing MIN */
r__1 = wnorm, r__2 = *m * anorm;
result[1] = dmin(r__1,r__2) / anorm / (*m * ulp);
} else {
/* Computing MIN */
r__1 = wnorm / anorm, r__2 = (real) (*m);
result[1] = dmin(r__1,r__2) / (*m * ulp);
}
}
/* Do Test 2
Compute U*U - I */
cgemm_("T", "N", m, m, n, &c_b2, &u[u_offset], ldu, &u[u_offset], ldu, &
c_b1, &work[work_offset], m);
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
i__2 = work_subscr(j, j);
i__3 = work_subscr(j, j);
q__1.r = work[i__3].r - 1.f, q__1.i = work[i__3].i;
work[i__2].r = q__1.r, work[i__2].i = q__1.i;
/* L50: */
}
/* Computing MIN */
r__1 = (real) (*m), r__2 = clange_("1", m, m, &work[work_offset], m, &
rwork[1]);
result[2] = dmin(r__1,r__2) / (*m * ulp);
return 0;
/* End of CSTT22 */
} /* cstt22_ */
/* Subroutine */ int slarrd_(char *range, char *order, integer *n, real *vl,
real *vu, integer *il, integer *iu, real *gers, real *reltol, real *
d__, real *e, real *e2, real *pivmin, integer *nsplit, integer *
isplit, integer *m, real *w, real *werr, real *wl, real *wu, integer *
iblock, integer *indexw, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer i__1, i__2, i__3;
real r__1, r__2;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer i__, j, ib, ie, je, nb;
real gl;
integer im, in;
real gu;
integer iw, jee;
real eps;
integer nwl;
real wlu, wul;
integer nwu;
real tmp1, tmp2;
integer iend, jblk, ioff, iout, itmp1, itmp2, jdisc;
extern logical lsame_(char *, char *);
integer iinfo;
real atoli;
integer iwoff, itmax;
real wkill, rtoli, uflow, tnorm;
integer ibegin, irange, idiscl;
extern doublereal slamch_(char *);
integer idumma[1];
real spdiam;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
integer idiscu;
extern /* Subroutine */ int slaebz_(integer *, integer *, integer *,
integer *, integer *, integer *, real *, real *, real *, real *,
real *, real *, integer *, real *, real *, integer *, integer *,
real *, integer *, integer *);
logical ncnvrg, toofew;
/* -- LAPACK auxiliary routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARRD computes the eigenvalues of a symmetric tridiagonal */
/* matrix T to suitable accuracy. This is an auxiliary code to be */
/* called from SSTEMR. */
/* The user may ask for all eigenvalues, all eigenvalues */
/* in the half-open interval (VL, VU], or the IL-th through IU-th */
/* eigenvalues. */
/* To avoid overflow, the matrix must be scaled so that its */
/* largest element is no greater than overflow**(1/2) * */
/* underflow**(1/4) in absolute value, and for greatest */
/* accuracy, it should not be much smaller than that. */
/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */
/* Matrix", Report CS41, Computer Science Dept., Stanford */
/* University, July 21, 1966. */
/* Arguments */
/* ========= */
/* RANGE (input) CHARACTER */
/* = 'A': ("All") all eigenvalues will be found. */
/* = 'V': ("Value") all eigenvalues in the half-open interval */
/* (VL, VU] will be found. */
/* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the */
/* entire matrix) will be found. */
/* ORDER (input) CHARACTER */
/* = 'B': ("By Block") the eigenvalues will be grouped by */
/* split-off block (see IBLOCK, ISPLIT) and */
/* ordered from smallest to largest within */
/* the block. */
/* = 'E': ("Entire matrix") */
/* the eigenvalues for the entire matrix */
/* will be ordered from smallest to */
/* largest. */
/* N (input) INTEGER */
/* The order of the tridiagonal matrix T. N >= 0. */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. Eigenvalues less than or equal */
/* to VL, or greater than VU, will not be returned. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* GERS (input) REAL array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). */
/* RELTOL (input) REAL */
/* The minimum relative width of an interval. When an interval */
/* is narrower than RELTOL times the larger (in */
/* magnitude) endpoint, then it is considered to be */
/* sufficiently small, i.e., converged. Note: this should */
/* always be at least radix*machine epsilon. */
/* D (input) REAL array, dimension (N) */
/* The n diagonal elements of the tridiagonal matrix T. */
/* E (input) REAL array, dimension (N-1) */
/* The (n-1) off-diagonal elements of the tridiagonal matrix T. */
/* E2 (input) REAL array, dimension (N-1) */
/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */
/* PIVMIN (input) REAL */
/* The minimum pivot allowed in the Sturm sequence for T. */
/* NSPLIT (input) INTEGER */
/* The number of diagonal blocks in the matrix T. */
/* 1 <= NSPLIT <= N. */
/* ISPLIT (input) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into submatrices. */
/* The first submatrix consists of rows/columns 1 to ISPLIT(1), */
/* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2), */
/* etc., and the NSPLIT-th consists of rows/columns */
/* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N. */
/* (Only the first NSPLIT elements will actually be used, but */
/* since the user cannot know a priori what value NSPLIT will */
/* have, N words must be reserved for ISPLIT.) */
/* M (output) INTEGER */
/* The actual number of eigenvalues found. 0 <= M <= N. */
/* (See also the description of INFO=2,3.) */
/* W (output) REAL array, dimension (N) */
/* On exit, the first M elements of W will contain the */
/* eigenvalue approximations. SLARRD computes an interval */
/* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue */
/* approximation is given as the interval midpoint */
/* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by */
/* WERR(j) = abs( a_j - b_j)/2 */
/* WERR (output) REAL array, dimension (N) */
/* The error bound on the corresponding eigenvalue approximation */
/* in W. */
/* WL (output) REAL */
/* WU (output) REAL */
/* The interval (WL, WU] contains all the wanted eigenvalues. */
/* If RANGE='V', then WL=VL and WU=VU. */
/* If RANGE='A', then WL and WU are the global Gerschgorin bounds */
/* on the spectrum. */
/* If RANGE='I', then WL and WU are computed by SLAEBZ from the */
/* index range specified. */
/* IBLOCK (output) INTEGER array, dimension (N) */
/* At each row/column j where E(j) is zero or small, the */
/* matrix T is considered to split into a block diagonal */
/* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which */
/* block (from 1 to the number of blocks) the eigenvalue W(i) */
/* belongs. (SLARRD may use the remaining N-M elements as */
/* workspace.) */
/* INDEXW (output) INTEGER array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the */
/* i-th eigenvalue W(i) is the j-th eigenvalue in block k. */
/* WORK (workspace) REAL array, dimension (4*N) */
/* IWORK (workspace) INTEGER array, dimension (3*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: some or all of the eigenvalues failed to converge or */
/* were not computed: */
/* =1 or 3: Bisection failed to converge for some */
/* eigenvalues; these eigenvalues are flagged by a */
/* negative block number. The effect is that the */
/* eigenvalues may not be as accurate as the */
/* absolute and relative tolerances. This is */
/* generally caused by unexpectedly inaccurate */
/* arithmetic. */
/* =2 or 3: RANGE='I' only: Not all of the eigenvalues */
/* IL:IU were found. */
/* Effect: M < IU+1-IL */
/* Cause: non-monotonic arithmetic, causing the */
/* Sturm sequence to be non-monotonic. */
/* Cure: recalculate, using RANGE='A', and pick */
/* out eigenvalues IL:IU. In some cases, */
/* increasing the PARAMETER "FUDGE" may */
/* make things work. */
/* = 4: RANGE='I', and the Gershgorin interval */
/* initially used was too small. No eigenvalues */
/* were computed. */
/* Probable cause: your machine has sloppy */
/* floating-point arithmetic. */
/* Cure: Increase the PARAMETER "FUDGE", */
/* recompile, and try again. */
/* Internal Parameters */
/* =================== */
/* FUDGE REAL , default = 2 */
/* A "fudge factor" to widen the Gershgorin intervals. Ideally, */
/* a value of 1 should work, but on machines with sloppy */
/* arithmetic, this needs to be larger. The default for */
/* publicly released versions should be large enough to handle */
/* the worst machine around. Note that this has no effect */
/* on accuracy of the solution. */
/* Based on contributions by */
/* W. Kahan, University of California, Berkeley, USA */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
--iwork;
--work;
--indexw;
--iblock;
--werr;
--w;
--isplit;
--e2;
--e;
--d__;
--gers;
/* Function Body */
*info = 0;
/* Decode RANGE */
if (lsame_(range, "A")) {
irange = 1;
} else if (lsame_(range, "V")) {
irange = 2;
} else if (lsame_(range, "I")) {
irange = 3;
} else {
irange = 0;
}
/* Check for Errors */
if (irange <= 0) {
*info = -1;
} else if (! (lsame_(order, "B") || lsame_(order,
"E"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (irange == 2) {
if (*vl >= *vu) {
*info = -5;
}
} else if (irange == 3 && (*il < 1 || *il > max(1,*n))) {
*info = -6;
} else if (irange == 3 && (*iu < min(*n,*il) || *iu > *n)) {
*info = -7;
}
if (*info != 0) {
return 0;
}
/* Initialize error flags */
*info = 0;
ncnvrg = FALSE_;
toofew = FALSE_;
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Simplification: */
if (irange == 3 && *il == 1 && *iu == *n) {
irange = 1;
}
/* Get machine constants */
eps = slamch_("P");
uflow = slamch_("U");
/* Special Case when N=1 */
/* Treat case of 1x1 matrix for quick return */
if (*n == 1) {
if (irange == 1 || irange == 2 && d__[1] > *vl && d__[1] <= *vu ||
irange == 3 && *il == 1 && *iu == 1) {
*m = 1;
w[1] = d__[1];
/* The computation error of the eigenvalue is zero */
werr[1] = 0.f;
iblock[1] = 1;
indexw[1] = 1;
}
return 0;
}
/* NB is the minimum vector length for vector bisection, or 0 */
/* if only scalar is to be done. */
nb = ilaenv_(&c__1, "SSTEBZ", " ", n, &c_n1, &c_n1, &c_n1);
if (nb <= 1) {
nb = 0;
}
/* Find global spectral radius */
gl = d__[1];
gu = d__[1];
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MIN */
r__1 = gl, r__2 = gers[(i__ << 1) - 1];
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = gu, r__2 = gers[i__ * 2];
gu = dmax(r__1,r__2);
/* L5: */
}
/* Compute global Gerschgorin bounds and spectral diameter */
/* Computing MAX */
r__1 = dabs(gl), r__2 = dabs(gu);
tnorm = dmax(r__1,r__2);
gl = gl - tnorm * 2.f * eps * *n - *pivmin * 4.f;
gu = gu + tnorm * 2.f * eps * *n + *pivmin * 4.f;
spdiam = gu - gl;
/* Input arguments for SLAEBZ: */
/* The relative tolerance. An interval (a,b] lies within */
/* "relative tolerance" if b-a < RELTOL*max(|a|,|b|), */
rtoli = *reltol;
/* Set the absolute tolerance for interval convergence to zero to force */
/* interval convergence based on relative size of the interval. */
/* This is dangerous because intervals might not converge when RELTOL is */
/* small. But at least a very small number should be selected so that for */
/* strongly graded matrices, the code can get relatively accurate */
/* eigenvalues. */
atoli = uflow * 4.f + *pivmin * 4.f;
if (irange == 3) {
/* RANGE='I': Compute an interval containing eigenvalues */
/* IL through IU. The initial interval [GL,GU] from the global */
/* Gerschgorin bounds GL and GU is refined by SLAEBZ. */
itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f))
+ 2;
work[*n + 1] = gl;
work[*n + 2] = gl;
work[*n + 3] = gu;
work[*n + 4] = gu;
work[*n + 5] = gl;
work[*n + 6] = gu;
iwork[1] = -1;
iwork[2] = -1;
iwork[3] = *n + 1;
iwork[4] = *n + 1;
iwork[5] = *il - 1;
iwork[6] = *iu;
slaebz_(&c__3, &itmax, n, &c__2, &c__2, &nb, &atoli, &rtoli, pivmin, &
d__[1], &e[1], &e2[1], &iwork[5], &work[*n + 1], &work[*n + 5]
, &iout, &iwork[1], &w[1], &iblock[1], &iinfo);
if (iinfo != 0) {
*info = iinfo;
return 0;
}
/* On exit, output intervals may not be ordered by ascending negcount */
if (iwork[6] == *iu) {
*wl = work[*n + 1];
wlu = work[*n + 3];
nwl = iwork[1];
*wu = work[*n + 4];
wul = work[*n + 2];
nwu = iwork[4];
} else {
*wl = work[*n + 2];
wlu = work[*n + 4];
nwl = iwork[2];
*wu = work[*n + 3];
wul = work[*n + 1];
nwu = iwork[3];
}
/* On exit, the interval [WL, WLU] contains a value with negcount NWL, */
/* and [WUL, WU] contains a value with negcount NWU. */
if (nwl < 0 || nwl >= *n || nwu < 1 || nwu > *n) {
*info = 4;
return 0;
}
} else if (irange == 2) {
*wl = *vl;
*wu = *vu;
} else if (irange == 1) {
*wl = gl;
*wu = gu;
}
/* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU. */
/* NWL accumulates the number of eigenvalues .le. WL, */
/* NWU accumulates the number of eigenvalues .le. WU */
*m = 0;
iend = 0;
*info = 0;
nwl = 0;
nwu = 0;
i__1 = *nsplit;
for (jblk = 1; jblk <= i__1; ++jblk) {
ioff = iend;
ibegin = ioff + 1;
iend = isplit[jblk];
in = iend - ioff;
if (in == 1) {
/* 1x1 block */
if (*wl >= d__[ibegin] - *pivmin) {
++nwl;
}
if (*wu >= d__[ibegin] - *pivmin) {
++nwu;
}
if (irange == 1 || *wl < d__[ibegin] - *pivmin && *wu >= d__[
ibegin] - *pivmin) {
++(*m);
w[*m] = d__[ibegin];
werr[*m] = 0.f;
/* The gap for a single block doesn't matter for the later */
/* algorithm and is assigned an arbitrary large value */
iblock[*m] = jblk;
indexw[*m] = 1;
}
/* Disabled 2x2 case because of a failure on the following matrix */
/* RANGE = 'I', IL = IU = 4 */
/* Original Tridiagonal, d = [ */
/* -0.150102010615740E+00 */
/* -0.849897989384260E+00 */
/* -0.128208148052635E-15 */
/* 0.128257718286320E-15 */
/* ]; */
/* e = [ */
/* -0.357171383266986E+00 */
/* -0.180411241501588E-15 */
/* -0.175152352710251E-15 */
/* ]; */
/* ELSE IF( IN.EQ.2 ) THEN */
/* * 2x2 block */
/* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 ) */
/* TMP1 = HALF*(D(IBEGIN)+D(IEND)) */
/* L1 = TMP1 - DISC */
/* IF( WL.GE. L1-PIVMIN ) */
/* $ NWL = NWL + 1 */
/* IF( WU.GE. L1-PIVMIN ) */
/* $ NWU = NWU + 1 */
/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE. */
/* $ L1-PIVMIN ) ) THEN */
/* M = M + 1 */
/* W( M ) = L1 */
/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */
/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */
/* IBLOCK( M ) = JBLK */
/* INDEXW( M ) = 1 */
/* ENDIF */
/* L2 = TMP1 + DISC */
/* IF( WL.GE. L2-PIVMIN ) */
/* $ NWL = NWL + 1 */
/* IF( WU.GE. L2-PIVMIN ) */
/* $ NWU = NWU + 1 */
/* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE. */
/* $ L2-PIVMIN ) ) THEN */
/* M = M + 1 */
/* W( M ) = L2 */
/* * The uncertainty of eigenvalues of a 2x2 matrix is very small */
/* WERR( M ) = EPS * ABS( W( M ) ) * TWO */
/* IBLOCK( M ) = JBLK */
/* INDEXW( M ) = 2 */
/* ENDIF */
} else {
/* General Case - block of size IN >= 2 */
/* Compute local Gerschgorin interval and use it as the initial */
/* interval for SLAEBZ */
gu = d__[ibegin];
gl = d__[ibegin];
tmp1 = 0.f;
i__2 = iend;
for (j = ibegin; j <= i__2; ++j) {
/* Computing MIN */
r__1 = gl, r__2 = gers[(j << 1) - 1];
gl = dmin(r__1,r__2);
/* Computing MAX */
r__1 = gu, r__2 = gers[j * 2];
gu = dmax(r__1,r__2);
/* L40: */
}
spdiam = gu - gl;
gl = gl - spdiam * 2.f * eps * in - *pivmin * 2.f;
gu = gu + spdiam * 2.f * eps * in + *pivmin * 2.f;
if (irange > 1) {
if (gu < *wl) {
/* the local block contains none of the wanted eigenvalues */
nwl += in;
nwu += in;
goto L70;
}
/* refine search interval if possible, only range (WL,WU] matters */
gl = dmax(gl,*wl);
gu = dmin(gu,*wu);
if (gl >= gu) {
goto L70;
}
}
/* Find negcount of initial interval boundaries GL and GU */
work[*n + 1] = gl;
work[*n + in + 1] = gu;
slaebz_(&c__1, &c__0, &in, &in, &c__1, &nb, &atoli, &rtoli,
pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &im, &iwork[1], &
w[*m + 1], &iblock[*m + 1], &iinfo);
if (iinfo != 0) {
*info = iinfo;
return 0;
}
nwl += iwork[1];
nwu += iwork[in + 1];
iwoff = *m - iwork[1];
/* Compute Eigenvalues */
itmax = (integer) ((log(gu - gl + *pivmin) - log(*pivmin)) / log(
2.f)) + 2;
slaebz_(&c__2, &itmax, &in, &in, &c__1, &nb, &atoli, &rtoli,
pivmin, &d__[ibegin], &e[ibegin], &e2[ibegin], idumma, &
work[*n + 1], &work[*n + (in << 1) + 1], &iout, &iwork[1],
&w[*m + 1], &iblock[*m + 1], &iinfo);
if (iinfo != 0) {
*info = iinfo;
return 0;
}
/* Copy eigenvalues into W and IBLOCK */
/* Use -JBLK for block number for unconverged eigenvalues. */
/* Loop over the number of output intervals from SLAEBZ */
i__2 = iout;
for (j = 1; j <= i__2; ++j) {
/* eigenvalue approximation is middle point of interval */
tmp1 = (work[j + *n] + work[j + in + *n]) * .5f;
/* semi length of error interval */
tmp2 = (r__1 = work[j + *n] - work[j + in + *n], dabs(r__1)) *
.5f;
if (j > iout - iinfo) {
/* Flag non-convergence. */
ncnvrg = TRUE_;
ib = -jblk;
} else {
ib = jblk;
}
i__3 = iwork[j + in] + iwoff;
for (je = iwork[j] + 1 + iwoff; je <= i__3; ++je) {
w[je] = tmp1;
werr[je] = tmp2;
indexw[je] = je - iwoff;
iblock[je] = ib;
/* L50: */
}
/* L60: */
}
*m += im;
}
L70:
;
}
/* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU */
/* If NWL+1 < IL or NWU > IU, discard extra eigenvalues. */
if (irange == 3) {
idiscl = *il - 1 - nwl;
idiscu = nwu - *iu;
if (idiscl > 0) {
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
/* Remove some of the smallest eigenvalues from the left so that */
/* at the end IDISCL =0. Move all eigenvalues up to the left. */
if (w[je] <= wlu && idiscl > 0) {
--idiscl;
} else {
++im;
w[im] = w[je];
werr[im] = werr[je];
indexw[im] = indexw[je];
iblock[im] = iblock[je];
}
/* L80: */
}
*m = im;
}
if (idiscu > 0) {
/* Remove some of the largest eigenvalues from the right so that */
/* at the end IDISCU =0. Move all eigenvalues up to the left. */
im = *m + 1;
for (je = *m; je >= 1; --je) {
if (w[je] >= wul && idiscu > 0) {
--idiscu;
} else {
--im;
w[im] = w[je];
werr[im] = werr[je];
indexw[im] = indexw[je];
iblock[im] = iblock[je];
}
/* L81: */
}
jee = 0;
i__1 = *m;
for (je = im; je <= i__1; ++je) {
++jee;
w[jee] = w[je];
werr[jee] = werr[je];
indexw[jee] = indexw[je];
iblock[jee] = iblock[je];
/* L82: */
}
*m = *m - im + 1;
}
if (idiscl > 0 || idiscu > 0) {
/* Code to deal with effects of bad arithmetic. (If N(w) is */
/* monotone non-decreasing, this should never happen.) */
/* Some low eigenvalues to be discarded are not in (WL,WLU], */
/* or high eigenvalues to be discarded are not in (WUL,WU] */
/* so just kill off the smallest IDISCL/largest IDISCU */
/* eigenvalues, by marking the corresponding IBLOCK = 0 */
if (idiscl > 0) {
wkill = *wu;
i__1 = idiscl;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] < wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L90: */
}
iblock[iw] = 0;
/* L100: */
}
}
if (idiscu > 0) {
wkill = *wl;
i__1 = idiscu;
for (jdisc = 1; jdisc <= i__1; ++jdisc) {
iw = 0;
i__2 = *m;
for (je = 1; je <= i__2; ++je) {
if (iblock[je] != 0 && (w[je] >= wkill || iw == 0)) {
iw = je;
wkill = w[je];
}
/* L110: */
}
iblock[iw] = 0;
/* L120: */
}
}
/* Now erase all eigenvalues with IBLOCK set to zero */
im = 0;
i__1 = *m;
for (je = 1; je <= i__1; ++je) {
if (iblock[je] != 0) {
++im;
w[im] = w[je];
werr[im] = werr[je];
indexw[im] = indexw[je];
iblock[im] = iblock[je];
}
/* L130: */
}
*m = im;
}
if (idiscl < 0 || idiscu < 0) {
toofew = TRUE_;
}
}
if (irange == 1 && *m != *n || irange == 3 && *m != *iu - *il + 1) {
toofew = TRUE_;
}
/* If ORDER='B', do nothing the eigenvalues are already sorted by */
/* block. */
/* If ORDER='E', sort the eigenvalues from smallest to largest */
if (lsame_(order, "E") && *nsplit > 1) {
i__1 = *m - 1;
for (je = 1; je <= i__1; ++je) {
ie = 0;
tmp1 = w[je];
i__2 = *m;
for (j = je + 1; j <= i__2; ++j) {
if (w[j] < tmp1) {
ie = j;
tmp1 = w[j];
}
/* L140: */
}
if (ie != 0) {
tmp2 = werr[ie];
itmp1 = iblock[ie];
itmp2 = indexw[ie];
w[ie] = w[je];
werr[ie] = werr[je];
iblock[ie] = iblock[je];
indexw[ie] = indexw[je];
w[je] = tmp1;
werr[je] = tmp2;
iblock[je] = itmp1;
indexw[je] = itmp2;
}
/* L150: */
}
}
*info = 0;
if (ncnvrg) {
++(*info);
}
if (toofew) {
*info += 2;
}
return 0;
/* End of SLARRD */
} /* slarrd_ */
/* Subroutine */ int slaebz_(integer *ijob, integer *nitmax, integer *n,
integer *mmax, integer *minp, integer *nbmin, real *abstol, real *
reltol, real *pivmin, real *d__, real *e, real *e2, integer *nval,
real *ab, real *c__, integer *mout, integer *nab, real *work, integer
*iwork, integer *info)
{
/* System generated locals */
integer nab_dim1, nab_offset, ab_dim1, ab_offset, i__1, i__2, i__3, i__4,
i__5, i__6;
real r__1, r__2, r__3, r__4;
/* Local variables */
static integer itmp1, itmp2, j, kfnew, klnew, kf, ji, kl, jp, jit;
static real tmp1, tmp2;
#define ab_ref(a_1,a_2) ab[(a_2)*ab_dim1 + a_1]
#define nab_ref(a_1,a_2) nab[(a_2)*nab_dim1 + a_1]
/* -- LAPACK auxiliary routine (instrum. to count ops. version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
June 30, 1999
Common block to return operation count and iteration count
ITCNT and OPS are only incremented (not initialized)
-----------------------------------------------------------------------
Purpose
=======
SLAEBZ contains the iteration loops which compute and use the
function N(w), which is the count of eigenvalues of a symmetric
tridiagonal matrix T less than or equal to its argument w. It
performs a choice of two types of loops:
IJOB=1, followed by
IJOB=2: It takes as input a list of intervals and returns a list of
sufficiently small intervals whose union contains the same
eigenvalues as the union of the original intervals.
The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
The output interval (AB(j,1),AB(j,2)] will contain
eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
IJOB=3: It performs a binary search in each input interval
(AB(j,1),AB(j,2)] for a point w(j) such that
N(w(j))=NVAL(j), and uses C(j) as the starting point of
the search. If such a w(j) is found, then on output
AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
(AB(j,1),AB(j,2)] will be a small interval containing the
point where N(w) jumps through NVAL(j), unless that point
lies outside the initial interval.
Note that the intervals are in all cases half-open intervals,
i.e., of the form (a,b] , which includes b but not a .
To avoid underflow, the matrix should be scaled so that its largest
element is no greater than overflow**(1/2) * underflow**(1/4)
in absolute value. To assure the most accurate computation
of small eigenvalues, the matrix should be scaled to be
not much smaller than that, either.
See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
Matrix", Report CS41, Computer Science Dept., Stanford
University, July 21, 1966
Note: the arguments are, in general, *not* checked for unreasonable
values.
Arguments
=========
IJOB (input) INTEGER
Specifies what is to be done:
= 1: Compute NAB for the initial intervals.
= 2: Perform bisection iteration to find eigenvalues of T.
= 3: Perform bisection iteration to invert N(w), i.e.,
to find a point which has a specified number of
eigenvalues of T to its left.
Other values will cause SLAEBZ to return with INFO=-1.
NITMAX (input) INTEGER
The maximum number of "levels" of bisection to be
performed, i.e., an interval of width W will not be made
smaller than 2^(-NITMAX) * W. If not all intervals
have converged after NITMAX iterations, then INFO is set
to the number of non-converged intervals.
N (input) INTEGER
The dimension n of the tridiagonal matrix T. It must be at
least 1.
MMAX (input) INTEGER
The maximum number of intervals. If more than MMAX intervals
are generated, then SLAEBZ will quit with INFO=MMAX+1.
MINP (input) INTEGER
The initial number of intervals. It may not be greater than
MMAX.
NBMIN (input) INTEGER
The smallest number of intervals that should be processed
using a vector loop. If zero, then only the scalar loop
will be used.
ABSTOL (input) REAL
The minimum (absolute) width of an interval. When an
interval is narrower than ABSTOL, or than RELTOL times the
larger (in magnitude) endpoint, then it is considered to be
sufficiently small, i.e., converged. This must be at least
zero.
RELTOL (input) REAL
The minimum relative width of an interval. When an interval
is narrower than ABSTOL, or than RELTOL times the larger (in
magnitude) endpoint, then it is considered to be
sufficiently small, i.e., converged. Note: this should
always be at least radix*machine epsilon.
PIVMIN (input) REAL
The minimum absolute value of a "pivot" in the Sturm
sequence loop. This *must* be at least max |e(j)**2| *
safe_min and at least safe_min, where safe_min is at least
the smallest number that can divide one without overflow.
D (input) REAL array, dimension (N)
The diagonal elements of the tridiagonal matrix T.
E (input) REAL array, dimension (N)
The offdiagonal elements of the tridiagonal matrix T in
positions 1 through N-1. E(N) is arbitrary.
E2 (input) REAL array, dimension (N)
The squares of the offdiagonal elements of the tridiagonal
matrix T. E2(N) is ignored.
NVAL (input/output) INTEGER array, dimension (MINP)
If IJOB=1 or 2, not referenced.
If IJOB=3, the desired values of N(w). The elements of NVAL
will be reordered to correspond with the intervals in AB.
Thus, NVAL(j) on output will not, in general be the same as
NVAL(j) on input, but it will correspond with the interval
(AB(j,1),AB(j,2)] on output.
AB (input/output) REAL array, dimension (MMAX,2)
The endpoints of the intervals. AB(j,1) is a(j), the left
endpoint of the j-th interval, and AB(j,2) is b(j), the
right endpoint of the j-th interval. The input intervals
will, in general, be modified, split, and reordered by the
calculation.
C (input/output) REAL array, dimension (MMAX)
If IJOB=1, ignored.
If IJOB=2, workspace.
If IJOB=3, then on input C(j) should be initialized to the
first search point in the binary search.
MOUT (output) INTEGER
If IJOB=1, the number of eigenvalues in the intervals.
If IJOB=2 or 3, the number of intervals output.
If IJOB=3, MOUT will equal MINP.
NAB (input/output) INTEGER array, dimension (MMAX,2)
If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
If IJOB=2, then on input, NAB(i,j) should be set. It must
satisfy the condition:
N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
which means that in interval i only eigenvalues
NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with
IJOB=1.
On output, NAB(i,j) will contain
max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
the input interval that the output interval
(AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
the input values of NAB(k,1) and NAB(k,2).
If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
unless N(w) > NVAL(i) for all search points w , in which
case NAB(i,1) will not be modified, i.e., the output
value will be the same as the input value (modulo
reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
for all search points w , in which case NAB(i,2) will
not be modified. Normally, NAB should be set to some
distinctive value(s) before SLAEBZ is called.
WORK (workspace) REAL array, dimension (MMAX)
Workspace.
IWORK (workspace) INTEGER array, dimension (MMAX)
Workspace.
INFO (output) INTEGER
= 0: All intervals converged.
= 1--MMAX: The last INFO intervals did not converge.
= MMAX+1: More than MMAX intervals were generated.
Further Details
===============
This routine is intended to be called only by other LAPACK
routines, thus the interface is less user-friendly. It is intended
for two purposes:
(a) finding eigenvalues. In this case, SLAEBZ should have one or
more initial intervals set up in AB, and SLAEBZ should be called
with IJOB=1. This sets up NAB, and also counts the eigenvalues.
Intervals with no eigenvalues would usually be thrown out at
this point. Also, if not all the eigenvalues in an interval i
are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX
no smaller than the value of MOUT returned by the call with
IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
tolerance specified by ABSTOL and RELTOL.
(b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
In this case, start with a Gershgorin interval (a,b). Set up
AB to contain 2 search intervals, both initially (a,b). One
NVAL element should contain f-1 and the other should contain l
, while C should contain a and b, resp. NAB(i,1) should be -1
and NAB(i,2) should be N+1, to flag an error if the desired
interval does not lie in (a,b). SLAEBZ is then called with
IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
>= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
w(l-r)=...=w(l+k) are handled similarly.
=====================================================================
Check for Errors
Parameter adjustments */
nab_dim1 = *mmax;
nab_offset = 1 + nab_dim1 * 1;
nab -= nab_offset;
ab_dim1 = *mmax;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--d__;
--e;
--e2;
--nval;
--c__;
--work;
--iwork;
/* Function Body */
*info = 0;
if (*ijob < 1 || *ijob > 3) {
*info = -1;
return 0;
}
/* Initialize NAB */
if (*ijob == 1) {
/* Compute the number of eigenvalues in the initial intervals. */
*mout = 0;
/* DIR$ NOVECTOR */
i__1 = *minp;
for (ji = 1; ji <= i__1; ++ji) {
for (jp = 1; jp <= 2; ++jp) {
tmp1 = d__[1] - ab_ref(ji, jp);
if (dabs(tmp1) < *pivmin) {
tmp1 = -(*pivmin);
}
nab_ref(ji, jp) = 0;
if (tmp1 <= 0.f) {
nab_ref(ji, jp) = 1;
}
i__2 = *n;
for (j = 2; j <= i__2; ++j) {
tmp1 = d__[j] - e2[j - 1] / tmp1 - ab_ref(ji, jp);
if (dabs(tmp1) < *pivmin) {
tmp1 = -(*pivmin);
}
if (tmp1 <= 0.f) {
nab_ref(ji, jp) = nab_ref(ji, jp) + 1;
}
/* L10: */
}
/* L20: */
}
*mout = *mout + nab_ref(ji, 2) - nab_ref(ji, 1);
/* L30: */
}
/* Increment opcount for determining the number of eigenvalues
in the initial intervals. */
latime_1.ops += (*minp << 1) * (*n - 1) * 3;
return 0;
}
/* Initialize for loop
KF and KL have the following meaning:
Intervals 1,...,KF-1 have converged.
Intervals KF,...,KL still need to be refined. */
kf = 1;
kl = *minp;
/* If IJOB=2, initialize C.
If IJOB=3, use the user-supplied starting point. */
if (*ijob == 2) {
i__1 = *minp;
for (ji = 1; ji <= i__1; ++ji) {
c__[ji] = (ab_ref(ji, 1) + ab_ref(ji, 2)) * .5f;
/* L40: */
}
/* Increment opcount for initializing C. */
latime_1.ops += *minp << 1;
}
/* Iteration loop */
i__1 = *nitmax;
for (jit = 1; jit <= i__1; ++jit) {
/* Loop over intervals */
if (kl - kf + 1 >= *nbmin && *nbmin > 0) {
/* Begin of Parallel Version of the loop */
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
/* Compute N(c), the number of eigenvalues less than c */
work[ji] = d__[1] - c__[ji];
iwork[ji] = 0;
if (work[ji] <= *pivmin) {
iwork[ji] = 1;
/* Computing MIN */
r__1 = work[ji], r__2 = -(*pivmin);
work[ji] = dmin(r__1,r__2);
}
i__3 = *n;
for (j = 2; j <= i__3; ++j) {
work[ji] = d__[j] - e2[j - 1] / work[ji] - c__[ji];
if (work[ji] <= *pivmin) {
++iwork[ji];
/* Computing MIN */
r__1 = work[ji], r__2 = -(*pivmin);
work[ji] = dmin(r__1,r__2);
}
/* L50: */
}
/* L60: */
}
/* Increment iteration counter. */
latime_1.itcnt = latime_1.itcnt + kl - kf + 1;
/* Increment opcount for evaluating Sturm sequences on
each interval. */
latime_1.ops += (kl - kf + 1) * (*n - 1) * 3;
if (*ijob <= 2) {
/* IJOB=2: Choose all intervals containing eigenvalues. */
klnew = kl;
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
/* Insure that N(w) is monotone
Computing MIN
Computing MAX */
i__5 = nab_ref(ji, 1), i__6 = iwork[ji];
i__3 = nab_ref(ji, 2), i__4 = max(i__5,i__6);
iwork[ji] = min(i__3,i__4);
/* Update the Queue -- add intervals if both halves
contain eigenvalues. */
if (iwork[ji] == nab_ref(ji, 2)) {
/* No eigenvalue in the upper interval:
just use the lower interval. */
ab_ref(ji, 2) = c__[ji];
} else if (iwork[ji] == nab_ref(ji, 1)) {
/* No eigenvalue in the lower interval:
just use the upper interval. */
ab_ref(ji, 1) = c__[ji];
} else {
++klnew;
if (klnew <= *mmax) {
/* Eigenvalue in both intervals -- add upper to
queue. */
ab_ref(klnew, 2) = ab_ref(ji, 2);
nab_ref(klnew, 2) = nab_ref(ji, 2);
ab_ref(klnew, 1) = c__[ji];
nab_ref(klnew, 1) = iwork[ji];
ab_ref(ji, 2) = c__[ji];
nab_ref(ji, 2) = iwork[ji];
} else {
*info = *mmax + 1;
}
}
/* L70: */
}
if (*info != 0) {
return 0;
}
kl = klnew;
} else {
/* IJOB=3: Binary search. Keep only the interval containing
w s.t. N(w) = NVAL */
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
if (iwork[ji] <= nval[ji]) {
ab_ref(ji, 1) = c__[ji];
nab_ref(ji, 1) = iwork[ji];
}
if (iwork[ji] >= nval[ji]) {
ab_ref(ji, 2) = c__[ji];
nab_ref(ji, 2) = iwork[ji];
}
/* L80: */
}
}
} else {
/* End of Parallel Version of the loop
Begin of Serial Version of the loop */
klnew = kl;
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
/* Compute N(w), the number of eigenvalues less than w */
tmp1 = c__[ji];
tmp2 = d__[1] - tmp1;
itmp1 = 0;
if (tmp2 <= *pivmin) {
itmp1 = 1;
/* Computing MIN */
r__1 = tmp2, r__2 = -(*pivmin);
tmp2 = dmin(r__1,r__2);
}
/* A series of compiler directives to defeat vectorization
for the next loop
$PL$ CMCHAR=' '
DIR$ NEXTSCALAR
$DIR SCALAR
DIR$ NEXT SCALAR
VD$L NOVECTOR
DEC$ NOVECTOR
VD$ NOVECTOR
VDIR NOVECTOR
VOCL LOOP,SCALAR
IBM PREFER SCALAR
$PL$ CMCHAR='*' */
i__3 = *n;
for (j = 2; j <= i__3; ++j) {
tmp2 = d__[j] - e2[j - 1] / tmp2 - tmp1;
if (tmp2 <= *pivmin) {
++itmp1;
/* Computing MIN */
r__1 = tmp2, r__2 = -(*pivmin);
tmp2 = dmin(r__1,r__2);
}
/* L90: */
}
if (*ijob <= 2) {
/* IJOB=2: Choose all intervals containing eigenvalues.
Insure that N(w) is monotone
Computing MIN
Computing MAX */
i__5 = nab_ref(ji, 1);
i__3 = nab_ref(ji, 2), i__4 = max(i__5,itmp1);
itmp1 = min(i__3,i__4);
/* Update the Queue -- add intervals if both halves
contain eigenvalues. */
if (itmp1 == nab_ref(ji, 2)) {
/* No eigenvalue in the upper interval:
just use the lower interval. */
ab_ref(ji, 2) = tmp1;
} else if (itmp1 == nab_ref(ji, 1)) {
/* No eigenvalue in the lower interval:
just use the upper interval. */
ab_ref(ji, 1) = tmp1;
} else if (klnew < *mmax) {
/* Eigenvalue in both intervals -- add upper to queue. */
++klnew;
ab_ref(klnew, 2) = ab_ref(ji, 2);
nab_ref(klnew, 2) = nab_ref(ji, 2);
ab_ref(klnew, 1) = tmp1;
nab_ref(klnew, 1) = itmp1;
ab_ref(ji, 2) = tmp1;
nab_ref(ji, 2) = itmp1;
} else {
*info = *mmax + 1;
return 0;
}
} else {
/* IJOB=3: Binary search. Keep only the interval
containing w s.t. N(w) = NVAL */
if (itmp1 <= nval[ji]) {
ab_ref(ji, 1) = tmp1;
nab_ref(ji, 1) = itmp1;
}
if (itmp1 >= nval[ji]) {
ab_ref(ji, 2) = tmp1;
nab_ref(ji, 2) = itmp1;
}
}
/* L100: */
}
/* Increment iteration counter. */
latime_1.itcnt = latime_1.itcnt + kl - kf + 1;
/* Increment opcount for evaluating Sturm sequences on
each interval. */
latime_1.ops += (kl - kf + 1) * (*n - 1) * 3;
kl = klnew;
/* End of Serial Version of the loop */
}
/* Check for convergence */
kfnew = kf;
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
tmp1 = (r__1 = ab_ref(ji, 2) - ab_ref(ji, 1), dabs(r__1));
/* Computing MAX */
r__3 = (r__1 = ab_ref(ji, 2), dabs(r__1)), r__4 = (r__2 = ab_ref(
ji, 1), dabs(r__2));
tmp2 = dmax(r__3,r__4);
/* Computing MAX */
r__1 = max(*abstol,*pivmin), r__2 = *reltol * tmp2;
if (tmp1 < dmax(r__1,r__2) || nab_ref(ji, 1) >= nab_ref(ji, 2)) {
/* Converged -- Swap with position KFNEW,
then increment KFNEW */
if (ji > kfnew) {
tmp1 = ab_ref(ji, 1);
tmp2 = ab_ref(ji, 2);
itmp1 = nab_ref(ji, 1);
itmp2 = nab_ref(ji, 2);
ab_ref(ji, 1) = ab_ref(kfnew, 1);
ab_ref(ji, 2) = ab_ref(kfnew, 2);
nab_ref(ji, 1) = nab_ref(kfnew, 1);
nab_ref(ji, 2) = nab_ref(kfnew, 2);
ab_ref(kfnew, 1) = tmp1;
ab_ref(kfnew, 2) = tmp2;
nab_ref(kfnew, 1) = itmp1;
nab_ref(kfnew, 2) = itmp2;
if (*ijob == 3) {
itmp1 = nval[ji];
nval[ji] = nval[kfnew];
nval[kfnew] = itmp1;
}
}
++kfnew;
}
/* L110: */
}
kf = kfnew;
/* Choose Midpoints */
i__2 = kl;
for (ji = kf; ji <= i__2; ++ji) {
c__[ji] = (ab_ref(ji, 1) + ab_ref(ji, 2)) * .5f;
/* L120: */
}
/* Increment opcount for convergence check and choosing midpoints. */
latime_1.ops += kl - kf + 1 << 2;
/* If no more intervals to refine, quit. */
if (kf > kl) {
goto L140;
}
/* L130: */
}
/* Converged */
L140:
/* Computing MAX */
i__1 = kl + 1 - kf;
*info = max(i__1,0);
*mout = kl;
return 0;
/* End of SLAEBZ */
} /* slaebz_ */
/* Subroutine */ int sposvxx_(char *fact, char *uplo, integer *n, integer *
nrhs, real *a, integer *lda, real *af, integer *ldaf, char *equed,
real *s, real *b, integer *ldb, real *x, integer *ldx, real *rcond,
real *rpvgrw, real *berr, integer *n_err_bnds__, real *
err_bnds_norm__, real *err_bnds_comp__, integer *nparams, real *
params, real *work, integer *iwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, af_dim1, af_offset, b_dim1, b_offset, x_dim1,
x_offset, err_bnds_norm_dim1, err_bnds_norm_offset,
err_bnds_comp_dim1, err_bnds_comp_offset, i__1;
real r__1, r__2;
/* Local variables */
integer j;
real amax, smin, smax;
extern doublereal sla_porpvgrw__(char *, integer *, real *, integer *,
real *, integer *, real *, ftnlen);
extern logical lsame_(char *, char *);
real scond;
logical equil, rcequ;
extern doublereal slamch_(char *);
logical nofact;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
integer infequ;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
real smlnum;
extern /* Subroutine */ int slaqsy_(char *, integer *, real *, integer *,
real *, real *, real *, char *), spotrf_(char *,
integer *, real *, integer *, integer *), spotrs_(char *,
integer *, integer *, real *, integer *, real *, integer *,
integer *), slascl2_(integer *, integer *, real *, real *,
integer *), spoequb_(integer *, real *, integer *, real *, real *
, real *, integer *), sporfsx_(char *, char *, integer *, integer
*, real *, integer *, real *, integer *, real *, real *, integer *
, real *, integer *, real *, real *, integer *, real *, real *,
integer *, real *, real *, integer *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* -- Contributed by James Demmel, Deaglan Halligan, Yozo Hida and -- */
/* -- Jason Riedy of Univ. of California Berkeley. -- */
/* -- November 2008 -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley and NAG Ltd. -- */
/* .. */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SPOSVXX uses the Cholesky factorization A = U**T*U or A = L*L**T */
/* to compute the solution to a real system of linear equations */
/* A * X = B, where A is an N-by-N symmetric positive definite matrix */
/* and X and B are N-by-NRHS matrices. */
/* If requested, both normwise and maximum componentwise error bounds */
/* are returned. SPOSVXX will return a solution with a tiny */
/* guaranteed error (O(eps) where eps is the working machine */
/* precision) unless the matrix is very ill-conditioned, in which */
/* case a warning is returned. Relevant condition numbers also are */
/* calculated and returned. */
/* SPOSVXX accepts user-provided factorizations and equilibration */
/* factors; see the definitions of the FACT and EQUED options. */
/* Solving with refinement and using a factorization from a previous */
/* SPOSVXX call will also produce a solution with either O(eps) */
/* errors or warnings, but we cannot make that claim for general */
/* user-provided factorizations and equilibration factors if they */
/* differ from what SPOSVXX would itself produce. */
/* Description */
/* =========== */
/* The following steps are performed: */
/* 1. If FACT = 'E', real scaling factors are computed to equilibrate */
/* the system: */
/* diag(S)*A*diag(S) *inv(diag(S))*X = diag(S)*B */
/* Whether or not the system will be equilibrated depends on the */
/* scaling of the matrix A, but if equilibration is used, A is */
/* overwritten by diag(S)*A*diag(S) and B by diag(S)*B. */
/* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to */
/* factor the matrix A (after equilibration if FACT = 'E') as */
/* A = U**T* U, if UPLO = 'U', or */
/* A = L * L**T, if UPLO = 'L', */
/* where U is an upper triangular matrix and L is a lower triangular */
/* matrix. */
/* 3. If the leading i-by-i principal minor is not positive definite, */
/* then the routine returns with INFO = i. Otherwise, the factored */
/* form of A is used to estimate the condition number of the matrix */
/* A (see argument RCOND). If the reciprocal of the condition number */
/* is less than machine precision, the routine still goes on to solve */
/* for X and compute error bounds as described below. */
/* 4. The system of equations is solved for X using the factored form */
/* of A. */
/* 5. By default (unless PARAMS(LA_LINRX_ITREF_I) is set to zero), */
/* the routine will use iterative refinement to try to get a small */
/* error and error bounds. Refinement calculates the residual to at */
/* least twice the working precision. */
/* 6. If equilibration was used, the matrix X is premultiplied by */
/* diag(S) so that it solves the original system before */
/* equilibration. */
/* Arguments */
/* ========= */
/* Some optional parameters are bundled in the PARAMS array. These */
/* settings determine how refinement is performed, but often the */
/* defaults are acceptable. If the defaults are acceptable, users */
/* can pass NPARAMS = 0 which prevents the source code from accessing */
/* the PARAMS argument. */
/* FACT (input) CHARACTER*1 */
/* Specifies whether or not the factored form of the matrix A is */
/* supplied on entry, and if not, whether the matrix A should be */
/* equilibrated before it is factored. */
/* = 'F': On entry, AF contains the factored form of A. */
/* If EQUED is not 'N', the matrix A has been */
/* equilibrated with scaling factors given by S. */
/* A and AF are not modified. */
/* = 'N': The matrix A will be copied to AF and factored. */
/* = 'E': The matrix A will be equilibrated if necessary, then */
/* copied to AF and factored. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The number of linear equations, i.e., the order of the */
/* matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of right hand sides, i.e., the number of columns */
/* of the matrices B and X. NRHS >= 0. */
/* A (input/output) REAL array, dimension (LDA,N) */
/* On entry, the symmetric matrix A, except if FACT = 'F' and EQUED = */
/* 'Y', then A must contain the equilibrated matrix */
/* diag(S)*A*diag(S). If UPLO = 'U', the leading N-by-N upper */
/* triangular part of A contains the upper triangular part of the */
/* matrix A, and the strictly lower triangular part of A is not */
/* referenced. If UPLO = 'L', the leading N-by-N lower triangular */
/* part of A contains the lower triangular part of the matrix A, and */
/* the strictly upper triangular part of A is not referenced. A is */
/* not modified if FACT = 'F' or 'N', or if FACT = 'E' and EQUED = */
/* 'N' on exit. */
/* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by */
/* diag(S)*A*diag(S). */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* AF (input or output) REAL array, dimension (LDAF,N) */
/* If FACT = 'F', then AF is an input argument and on entry */
/* contains the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T, in the same storage */
/* format as A. If EQUED .ne. 'N', then AF is the factored */
/* form of the equilibrated matrix diag(S)*A*diag(S). */
/* If FACT = 'N', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the original */
/* matrix A. */
/* If FACT = 'E', then AF is an output argument and on exit */
/* returns the triangular factor U or L from the Cholesky */
/* factorization A = U**T*U or A = L*L**T of the equilibrated */
/* matrix A (see the description of A for the form of the */
/* equilibrated matrix). */
/* LDAF (input) INTEGER */
/* The leading dimension of the array AF. LDAF >= max(1,N). */
/* EQUED (input or output) CHARACTER*1 */
/* Specifies the form of equilibration that was done. */
/* = 'N': No equilibration (always true if FACT = 'N'). */
/* = 'Y': Both row and column equilibration, i.e., A has been */
/* replaced by diag(S) * A * diag(S). */
/* EQUED is an input argument if FACT = 'F'; otherwise, it is an */
/* output argument. */
/* S (input or output) REAL array, dimension (N) */
/* The row scale factors for A. If EQUED = 'Y', A is multiplied on */
/* the left and right by diag(S). S is an input argument if FACT = */
/* 'F'; otherwise, S is an output argument. If FACT = 'F' and EQUED */
/* = 'Y', each element of S must be positive. If S is output, each */
/* element of S is a power of the radix. If S is input, each element */
/* of S should be a power of the radix to ensure a reliable solution */
/* and error estimates. Scaling by powers of the radix does not cause */
/* rounding errors unless the result underflows or overflows. */
/* Rounding errors during scaling lead to refining with a matrix that */
/* is not equivalent to the input matrix, producing error estimates */
/* that may not be reliable. */
/* B (input/output) REAL array, dimension (LDB,NRHS) */
/* On entry, the N-by-NRHS right hand side matrix B. */
/* On exit, */
/* if EQUED = 'N', B is not modified; */
/* if EQUED = 'Y', B is overwritten by diag(S)*B; */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (output) REAL array, dimension (LDX,NRHS) */
/* If INFO = 0, the N-by-NRHS solution matrix X to the original */
/* system of equations. Note that A and B are modified on exit if */
/* EQUED .ne. 'N', and the solution to the equilibrated system is */
/* inv(diag(S))*X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* RCOND (output) REAL */
/* Reciprocal scaled condition number. This is an estimate of the */
/* reciprocal Skeel condition number of the matrix A after */
/* equilibration (if done). If this is less than the machine */
/* precision (in particular, if it is zero), the matrix is singular */
/* to working precision. Note that the error may still be small even */
/* if this number is very small and the matrix appears ill- */
/* conditioned. */
/* RPVGRW (output) REAL */
/* Reciprocal pivot growth. On exit, this contains the reciprocal */
/* pivot growth factor norm(A)/norm(U). The "max absolute element" */
/* norm is used. If this is much less than 1, then the stability of */
/* the LU factorization of the (equilibrated) matrix A could be poor. */
/* This also means that the solution X, estimated condition numbers, */
/* and error bounds could be unreliable. If factorization fails with */
/* 0<INFO<=N, then this contains the reciprocal pivot growth factor */
/* for the leading INFO columns of A. */
/* BERR (output) REAL array, dimension (NRHS) */
/* Componentwise relative backward error. This is the */
/* componentwise relative backward error of each solution vector X(j) */
/* (i.e., the smallest relative change in any element of A or B that */
/* makes X(j) an exact solution). */
/* N_ERR_BNDS (input) INTEGER */
/* Number of error bounds to return for each right hand side */
/* and each type (normwise or componentwise). See ERR_BNDS_NORM and */
/* ERR_BNDS_COMP below. */
/* ERR_BNDS_NORM (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* normwise relative error, which is defined as follows: */
/* Normwise relative error in the ith solution vector: */
/* max_j (abs(XTRUE(j,i) - X(j,i))) */
/* ------------------------------ */
/* max_j abs(X(j,i)) */
/* The array is indexed by the type of error information as described */
/* below. There currently are up to three pieces of information */
/* returned. */
/* The first index in ERR_BNDS_NORM(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_NORM(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated normwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*A, where S scales each row by a power of the */
/* radix so all absolute row sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* ERR_BNDS_COMP (output) REAL array, dimension (NRHS, N_ERR_BNDS) */
/* For each right-hand side, this array contains information about */
/* various error bounds and condition numbers corresponding to the */
/* componentwise relative error, which is defined as follows: */
/* Componentwise relative error in the ith solution vector: */
/* abs(XTRUE(j,i) - X(j,i)) */
/* max_j ---------------------- */
/* abs(X(j,i)) */
/* The array is indexed by the right-hand side i (on which the */
/* componentwise relative error depends), and the type of error */
/* information as described below. There currently are up to three */
/* pieces of information returned for each right-hand side. If */
/* componentwise accuracy is not requested (PARAMS(3) = 0.0), then */
/* ERR_BNDS_COMP is not accessed. If N_ERR_BNDS .LT. 3, then at most */
/* the first (:,N_ERR_BNDS) entries are returned. */
/* The first index in ERR_BNDS_COMP(i,:) corresponds to the ith */
/* right-hand side. */
/* The second index in ERR_BNDS_COMP(:,err) contains the following */
/* three fields: */
/* err = 1 "Trust/don't trust" boolean. Trust the answer if the */
/* reciprocal condition number is less than the threshold */
/* sqrt(n) * slamch('Epsilon'). */
/* err = 2 "Guaranteed" error bound: The estimated forward error, */
/* almost certainly within a factor of 10 of the true error */
/* so long as the next entry is greater than the threshold */
/* sqrt(n) * slamch('Epsilon'). This error bound should only */
/* be trusted if the previous boolean is true. */
/* err = 3 Reciprocal condition number: Estimated componentwise */
/* reciprocal condition number. Compared with the threshold */
/* sqrt(n) * slamch('Epsilon') to determine if the error */
/* estimate is "guaranteed". These reciprocal condition */
/* numbers are 1 / (norm(Z^{-1},inf) * norm(Z,inf)) for some */
/* appropriately scaled matrix Z. */
/* Let Z = S*(A*diag(x)), where x is the solution for the */
/* current right-hand side and S scales each row of */
/* A*diag(x) by a power of the radix so all absolute row */
/* sums of Z are approximately 1. */
/* See Lapack Working Note 165 for further details and extra */
/* cautions. */
/* NPARAMS (input) INTEGER */
/* Specifies the number of parameters set in PARAMS. If .LE. 0, the */
/* PARAMS array is never referenced and default values are used. */
/* PARAMS (input / output) REAL array, dimension NPARAMS */
/* Specifies algorithm parameters. If an entry is .LT. 0.0, then */
/* that entry will be filled with default value used for that */
/* parameter. Only positions up to NPARAMS are accessed; defaults */
/* are used for higher-numbered parameters. */
/* PARAMS(LA_LINRX_ITREF_I = 1) : Whether to perform iterative */
/* refinement or not. */
/* Default: 1.0 */
/* = 0.0 : No refinement is performed, and no error bounds are */
/* computed. */
/* = 1.0 : Use the double-precision refinement algorithm, */
/* possibly with doubled-single computations if the */
/* compilation environment does not support DOUBLE */
/* PRECISION. */
/* (other values are reserved for future use) */
/* PARAMS(LA_LINRX_ITHRESH_I = 2) : Maximum number of residual */
/* computations allowed for refinement. */
/* Default: 10 */
/* Aggressive: Set to 100 to permit convergence using approximate */
/* factorizations or factorizations other than LU. If */
/* the factorization uses a technique other than */
/* Gaussian elimination, the guarantees in */
/* err_bnds_norm and err_bnds_comp may no longer be */
/* trustworthy. */
/* PARAMS(LA_LINRX_CWISE_I = 3) : Flag determining if the code */
/* will attempt to find a solution with small componentwise */
/* relative error in the double-precision algorithm. Positive */
/* is true, 0.0 is false. */
/* Default: 1.0 (attempt componentwise convergence) */
/* WORK (workspace) REAL array, dimension (4*N) */
/* IWORK (workspace) INTEGER array, dimension (N) */
/* INFO (output) INTEGER */
/* = 0: Successful exit. The solution to every right-hand side is */
/* guaranteed. */
/* < 0: If INFO = -i, the i-th argument had an illegal value */
/* > 0 and <= N: U(INFO,INFO) is exactly zero. The factorization */
/* has been completed, but the factor U is exactly singular, so */
/* the solution and error bounds could not be computed. RCOND = 0 */
/* is returned. */
/* = N+J: The solution corresponding to the Jth right-hand side is */
/* not guaranteed. The solutions corresponding to other right- */
/* hand sides K with K > J may not be guaranteed as well, but */
/* only the first such right-hand side is reported. If a small */
/* componentwise error is not requested (PARAMS(3) = 0.0) then */
/* the Jth right-hand side is the first with a normwise error */
/* bound that is not guaranteed (the smallest J such */
/* that ERR_BNDS_NORM(J,1) = 0.0). By default (PARAMS(3) = 1.0) */
/* the Jth right-hand side is the first with either a normwise or */
/* componentwise error bound that is not guaranteed (the smallest */
/* J such that either ERR_BNDS_NORM(J,1) = 0.0 or */
/* ERR_BNDS_COMP(J,1) = 0.0). See the definition of */
/* ERR_BNDS_NORM(:,1) and ERR_BNDS_COMP(:,1). To get information */
/* about all of the right-hand sides check ERR_BNDS_NORM or */
/* ERR_BNDS_COMP. */
/* ================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
err_bnds_comp_dim1 = *nrhs;
err_bnds_comp_offset = 1 + err_bnds_comp_dim1;
err_bnds_comp__ -= err_bnds_comp_offset;
err_bnds_norm_dim1 = *nrhs;
err_bnds_norm_offset = 1 + err_bnds_norm_dim1;
err_bnds_norm__ -= err_bnds_norm_offset;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
af_dim1 = *ldaf;
af_offset = 1 + af_dim1;
af -= af_offset;
--s;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
--berr;
--params;
--work;
--iwork;
/* Function Body */
*info = 0;
nofact = lsame_(fact, "N");
equil = lsame_(fact, "E");
smlnum = slamch_("Safe minimum");
bignum = 1.f / smlnum;
if (nofact || equil) {
*(unsigned char *)equed = 'N';
rcequ = FALSE_;
} else {
rcequ = lsame_(equed, "Y");
}
/* Default is failure. If an input parameter is wrong or */
/* factorization fails, make everything look horrible. Only the */
/* pivot growth is set here, the rest is initialized in SPORFSX. */
*rpvgrw = 0.f;
/* Test the input parameters. PARAMS is not tested until SPORFSX. */
if (! nofact && ! equil && ! lsame_(fact, "F")) {
*info = -1;
} else if (! lsame_(uplo, "U") && ! lsame_(uplo,
"L")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*nrhs < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldaf < max(1,*n)) {
*info = -8;
} else if (lsame_(fact, "F") && ! (rcequ || lsame_(
equed, "N"))) {
*info = -9;
} else {
if (rcequ) {
smin = bignum;
smax = 0.f;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
/* Computing MIN */
r__1 = smin, r__2 = s[j];
smin = dmin(r__1,r__2);
/* Computing MAX */
r__1 = smax, r__2 = s[j];
smax = dmax(r__1,r__2);
/* L10: */
}
if (smin <= 0.f) {
*info = -10;
} else if (*n > 0) {
scond = dmax(smin,smlnum) / dmin(smax,bignum);
} else {
scond = 1.f;
}
}
if (*info == 0) {
if (*ldb < max(1,*n)) {
*info = -12;
} else if (*ldx < max(1,*n)) {
*info = -14;
}
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SPOSVXX", &i__1);
return 0;
}
if (equil) {
/* Compute row and column scalings to equilibrate the matrix A. */
spoequb_(n, &a[a_offset], lda, &s[1], &scond, &amax, &infequ);
if (infequ == 0) {
/* Equilibrate the matrix. */
slaqsy_(uplo, n, &a[a_offset], lda, &s[1], &scond, &amax, equed);
rcequ = lsame_(equed, "Y");
}
}
/* Scale the right-hand side. */
if (rcequ) {
slascl2_(n, nrhs, &s[1], &b[b_offset], ldb);
}
if (nofact || equil) {
/* Compute the LU factorization of A. */
slacpy_(uplo, n, n, &a[a_offset], lda, &af[af_offset], ldaf);
spotrf_(uplo, n, &af[af_offset], ldaf, info);
/* Return if INFO is non-zero. */
if (*info != 0) {
/* Pivot in column INFO is exactly 0 */
/* Compute the reciprocal pivot growth factor of the */
/* leading rank-deficient INFO columns of A. */
*rpvgrw = sla_porpvgrw__(uplo, info, &a[a_offset], lda, &af[
af_offset], ldaf, &work[1], (ftnlen)1);
return 0;
}
}
/* Compute the reciprocal growth factor RPVGRW. */
*rpvgrw = sla_porpvgrw__(uplo, n, &a[a_offset], lda, &af[af_offset], ldaf,
&work[1], (ftnlen)1);
/* Compute the solution matrix X. */
slacpy_("Full", n, nrhs, &b[b_offset], ldb, &x[x_offset], ldx);
spotrs_(uplo, n, nrhs, &af[af_offset], ldaf, &x[x_offset], ldx, info);
/* Use iterative refinement to improve the computed solution and */
/* compute error bounds and backward error estimates for it. */
sporfsx_(uplo, equed, n, nrhs, &a[a_offset], lda, &af[af_offset], ldaf, &
s[1], &b[b_offset], ldb, &x[x_offset], ldx, rcond, &berr[1],
n_err_bnds__, &err_bnds_norm__[err_bnds_norm_offset], &
err_bnds_comp__[err_bnds_comp_offset], nparams, ¶ms[1], &work[
1], &iwork[1], info);
/* Scale solutions. */
if (rcequ) {
slascl2_(n, nrhs, &s[1], &x[x_offset], ldx);
}
return 0;
/* End of SPOSVXX */
} /* sposvxx_ */
/* Subroutine */ int cgbt05_(char *trans, integer *n, integer *kl, integer *
ku, integer *nrhs, complex *ab, integer *ldab, complex *b, integer *
ldb, complex *x, integer *ldx, complex *xact, integer *ldxact, real *
ferr, real *berr, real *reslts)
{
/* System generated locals */
integer ab_dim1, ab_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
static real diff, axbi;
static integer imax;
static real unfl, ovfl;
static integer i__, j, k;
extern logical lsame_(char *, char *);
static real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
static integer nz;
static real errbnd;
static logical notran;
static real eps, tmp;
#define xact_subscr(a_1,a_2) (a_2)*xact_dim1 + a_1
#define xact_ref(a_1,a_2) xact[xact_subscr(a_1,a_2)]
#define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1
#define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)]
#define x_subscr(a_1,a_2) (a_2)*x_dim1 + a_1
#define x_ref(a_1,a_2) x[x_subscr(a_1,a_2)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
February 29, 1992
Purpose
=======
CGBT05 tests the error bounds from iterative refinement for the
computed solution to a system of equations op(A)*X = B, where A is a
general band matrix of order n with kl subdiagonals and ku
superdiagonals and op(A) = A or A**T, depending on TRANS.
RESLTS(1) = test of the error bound
= norm(X - XACT) / ( norm(X) * FERR )
A large value is returned if this ratio is not less than one.
RESLTS(2) = residual from the iterative refinement routine
= the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i )
and NZ = max. number of nonzeros in any row of A, plus 1
Arguments
=========
TRANS (input) CHARACTER*1
Specifies the form of the system of equations.
= 'N': A * X = B (No transpose)
= 'T': A**T * X = B (Transpose)
= 'C': A**H * X = B (Conjugate transpose = Transpose)
N (input) INTEGER
The number of rows of the matrices X, B, and XACT, and the
order of the matrix A. N >= 0.
KL (input) INTEGER
The number of subdiagonals within the band of A. KL >= 0.
KU (input) INTEGER
The number of superdiagonals within the band of A. KU >= 0.
NRHS (input) INTEGER
The number of columns of the matrices X, B, and XACT.
NRHS >= 0.
AB (input) COMPLEX array, dimension (LDAB,N)
The original band matrix A, stored in rows 1 to KL+KU+1.
The j-th column of A is stored in the j-th column of the
array AB as follows:
AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KL+KU+1.
B (input) COMPLEX array, dimension (LDB,NRHS)
The right hand side vectors for the system of linear
equations.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
X (input) COMPLEX array, dimension (LDX,NRHS)
The computed solution vectors. Each vector is stored as a
column of the matrix X.
LDX (input) INTEGER
The leading dimension of the array X. LDX >= max(1,N).
XACT (input) COMPLEX array, dimension (LDX,NRHS)
The exact solution vectors. Each vector is stored as a
column of the matrix XACT.
LDXACT (input) INTEGER
The leading dimension of the array XACT. LDXACT >= max(1,N).
FERR (input) REAL array, dimension (NRHS)
The estimated forward error bounds for each solution vector
X. If XTRUE is the true solution, FERR bounds the magnitude
of the largest entry in (X - XTRUE) divided by the magnitude
of the largest entry in X.
BERR (input) REAL array, dimension (NRHS)
The componentwise relative backward error of each solution
vector (i.e., the smallest relative change in any entry of A
or B that makes X an exact solution).
RESLTS (output) REAL array, dimension (2)
The maximum over the NRHS solution vectors of the ratios:
RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR )
RESLTS(2) = BERR / ( NZ*EPS + (*) )
=====================================================================
Quick exit if N = 0 or NRHS = 0.
Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1 * 1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1 * 1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
notran = lsame_(trans, "N");
/* Computing MIN */
i__1 = *kl + *ku + 2, i__2 = *n + 1;
nz = min(i__1,i__2);
/* Test 1: Compute the maximum of
norm(X - XACT) / ( norm(X) * FERR )
over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x_ref(1, j), &c__1);
/* Computing MAX */
i__2 = x_subscr(imax, j);
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x_ref(imax, j)
), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = x_subscr(i__, j);
i__4 = xact_subscr(i__, j);
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( NZ*EPS + (*) ), where
(*) = NZ*UNFL / (min_i (abs(op(A))*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = b_subscr(i__, k);
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b_ref(i__,
k)), dabs(r__2));
if (notran) {
/* Computing MAX */
i__3 = i__ - *kl;
/* Computing MIN */
i__5 = i__ + *ku;
i__4 = min(i__5,*n);
for (j = max(i__3,1); j <= i__4; ++j) {
i__3 = ab_subscr(*ku + 1 + i__ - j, j);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__3].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + i__ - j, j)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L40: */
}
} else {
/* Computing MAX */
i__4 = i__ - *ku;
/* Computing MIN */
i__5 = i__ + *kl;
i__3 = min(i__5,*n);
for (j = max(i__4,1); j <= i__3; ++j) {
i__4 = ab_subscr(*ku + 1 + j - i__, i__);
i__5 = x_subscr(j, k);
tmp += ((r__1 = ab[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ab_ref(*ku + 1 + j - i__, i__)), dabs(r__2))) * ((
r__3 = x[i__5].r, dabs(r__3)) + (r__4 = r_imag(&
x_ref(j, k)), dabs(r__4)));
/* L50: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L60: */
}
/* Computing MAX */
r__1 = axbi, r__2 = nz * unfl;
tmp = berr[k] / (nz * eps + nz * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L70: */
}
return 0;
/* End of CGBT05 */
} /* cgbt05_ */
/* Subroutine */ int sdisna_(char *job, integer *m, integer *n, real *d__,
real *sep, integer *info)
{
/* System generated locals */
integer i__1;
real r__1, r__2, r__3;
/* Local variables */
integer i__, k;
real eps;
logical decr, left, incr, sing, eigen;
real anorm;
logical right;
real oldgap;
real safmin;
real newgap, thresh;
/* -- LAPACK routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SDISNA computes the reciprocal condition numbers for the eigenvectors */
/* of a real symmetric or complex Hermitian matrix or for the left or */
/* right singular vectors of a general m-by-n matrix. The reciprocal */
/* condition number is the 'gap' between the corresponding eigenvalue or */
/* singular value and the nearest other one. */
/* The bound on the error, measured by angle in radians, in the I-th */
/* computed vector is given by */
/* SLAMCH( 'E' ) * ( ANORM / SEP( I ) ) */
/* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed */
/* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of */
/* the error bound. */
/* SDISNA may also be used to compute error bounds for eigenvectors of */
/* the generalized symmetric definite eigenproblem. */
/* Arguments */
/* ========= */
/* JOB (input) CHARACTER*1 */
/* Specifies for which problem the reciprocal condition numbers */
/* should be computed: */
/* = 'E': the eigenvectors of a symmetric/Hermitian matrix; */
/* = 'L': the left singular vectors of a general matrix; */
/* = 'R': the right singular vectors of a general matrix. */
/* M (input) INTEGER */
/* The number of rows of the matrix. M >= 0. */
/* N (input) INTEGER */
/* If JOB = 'L' or 'R', the number of columns of the matrix, */
/* in which case N >= 0. Ignored if JOB = 'E'. */
/* D (input) REAL array, dimension (M) if JOB = 'E' */
/* dimension (min(M,N)) if JOB = 'L' or 'R' */
/* The eigenvalues (if JOB = 'E') or singular values (if JOB = */
/* 'L' or 'R') of the matrix, in either increasing or decreasing */
/* order. If singular values, they must be non-negative. */
/* SEP (output) REAL array, dimension (M) if JOB = 'E' */
/* dimension (min(M,N)) if JOB = 'L' or 'R' */
/* The reciprocal condition numbers of the vectors. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* ===================================================================== */
/* Test the input arguments */
/* Parameter adjustments */
--sep;
--d__;
/* Function Body */
*info = 0;
eigen = lsame_(job, "E");
left = lsame_(job, "L");
right = lsame_(job, "R");
sing = left || right;
if (eigen) {
k = *m;
} else if (sing) {
k = min(*m,*n);
}
if (! eigen && ! sing) {
*info = -1;
} else if (*m < 0) {
*info = -2;
} else if (k < 0) {
*info = -3;
} else {
incr = TRUE_;
decr = TRUE_;
i__1 = k - 1;
for (i__ = 1; i__ <= i__1; ++i__) {
if (incr) {
incr = incr && d__[i__] <= d__[i__ + 1];
}
if (decr) {
decr = decr && d__[i__] >= d__[i__ + 1];
}
}
if (sing && k > 0) {
if (incr) {
incr = incr && 0.f <= d__[1];
}
if (decr) {
decr = decr && d__[k] >= 0.f;
}
}
if (! (incr || decr)) {
*info = -4;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SDISNA", &i__1);
return 0;
}
/* Quick return if possible */
if (k == 0) {
return 0;
}
/* Compute reciprocal condition numbers */
if (k == 1) {
sep[1] = slamch_("O");
} else {
oldgap = (r__1 = d__[2] - d__[1], dabs(r__1));
sep[1] = oldgap;
i__1 = k - 1;
for (i__ = 2; i__ <= i__1; ++i__) {
newgap = (r__1 = d__[i__ + 1] - d__[i__], dabs(r__1));
sep[i__] = dmin(oldgap,newgap);
oldgap = newgap;
}
sep[k] = oldgap;
}
if (sing) {
if (left && *m > *n || right && *m < *n) {
if (incr) {
sep[1] = dmin(sep[1],d__[1]);
}
if (decr) {
/* Computing MIN */
r__1 = sep[k], r__2 = d__[k];
sep[k] = dmin(r__1,r__2);
}
}
}
/* Ensure that reciprocal condition numbers are not less than */
/* threshold, in order to limit the size of the error bound */
eps = slamch_("E");
safmin = slamch_("S");
/* Computing MAX */
r__2 = dabs(d__[1]), r__3 = (r__1 = d__[k], dabs(r__1));
anorm = dmax(r__2,r__3);
if (anorm == 0.f) {
thresh = eps;
} else {
/* Computing MAX */
r__1 = eps * anorm;
thresh = dmax(r__1,safmin);
}
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
/* Computing MAX */
r__1 = sep[i__];
sep[i__] = dmax(r__1,thresh);
}
return 0;
/* End of SDISNA */
} /* sdisna_ */
/* Subroutine */ int ctrt05_(char *uplo, char *trans, char *diag, integer *n,
integer *nrhs, complex *a, integer *lda, complex *b, integer *ldb,
complex *x, integer *ldx, complex *xact, integer *ldxact, real *ferr,
real *berr, real *reslts)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, xact_dim1,
xact_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Local variables */
integer i__, j, k, ifu;
real eps, tmp, diff, axbi;
integer imax;
real unfl, ovfl;
logical unit;
logical upper;
real xnorm;
real errbnd;
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CTRT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* triangular n by n matrix. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the matrix A is upper or lower triangular. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the form of the system of equations. */
/* = 'N': A * X = B (No transpose) */
/* = 'T': A'* X = B (Transpose) */
/* = 'C': A'* X = B (Conjugate transpose = Transpose) */
/* DIAG (input) CHARACTER*1 */
/* Specifies whether or not the matrix A is unit triangular. */
/* = 'N': Non-unit triangular */
/* = 'U': Unit triangular */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* A (input) COMPLEX array, dimension (LDA,N) */
/* The triangular matrix A. If UPLO = 'U', the leading n by n */
/* upper triangular part of the array A contains the upper */
/* triangular matrix, and the strictly lower triangular part of */
/* A is not referenced. If UPLO = 'L', the leading n by n lower */
/* triangular part of the array A contains the lower triangular */
/* matrix, and the strictly upper triangular part of A is not */
/* referenced. If DIAG = 'U', the diagonal elements of A are */
/* also not referenced and are assumed to be 1. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) REAL array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) REAL array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
upper = lsame_(uplo, "U");
notran = lsame_(trans, "N");
unit = lsame_(diag, "U");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
x_dim1]), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
ifu = 0;
if (unit) {
ifu = 1;
}
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
b_dim1]), dabs(r__2));
if (upper) {
if (! notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = j + i__ * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[j + i__ * a_dim1]), dabs(r__2))) * (
(r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x[j + k * x_dim1]), dabs(r__4)));
/* L40: */
}
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
} else {
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = i__ + j * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * (
(r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x[j + k * x_dim1]), dabs(r__4)));
/* L50: */
}
}
} else {
if (notran) {
i__3 = i__ - ifu;
for (j = 1; j <= i__3; ++j) {
i__4 = i__ + j * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[i__ + j * a_dim1]), dabs(r__2))) * (
(r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x[j + k * x_dim1]), dabs(r__4)));
/* L60: */
}
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
} else {
if (unit) {
i__3 = i__ + k * x_dim1;
tmp += (r__1 = x[i__3].r, dabs(r__1)) + (r__2 =
r_imag(&x[i__ + k * x_dim1]), dabs(r__2));
}
i__3 = *n;
for (j = i__ + ifu; j <= i__3; ++j) {
i__4 = j + i__ * a_dim1;
i__5 = j + k * x_dim1;
tmp += ((r__1 = a[i__4].r, dabs(r__1)) + (r__2 =
r_imag(&a[j + i__ * a_dim1]), dabs(r__2))) * (
(r__3 = x[i__5].r, dabs(r__3)) + (r__4 =
r_imag(&x[j + k * x_dim1]), dabs(r__4)));
/* L70: */
}
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of CTRT05 */
} /* ctrt05_ */
/* Subroutine */ int cppt05_(char *uplo, integer *n, integer *nrhs, complex *
ap, complex *b, integer *ldb, complex *x, integer *ldx, complex *xact,
integer *ldxact, real *ferr, real *berr, real *reslts)
{
/* System generated locals */
integer b_dim1, b_offset, x_dim1, x_offset, xact_dim1, xact_offset, i__1,
i__2, i__3, i__4, i__5;
real r__1, r__2, r__3, r__4;
complex q__1, q__2;
/* Builtin functions */
double r_imag(complex *);
/* Local variables */
integer i__, j, k, jc;
real eps, tmp, diff, axbi;
integer imax;
real unfl, ovfl;
extern logical lsame_(char *, char *);
logical upper;
real xnorm;
extern integer icamax_(integer *, complex *, integer *);
extern doublereal slamch_(char *);
real errbnd;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CPPT05 tests the error bounds from iterative refinement for the */
/* computed solution to a system of equations A*X = B, where A is a */
/* Hermitian matrix in packed storage format. */
/* RESLTS(1) = test of the error bound */
/* = norm(X - XACT) / ( norm(X) * FERR ) */
/* A large value is returned if this ratio is not less than one. */
/* RESLTS(2) = residual from the iterative refinement routine */
/* = the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* Hermitian matrix A is stored. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The number of rows of the matrices X, B, and XACT, and the */
/* order of the matrix A. N >= 0. */
/* NRHS (input) INTEGER */
/* The number of columns of the matrices X, B, and XACT. */
/* NRHS >= 0. */
/* AP (input) COMPLEX array, dimension (N*(N+1)/2) */
/* The upper or lower triangle of the Hermitian matrix A, packed */
/* columnwise in a linear array. The j-th column of A is stored */
/* in the array AP as follows: */
/* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */
/* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n. */
/* B (input) COMPLEX array, dimension (LDB,NRHS) */
/* The right hand side vectors for the system of linear */
/* equations. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= max(1,N). */
/* X (input) COMPLEX array, dimension (LDX,NRHS) */
/* The computed solution vectors. Each vector is stored as a */
/* column of the matrix X. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. LDX >= max(1,N). */
/* XACT (input) COMPLEX array, dimension (LDX,NRHS) */
/* The exact solution vectors. Each vector is stored as a */
/* column of the matrix XACT. */
/* LDXACT (input) INTEGER */
/* The leading dimension of the array XACT. LDXACT >= max(1,N). */
/* FERR (input) REAL array, dimension (NRHS) */
/* The estimated forward error bounds for each solution vector */
/* X. If XTRUE is the true solution, FERR bounds the magnitude */
/* of the largest entry in (X - XTRUE) divided by the magnitude */
/* of the largest entry in X. */
/* BERR (input) REAL array, dimension (NRHS) */
/* The componentwise relative backward error of each solution */
/* vector (i.e., the smallest relative change in any entry of A */
/* or B that makes X an exact solution). */
/* RESLTS (output) REAL array, dimension (2) */
/* The maximum over the NRHS solution vectors of the ratios: */
/* RESLTS(1) = norm(X - XACT) / ( norm(X) * FERR ) */
/* RESLTS(2) = BERR / ( (n+1)*EPS + (*) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Quick exit if N = 0 or NRHS = 0. */
/* Parameter adjustments */
--ap;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
xact_dim1 = *ldxact;
xact_offset = 1 + xact_dim1;
xact -= xact_offset;
--ferr;
--berr;
--reslts;
/* Function Body */
if (*n <= 0 || *nrhs <= 0) {
reslts[1] = 0.f;
reslts[2] = 0.f;
return 0;
}
eps = slamch_("Epsilon");
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
upper = lsame_(uplo, "U");
/* Test 1: Compute the maximum of */
/* norm(X - XACT) / ( norm(X) * FERR ) */
/* over all the vectors X and XACT using the infinity-norm. */
errbnd = 0.f;
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
imax = icamax_(n, &x[j * x_dim1 + 1], &c__1);
/* Computing MAX */
i__2 = imax + j * x_dim1;
r__3 = (r__1 = x[i__2].r, dabs(r__1)) + (r__2 = r_imag(&x[imax + j *
x_dim1]), dabs(r__2));
xnorm = dmax(r__3,unfl);
diff = 0.f;
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + j * x_dim1;
i__4 = i__ + j * xact_dim1;
q__2.r = x[i__3].r - xact[i__4].r, q__2.i = x[i__3].i - xact[i__4]
.i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
r__3 = diff, r__4 = (r__1 = q__1.r, dabs(r__1)) + (r__2 = r_imag(&
q__1), dabs(r__2));
diff = dmax(r__3,r__4);
/* L10: */
}
if (xnorm > 1.f) {
goto L20;
} else if (diff <= ovfl * xnorm) {
goto L20;
} else {
errbnd = 1.f / eps;
goto L30;
}
L20:
if (diff / xnorm <= ferr[j]) {
/* Computing MAX */
r__1 = errbnd, r__2 = diff / xnorm / ferr[j];
errbnd = dmax(r__1,r__2);
} else {
errbnd = 1.f / eps;
}
L30:
;
}
reslts[1] = errbnd;
/* Test 2: Compute the maximum of BERR / ( (n+1)*EPS + (*) ), where */
/* (*) = (n+1)*UNFL / (min_i (abs(A)*abs(X) +abs(b))_i ) */
i__1 = *nrhs;
for (k = 1; k <= i__1; ++k) {
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__) {
i__3 = i__ + k * b_dim1;
tmp = (r__1 = b[i__3].r, dabs(r__1)) + (r__2 = r_imag(&b[i__ + k *
b_dim1]), dabs(r__2));
if (upper) {
jc = (i__ - 1) * i__ / 2;
i__3 = i__ - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = jc + j;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[jc + j]), dabs(r__2))) * ((r__3 = x[i__5].r,
dabs(r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]),
dabs(r__4)));
/* L40: */
}
i__3 = jc + i__;
i__4 = i__ + k * x_dim1;
tmp += (r__1 = ap[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
dabs(r__3)));
jc = jc + i__ + i__;
i__3 = *n;
for (j = i__ + 1; j <= i__3; ++j) {
i__4 = jc;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[jc]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]), dabs(
r__4)));
jc += j;
/* L50: */
}
} else {
jc = i__;
i__3 = i__ - 1;
for (j = 1; j <= i__3; ++j) {
i__4 = jc;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[jc]), dabs(r__2))) * ((r__3 = x[i__5].r, dabs(
r__3)) + (r__4 = r_imag(&x[j + k * x_dim1]), dabs(
r__4)));
jc = jc + *n - j;
/* L60: */
}
i__3 = jc;
i__4 = i__ + k * x_dim1;
tmp += (r__1 = ap[i__3].r, dabs(r__1)) * ((r__2 = x[i__4].r,
dabs(r__2)) + (r__3 = r_imag(&x[i__ + k * x_dim1]),
dabs(r__3)));
i__3 = *n;
for (j = i__ + 1; j <= i__3; ++j) {
i__4 = jc + j - i__;
i__5 = j + k * x_dim1;
tmp += ((r__1 = ap[i__4].r, dabs(r__1)) + (r__2 = r_imag(&
ap[jc + j - i__]), dabs(r__2))) * ((r__3 = x[i__5]
.r, dabs(r__3)) + (r__4 = r_imag(&x[j + k *
x_dim1]), dabs(r__4)));
/* L70: */
}
}
if (i__ == 1) {
axbi = tmp;
} else {
axbi = dmin(axbi,tmp);
}
/* L80: */
}
/* Computing MAX */
r__1 = axbi, r__2 = (*n + 1) * unfl;
tmp = berr[k] / ((*n + 1) * eps + (*n + 1) * unfl / dmax(r__1,r__2));
if (k == 1) {
reslts[2] = tmp;
} else {
reslts[2] = dmax(reslts[2],tmp);
}
/* L90: */
}
return 0;
/* End of CPPT05 */
} /* cppt05_ */
doublereal sopbl2_(char *subnam, integer *m, integer *n, integer *kkl,
integer *kku)
{
/* System generated locals */
integer i__1, i__2, i__3;
real ret_val;
/* Builtin functions
Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
static real adds;
extern logical lsame_(char *, char *);
static char c1[1], c2[2], c3[3];
static real mults, ek, em, en, kl, ku;
extern logical lsamen_(integer *, char *, char *);
/* -- LAPACK timing routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
SOPBL2 computes an approximation of the number of floating point
operations used by a subroutine SUBNAM with the given values
of the parameters M, N, KL, and KU.
This version counts operations for the Level 2 BLAS.
Arguments
=========
SUBNAM (input) CHARACTER*6
The name of the subroutine.
M (input) INTEGER
The number of rows of the coefficient matrix. M >= 0.
N (input) INTEGER
The number of columns of the coefficient matrix.
If the matrix is square (such as in a solve routine) then
N is the number of right hand sides. N >= 0.
KKL (input) INTEGER
The lower band width of the coefficient matrix.
KL is set to max( 0, min( M-1, KKL ) ).
KKU (input) INTEGER
The upper band width of the coefficient matrix.
KU is set to max( 0, min( N-1, KKU ) ).
=====================================================================
Quick return if possible */
if (*m <= 0 || ! (lsame_(subnam, "S") || lsame_(
subnam, "D") || lsame_(subnam, "C") || lsame_(subnam, "Z"))) {
ret_val = 0.f;
return ret_val;
}
*(unsigned char *)c1 = *(unsigned char *)subnam;
s_copy(c2, subnam + 1, (ftnlen)2, (ftnlen)2);
s_copy(c3, subnam + 3, (ftnlen)3, (ftnlen)3);
mults = 0.f;
adds = 0.f;
/* Computing MAX
Computing MIN */
i__3 = *m - 1;
i__1 = 0, i__2 = min(i__3,*kkl);
kl = (real) max(i__1,i__2);
/* Computing MAX
Computing MIN */
i__3 = *n - 1;
i__1 = 0, i__2 = min(i__3,*kku);
ku = (real) max(i__1,i__2);
em = (real) (*m);
en = (real) (*n);
ek = kl;
/* -------------------------------
Matrix-vector multiply routines
------------------------------- */
if (lsamen_(&c__3, c3, "MV ")) {
if (lsamen_(&c__2, c2, "GE")) {
mults = em * (en + 1.f);
adds = em * en;
/* Assume M <= N + KL and KL < M
N <= M + KU and KU < N
so that the zero sections are triangles. */
} else if (lsamen_(&c__2, c2, "GB")) {
mults = em * (en + 1.f) - (em - 1.f - kl) * (em - kl) / 2.f - (en
- 1.f - ku) * (en - ku) / 2.f;
adds = em * (en + 1.f) - (em - 1.f - kl) * (em - kl) / 2.f - (en
- 1.f - ku) * (en - ku) / 2.f;
} else if (lsamen_(&c__2, c2, "SY") || lsamen_(&
c__2, c2, "SP") || lsamen_(&c__3,
subnam, "CHE") || lsamen_(&c__3, subnam,
"ZHE") || lsamen_(&c__3, subnam, "CHP") || lsamen_(&c__3, subnam, "ZHP")) {
mults = em * (em + 1.f);
adds = em * em;
} else if (lsamen_(&c__2, c2, "SB") || lsamen_(&
c__3, subnam, "CHB") || lsamen_(&c__3,
subnam, "ZHB")) {
mults = em * (em + 1.f) - (em - 1.f - ek) * (em - ek);
adds = em * em - (em - 1.f - ek) * (em - ek);
} else if (lsamen_(&c__2, c2, "TR") || lsamen_(&
c__2, c2, "TP")) {
mults = em * (em + 1.f) / 2.f;
adds = (em - 1.f) * em / 2.f;
} else if (lsamen_(&c__2, c2, "TB")) {
mults = em * (em + 1.f) / 2.f - (em - ek - 1.f) * (em - ek) / 2.f;
adds = (em - 1.f) * em / 2.f - (em - ek - 1.f) * (em - ek) / 2.f;
}
/* ---------------------
Matrix solve routines
--------------------- */
} else if (lsamen_(&c__3, c3, "SV ")) {
if (lsamen_(&c__2, c2, "TR") || lsamen_(&c__2,
c2, "TP")) {
mults = em * (em + 1.f) / 2.f;
adds = (em - 1.f) * em / 2.f;
} else if (lsamen_(&c__2, c2, "TB")) {
mults = em * (em + 1.f) / 2.f - (em - ek - 1.f) * (em - ek) / 2.f;
adds = (em - 1.f) * em / 2.f - (em - ek - 1.f) * (em - ek) / 2.f;
}
/* ----------------
Rank-one updates
---------------- */
} else if (lsamen_(&c__3, c3, "R ")) {
if (lsamen_(&c__3, subnam, "SGE") || lsamen_(&
c__3, subnam, "DGE")) {
mults = em * en + dmin(em,en);
adds = em * en;
} else if (lsamen_(&c__2, c2, "SY") || lsamen_(&
c__2, c2, "SP") || lsamen_(&c__3,
subnam, "CHE") || lsamen_(&c__3, subnam,
"CHP") || lsamen_(&c__3, subnam, "ZHE") || lsamen_(&c__3, subnam, "ZHP")) {
mults = em * (em + 1.f) / 2.f + em;
adds = em * (em + 1.f) / 2.f;
}
} else if (lsamen_(&c__3, c3, "RC ") || lsamen_(&
c__3, c3, "RU ")) {
if (lsamen_(&c__3, subnam, "CGE") || lsamen_(&
c__3, subnam, "ZGE")) {
mults = em * en + dmin(em,en);
adds = em * en;
}
/* ----------------
Rank-two updates
---------------- */
} else if (lsamen_(&c__3, c3, "R2 ")) {
if (lsamen_(&c__2, c2, "SY") || lsamen_(&c__2,
c2, "SP") || lsamen_(&c__3, subnam,
"CHE") || lsamen_(&c__3, subnam, "CHP") || lsamen_(&c__3, subnam, "ZHE") || lsamen_(&c__3, subnam, "ZHP")) {
mults = em * (em + 1.f) + em * 2.f;
adds = em * (em + 1.f);
}
}
/* ------------------------------------------------
Compute the total number of operations.
For real and double precision routines, count
1 for each multiply and 1 for each add.
For complex and complex*16 routines, count
6 for each multiply and 2 for each add.
------------------------------------------------ */
if (lsame_(c1, "S") || lsame_(c1, "D")) {
ret_val = mults + adds;
} else {
ret_val = mults * 6 + adds * 2;
}
return ret_val;
/* End of SOPBL2 */
} /* sopbl2_ */
/* Subroutine */ int slarrv_(integer *n, real *vl, real *vu, real *d__, real *
l, real *pivmin, integer *isplit, integer *m, integer *dol, integer *
dou, real *minrgp, real *rtol1, real *rtol2, real *w, real *werr,
real *wgap, integer *iblock, integer *indexw, real *gers, real *z__,
integer *ldz, integer *isuppz, real *work, integer *iwork, integer *
info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5;
real r__1, r__2;
logical L__1;
/* Builtin functions */
double log(doublereal);
/* Local variables */
integer minwsize, i__, j, k, p, q, miniwsize, ii;
real gl;
integer im, in;
real gu, gap, eps, tau, tol, tmp;
integer zto;
real ztz;
integer iend, jblk;
real lgap;
integer done;
real rgap, left;
integer wend, iter;
real bstw;
integer itmp1, indld;
real fudge;
integer idone;
real sigma;
integer iinfo, iindr;
real resid;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
logical eskip;
real right;
integer nclus, zfrom;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
real rqtol;
integer iindc1, iindc2;
extern /* Subroutine */ int slar1v_(integer *, integer *, integer *, real
*, real *, real *, real *, real *, real *, real *, real *,
logical *, integer *, real *, real *, integer *, integer *, real *
, real *, real *, real *);
logical stp2ii;
real lambda;
integer ibegin, indeig;
logical needbs;
integer indlld;
real sgndef, mingma;
extern doublereal slamch_(char *);
integer oldien, oldncl, wbegin;
real spdiam;
integer negcnt, oldcls;
real savgap;
integer ndepth;
real ssigma;
logical usedbs;
integer iindwk, offset;
real gaptol;
extern /* Subroutine */ int slarrb_(integer *, real *, real *, integer *,
integer *, real *, real *, integer *, real *, real *, real *,
real *, integer *, real *, real *, integer *, integer *), slarrf_(
integer *, real *, real *, real *, integer *, integer *, real *,
real *, real *, real *, real *, real *, real *, real *, real *,
real *, real *, integer *);
integer newcls, oldfst, indwrk, windex, oldlst;
logical usedrq;
integer newfst, newftt, parity, windmn, isupmn, newlst, windpl, zusedl,
newsiz, zusedu, zusedw;
real bstres, nrminv;
logical tryrqc;
integer isupmx;
real rqcorr;
extern /* Subroutine */ int slaset_(char *, integer *, integer *, real *,
real *, real *, integer *);
/* -- LAPACK auxiliary routine (version 3.1.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SLARRV computes the eigenvectors of the tridiagonal matrix */
/* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T. */
/* The input eigenvalues should have been computed by SLARRE. */
/* Arguments */
/* ========= */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* VL (input) REAL */
/* VU (input) REAL */
/* Lower and upper bounds of the interval that contains the desired */
/* eigenvalues. VL < VU. Needed to compute gaps on the left or right */
/* end of the extremal eigenvalues in the desired RANGE. */
/* D (input/output) REAL array, dimension (N) */
/* On entry, the N diagonal elements of the diagonal matrix D. */
/* On exit, D may be overwritten. */
/* L (input/output) REAL array, dimension (N) */
/* On entry, the (N-1) subdiagonal elements of the unit */
/* bidiagonal matrix L are in elements 1 to N-1 of L */
/* (if the matrix is not splitted.) At the end of each block */
/* is stored the corresponding shift as given by SLARRE. */
/* On exit, L is overwritten. */
/* PIVMIN (in) DOUBLE PRECISION */
/* The minimum pivot allowed in the Sturm sequence. */
/* ISPLIT (input) INTEGER array, dimension (N) */
/* The splitting points, at which T breaks up into blocks. */
/* The first block consists of rows/columns 1 to */
/* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1 */
/* through ISPLIT( 2 ), etc. */
/* M (input) INTEGER */
/* The total number of input eigenvalues. 0 <= M <= N. */
/* DOL (input) INTEGER */
/* DOU (input) INTEGER */
/* If the user wants to compute only selected eigenvectors from all */
/* the eigenvalues supplied, he can specify an index range DOL:DOU. */
/* Or else the setting DOL=1, DOU=M should be applied. */
/* Note that DOL and DOU refer to the order in which the eigenvalues */
/* are stored in W. */
/* If the user wants to compute only selected eigenpairs, then */
/* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the */
/* computed eigenvectors. All other columns of Z are set to zero. */
/* MINRGP (input) REAL */
/* RTOL1 (input) REAL */
/* RTOL2 (input) REAL */
/* Parameters for bisection. */
/* An interval [LEFT,RIGHT] has converged if */
/* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) ) */
/* W (input/output) REAL array, dimension (N) */
/* The first M elements of W contain the APPROXIMATE eigenvalues for */
/* which eigenvectors are to be computed. The eigenvalues */
/* should be grouped by split-off block and ordered from */
/* smallest to largest within the block ( The output array */
/* W from SLARRE is expected here ). Furthermore, they are with */
/* respect to the shift of the corresponding root representation */
/* for their block. On exit, W holds the eigenvalues of the */
/* UNshifted matrix. */
/* WERR (input/output) REAL array, dimension (N) */
/* The first M elements contain the semiwidth of the uncertainty */
/* interval of the corresponding eigenvalue in W */
/* WGAP (input/output) REAL array, dimension (N) */
/* The separation from the right neighbor eigenvalue in W. */
/* IBLOCK (input) INTEGER array, dimension (N) */
/* The indices of the blocks (submatrices) associated with the */
/* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue */
/* W(i) belongs to the first block from the top, =2 if W(i) */
/* belongs to the second block, etc. */
/* INDEXW (input) INTEGER array, dimension (N) */
/* The indices of the eigenvalues within each block (submatrix); */
/* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the */
/* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block. */
/* GERS (input) REAL array, dimension (2*N) */
/* The N Gerschgorin intervals (the i-th Gerschgorin interval */
/* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should */
/* be computed from the original UNshifted matrix. */
/* Z (output) REAL array, dimension (LDZ, max(1,M) ) */
/* If INFO = 0, the first M columns of Z contain the */
/* orthonormal eigenvectors of the matrix T */
/* corresponding to the input eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) ) */
/* The support of the eigenvectors in Z, i.e., the indices */
/* indicating the nonzero elements in Z. The I-th eigenvector */
/* is nonzero only in elements ISUPPZ( 2*I-1 ) through */
/* ISUPPZ( 2*I ). */
/* WORK (workspace) REAL array, dimension (12*N) */
/* IWORK (workspace) INTEGER array, dimension (7*N) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* > 0: A problem occured in SLARRV. */
/* < 0: One of the called subroutines signaled an internal problem. */
/* Needs inspection of the corresponding parameter IINFO */
/* for further information. */
/* =-1: Problem in SLARRB when refining a child's eigenvalues. */
/* =-2: Problem in SLARRF when computing the RRR of a child. */
/* When a child is inside a tight cluster, it can be difficult */
/* to find an RRR. A partial remedy from the user's point of */
/* view is to make the parameter MINRGP smaller and recompile. */
/* However, as the orthogonality of the computed vectors is */
/* proportional to 1/MINRGP, the user should be aware that */
/* he might be trading in precision when he decreases MINRGP. */
/* =-3: Problem in SLARRB when refining a single eigenvalue */
/* after the Rayleigh correction was rejected. */
/* = 5: The Rayleigh Quotient Iteration failed to converge to */
/* full accuracy in MAXITR steps. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Beresford Parlett, University of California, Berkeley, USA */
/* Jim Demmel, University of California, Berkeley, USA */
/* Inderjit Dhillon, University of Texas, Austin, USA */
/* Osni Marques, LBNL/NERSC, USA */
/* Christof Voemel, University of California, Berkeley, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* .. */
/* The first N entries of WORK are reserved for the eigenvalues */
/* Parameter adjustments */
--d__;
--l;
--isplit;
--w;
--werr;
--wgap;
--iblock;
--indexw;
--gers;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
indld = *n + 1;
indlld = (*n << 1) + 1;
indwrk = *n * 3 + 1;
minwsize = *n * 12;
i__1 = minwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
work[i__] = 0.f;
/* L5: */
}
/* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the */
/* factorization used to compute the FP vector */
iindr = 0;
/* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current */
/* layer and the one above. */
iindc1 = *n;
iindc2 = *n << 1;
iindwk = *n * 3 + 1;
miniwsize = *n * 7;
i__1 = miniwsize;
for (i__ = 1; i__ <= i__1; ++i__) {
iwork[i__] = 0;
/* L10: */
}
zusedl = 1;
if (*dol > 1) {
/* Set lower bound for use of Z */
zusedl = *dol - 1;
}
zusedu = *m;
if (*dou < *m) {
/* Set lower bound for use of Z */
zusedu = *dou + 1;
}
/* The width of the part of Z that is used */
zusedw = zusedu - zusedl + 1;
slaset_("Full", n, &zusedw, &c_b5, &c_b5, &z__[zusedl * z_dim1 + 1], ldz);
eps = slamch_("Precision");
rqtol = eps * 2.f;
/* Set expert flags for standard code. */
tryrqc = TRUE_;
if (*dol == 1 && *dou == *m) {
} else {
/* Only selected eigenpairs are computed. Since the other evalues */
/* are not refined by RQ iteration, bisection has to compute to full */
/* accuracy. */
*rtol1 = eps * 4.f;
*rtol2 = eps * 4.f;
}
/* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the */
/* desired eigenvalues. The support of the nonzero eigenvector */
/* entries is contained in the interval IBEGIN:IEND. */
/* Remark that if k eigenpairs are desired, then the eigenvectors */
/* are stored in k contiguous columns of Z. */
/* DONE is the number of eigenvectors already computed */
done = 0;
ibegin = 1;
wbegin = 1;
i__1 = iblock[*m];
for (jblk = 1; jblk <= i__1; ++jblk) {
iend = isplit[jblk];
sigma = l[iend];
/* Find the eigenvectors of the submatrix indexed IBEGIN */
/* through IEND. */
wend = wbegin - 1;
L15:
if (wend < *m) {
if (iblock[wend + 1] == jblk) {
++wend;
goto L15;
}
}
if (wend < wbegin) {
ibegin = iend + 1;
goto L170;
} else if (wend < *dol || wbegin > *dou) {
ibegin = iend + 1;
wbegin = wend + 1;
goto L170;
}
/* Find local spectral diameter of the block */
gl = gers[(ibegin << 1) - 1];
gu = gers[ibegin * 2];
i__2 = iend;
for (i__ = ibegin + 1; i__ <= i__2; ++i__) {
/* Computing MIN */
r__1 = gers[(i__ << 1) - 1];
gl = dmin(r__1,gl);
/* Computing MAX */
r__1 = gers[i__ * 2];
gu = dmax(r__1,gu);
/* L20: */
}
spdiam = gu - gl;
/* OLDIEN is the last index of the previous block */
oldien = ibegin - 1;
/* Calculate the size of the current block */
in = iend - ibegin + 1;
/* The number of eigenvalues in the current block */
im = wend - wbegin + 1;
/* This is for a 1x1 block */
if (ibegin == iend) {
++done;
z__[ibegin + wbegin * z_dim1] = 1.f;
isuppz[(wbegin << 1) - 1] = ibegin;
isuppz[wbegin * 2] = ibegin;
w[wbegin] += sigma;
work[wbegin] = w[wbegin];
ibegin = iend + 1;
++wbegin;
goto L170;
}
/* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND) */
/* Note that these can be approximations, in this case, the corresp. */
/* entries of WERR give the size of the uncertainty interval. */
/* The eigenvalue approximations will be refined when necessary as */
/* high relative accuracy is required for the computation of the */
/* corresponding eigenvectors. */
scopy_(&im, &w[wbegin], &c__1, &work[wbegin], &c__1);
/* We store in W the eigenvalue approximations w.r.t. the original */
/* matrix T. */
i__2 = im;
for (i__ = 1; i__ <= i__2; ++i__) {
w[wbegin + i__ - 1] += sigma;
/* L30: */
}
/* NDEPTH is the current depth of the representation tree */
ndepth = 0;
/* PARITY is either 1 or 0 */
parity = 1;
/* NCLUS is the number of clusters for the next level of the */
/* representation tree, we start with NCLUS = 1 for the root */
nclus = 1;
iwork[iindc1 + 1] = 1;
iwork[iindc1 + 2] = im;
/* IDONE is the number of eigenvectors already computed in the current */
/* block */
idone = 0;
/* loop while( IDONE.LT.IM ) */
/* generate the representation tree for the current block and */
/* compute the eigenvectors */
L40:
if (idone < im) {
/* This is a crude protection against infinitely deep trees */
if (ndepth > *m) {
*info = -2;
return 0;
}
/* breadth first processing of the current level of the representation */
/* tree: OLDNCL = number of clusters on current level */
oldncl = nclus;
/* reset NCLUS to count the number of child clusters */
nclus = 0;
parity = 1 - parity;
if (parity == 0) {
oldcls = iindc1;
newcls = iindc2;
} else {
oldcls = iindc2;
newcls = iindc1;
}
/* Process the clusters on the current level */
i__2 = oldncl;
for (i__ = 1; i__ <= i__2; ++i__) {
j = oldcls + (i__ << 1);
/* OLDFST, OLDLST = first, last index of current cluster. */
/* cluster indices start with 1 and are relative */
/* to WBEGIN when accessing W, WGAP, WERR, Z */
oldfst = iwork[j - 1];
oldlst = iwork[j];
if (ndepth > 0) {
/* Retrieve relatively robust representation (RRR) of cluster */
/* that has been computed at the previous level */
/* The RRR is stored in Z and overwritten once the eigenvectors */
/* have been computed or when the cluster is refined */
if (*dol == 1 && *dou == *m) {
/* Get representation from location of the leftmost evalue */
/* of the cluster */
j = wbegin + oldfst - 1;
} else {
if (wbegin + oldfst - 1 < *dol) {
/* Get representation from the left end of Z array */
j = *dol - 1;
} else if (wbegin + oldfst - 1 > *dou) {
/* Get representation from the right end of Z array */
j = *dou;
} else {
j = wbegin + oldfst - 1;
}
}
scopy_(&in, &z__[ibegin + j * z_dim1], &c__1, &d__[ibegin]
, &c__1);
i__3 = in - 1;
scopy_(&i__3, &z__[ibegin + (j + 1) * z_dim1], &c__1, &l[
ibegin], &c__1);
sigma = z__[iend + (j + 1) * z_dim1];
/* Set the corresponding entries in Z to zero */
slaset_("Full", &in, &c__2, &c_b5, &c_b5, &z__[ibegin + j
* z_dim1], ldz);
}
/* Compute DL and DLL of current RRR */
i__3 = iend - 1;
for (j = ibegin; j <= i__3; ++j) {
tmp = d__[j] * l[j];
work[indld - 1 + j] = tmp;
work[indlld - 1 + j] = tmp * l[j];
/* L50: */
}
if (ndepth > 0) {
/* P and Q are index of the first and last eigenvalue to compute */
/* within the current block */
p = indexw[wbegin - 1 + oldfst];
q = indexw[wbegin - 1 + oldlst];
/* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET */
/* thru' Q-OFFSET elements of these arrays are to be used. */
/* OFFSET = P-OLDFST */
offset = indexw[wbegin] - 1;
/* perform limited bisection (if necessary) to get approximate */
/* eigenvalues to the precision needed. */
slarrb_(&in, &d__[ibegin], &work[indlld + ibegin - 1], &p,
&q, rtol1, rtol2, &offset, &work[wbegin], &wgap[
wbegin], &werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &in, &iinfo);
if (iinfo != 0) {
*info = -1;
return 0;
}
/* We also recompute the extremal gaps. W holds all eigenvalues */
/* of the unshifted matrix and must be used for computation */
/* of WGAP, the entries of WORK might stem from RRRs with */
/* different shifts. The gaps from WBEGIN-1+OLDFST to */
/* WBEGIN-1+OLDLST are correctly computed in SLARRB. */
/* However, we only allow the gaps to become greater since */
/* this is what should happen when we decrease WERR */
if (oldfst > 1) {
/* Computing MAX */
r__1 = wgap[wbegin + oldfst - 2], r__2 = w[wbegin +
oldfst - 1] - werr[wbegin + oldfst - 1] - w[
wbegin + oldfst - 2] - werr[wbegin + oldfst -
2];
wgap[wbegin + oldfst - 2] = dmax(r__1,r__2);
}
if (wbegin + oldlst - 1 < wend) {
/* Computing MAX */
r__1 = wgap[wbegin + oldlst - 1], r__2 = w[wbegin +
oldlst] - werr[wbegin + oldlst] - w[wbegin +
oldlst - 1] - werr[wbegin + oldlst - 1];
wgap[wbegin + oldlst - 1] = dmax(r__1,r__2);
}
/* Each time the eigenvalues in WORK get refined, we store */
/* the newly found approximation with all shifts applied in W */
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
w[wbegin + j - 1] = work[wbegin + j - 1] + sigma;
/* L53: */
}
}
/* Process the current node. */
newfst = oldfst;
i__3 = oldlst;
for (j = oldfst; j <= i__3; ++j) {
if (j == oldlst) {
/* we are at the right end of the cluster, this is also the */
/* boundary of the child cluster */
newlst = j;
} else if (wgap[wbegin + j - 1] >= *minrgp * (r__1 = work[
wbegin + j - 1], dabs(r__1))) {
/* the right relative gap is big enough, the child cluster */
/* (NEWFST,..,NEWLST) is well separated from the following */
newlst = j;
} else {
/* inside a child cluster, the relative gap is not */
/* big enough. */
goto L140;
}
/* Compute size of child cluster found */
newsiz = newlst - newfst + 1;
/* NEWFTT is the place in Z where the new RRR or the computed */
/* eigenvector is to be stored */
if (*dol == 1 && *dou == *m) {
/* Store representation at location of the leftmost evalue */
/* of the cluster */
newftt = wbegin + newfst - 1;
} else {
if (wbegin + newfst - 1 < *dol) {
/* Store representation at the left end of Z array */
newftt = *dol - 1;
} else if (wbegin + newfst - 1 > *dou) {
/* Store representation at the right end of Z array */
newftt = *dou;
} else {
newftt = wbegin + newfst - 1;
}
}
if (newsiz > 1) {
/* Current child is not a singleton but a cluster. */
/* Compute and store new representation of child. */
/* Compute left and right cluster gap. */
/* LGAP and RGAP are not computed from WORK because */
/* the eigenvalue approximations may stem from RRRs */
/* different shifts. However, W hold all eigenvalues */
/* of the unshifted matrix. Still, the entries in WGAP */
/* have to be computed from WORK since the entries */
/* in W might be of the same order so that gaps are not */
/* exhibited correctly for very close eigenvalues. */
if (newfst == 1) {
/* Computing MAX */
r__1 = 0.f, r__2 = w[wbegin] - werr[wbegin] - *vl;
lgap = dmax(r__1,r__2);
} else {
lgap = wgap[wbegin + newfst - 2];
}
rgap = wgap[wbegin + newlst - 1];
/* Compute left- and rightmost eigenvalue of child */
/* to high precision in order to shift as close */
/* as possible and obtain as large relative gaps */
/* as possible */
for (k = 1; k <= 2; ++k) {
if (k == 1) {
p = indexw[wbegin - 1 + newfst];
} else {
p = indexw[wbegin - 1 + newlst];
}
offset = indexw[wbegin] - 1;
slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &p, &p, &rqtol, &rqtol, &offset, &
work[wbegin], &wgap[wbegin], &werr[wbegin]
, &work[indwrk], &iwork[iindwk], pivmin, &
spdiam, &in, &iinfo);
/* L55: */
}
if (wbegin + newlst - 1 < *dol || wbegin + newfst - 1
> *dou) {
/* if the cluster contains no desired eigenvalues */
/* skip the computation of that branch of the rep. tree */
/* We could skip before the refinement of the extremal */
/* eigenvalues of the child, but then the representation */
/* tree could be different from the one when nothing is */
/* skipped. For this reason we skip at this place. */
idone = idone + newlst - newfst + 1;
goto L139;
}
/* Compute RRR of child cluster. */
/* Note that the new RRR is stored in Z */
/* SLARRF needs LWORK = 2*N */
slarrf_(&in, &d__[ibegin], &l[ibegin], &work[indld +
ibegin - 1], &newfst, &newlst, &work[wbegin],
&wgap[wbegin], &werr[wbegin], &spdiam, &lgap,
&rgap, pivmin, &tau, &z__[ibegin + newftt *
z_dim1], &z__[ibegin + (newftt + 1) * z_dim1],
&work[indwrk], &iinfo);
if (iinfo == 0) {
/* a new RRR for the cluster was found by SLARRF */
/* update shift and store it */
ssigma = sigma + tau;
z__[iend + (newftt + 1) * z_dim1] = ssigma;
/* WORK() are the midpoints and WERR() the semi-width */
/* Note that the entries in W are unchanged. */
i__4 = newlst;
for (k = newfst; k <= i__4; ++k) {
fudge = eps * 3.f * (r__1 = work[wbegin + k -
1], dabs(r__1));
work[wbegin + k - 1] -= tau;
fudge += eps * 4.f * (r__1 = work[wbegin + k
- 1], dabs(r__1));
/* Fudge errors */
werr[wbegin + k - 1] += fudge;
/* Gaps are not fudged. Provided that WERR is small */
/* when eigenvalues are close, a zero gap indicates */
/* that a new representation is needed for resolving */
/* the cluster. A fudge could lead to a wrong decision */
/* of judging eigenvalues 'separated' which in */
/* reality are not. This could have a negative impact */
/* on the orthogonality of the computed eigenvectors. */
/* L116: */
}
++nclus;
k = newcls + (nclus << 1);
iwork[k - 1] = newfst;
iwork[k] = newlst;
} else {
*info = -2;
return 0;
}
} else {
/* Compute eigenvector of singleton */
iter = 0;
tol = log((real) in) * 4.f * eps;
k = newfst;
windex = wbegin + k - 1;
/* Computing MAX */
i__4 = windex - 1;
windmn = max(i__4,1);
/* Computing MIN */
i__4 = windex + 1;
windpl = min(i__4,*m);
lambda = work[windex];
++done;
/* Check if eigenvector computation is to be skipped */
if (windex < *dol || windex > *dou) {
eskip = TRUE_;
goto L125;
} else {
eskip = FALSE_;
}
left = work[windex] - werr[windex];
right = work[windex] + werr[windex];
indeig = indexw[windex];
/* Note that since we compute the eigenpairs for a child, */
/* all eigenvalue approximations are w.r.t the same shift. */
/* In this case, the entries in WORK should be used for */
/* computing the gaps since they exhibit even very small */
/* differences in the eigenvalues, as opposed to the */
/* entries in W which might "look" the same. */
if (k == 1) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VL, the formula */
/* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA ) */
/* can lead to an overestimation of the left gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small left gap. */
/* Computing MAX */
r__1 = dabs(left), r__2 = dabs(right);
lgap = eps * dmax(r__1,r__2);
} else {
lgap = wgap[windmn];
}
if (k == im) {
/* In the case RANGE='I' and with not much initial */
/* accuracy in LAMBDA and VU, the formula */
/* can lead to an overestimation of the right gap and */
/* thus to inadequately early RQI 'convergence'. */
/* Prevent this by forcing a small right gap. */
/* Computing MAX */
r__1 = dabs(left), r__2 = dabs(right);
rgap = eps * dmax(r__1,r__2);
} else {
rgap = wgap[windex];
}
gap = dmin(lgap,rgap);
if (k == 1 || k == im) {
/* The eigenvector support can become wrong */
/* because significant entries could be cut off due to a */
/* large GAPTOL parameter in LAR1V. Prevent this. */
gaptol = 0.f;
} else {
gaptol = gap * eps;
}
isupmn = in;
isupmx = 1;
/* Update WGAP so that it holds the minimum gap */
/* to the left or the right. This is crucial in the */
/* case where bisection is used to ensure that the */
/* eigenvalue is refined up to the required precision. */
/* The correct value is restored afterwards. */
savgap = wgap[windex];
wgap[windex] = gap;
/* We want to use the Rayleigh Quotient Correction */
/* as often as possible since it converges quadratically */
/* when we are close enough to the desired eigenvalue. */
/* However, the Rayleigh Quotient can have the wrong sign */
/* and lead us away from the desired eigenvalue. In this */
/* case, the best we can do is to use bisection. */
usedbs = FALSE_;
usedrq = FALSE_;
/* Bisection is initially turned off unless it is forced */
needbs = ! tryrqc;
L120:
/* Check if bisection should be used to refine eigenvalue */
if (needbs) {
/* Take the bisection as new iterate */
usedbs = TRUE_;
itmp1 = iwork[iindr + windex];
offset = indexw[wbegin] - 1;
r__1 = eps * 2.f;
slarrb_(&in, &d__[ibegin], &work[indlld + ibegin
- 1], &indeig, &indeig, &c_b5, &r__1, &
offset, &work[wbegin], &wgap[wbegin], &
werr[wbegin], &work[indwrk], &iwork[
iindwk], pivmin, &spdiam, &itmp1, &iinfo);
if (iinfo != 0) {
*info = -3;
return 0;
}
lambda = work[windex];
/* Reset twist index from inaccurate LAMBDA to */
/* force computation of true MINGMA */
iwork[iindr + windex] = 0;
}
/* Given LAMBDA, compute the eigenvector. */
L__1 = ! usedbs;
slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin], &l[
ibegin], &work[indld + ibegin - 1], &work[
indlld + ibegin - 1], pivmin, &gaptol, &z__[
ibegin + windex * z_dim1], &L__1, &negcnt, &
ztz, &mingma, &iwork[iindr + windex], &isuppz[
(windex << 1) - 1], &nrminv, &resid, &rqcorr,
&work[indwrk]);
if (iter == 0) {
bstres = resid;
bstw = lambda;
} else if (resid < bstres) {
bstres = resid;
bstw = lambda;
}
/* Computing MIN */
i__4 = isupmn, i__5 = isuppz[(windex << 1) - 1];
isupmn = min(i__4,i__5);
/* Computing MAX */
i__4 = isupmx, i__5 = isuppz[windex * 2];
isupmx = max(i__4,i__5);
++iter;
/* sin alpha <= |resid|/gap */
/* Note that both the residual and the gap are */
/* proportional to the matrix, so ||T|| doesn't play */
/* a role in the quotient */
/* Convergence test for Rayleigh-Quotient iteration */
/* (omitted when Bisection has been used) */
if (resid > tol * gap && dabs(rqcorr) > rqtol * dabs(
lambda) && ! usedbs) {
/* We need to check that the RQCORR update doesn't */
/* move the eigenvalue away from the desired one and */
/* towards a neighbor. -> protection with bisection */
if (indeig <= negcnt) {
/* The wanted eigenvalue lies to the left */
sgndef = -1.f;
} else {
/* The wanted eigenvalue lies to the right */
sgndef = 1.f;
}
/* We only use the RQCORR if it improves the */
/* the iterate reasonably. */
if (rqcorr * sgndef >= 0.f && lambda + rqcorr <=
right && lambda + rqcorr >= left) {
usedrq = TRUE_;
/* Store new midpoint of bisection interval in WORK */
if (sgndef == 1.f) {
/* The current LAMBDA is on the left of the true */
/* eigenvalue */
left = lambda;
/* We prefer to assume that the error estimate */
/* is correct. We could make the interval not */
/* as a bracket but to be modified if the RQCORR */
/* chooses to. In this case, the RIGHT side should */
/* be modified as follows: */
/* RIGHT = MAX(RIGHT, LAMBDA + RQCORR) */
} else {
/* The current LAMBDA is on the right of the true */
/* eigenvalue */
right = lambda;
/* See comment about assuming the error estimate is */
/* correct above. */
/* LEFT = MIN(LEFT, LAMBDA + RQCORR) */
}
work[windex] = (right + left) * .5f;
/* Take RQCORR since it has the correct sign and */
/* improves the iterate reasonably */
lambda += rqcorr;
/* Update width of error interval */
werr[windex] = (right - left) * .5f;
} else {
needbs = TRUE_;
}
if (right - left < rqtol * dabs(lambda)) {
/* The eigenvalue is computed to bisection accuracy */
/* compute eigenvector and stop */
usedbs = TRUE_;
goto L120;
} else if (iter < 10) {
goto L120;
} else if (iter == 10) {
needbs = TRUE_;
goto L120;
} else {
*info = 5;
return 0;
}
} else {
stp2ii = FALSE_;
if (usedrq && usedbs && bstres <= resid) {
lambda = bstw;
stp2ii = TRUE_;
}
if (stp2ii) {
/* improve error angle by second step */
L__1 = ! usedbs;
slar1v_(&in, &c__1, &in, &lambda, &d__[ibegin]
, &l[ibegin], &work[indld + ibegin -
1], &work[indlld + ibegin - 1],
pivmin, &gaptol, &z__[ibegin + windex
* z_dim1], &L__1, &negcnt, &ztz, &
mingma, &iwork[iindr + windex], &
isuppz[(windex << 1) - 1], &nrminv, &
resid, &rqcorr, &work[indwrk]);
}
work[windex] = lambda;
}
/* Compute FP-vector support w.r.t. whole matrix */
isuppz[(windex << 1) - 1] += oldien;
isuppz[windex * 2] += oldien;
zfrom = isuppz[(windex << 1) - 1];
zto = isuppz[windex * 2];
isupmn += oldien;
isupmx += oldien;
/* Ensure vector is ok if support in the RQI has changed */
if (isupmn < zfrom) {
i__4 = zfrom - 1;
for (ii = isupmn; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.f;
/* L122: */
}
}
if (isupmx > zto) {
i__4 = isupmx;
for (ii = zto + 1; ii <= i__4; ++ii) {
z__[ii + windex * z_dim1] = 0.f;
/* L123: */
}
}
i__4 = zto - zfrom + 1;
sscal_(&i__4, &nrminv, &z__[zfrom + windex * z_dim1],
&c__1);
L125:
/* Update W */
w[windex] = lambda + sigma;
/* Recompute the gaps on the left and right */
/* But only allow them to become larger and not */
/* smaller (which can only happen through "bad" */
/* cancellation and doesn't reflect the theory */
/* where the initial gaps are underestimated due */
/* to WERR being too crude.) */
if (! eskip) {
if (k > 1) {
/* Computing MAX */
r__1 = wgap[windmn], r__2 = w[windex] - werr[
windex] - w[windmn] - werr[windmn];
wgap[windmn] = dmax(r__1,r__2);
}
if (windex < wend) {
/* Computing MAX */
r__1 = savgap, r__2 = w[windpl] - werr[windpl]
- w[windex] - werr[windex];
wgap[windex] = dmax(r__1,r__2);
}
}
++idone;
}
/* here ends the code for the current child */
L139:
/* Proceed to any remaining child nodes */
newfst = j + 1;
L140:
;
}
/* L150: */
}
++ndepth;
goto L40;
}
ibegin = iend + 1;
wbegin = wend + 1;
L170:
;
}
return 0;
/* End of SLARRV */
} /* slarrv_ */
/* Subroutine */ int ssbevx_(char *jobz, char *range, char *uplo, integer *n,
integer *kd, real *ab, integer *ldab, real *q, integer *ldq, real *vl,
real *vu, integer *il, integer *iu, real *abstol, integer *m, real *
w, real *z__, integer *ldz, real *work, integer *iwork, integer *
ifail, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
i__2;
real r__1, r__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, jj;
real eps, vll, vuu, tmp1;
integer indd, inde;
real anrm;
integer imax;
real rmin, rmax;
logical test;
integer itmp1, indee;
real sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
char order[1];
extern /* Subroutine */ int sgemv_(char *, integer *, integer *, real *,
real *, integer *, real *, integer *, real *, real *, integer *);
logical lower;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *), sswap_(integer *, real *, integer *, real *, integer *
);
logical wantz, alleig, indeig;
integer iscale, indibl;
logical valeig;
extern doublereal slamch_(char *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real abstll, bignum;
extern doublereal slansb_(char *, char *, integer *, integer *, real *,
integer *, real *);
extern /* Subroutine */ int slascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, real *, integer *, integer *);
integer indisp, indiwo;
extern /* Subroutine */ int slacpy_(char *, integer *, integer *, real *,
integer *, real *, integer *);
integer indwrk;
extern /* Subroutine */ int ssbtrd_(char *, char *, integer *, integer *,
real *, integer *, real *, real *, real *, integer *, real *,
integer *), sstein_(integer *, real *, real *,
integer *, real *, integer *, integer *, real *, integer *, real *
, integer *, integer *, integer *), ssterf_(integer *, real *,
real *, integer *);
integer nsplit;
real smlnum;
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *), ssteqr_(char *, integer *, real *,
real *, real *, integer *, real *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* SSBEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric band matrix A. Eigenvalues and eigenvectors can */
/* be selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found; */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found; */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) REAL array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, AB is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the first */
/* superdiagonal and the diagonal of the tridiagonal matrix T */
/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/* the diagonal and first subdiagonal of T are returned in the */
/* first two rows of AB. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD + 1. */
/* Q (output) REAL array, dimension (LDQ, N) */
/* If JOBZ = 'V', the N-by-N orthogonal matrix used in the */
/* reduction to tridiagonal form. */
/* If JOBZ = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. If JOBZ = 'V', then */
/* LDQ >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing AB to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*SLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) REAL array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and the */
/* index of the eigenvector is returned in IFAIL. */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace) REAL array, dimension (7*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
} else if (wantz && *ldq < max(1,*n)) {
*info = -9;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -11;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -12;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -13;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSBEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
*m = 1;
if (lower) {
tmp1 = ab[ab_dim1 + 1];
} else {
tmp1 = ab[*kd + 1 + ab_dim1];
}
if (valeig) {
if (! (*vl < tmp1 && *vu >= tmp1)) {
*m = 0;
}
}
if (*m == 1) {
w[1] = tmp1;
if (wantz) {
z__[z_dim1 + 1] = 1.f;
}
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.f;
vuu = 0.f;
}
anrm = slansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
slascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
slascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call SSBTRD to reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
ssbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
&q[q_offset], ldq, &work[indwrk], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call SSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try SSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.f) {
scopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssterf_(n, &w[1], &work[indee], info);
} else {
slacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
i__1 = *n - 1;
scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
ssteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwrk], &iwork[indiwo], info);
if (wantz) {
sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by SSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
scopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
sgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
c_b34, &z__[j * z_dim1 + 1], &c__1);
/* L20: */
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of SSBEVX */
} /* ssbevx_ */
/* Subroutine */ int clahqr_(logical *wantt, logical *wantz, integer *n,
integer *ilo, integer *ihi, complex *h__, integer *ldh, complex *w,
integer *iloz, integer *ihiz, complex *z__, integer *ldz, integer *
info)
{
/* System generated locals */
integer h_dim1, h_offset, z_dim1, z_offset, i__1, i__2, i__3, i__4;
real r__1, r__2, r__3, r__4, r__5, r__6;
complex q__1, q__2, q__3, q__4, q__5, q__6, q__7;
/* Builtin functions */
double r_imag(complex *);
void r_cnjg(complex *, complex *);
double c_abs(complex *);
void c_sqrt(complex *, complex *), pow_ci(complex *, complex *, integer *)
;
/* Local variables */
integer i__, j, k, l, m;
real s;
complex t, u, v[2], x, y;
integer i1, i2;
complex t1;
real t2;
complex v2;
real aa, ab, ba, bb, h10;
complex h11;
real h21;
complex h22, sc;
integer nh, nz;
real sx;
integer jhi;
complex h11s;
integer jlo, its;
real ulp;
complex sum;
real tst;
complex temp;
extern /* Subroutine */ int cscal_(integer *, complex *, complex *,
integer *), ccopy_(integer *, complex *, integer *, complex *,
integer *);
real rtemp;
extern /* Subroutine */ int slabad_(real *, real *), clarfg_(integer *,
complex *, complex *, integer *, complex *);
extern /* Complex */ VOID cladiv_(complex *, complex *, complex *);
extern doublereal slamch_(char *);
real safmin, safmax, smlnum;
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CLAHQR is an auxiliary routine called by CHSEQR to update the */
/* eigenvalues and Schur decomposition already computed by CHSEQR, by */
/* dealing with the Hessenberg submatrix in rows and columns ILO to */
/* IHI. */
/* Arguments */
/* ========= */
/* WANTT (input) LOGICAL */
/* = .TRUE. : the full Schur form T is required; */
/* = .FALSE.: only eigenvalues are required. */
/* WANTZ (input) LOGICAL */
/* = .TRUE. : the matrix of Schur vectors Z is required; */
/* = .FALSE.: Schur vectors are not required. */
/* N (input) INTEGER */
/* The order of the matrix H. N >= 0. */
/* ILO (input) INTEGER */
/* IHI (input) INTEGER */
/* It is assumed that H is already upper triangular in rows and */
/* columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless ILO = 1). */
/* CLAHQR works primarily with the Hessenberg submatrix in rows */
/* and columns ILO to IHI, but applies transformations to all of */
/* H if WANTT is .TRUE.. */
/* 1 <= ILO <= max(1,IHI); IHI <= N. */
/* H (input/output) COMPLEX array, dimension (LDH,N) */
/* On entry, the upper Hessenberg matrix H. */
/* On exit, if INFO is zero and if WANTT is .TRUE., then H */
/* is upper triangular in rows and columns ILO:IHI. If INFO */
/* is zero and if WANTT is .FALSE., then the contents of H */
/* are unspecified on exit. The output state of H in case */
/* INF is positive is below under the description of INFO. */
/* LDH (input) INTEGER */
/* The leading dimension of the array H. LDH >= max(1,N). */
/* W (output) COMPLEX array, dimension (N) */
/* The computed eigenvalues ILO to IHI are stored in the */
/* corresponding elements of W. If WANTT is .TRUE., the */
/* eigenvalues are stored in the same order as on the diagonal */
/* of the Schur form returned in H, with W(i) = H(i,i). */
/* ILOZ (input) INTEGER */
/* IHIZ (input) INTEGER */
/* Specify the rows of Z to which transformations must be */
/* applied if WANTZ is .TRUE.. */
/* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N. */
/* Z (input/output) COMPLEX array, dimension (LDZ,N) */
/* If WANTZ is .TRUE., on entry Z must contain the current */
/* matrix Z of transformations accumulated by CHSEQR, and on */
/* exit Z has been updated; transformations are applied only to */
/* the submatrix Z(ILOZ:IHIZ,ILO:IHI). */
/* If WANTZ is .FALSE., Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* .GT. 0: if INFO = i, CLAHQR failed to compute all the */
/* eigenvalues ILO to IHI in a total of 30 iterations */
/* per eigenvalue; elements i+1:ihi of W contain */
/* those eigenvalues which have been successfully */
/* computed. */
/* If INFO .GT. 0 and WANTT is .FALSE., then on exit, */
/* the remaining unconverged eigenvalues are the */
/* eigenvalues of the upper Hessenberg matrix */
/* rows and columns ILO thorugh INFO of the final, */
/* output value of H. */
/* If INFO .GT. 0 and WANTT is .TRUE., then on exit */
/* (*) (initial value of H)*U = U*(final value of H) */
/* where U is an orthognal matrix. The final */
/* value of H is upper Hessenberg and triangular in */
/* rows and columns INFO+1 through IHI. */
/* If INFO .GT. 0 and WANTZ is .TRUE., then on exit */
/* (final value of Z) = (initial value of Z)*U */
/* where U is the orthogonal matrix in (*) */
/* (regardless of the value of WANTT.) */
/* Further Details */
/* =============== */
/* 02-96 Based on modifications by */
/* David Day, Sandia National Laboratory, USA */
/* 12-04 Further modifications by */
/* Ralph Byers, University of Kansas, USA */
/* This is a modified version of CLAHQR from LAPACK version 3.0. */
/* It is (1) more robust against overflow and underflow and */
/* (2) adopts the more conservative Ahues & Tisseur stopping */
/* criterion (LAWN 122, 1997). */
/* ========================================================= */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Statement Functions .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Statement Function definitions .. */
/* .. */
/* .. Executable Statements .. */
/* Parameter adjustments */
h_dim1 = *ldh;
h_offset = 1 + h_dim1;
h__ -= h_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
/* Function Body */
*info = 0;
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*ilo == *ihi) {
i__1 = *ilo;
i__2 = *ilo + *ilo * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
return 0;
}
/* ==== clear out the trash ==== */
i__1 = *ihi - 3;
for (j = *ilo; j <= i__1; ++j) {
i__2 = j + 2 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
i__2 = j + 3 + j * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
/* L10: */
}
if (*ilo <= *ihi - 2) {
i__1 = *ihi + (*ihi - 2) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* ==== ensure that subdiagonal entries are real ==== */
if (*wantt) {
jlo = 1;
jhi = *n;
} else {
jlo = *ilo;
jhi = *ihi;
}
i__1 = *ihi;
for (i__ = *ilo + 1; i__ <= i__1; ++i__) {
if (r_imag(&h__[i__ + (i__ - 1) * h_dim1]) != 0.f) {
/* ==== The following redundant normalization */
/* . avoids problems with both gradual and */
/* . sudden underflow in ABS(H(I,I-1)) ==== */
i__2 = i__ + (i__ - 1) * h_dim1;
i__3 = i__ + (i__ - 1) * h_dim1;
r__3 = (r__1 = h__[i__3].r, dabs(r__1)) + (r__2 = r_imag(&h__[i__
+ (i__ - 1) * h_dim1]), dabs(r__2));
q__1.r = h__[i__2].r / r__3, q__1.i = h__[i__2].i / r__3;
sc.r = q__1.r, sc.i = q__1.i;
r_cnjg(&q__2, &sc);
r__1 = c_abs(&sc);
q__1.r = q__2.r / r__1, q__1.i = q__2.i / r__1;
sc.r = q__1.r, sc.i = q__1.i;
i__2 = i__ + (i__ - 1) * h_dim1;
r__1 = c_abs(&h__[i__ + (i__ - 1) * h_dim1]);
h__[i__2].r = r__1, h__[i__2].i = 0.f;
i__2 = jhi - i__ + 1;
cscal_(&i__2, &sc, &h__[i__ + i__ * h_dim1], ldh);
/* Computing MIN */
i__3 = jhi, i__4 = i__ + 1;
i__2 = min(i__3,i__4) - jlo + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &h__[jlo + i__ * h_dim1], &c__1);
if (*wantz) {
i__2 = *ihiz - *iloz + 1;
r_cnjg(&q__1, &sc);
cscal_(&i__2, &q__1, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L20: */
}
nh = *ihi - *ilo + 1;
nz = *ihiz - *iloz + 1;
/* Set machine-dependent constants for the stopping criterion. */
safmin = slamch_("SAFE MINIMUM");
safmax = 1.f / safmin;
slabad_(&safmin, &safmax);
ulp = slamch_("PRECISION");
smlnum = safmin * ((real) nh / ulp);
/* I1 and I2 are the indices of the first row and last column of H */
/* to which transformations must be applied. If eigenvalues only are */
/* being computed, I1 and I2 are set inside the main loop. */
if (*wantt) {
i1 = 1;
i2 = *n;
}
/* The main loop begins here. I is the loop index and decreases from */
/* IHI to ILO in steps of 1. Each iteration of the loop works */
/* with the active submatrix in rows and columns L to I. */
/* Eigenvalues I+1 to IHI have already converged. Either L = ILO, or */
/* H(L,L-1) is negligible so that the matrix splits. */
i__ = *ihi;
L30:
if (i__ < *ilo) {
goto L150;
}
/* Perform QR iterations on rows and columns ILO to I until a */
/* submatrix of order 1 splits off at the bottom because a */
/* subdiagonal element has become negligible. */
l = *ilo;
for (its = 0; its <= 30; ++its) {
/* Look for a single small subdiagonal element. */
i__1 = l + 1;
for (k = i__; k >= i__1; --k) {
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k + (k
- 1) * h_dim1]), dabs(r__2)) <= smlnum) {
goto L50;
}
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
tst = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[k -
1 + (k - 1) * h_dim1]), dabs(r__2)) + ((r__3 = h__[i__3]
.r, dabs(r__3)) + (r__4 = r_imag(&h__[k + k * h_dim1]),
dabs(r__4)));
if (tst == 0.f) {
if (k - 2 >= *ilo) {
i__2 = k - 1 + (k - 2) * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
if (k + 1 <= *ihi) {
i__2 = k + 1 + k * h_dim1;
tst += (r__1 = h__[i__2].r, dabs(r__1));
}
}
/* ==== The following is a conservative small subdiagonal */
/* . deflation criterion due to Ahues & Tisseur (LAWN 122, */
/* . 1997). It has better mathematical foundation and */
/* . improves accuracy in some examples. ==== */
i__2 = k + (k - 1) * h_dim1;
if ((r__1 = h__[i__2].r, dabs(r__1)) <= ulp * tst) {
/* Computing MAX */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ab = dmax(r__5,r__6);
/* Computing MIN */
i__2 = k + (k - 1) * h_dim1;
i__3 = k - 1 + k * h_dim1;
r__5 = (r__1 = h__[i__2].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + (k - 1) * h_dim1]), dabs(r__2)), r__6 = (r__3 =
h__[i__3].r, dabs(r__3)) + (r__4 = r_imag(&h__[k - 1
+ k * h_dim1]), dabs(r__4));
ba = dmin(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MAX */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
aa = dmax(r__5,r__6);
i__2 = k - 1 + (k - 1) * h_dim1;
i__3 = k + k * h_dim1;
q__2.r = h__[i__2].r - h__[i__3].r, q__2.i = h__[i__2].i -
h__[i__3].i;
q__1.r = q__2.r, q__1.i = q__2.i;
/* Computing MIN */
i__4 = k + k * h_dim1;
r__5 = (r__1 = h__[i__4].r, dabs(r__1)) + (r__2 = r_imag(&h__[
k + k * h_dim1]), dabs(r__2)), r__6 = (r__3 = q__1.r,
dabs(r__3)) + (r__4 = r_imag(&q__1), dabs(r__4));
bb = dmin(r__5,r__6);
s = aa + ab;
/* Computing MAX */
r__1 = smlnum, r__2 = ulp * (bb * (aa / s));
if (ba * (ab / s) <= dmax(r__1,r__2)) {
goto L50;
}
}
/* L40: */
}
L50:
l = k;
if (l > *ilo) {
/* H(L,L-1) is negligible */
i__1 = l + (l - 1) * h_dim1;
h__[i__1].r = 0.f, h__[i__1].i = 0.f;
}
/* Exit from loop if a submatrix of order 1 has split off. */
if (l >= i__) {
goto L140;
}
/* Now the active submatrix is in rows and columns L to I. If */
/* eigenvalues only are being computed, only the active submatrix */
/* need be transformed. */
if (! (*wantt)) {
i1 = l;
i2 = i__;
}
if (its == 10) {
/* Exceptional shift. */
i__1 = l + 1 + l * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = l + l * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else if (its == 20) {
/* Exceptional shift. */
i__1 = i__ + (i__ - 1) * h_dim1;
s = (r__1 = h__[i__1].r, dabs(r__1)) * .75f;
i__1 = i__ + i__ * h_dim1;
q__1.r = s + h__[i__1].r, q__1.i = h__[i__1].i;
t.r = q__1.r, t.i = q__1.i;
} else {
/* Wilkinson's shift. */
i__1 = i__ + i__ * h_dim1;
t.r = h__[i__1].r, t.i = h__[i__1].i;
c_sqrt(&q__2, &h__[i__ - 1 + i__ * h_dim1]);
c_sqrt(&q__3, &h__[i__ + (i__ - 1) * h_dim1]);
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r *
q__3.i + q__2.i * q__3.r;
u.r = q__1.r, u.i = q__1.i;
s = (r__1 = u.r, dabs(r__1)) + (r__2 = r_imag(&u), dabs(r__2));
if (s != 0.f) {
i__1 = i__ - 1 + (i__ - 1) * h_dim1;
q__2.r = h__[i__1].r - t.r, q__2.i = h__[i__1].i - t.i;
q__1.r = q__2.r * .5f, q__1.i = q__2.i * .5f;
x.r = q__1.r, x.i = q__1.i;
sx = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x), dabs(r__2)
);
/* Computing MAX */
r__3 = s, r__4 = (r__1 = x.r, dabs(r__1)) + (r__2 = r_imag(&x)
, dabs(r__2));
s = dmax(r__3,r__4);
q__5.r = x.r / s, q__5.i = x.i / s;
pow_ci(&q__4, &q__5, &c__2);
q__7.r = u.r / s, q__7.i = u.i / s;
pow_ci(&q__6, &q__7, &c__2);
q__3.r = q__4.r + q__6.r, q__3.i = q__4.i + q__6.i;
c_sqrt(&q__2, &q__3);
q__1.r = s * q__2.r, q__1.i = s * q__2.i;
y.r = q__1.r, y.i = q__1.i;
if (sx > 0.f) {
q__1.r = x.r / sx, q__1.i = x.i / sx;
q__2.r = x.r / sx, q__2.i = x.i / sx;
if (q__1.r * y.r + r_imag(&q__2) * r_imag(&y) < 0.f) {
q__3.r = -y.r, q__3.i = -y.i;
y.r = q__3.r, y.i = q__3.i;
}
}
q__4.r = x.r + y.r, q__4.i = x.i + y.i;
cladiv_(&q__3, &u, &q__4);
q__2.r = u.r * q__3.r - u.i * q__3.i, q__2.i = u.r * q__3.i +
u.i * q__3.r;
q__1.r = t.r - q__2.r, q__1.i = t.i - q__2.i;
t.r = q__1.r, t.i = q__1.i;
}
}
/* Look for two consecutive small subdiagonal elements. */
i__1 = l + 1;
for (m = i__ - 1; m >= i__1; --m) {
/* Determine the effect of starting the single-shift QR */
/* iteration at row M, and see if this would make H(M,M-1) */
/* negligible. */
i__2 = m + m * h_dim1;
h11.r = h__[i__2].r, h11.i = h__[i__2].i;
i__2 = m + 1 + (m + 1) * h_dim1;
h22.r = h__[i__2].r, h22.i = h__[i__2].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
h21 = h__[i__2].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(
r__2)) + dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
i__2 = m + (m - 1) * h_dim1;
h10 = h__[i__2].r;
if (dabs(h10) * dabs(h21) <= ulp * (((r__1 = h11s.r, dabs(r__1))
+ (r__2 = r_imag(&h11s), dabs(r__2))) * ((r__3 = h11.r,
dabs(r__3)) + (r__4 = r_imag(&h11), dabs(r__4)) + ((r__5 =
h22.r, dabs(r__5)) + (r__6 = r_imag(&h22), dabs(r__6)))))
) {
goto L70;
}
/* L60: */
}
i__1 = l + l * h_dim1;
h11.r = h__[i__1].r, h11.i = h__[i__1].i;
i__1 = l + 1 + (l + 1) * h_dim1;
h22.r = h__[i__1].r, h22.i = h__[i__1].i;
q__1.r = h11.r - t.r, q__1.i = h11.i - t.i;
h11s.r = q__1.r, h11s.i = q__1.i;
i__1 = l + 1 + l * h_dim1;
h21 = h__[i__1].r;
s = (r__1 = h11s.r, dabs(r__1)) + (r__2 = r_imag(&h11s), dabs(r__2))
+ dabs(h21);
q__1.r = h11s.r / s, q__1.i = h11s.i / s;
h11s.r = q__1.r, h11s.i = q__1.i;
h21 /= s;
v[0].r = h11s.r, v[0].i = h11s.i;
v[1].r = h21, v[1].i = 0.f;
L70:
/* Single-shift QR step */
i__1 = i__ - 1;
for (k = m; k <= i__1; ++k) {
/* The first iteration of this loop determines a reflection G */
/* from the vector V and applies it from left and right to H, */
/* thus creating a nonzero bulge below the subdiagonal. */
/* Each subsequent iteration determines a reflection G to */
/* restore the Hessenberg form in the (K-1)th column, and thus */
/* chases the bulge one step toward the bottom of the active */
/* submatrix. */
/* V(2) is always real before the call to CLARFG, and hence */
/* after the call T2 ( = T1*V(2) ) is also real. */
if (k > m) {
ccopy_(&c__2, &h__[k + (k - 1) * h_dim1], &c__1, v, &c__1);
}
clarfg_(&c__2, v, &v[1], &c__1, &t1);
if (k > m) {
i__2 = k + (k - 1) * h_dim1;
h__[i__2].r = v[0].r, h__[i__2].i = v[0].i;
i__2 = k + 1 + (k - 1) * h_dim1;
h__[i__2].r = 0.f, h__[i__2].i = 0.f;
}
v2.r = v[1].r, v2.i = v[1].i;
q__1.r = t1.r * v2.r - t1.i * v2.i, q__1.i = t1.r * v2.i + t1.i *
v2.r;
t2 = q__1.r;
/* Apply G from the left to transform the rows of the matrix */
/* in columns K to I2. */
i__2 = i2;
for (j = k; j <= i__2; ++j) {
r_cnjg(&q__3, &t1);
i__3 = k + j * h_dim1;
q__2.r = q__3.r * h__[i__3].r - q__3.i * h__[i__3].i, q__2.i =
q__3.r * h__[i__3].i + q__3.i * h__[i__3].r;
i__4 = k + 1 + j * h_dim1;
q__4.r = t2 * h__[i__4].r, q__4.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__4.r, q__1.i = q__2.i + q__4.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = k + j * h_dim1;
i__4 = k + j * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = k + 1 + j * h_dim1;
i__4 = k + 1 + j * h_dim1;
q__2.r = sum.r * v2.r - sum.i * v2.i, q__2.i = sum.r * v2.i +
sum.i * v2.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L80: */
}
/* Apply G from the right to transform the columns of the */
/* matrix in rows I1 to min(K+2,I). */
/* Computing MIN */
i__3 = k + 2;
i__2 = min(i__3,i__);
for (j = i1; j <= i__2; ++j) {
i__3 = j + k * h_dim1;
q__2.r = t1.r * h__[i__3].r - t1.i * h__[i__3].i, q__2.i =
t1.r * h__[i__3].i + t1.i * h__[i__3].r;
i__4 = j + (k + 1) * h_dim1;
q__3.r = t2 * h__[i__4].r, q__3.i = t2 * h__[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = j + k * h_dim1;
i__4 = j + k * h_dim1;
q__1.r = h__[i__4].r - sum.r, q__1.i = h__[i__4].i - sum.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
i__3 = j + (k + 1) * h_dim1;
i__4 = j + (k + 1) * h_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = h__[i__4].r - q__2.r, q__1.i = h__[i__4].i - q__2.i;
h__[i__3].r = q__1.r, h__[i__3].i = q__1.i;
/* L90: */
}
if (*wantz) {
/* Accumulate transformations in the matrix Z */
i__2 = *ihiz;
for (j = *iloz; j <= i__2; ++j) {
i__3 = j + k * z_dim1;
q__2.r = t1.r * z__[i__3].r - t1.i * z__[i__3].i, q__2.i =
t1.r * z__[i__3].i + t1.i * z__[i__3].r;
i__4 = j + (k + 1) * z_dim1;
q__3.r = t2 * z__[i__4].r, q__3.i = t2 * z__[i__4].i;
q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i;
sum.r = q__1.r, sum.i = q__1.i;
i__3 = j + k * z_dim1;
i__4 = j + k * z_dim1;
q__1.r = z__[i__4].r - sum.r, q__1.i = z__[i__4].i -
sum.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
i__3 = j + (k + 1) * z_dim1;
i__4 = j + (k + 1) * z_dim1;
r_cnjg(&q__3, &v2);
q__2.r = sum.r * q__3.r - sum.i * q__3.i, q__2.i = sum.r *
q__3.i + sum.i * q__3.r;
q__1.r = z__[i__4].r - q__2.r, q__1.i = z__[i__4].i -
q__2.i;
z__[i__3].r = q__1.r, z__[i__3].i = q__1.i;
/* L100: */
}
}
if (k == m && m > l) {
/* If the QR step was started at row M > L because two */
/* consecutive small subdiagonals were found, then extra */
/* scaling must be performed to ensure that H(M,M-1) remains */
/* real. */
q__1.r = 1.f - t1.r, q__1.i = 0.f - t1.i;
temp.r = q__1.r, temp.i = q__1.i;
r__1 = c_abs(&temp);
q__1.r = temp.r / r__1, q__1.i = temp.i / r__1;
temp.r = q__1.r, temp.i = q__1.i;
i__2 = m + 1 + m * h_dim1;
i__3 = m + 1 + m * h_dim1;
r_cnjg(&q__2, &temp);
q__1.r = h__[i__3].r * q__2.r - h__[i__3].i * q__2.i, q__1.i =
h__[i__3].r * q__2.i + h__[i__3].i * q__2.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
if (m + 2 <= i__) {
i__2 = m + 2 + (m + 1) * h_dim1;
i__3 = m + 2 + (m + 1) * h_dim1;
q__1.r = h__[i__3].r * temp.r - h__[i__3].i * temp.i,
q__1.i = h__[i__3].r * temp.i + h__[i__3].i *
temp.r;
h__[i__2].r = q__1.r, h__[i__2].i = q__1.i;
}
i__2 = i__;
for (j = m; j <= i__2; ++j) {
if (j != m + 1) {
if (i2 > j) {
i__3 = i2 - j;
cscal_(&i__3, &temp, &h__[j + (j + 1) * h_dim1],
ldh);
}
i__3 = j - i1;
r_cnjg(&q__1, &temp);
cscal_(&i__3, &q__1, &h__[i1 + j * h_dim1], &c__1);
if (*wantz) {
r_cnjg(&q__1, &temp);
cscal_(&nz, &q__1, &z__[*iloz + j * z_dim1], &
c__1);
}
}
/* L110: */
}
}
/* L120: */
}
/* Ensure that H(I,I-1) is real. */
i__1 = i__ + (i__ - 1) * h_dim1;
temp.r = h__[i__1].r, temp.i = h__[i__1].i;
if (r_imag(&temp) != 0.f) {
rtemp = c_abs(&temp);
i__1 = i__ + (i__ - 1) * h_dim1;
h__[i__1].r = rtemp, h__[i__1].i = 0.f;
q__1.r = temp.r / rtemp, q__1.i = temp.i / rtemp;
temp.r = q__1.r, temp.i = q__1.i;
if (i2 > i__) {
i__1 = i2 - i__;
r_cnjg(&q__1, &temp);
cscal_(&i__1, &q__1, &h__[i__ + (i__ + 1) * h_dim1], ldh);
}
i__1 = i__ - i1;
cscal_(&i__1, &temp, &h__[i1 + i__ * h_dim1], &c__1);
if (*wantz) {
cscal_(&nz, &temp, &z__[*iloz + i__ * z_dim1], &c__1);
}
}
/* L130: */
}
/* Failure to converge in remaining number of iterations */
*info = i__;
return 0;
L140:
/* H(I,I-1) is negligible: one eigenvalue has converged. */
i__1 = i__;
i__2 = i__ + i__ * h_dim1;
w[i__1].r = h__[i__2].r, w[i__1].i = h__[i__2].i;
/* return to start of the main loop with new value of I. */
i__ = l - 1;
goto L30;
L150:
return 0;
/* End of CLAHQR */
} /* clahqr_ */
