int dsyevx_(char *jobz, char *range, char *uplo, int *n,
double *a, int *lda, double *vl, double *vu, int *
il, int *iu, double *abstol, int *m, double *w,
double *z__, int *ldz, double *work, int *lwork,
int *iwork, int *ifail, int *info)
{
/* System generated locals */
int a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
double d__1, d__2;
/* Builtin functions */
double sqrt(double);
/* Local variables */
int i__, j, nb, jj;
double eps, vll, vuu, tmp1;
int indd, inde;
double anrm;
int imax;
double rmin, rmax;
int test;
int itmp1, indee;
extern int dscal_(int *, double *, double *,
int *);
double sigma;
extern int lsame_(char *, char *);
int iinfo;
char order[1];
extern int dcopy_(int *, double *, int *,
double *, int *), dswap_(int *, double *, int
*, double *, int *);
int lower, wantz;
extern double dlamch_(char *);
int alleig, indeig;
int iscale, indibl;
int valeig;
extern int dlacpy_(char *, int *, int *,
double *, int *, double *, int *);
double safmin;
extern int ilaenv_(int *, char *, char *, int *, int *,
int *, int *);
extern int xerbla_(char *, int *);
double abstll, bignum;
int indtau, indisp;
extern int dstein_(int *, double *, double *,
int *, double *, int *, int *, double *,
int *, double *, int *, int *, int *),
dsterf_(int *, double *, double *, int *);
int indiwo, indwkn;
extern double dlansy_(char *, char *, int *, double *,
int *, double *);
extern int dstebz_(char *, char *, int *, double
*, double *, int *, int *, double *, double *,
double *, int *, int *, double *, int *,
int *, double *, int *, int *);
int indwrk, lwkmin;
extern int dorgtr_(char *, int *, double *,
int *, double *, double *, int *, int *), dsteqr_(char *, int *, double *, double *,
double *, int *, double *, int *),
dormtr_(char *, char *, char *, int *, int *, double *
, int *, double *, double *, int *, double *,
int *, int *);
int llwrkn, llwork, nsplit;
double smlnum;
extern int dsytrd_(char *, int *, double *,
int *, double *, double *, double *, double *,
int *, int *);
int lwkopt;
int lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSYEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a float 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) DOUBLE PRECISION 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) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('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) DOUBLE PRECISION array, dimension (N) */
/* On normal exit, the first M elements contain the selected */
/* eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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 DSYTRD and DORMTR */
/* 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. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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] = (double) lwkmin;
} else {
lwkmin = *n << 3;
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", 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] = (double) lwkopt;
}
if (*lwork < lwkmin && ! lquery) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVX", &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.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = MIN(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
if (anrm > 0. && 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;
dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(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 DSTERF or DORGTR and SSTEQR. If this fails for */
/* some eigenvalue, then try DSTEBZ. */
test = FALSE;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
, &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(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;
/* L30: */
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ 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;
dstebz_(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) {
dstein_(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 DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("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;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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];
}
/* L50: */
}
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;
dswap_(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;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (double) lwkopt;
return 0;
/* End of DSYEVX */
} /* dsyevx_ */
/* Subroutine */ int zhpevx_(char *jobz, char *range, char *uplo, integer *n,
doublecomplex *ap, doublereal *vl, doublereal *vu, integer *il,
integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublecomplex *z__, integer *ldz, doublecomplex *work, doublereal *
rwork, integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
logical wantz;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
doublereal abstll, bignum;
integer indiwk, indisp, indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
extern doublereal zlanhp_(char *, char *, integer *, doublecomplex *,
doublereal *);
integer indrwk, indwrk, nsplit;
doublereal smlnum;
extern /* Subroutine */ int zhptrd_(char *, integer *, doublecomplex *,
doublereal *, doublereal *, doublecomplex *, integer *),
zstein_(integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublecomplex *, integer *,
doublereal *, integer *, integer *, integer *), zsteqr_(char *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *,
doublereal *, integer *), zupgtr_(char *, integer *,
doublecomplex *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *), zupmtr_(char *, char *, char
*, integer *, integer *, doublecomplex *, doublecomplex *,
doublecomplex *, integer *, doublecomplex *, integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* ZHPEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a complex Hermitian matrix A in packed storage. */
/* Eigenvalues/vectors 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. */
/* AP (input/output) COMPLEX*16 array, dimension (N*(N+1)/2) */
/* On entry, 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)*(2*n-j)/2) = A(i,j) for j<=i<=n. */
/* On exit, AP is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the diagonal */
/* and first superdiagonal of the tridiagonal matrix T overwrite */
/* the corresponding elements of A, and if UPLO = 'L', the */
/* diagonal and first subdiagonal of T overwrite the */
/* corresponding elements of A. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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 AP to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('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) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the selected eigenvalues in ascending order. */
/* Z (output) COMPLEX*16 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) COMPLEX*16 array, dimension (2*N) */
/* RWORK (workspace) DOUBLE PRECISION 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 */
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHPEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = ap[1].r;
} else {
if (*vl < ap[1].r && *vu >= ap[1].r) {
*m = 1;
w[1] = ap[1].r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1., z__[i__1].i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
anrm = zlanhp_("M", uplo, n, &ap[1], &rwork[1]);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
zdscal_(&i__1, &sigma, &ap[1], &c__1);
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHPTRD to reduce Hermitian packed matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
zhptrd_(uplo, n, &ap[1], &rwork[indd], &rwork[inde], &work[indtau], &
iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or ZUPGTR and ZSTEQR. If this fails */
/* for some eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
dsterf_(n, &w[1], &rwork[indee], info);
} else {
zupgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
work[indwrk], &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
rwork[indrwk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L20;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], &
rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &
rwork[indrwk], &iwork[indiwk], info);
if (wantz) {
zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by ZSTEIN. */
indwrk = indtau + *n;
zupmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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];
}
/* L30: */
}
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;
zswap_(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;
}
}
/* L40: */
}
}
return 0;
/* End of ZHPEVX */
} /* zhpevx_ */
/* Subroutine */
int zheevx_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal * w, doublecomplex *z__, integer *ldz, doublecomplex *work, integer * lwork, doublereal *rwork, integer *iwork, integer *ifail, integer * info)
{
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, nb, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */
int dscal_(integer *, doublereal *, doublereal *, integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo;
char order[1];
extern /* Subroutine */
int dcopy_(integer *, doublereal *, integer *, doublereal *, integer *);
logical lower, wantz;
extern /* Subroutine */
int zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *);
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int xerbla_(char *, integer *), zdscal_( integer *, doublereal *, doublecomplex *, integer *);
doublereal abstll, bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, integer *, doublereal *);
integer indiwk, indisp, indtau;
extern /* Subroutine */
int dsterf_(integer *, doublereal *, doublereal *, integer *), dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *);
integer indrwk, indwrk;
extern /* Subroutine */
int zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, doublecomplex *, integer *, integer *);
integer lwkmin;
extern /* Subroutine */
int zlacpy_(char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *);
integer llwork, nsplit;
doublereal smlnum;
extern /* Subroutine */
int zstein_(integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, doublecomplex *, integer *, doublereal *, integer *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *), zungtr_(char *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, integer *), zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
/* -- LAPACK driver routine (version 3.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* 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;
--rwork;
--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].r = (doublereal) lwkmin;
work[1].i = 0.; // , expr subst
}
else
{
lwkmin = *n << 1;
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = nb;
i__2 = ilaenv_(&c__1, "ZUNMTR", uplo, n, &c_n1, &c_n1, &c_n1); // , expr subst
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = 1;
i__2 = (nb + 1) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
}
if (*lwork < lwkmin && ! lquery)
{
*info = -17;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHEEVX", &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;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
else if (valeig)
{
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < a[i__1].r && *vu >= a[i__2].r)
{
*m = 1;
i__1 = a_dim1 + 1;
w[1] = a[i__1].r;
}
}
if (wantz)
{
i__1 = z_dim1 + 1;
z__[i__1].r = 1.;
z__[i__1].i = 0.; // , expr subst
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum);
d__2 = 1. / sqrt(sqrt(safmin)); // , expr subst
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig)
{
vll = *vl;
vuu = *vu;
}
anrm = zlanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]);
if (anrm > 0. && 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;
zdscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
}
else
{
i__1 = *n;
for (j = 1;
j <= i__1;
++j)
{
zdscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.)
{
abstll = *abstol * sigma;
}
if (valeig)
{
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &a[a_offset], lda, &rwork[indd], &rwork[inde], &work[ indtau], &work[indwrk], &llwork, &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal to */
/* zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for */
/* some eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig)
{
if (*il == 1 && *iu == *n)
{
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.)
{
dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz)
{
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
dsterf_(n, &w[1], &rwork[indee], info);
}
else
{
zlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
zungtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk] , &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, & rwork[indrwk], info);
if (*info == 0)
{
i__1 = *n;
for (i__ = 1;
i__ <= i__1;
++i__)
{
ifail[i__] = 0;
/* L30: */
}
}
}
if (*info == 0)
{
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz)
{
*(unsigned char *)order = 'B';
}
else
{
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & rwork[indrwk], &iwork[indiwk], info);
if (wantz)
{
zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by ZSTEIN. */
zunmtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau], &z__[ z_offset], ldz, &work[indwrk], &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1)
{
if (*info == 0)
{
imax = *m;
}
else
{
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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];
}
/* L50: */
}
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;
zswap_(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;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size. */
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZHEEVX */
}
/* Subroutine */ int dstevx_(char *jobz, char *range, integer *n, doublereal *
d__, doublereal *e, doublereal *vl, doublereal *vu, integer *il,
integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublereal *z__, integer *ldz, doublereal *work, integer *iwork,
integer *ifail, integer *info)
{
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, jj;
doublereal eps, vll, vuu, tmp1;
integer imax;
doublereal rmin, rmax;
logical test;
doublereal tnrm;
integer itmp1;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical wantz;
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *);
integer indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
integer indiwo;
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer nsplit;
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSTEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric tridiagonal 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. */
/* N (input) INTEGER */
/* The order of the matrix. N >= 0. */
/* D (input/output) DOUBLE PRECISION array, dimension (N) */
/* On entry, the n diagonal elements of the tridiagonal matrix */
/* A. */
/* On exit, D may be multiplied by a constant factor chosen */
/* to avoid over/underflow in computing the eigenvalues. */
/* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1)) */
/* On entry, the (n-1) subdiagonal elements of the tridiagonal */
/* matrix A in elements 1 to N-1 of E. */
/* On exit, E may be multiplied by a constant factor chosen */
/* to avoid over/underflow in computing the eigenvalues. */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('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) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) DOUBLE PRECISION 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 (INFO > 0), 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) DOUBLE PRECISION array, dimension (5*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 */
--d__;
--e;
--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");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSTEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = d__[1];
} else {
if (*vl < d__[1] && *vu >= d__[1]) {
*m = 1;
w[1] = d__[1];
}
}
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
tnrm = dlanst_("M", n, &d__[1], &e[1]);
if (tnrm > 0. && tnrm < rmin) {
iscale = 1;
sigma = rmin / tnrm;
} else if (tnrm > rmax) {
iscale = 1;
sigma = rmax / tnrm;
}
if (iscale == 1) {
dscal_(n, &sigma, &d__[1], &c__1);
i__1 = *n - 1;
dscal_(&i__1, &sigma, &e[1], &c__1);
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* If all eigenvalues are desired and ABSTOL is less than zero, then */
/* call DSTERF or SSTEQR. If this fails for some eigenvalue, then */
/* try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &d__[1], &c__1, &w[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &e[1], &c__1, &work[1], &c__1);
indwrk = *n + 1;
if (! wantz) {
dsterf_(n, &w[1], &work[1], info);
} else {
dsteqr_("I", n, &w[1], &work[1], &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 L20;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indwrk = 1;
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, &
nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], &
iwork[indiwo], info);
if (wantz) {
dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], &
z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1],
info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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];
}
/* L30: */
}
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;
dswap_(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;
}
}
/* L40: */
}
}
return 0;
/* End of DSTEVX */
} /* dstevx_ */
/* Subroutine */ int dsyevr_(char *jobz, char *range, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublereal *z__, integer *ldz, integer *isuppz, doublereal *work,
integer *lwork, integer *iwork, integer *liwork, integer *info)
{
/* -- LAPACK driver routine (version 3.1) --
Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
November 2006
Purpose
=======
DSYEVR 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.
DSYEVR first reduces the matrix A to tridiagonal form T with a call
to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
the eigenspectrum using Relatively Robust Representations. DSTEMR
computes eigenvalues by the dqds algorithm, while orthogonal
eigenvectors are computed from various "good" L D L^T representations
(also known as Relatively Robust Representations). Gram-Schmidt
orthogonalization is avoided as far as possible. More specifically,
the various steps of the algorithm are as follows.
For each unreduced block (submatrix) of T,
(a) Compute T - sigma I = L D L^T, so that L and D
define all the wanted eigenvalues to high relative accuracy.
This means that small relative changes in the entries of D and L
cause only small relative changes in the eigenvalues and
eigenvectors. The standard (unfactored) representation of the
tridiagonal matrix T does not have this property in general.
(b) Compute the eigenvalues to suitable accuracy.
If the eigenvectors are desired, the algorithm attains full
accuracy of the computed eigenvalues only right before
the corresponding vectors have to be computed, see steps c) and d).
(c) For each cluster of close eigenvalues, select a new
shift close to the cluster, find a new factorization, and refine
the shifted eigenvalues to suitable accuracy.
(d) For each eigenvalue with a large enough relative separation compute
the corresponding eigenvector by forming a rank revealing twisted
factorization. Go back to (c) for any clusters that remain.
The desired accuracy of the output can be specified by the input
parameter ABSTOL.
For more details, see DSTEMR's documentation and:
- Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
- Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
2004. Also LAPACK Working Note 154.
- Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
tridiagonal eigenvalue/eigenvector problem",
Computer Science Division Technical Report No. UCB/CSD-97-971,
UC Berkeley, May 1997.
Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
on machines which conform to the ieee-754 floating point standard.
DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
when partial spectrum requests are made.
Normal execution of DSTEMR may create NaNs and infinities and
hence may abort due to a floating point exception in environments
which do not handle NaNs and infinities in the ieee standard default
manner.
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.
********* For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
********* DSTEIN are called
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) DOUBLE PRECISION 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) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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) DOUBLE PRECISION
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.
See "Computing Small Singular Values of Bidiagonal Matrices
with Guaranteed High Relative Accuracy," by Demmel and
Kahan, LAPACK Working Note #3.
If high relative accuracy is important, set ABSTOL to
DLAMCH( 'Safe minimum' ). Doing so will guarantee that
eigenvalues are computed to high relative accuracy when
possible in future releases. The current code does not
make any guarantees about high relative accuracy, but
future releases will. See J. Barlow and J. Demmel,
"Computing Accurate Eigensystems of Scaled Diagonally
Dominant Matrices", LAPACK Working Note #7, for a discussion
of which matrices define their eigenvalues to high relative
accuracy.
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) DOUBLE PRECISION array, dimension (N)
The first M elements contain the selected eigenvalues in
ascending order.
Z (output) DOUBLE PRECISION 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 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.
Supplying N columns is always safe.
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 ).
********* Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The dimension of the array WORK. LWORK >= max(1,26*N).
For optimal efficiency, LWORK >= (NB+6)*N,
where NB is the max of the blocksize for DSYTRD and DORMTR
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/output) INTEGER array, dimension (MAX(1,LIWORK))
On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
LIWORK (input) INTEGER
The dimension of the array IWORK. LIWORK >= max(1,10*N).
If LIWORK = -1, then a workspace query is assumed; the
routine only calculates the optimal size of the IWORK array,
returns this value as the first entry of the IWORK array, and
no error message related to LIWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: Internal error
Further Details
===============
Based on contributions by
Inderjit Dhillon, IBM Almaden, USA
Osni Marques, LBNL/NERSC, USA
Ken Stanley, Computer Science Division, University of
California at Berkeley, USA
Jason Riedy, Computer Science Division, University of
California at Berkeley, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__10 = 10;
static integer c__1 = 1;
static integer c__2 = 2;
static integer c__3 = 3;
static integer c__4 = 4;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, nb, jj;
static doublereal eps, vll, vuu, tmp1;
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer inddd, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
static integer indwk;
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static integer lwmin;
static logical lower, wantz;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, ieeeok, indibl, indifl;
static logical valeig;
static doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal abstll, bignum;
static integer indtau, indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo, indwkn;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *),
dstemr_(char *, char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, integer *,
logical *, doublereal *, integer *, integer *, integer *, integer
*);
static integer liwmin;
static logical tryrac;
extern /* Subroutine */ int dormtr_(char *, char *, char *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *);
static integer llwrkn, llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--isuppz;
--work;
--iwork;
/* Function Body */
ieeeok = ilaenv_(&c__10, "DSYEVR", "N", &c__1, &c__2, &c__3, &c__4, (
ftnlen)6, (ftnlen)1);
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1 || *liwork == -1;
/* Computing MAX */
i__1 = 1, i__2 = *n * 26;
lwmin = max(i__1,i__2);
/* Computing MAX */
i__1 = 1, i__2 = *n * 10;
liwmin = max(i__1,i__2);
*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;
} else if (*lwork < lwmin && ! lquery) {
*info = -18;
} else if (*liwork < liwmin && ! lquery) {
*info = -20;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
/* Computing MAX */
i__1 = (nb + 1) * *n;
lwkopt = max(i__1,lwmin);
work[1] = (doublereal) lwkopt;
iwork[1] = liwmin;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVR", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
work[1] = 7.;
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.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
vll = *vl;
vuu = *vu;
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
if (anrm > 0. && 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;
dscal_(&i__2, &sigma, &a[j + j * a_dim1], &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(&j, &sigma, &a[j * a_dim1 + 1], &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Initialize indices into workspaces. Note: The IWORK indices are
used only if DSTERF or DSTEMR fail.
WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
elementary reflectors used in DSYTRD. */
indtau = 1;
/* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries. */
indd = indtau + *n;
/* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
tridiagonal matrix from DSYTRD. */
inde = indd + *n;
/* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
-written by DSTEMR (the DSTERF path copies the diagonal to W). */
inddd = inde + *n;
/* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
-written while computing the eigenvalues in DSTERF and DSTEMR. */
indee = inddd + *n;
/* INDWK is the starting offset of the left-over workspace, and
LLWORK is the remaining workspace size. */
indwk = indee + *n;
llwork = *lwork - indwk + 1;
/* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
stores the block indices of each of the M<=N eigenvalues. */
indibl = 1;
/* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
stores the starting and finishing indices of each block. */
indisp = indibl + *n;
/* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
that corresponding to eigenvectors that fail to converge in
DSTEIN. This information is discarded; if any fail, the driver
returns INFO > 0. */
indifl = indisp + *n;
/* INDIWO is the offset of the remaining integer workspace. */
indiwo = indisp + *n;
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwk], &llwork, &iinfo);
/* If all eigenvalues are desired
then call DSTERF or DSTEMR and DORMTR. */
if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) {
if (! wantz) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dcopy_(n, &work[indd], &c__1, &work[inddd], &c__1);
if (*abstol <= *n * 0. * eps) {
tryrac = TRUE_;
} else {
tryrac = FALSE_;
}
dstemr_(jobz, "A", n, &work[inddd], &work[indee], vl, vu, il, iu,
m, &w[1], &z__[z_offset], ldz, n, &isuppz[1], &tryrac, &
work[indwk], lwork, &iwork[1], liwork, info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
if (wantz && *info == 0) {
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("L", uplo, "N", n, m, &a[a_offset], lda, &work[indtau]
, &z__[z_offset], ldz, &work[indwkn], &llwrkn, &iinfo);
}
}
if (*info == 0) {
/* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are
undefined. */
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
Also call DSTEBZ and DSTEIN if DSTEMR fails. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwk], &iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwk], &iwork[indiwo], &
iwork[indifl], info);
/* Apply orthogonal matrix used in reduction to tridiagonal
form to eigenvectors returned by DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("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.
Jump here if DSTEMR/DSTEIN succeeded. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with
eigenvectors. Note: We do not sort the IFAIL portion of IWORK.
It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
not return this detailed information to the user. */
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) {
w[i__] = w[j];
w[j] = tmp1;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
}
/* L50: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
iwork[1] = liwmin;
return 0;
/* End of DSYEVR */
} /* dsyevr_ */
/* Subroutine */ int zheevx_(char *jobz, char *range, char *uplo, integer *n,
doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu,
integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *
w, doublecomplex *z, integer *ldz, doublecomplex *work, integer *
lwork, doublereal *rwork, integer *iwork, integer *ifail, integer *
info)
{
/* -- LAPACK driver 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
=======
ZHEEVX computes selected eigenvalues and, optionally, eigenvectors
of a complex Hermitian 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) COMPLEX*16 array, dimension (LDA, N)
On entry, the Hermitian 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) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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) DOUBLE PRECISION
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*DLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*DLAMCH('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) DOUBLE PRECISION array, dimension (N)
On normal exit, the first M elements contain the selected
eigenvalues in ascending order.
Z (output) COMPLEX*16 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) COMPLEX*16 array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for ZHETRD returned by ILAENV.
RWORK (workspace) DOUBLE PRECISION 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.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
doublecomplex z__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt, itmp1, i, j, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *);
static logical lower, wantz;
extern /* Subroutine */ int zswap_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer jj;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *), zdscal_(
integer *, doublereal *, doublecomplex *, integer *);
static doublereal abstll, bignum;
extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *,
integer *, doublereal *);
static integer indiwk, indisp, indtau;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int zhetrd_(char *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *,
doublecomplex *, integer *, integer *), zlacpy_(char *,
integer *, integer *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int zstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublecomplex *,
integer *, doublereal *, integer *, integer *, integer *),
zsteqr_(char *, integer *, doublereal *, doublereal *,
doublecomplex *, integer *, doublereal *, integer *),
zungtr_(char *, integer *, doublecomplex *, integer *,
doublecomplex *, doublecomplex *, integer *, integer *),
zunmtr_(char *, char *, char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, doublecomplex *,
integer *, doublecomplex *, integer *, integer *);
static doublereal eps, vll, vuu, tmp1;
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define IWORK(I) iwork[(I)-1]
#define IFAIL(I) ifail[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
lower = lsame_(uplo, "L");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*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 && *n > 0 && *vu <= *vl) {
*info = -8;
} else if (indeig && *il < 1) {
*info = -9;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -10;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -15;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2)) {
*info = -17;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
WORK(1).r = 1., WORK(1).i = 0.;
return 0;
}
if (*n == 1) {
WORK(1).r = 1., WORK(1).i = 0.;
if (alleig || indeig) {
*m = 1;
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
} else if (valeig) {
i__1 = a_dim1 + 1;
i__2 = a_dim1 + 1;
if (*vl < A(1,1).r && *vu >= A(1,1).r) {
*m = 1;
i__1 = a_dim1 + 1;
W(1) = A(1,1).r;
}
}
if (wantz) {
i__1 = z_dim1 + 1;
Z(1,1).r = 1., Z(1,1).i = 0.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
}
anrm = zlanhe_("M", uplo, n, &A(1,1), lda, &RWORK(1));
if (anrm > 0. && 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 <= *n; ++j) {
i__2 = *n - j + 1;
zdscal_(&i__2, &sigma, &A(j,j), &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= *n; ++j) {
zdscal_(&j, &sigma, &A(1,j), &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call ZHETRD to reduce Hermitian matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indtau = 1;
indwrk = indtau + *n;
llwork = *lwork - indwrk + 1;
zhetrd_(uplo, n, &A(1,1), lda, &RWORK(indd), &RWORK(inde), &WORK(
indtau), &WORK(indwrk), &llwork, &iinfo);
i__1 = indwrk;
z__1.r = *n + WORK(indwrk).r, z__1.i = WORK(indwrk).i;
lopt = (integer) z__1.r;
/* If all eigenvalues are desired and ABSTOL is less than or equal to
zero, then call DSTERF or ZUNGTR and ZSTEQR. If this fails for
some eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &RWORK(indd), &c__1, &W(1), &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
dsterf_(n, &W(1), &RWORK(indee), info);
} else {
zlacpy_("A", n, n, &A(1,1), lda, &Z(1,1), ldz);
zungtr_(uplo, n, &Z(1,1), ldz, &WORK(indtau), &WORK(indwrk),
&llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &RWORK(inde), &c__1, &RWORK(indee), &c__1);
zsteqr_(jobz, n, &W(1), &RWORK(indee), &Z(1,1), ldz, &RWORK(
indrwk), info);
if (*info == 0) {
i__1 = *n;
for (i = 1; i <= *n; ++i) {
IFAIL(i) = 0;
/* L30: */
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &RWORK(indd), &
RWORK(inde), m, &nsplit, &W(1), &IWORK(indibl), &IWORK(indisp), &
RWORK(indrwk), &IWORK(indiwk), info);
if (wantz) {
zstein_(n, &RWORK(indd), &RWORK(inde), m, &W(1), &IWORK(indibl), &
IWORK(indisp), &Z(1,1), ldz, &RWORK(indrwk), &IWORK(
indiwk), &IFAIL(1), info);
/* Apply unitary matrix used in reduction to tridiagonal
form to eigenvectors returned by ZSTEIN. */
zunmtr_("L", uplo, "N", n, m, &A(1,1), lda, &WORK(indtau), &Z(1,1), ldz, &WORK(indwrk), &llwork, &iinfo);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L40:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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 <= *m-1; ++j) {
i = 0;
tmp1 = W(j);
i__2 = *m;
for (jj = j + 1; jj <= *m; ++jj) {
if (W(jj) < tmp1) {
i = jj;
tmp1 = W(jj);
}
/* L50: */
}
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;
zswap_(n, &Z(1,i), &c__1, &Z(1,j), &
c__1);
if (*info != 0) {
itmp1 = IFAIL(i);
IFAIL(i) = IFAIL(j);
IFAIL(j) = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal complex workspace size.
Computing MAX */
i__1 = (*n << 1) - 1;
d__1 = (doublereal) max(i__1,lopt);
WORK(1).r = d__1, WORK(1).i = 0.;
return 0;
/* End of ZHEEVX */
} /* zheevx_ */
int main(void)
{
/* Local scalars */
char range, range_i;
char order, order_i;
lapack_int n, n_i;
double vl, vl_i;
double vu, vu_i;
lapack_int il, il_i;
lapack_int iu, iu_i;
double abstol, abstol_i;
lapack_int m, m_i;
lapack_int nsplit, nsplit_i;
lapack_int info, info_i;
lapack_int i;
int failed;
/* Local arrays */
double *d = NULL, *d_i = NULL;
double *e = NULL, *e_i = NULL;
double *w = NULL, *w_i = NULL;
lapack_int *iblock = NULL, *iblock_i = NULL;
lapack_int *isplit = NULL, *isplit_i = NULL;
double *work = NULL, *work_i = NULL;
lapack_int *iwork = NULL, *iwork_i = NULL;
double *w_save = NULL;
lapack_int *iblock_save = NULL;
lapack_int *isplit_save = NULL;
/* Iniitialize the scalar parameters */
init_scalars_dstebz( &range, &order, &n, &vl, &vu, &il, &iu, &abstol );
range_i = range;
order_i = order;
n_i = n;
vl_i = vl;
vu_i = vu;
il_i = il;
iu_i = iu;
abstol_i = abstol;
/* Allocate memory for the LAPACK routine arrays */
d = (double *)LAPACKE_malloc( n * sizeof(double) );
e = (double *)LAPACKE_malloc( (n-1) * sizeof(double) );
w = (double *)LAPACKE_malloc( n * sizeof(double) );
iblock = (lapack_int *)LAPACKE_malloc( n * sizeof(lapack_int) );
isplit = (lapack_int *)LAPACKE_malloc( n * sizeof(lapack_int) );
work = (double *)LAPACKE_malloc( 4*n * sizeof(double) );
iwork = (lapack_int *)LAPACKE_malloc( 3*n * sizeof(lapack_int) );
/* Allocate memory for the C interface function arrays */
d_i = (double *)LAPACKE_malloc( n * sizeof(double) );
e_i = (double *)LAPACKE_malloc( (n-1) * sizeof(double) );
w_i = (double *)LAPACKE_malloc( n * sizeof(double) );
iblock_i = (lapack_int *)LAPACKE_malloc( n * sizeof(lapack_int) );
isplit_i = (lapack_int *)LAPACKE_malloc( n * sizeof(lapack_int) );
work_i = (double *)LAPACKE_malloc( 4*n * sizeof(double) );
iwork_i = (lapack_int *)LAPACKE_malloc( 3*n * sizeof(lapack_int) );
/* Allocate memory for the backup arrays */
w_save = (double *)LAPACKE_malloc( n * sizeof(double) );
iblock_save = (lapack_int *)LAPACKE_malloc( n * sizeof(lapack_int) );
isplit_save = (lapack_int *)LAPACKE_malloc( n * sizeof(lapack_int) );
/* Allocate memory for the row-major arrays */
/* Initialize input arrays */
init_d( n, d );
init_e( (n-1), e );
init_w( n, w );
init_iblock( n, iblock );
init_isplit( n, isplit );
init_work( 4*n, work );
init_iwork( 3*n, iwork );
/* Backup the ouptut arrays */
for( i = 0; i < n; i++ ) {
w_save[i] = w[i];
}
for( i = 0; i < n; i++ ) {
iblock_save[i] = iblock[i];
}
for( i = 0; i < n; i++ ) {
isplit_save[i] = isplit[i];
}
/* Call the LAPACK routine */
dstebz_( &range, &order, &n, &vl, &vu, &il, &iu, &abstol, d, e, &m, &nsplit,
w, iblock, isplit, work, iwork, &info );
/* Initialize input data, call the column-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < n; i++ ) {
d_i[i] = d[i];
}
for( i = 0; i < (n-1); i++ ) {
e_i[i] = e[i];
}
for( i = 0; i < n; i++ ) {
w_i[i] = w_save[i];
}
for( i = 0; i < n; i++ ) {
iblock_i[i] = iblock_save[i];
}
for( i = 0; i < n; i++ ) {
isplit_i[i] = isplit_save[i];
}
for( i = 0; i < 4*n; i++ ) {
work_i[i] = work[i];
}
for( i = 0; i < 3*n; i++ ) {
iwork_i[i] = iwork[i];
}
info_i = LAPACKE_dstebz_work( range_i, order_i, n_i, vl_i, vu_i, il_i, iu_i,
abstol_i, d_i, e_i, &m_i, &nsplit_i, w_i,
iblock_i, isplit_i, work_i, iwork_i );
failed = compare_dstebz( m, m_i, nsplit, nsplit_i, w, w_i, iblock, iblock_i,
isplit, isplit_i, info, info_i, n );
if( failed == 0 ) {
printf( "PASSED: column-major middle-level interface to dstebz\n" );
} else {
printf( "FAILED: column-major middle-level interface to dstebz\n" );
}
/* Initialize input data, call the column-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < n; i++ ) {
d_i[i] = d[i];
}
for( i = 0; i < (n-1); i++ ) {
e_i[i] = e[i];
}
for( i = 0; i < n; i++ ) {
w_i[i] = w_save[i];
}
for( i = 0; i < n; i++ ) {
iblock_i[i] = iblock_save[i];
}
for( i = 0; i < n; i++ ) {
isplit_i[i] = isplit_save[i];
}
for( i = 0; i < 4*n; i++ ) {
work_i[i] = work[i];
}
for( i = 0; i < 3*n; i++ ) {
iwork_i[i] = iwork[i];
}
info_i = LAPACKE_dstebz( range_i, order_i, n_i, vl_i, vu_i, il_i, iu_i,
abstol_i, d_i, e_i, &m_i, &nsplit_i, w_i, iblock_i,
isplit_i );
failed = compare_dstebz( m, m_i, nsplit, nsplit_i, w, w_i, iblock, iblock_i,
isplit, isplit_i, info, info_i, n );
if( failed == 0 ) {
printf( "PASSED: column-major high-level interface to dstebz\n" );
} else {
printf( "FAILED: column-major high-level interface to dstebz\n" );
}
failed = compare_dstebz( m, m_i, nsplit, nsplit_i, w, w_i, iblock, iblock_i,
isplit, isplit_i, info, info_i, n );
if( failed == 0 ) {
printf( "PASSED: row-major middle-level interface to dstebz\n" );
} else {
printf( "FAILED: row-major middle-level interface to dstebz\n" );
}
failed = compare_dstebz( m, m_i, nsplit, nsplit_i, w, w_i, iblock, iblock_i,
isplit, isplit_i, info, info_i, n );
if( failed == 0 ) {
printf( "PASSED: row-major high-level interface to dstebz\n" );
} else {
printf( "FAILED: row-major high-level interface to dstebz\n" );
}
/* Release memory */
if( d != NULL ) {
LAPACKE_free( d );
}
if( d_i != NULL ) {
LAPACKE_free( d_i );
}
if( e != NULL ) {
LAPACKE_free( e );
}
if( e_i != NULL ) {
LAPACKE_free( e_i );
}
if( w != NULL ) {
LAPACKE_free( w );
}
if( w_i != NULL ) {
LAPACKE_free( w_i );
}
if( w_save != NULL ) {
LAPACKE_free( w_save );
}
if( iblock != NULL ) {
LAPACKE_free( iblock );
}
if( iblock_i != NULL ) {
LAPACKE_free( iblock_i );
}
if( iblock_save != NULL ) {
LAPACKE_free( iblock_save );
}
if( isplit != NULL ) {
LAPACKE_free( isplit );
}
if( isplit_i != NULL ) {
LAPACKE_free( isplit_i );
}
if( isplit_save != NULL ) {
LAPACKE_free( isplit_save );
}
if( work != NULL ) {
LAPACKE_free( work );
}
if( work_i != NULL ) {
LAPACKE_free( work_i );
}
if( iwork != NULL ) {
LAPACKE_free( iwork );
}
if( iwork_i != NULL ) {
LAPACKE_free( iwork_i );
}
return 0;
}
/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n,
integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *
bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl,
doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
*m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
/* Local variables */
integer i__, j, jj;
doublereal tmp1;
integer indd, inde;
char vect[1];
logical test;
integer itmp1, indee;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical upper, wantz, alleig, indeig;
integer indibl;
logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *), dpbstf_(char *, integer *,
integer *, doublereal *, integer *, integer *), dsbtrd_(
char *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *);
integer indisp;
extern /* Subroutine */ int dsbgst_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *),
dstein_(integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *);
integer indiwo;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer nsplit;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBGVX computes selected eigenvalues, and optionally, eigenvectors */
/* of a real generalized symmetric-definite banded eigenproblem, of */
/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
/* and banded, and B is also positive definite. Eigenvalues and */
/* eigenvectors can be selected by specifying either all eigenvalues, */
/* 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 triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* KA (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
/* KB (input) INTEGER */
/* The number of superdiagonals of the matrix B if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first ka+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(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
/* On exit, the contents of AB are destroyed. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KA+1. */
/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix B, stored in the first kb+1 rows of the array. The */
/* j-th column of B is stored in the j-th column of the array BB */
/* as follows: */
/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
/* On exit, the factor S from the split Cholesky factorization */
/* B = S**T*S, as returned by DPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */
/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
/* and consequently C to tridiagonal form. */
/* If JOBZ = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. If JOBZ = 'N', */
/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('S'). */
/* 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) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors, with the i-th column of Z holding the */
/* eigenvector associated with W(i). The eigenvectors are */
/* normalized so Z**T*B*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N) */
/* IWORK (workspace/output) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (M) */
/* 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 eigenvalues 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 */
/* <= N: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in IFAIL. */
/* > N : DPBSTF returned an error code; i.e., */
/* if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. 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;
bb_dim1 = *ldbb;
bb_offset = 1 + bb_dim1;
bb -= bb_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");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ka < 0) {
*info = -5;
} else if (*kb < 0 || *kb > *ka) {
*info = -6;
} else if (*ldab < *ka + 1) {
*info = -8;
} else if (*ldbb < *kb + 1) {
*info = -10;
} else if (*ldq < 1 || wantz && *ldq < *n) {
*info = -12;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -14;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -15;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -16;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSBGVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&q[q_offset], ldq, &work[1], &iinfo);
/* Reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
dsbtrd_(vect, uplo, n, ka, &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 DSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
if (! wantz) {
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
dsteqr_(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 DSTEBZ and, if eigenvectors are desired, */
/* call DSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde],
m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk],
&iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply transformation matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, &
c_b27, &z__[j * z_dim1 + 1], &c__1);
/* L20: */
}
}
L30:
/* 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;
dswap_(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 DSBGVX */
} /* dsbgvx_ */
/* Subroutine */ int dspevx_(char *jobz, char *range, char *uplo, integer *n,
doublereal *ap, doublereal *vl, doublereal *vu, integer *il, integer *
iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *iwork, integer *ifail,
integer *info)
{
/* -- LAPACK driver 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
=======
DSPEVX computes selected eigenvalues and, optionally, eigenvectors
of a real symmetric matrix A in packed storage. Eigenvalues/vectors
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.
AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
On entry, the upper or lower triangle of the symmetric 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)*(2*n-j)/2) = A(i,j) for j<=i<=n.
On exit, AP is overwritten by values generated during the
reduction to tridiagonal form. If UPLO = 'U', the diagonal
and first superdiagonal of the tridiagonal matrix T overwrite
the corresponding elements of A, and if UPLO = 'L', the
diagonal and first subdiagonal of T overwrite the
corresponding elements of A.
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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) DOUBLE PRECISION
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 AP to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*DLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*DLAMCH('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) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the selected eigenvalues in ascending order.
Z (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (8*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.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
/* System generated locals */
integer z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer itmp1, i__, j, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static logical wantz;
static integer jj;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal abstll, bignum;
extern doublereal dlansp_(char *, char *, integer *, doublereal *,
doublereal *);
static integer indtau, indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo;
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static integer indwrk;
extern /* Subroutine */ int dopgtr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dsptrd_(char *, integer *, doublereal *, doublereal *,
doublereal *, doublereal *, integer *), dsteqr_(char *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dopmtr_(char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
static integer nsplit;
static doublereal smlnum, eps, vll, vuu, tmp1;
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
--ap;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lsame_(uplo, "L") || lsame_(uplo,
"U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -7;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -8;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -9;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -14;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSPEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (alleig || indeig) {
*m = 1;
w[1] = ap[1];
} else {
if (*vl < ap[1] && *vu >= ap[1]) {
*m = 1;
w[1] = ap[1];
}
}
if (wantz) {
z___ref(1, 1) = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
anrm = dlansp_("M", uplo, n, &ap[1], &work[1]);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
i__1 = *n * (*n + 1) / 2;
dscal_(&i__1, &sigma, &ap[1], &c__1);
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
dsptrd_(uplo, n, &ap[1], &work[indd], &work[inde], &work[indtau], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal
to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails
for some eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dopgtr_(uplo, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &
work[indwrk], &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(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 L20;
}
*info = 0;
}
/* Otherwise, call DSTEBZ 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;
dstebz_(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) {
dstein_(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 DSTEIN. */
dopmtr_("L", uplo, "N", n, m, &ap[1], &work[indtau], &z__[z_offset],
ldz, &work[indwrk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L20:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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];
}
/* L30: */
}
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;
dswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, j), &c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L40: */
}
}
return 0;
/* End of DSPEVX */
} /* dspevx_ */
/* Subroutine */ int dsyevx_(char *jobz, char *range, char *uplo, integer *n,
doublereal *a, integer *lda, doublereal *vl, doublereal *vu, integer *
il, integer *iu, doublereal *abstol, integer *m, doublereal *w,
doublereal *z__, integer *ldz, doublereal *work, integer *lwork,
integer *iwork, integer *ifail, integer *info)
{
/* -- LAPACK driver 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
=======
DSYEVX 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) DOUBLE PRECISION 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) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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) DOUBLE PRECISION
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*DLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*DLAMCH('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) DOUBLE PRECISION array, dimension (N)
On normal exit, the first M elements contain the selected
eigenvalues in ascending order.
Z (output) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,8*N).
For optimal efficiency, LWORK >= (NB+3)*N,
where NB is the max of the blocksize for DSYTRD and DORMTR
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 */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
/* System generated locals */
integer a_dim1, a_offset, z_dim1, z_offset, i__1, i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer lopt, itmp1, i__, j, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static logical lower, wantz;
static integer nb, jj;
extern doublereal dlamch_(char *);
static logical alleig, indeig;
static integer iscale, indibl;
static logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
static doublereal safmin;
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int xerbla_(char *, integer *);
static doublereal abstll, bignum;
static integer indtau, indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo, indwkn;
extern doublereal dlansy_(char *, char *, integer *, doublereal *,
integer *, doublereal *);
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
static integer indwrk;
extern /* Subroutine */ int dorgtr_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *, integer *), dsteqr_(char *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *),
dormtr_(char *, char *, char *, integer *, integer *, doublereal *
, integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, integer *);
static integer llwrkn, llwork, nsplit;
static doublereal smlnum;
extern /* Subroutine */ int dsytrd_(char *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
integer *, integer *);
static integer lwkopt;
static logical lquery;
static doublereal eps, vll, vuu, tmp1;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
#define z___ref(a_1,a_2) z__[(a_2)*z_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
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;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n << 3;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -17;
}
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
/* Computing MAX */
i__1 = nb, i__2 = ilaenv_(&c__1, "DORMTR", uplo, n, &c_n1, &c_n1, &
c_n1, (ftnlen)6, (ftnlen)1);
nb = max(i__1,i__2);
lwkopt = (nb + 3) * *n;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYEVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
if (*n == 1) {
work[1] = 7.;
if (alleig || indeig) {
*m = 1;
w[1] = a_ref(1, 1);
} else {
if (*vl < a_ref(1, 1) && *vu >= a_ref(1, 1)) {
*m = 1;
w[1] = a_ref(1, 1);
}
}
if (wantz) {
z___ref(1, 1) = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
vll = *vl;
vuu = *vu;
anrm = dlansy_("M", uplo, n, &a[a_offset], lda, &work[1]);
if (anrm > 0. && 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;
dscal_(&i__2, &sigma, &a_ref(j, j), &c__1);
/* L10: */
}
} else {
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
dscal_(&j, &sigma, &a_ref(1, j), &c__1);
/* L20: */
}
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSYTRD to reduce symmetric matrix to tridiagonal form. */
indtau = 1;
inde = indtau + *n;
indd = inde + *n;
indwrk = indd + *n;
llwork = *lwork - indwrk + 1;
dsytrd_(uplo, n, &a[a_offset], lda, &work[indd], &work[inde], &work[
indtau], &work[indwrk], &llwork, &iinfo);
lopt = (integer) (*n * 3 + work[indwrk]);
/* If all eigenvalues are desired and ABSTOL is less than or equal to
zero, then call DSTERF or DORGTR and SSTEQR. If this fails for
some eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &a[a_offset], lda, &z__[z_offset], ldz);
dorgtr_(uplo, n, &z__[z_offset], ldz, &work[indtau], &work[indwrk]
, &llwork, &iinfo);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(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;
/* L30: */
}
}
}
if (*info == 0) {
*m = *n;
goto L40;
}
*info = 0;
}
/* Otherwise, call DSTEBZ 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;
dstebz_(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) {
dstein_(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 DSTEIN. */
indwkn = inde;
llwrkn = *lwork - indwkn + 1;
dormtr_("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;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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];
}
/* L50: */
}
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;
dswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, j), &c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L60: */
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYEVX */
} /* dsyevx_ */
/* Subroutine */ int zhbgvx_(char *jobz, char *range, char *uplo, integer *n,
integer *ka, integer *kb, doublecomplex *ab, integer *ldab,
doublecomplex *bb, integer *ldbb, doublecomplex *q, integer *ldq,
doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *
abstol, integer *m, doublereal *w, doublecomplex *z__, integer *ldz,
doublecomplex *work, doublereal *rwork, integer *iwork, integer *
ifail, integer *info)
{
/* -- LAPACK driver 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
=======
ZHBGVX computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-definite banded eigenproblem, of
the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian
and banded, and B is also positive definite. Eigenvalues and
eigenvectors can be selected by specifying either all eigenvalues,
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 triangles of A and B are stored;
= 'L': Lower triangles of A and B are stored.
N (input) INTEGER
The order of the matrices A and B. N >= 0.
KA (input) INTEGER
The number of superdiagonals of the matrix A if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KA >= 0.
KB (input) INTEGER
The number of superdiagonals of the matrix B if UPLO = 'U',
or the number of subdiagonals if UPLO = 'L'. KB >= 0.
AB (input/output) COMPLEX*16 array, dimension (LDAB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix A, stored in the first ka+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(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
On exit, the contents of AB are destroyed.
LDAB (input) INTEGER
The leading dimension of the array AB. LDAB >= KA+1.
BB (input/output) COMPLEX*16 array, dimension (LDBB, N)
On entry, the upper or lower triangle of the Hermitian band
matrix B, stored in the first kb+1 rows of the array. The
j-th column of B is stored in the j-th column of the array BB
as follows:
if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
On exit, the factor S from the split Cholesky factorization
B = S**H*S, as returned by ZPBSTF.
LDBB (input) INTEGER
The leading dimension of the array BB. LDBB >= KB+1.
Q (output) COMPLEX*16 array, dimension (LDQ, N)
If JOBZ = 'V', the n-by-n matrix used in the reduction of
A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
and consequently C to tridiagonal form.
If JOBZ = 'N', the array Q is not referenced.
LDQ (input) INTEGER
The leading dimension of the array Q. If JOBZ = 'N',
LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
VL (input) DOUBLE PRECISION
VU (input) DOUBLE PRECISION
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) DOUBLE PRECISION
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 AP to tridiagonal form.
Eigenvalues will be computed most accurately when ABSTOL is
set to twice the underflow threshold 2*DLAMCH('S'), not zero.
If this routine returns with INFO>0, indicating that some
eigenvectors did not converge, try setting ABSTOL to
2*DLAMCH('S').
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) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX*16 array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
eigenvectors, with the i-th column of Z holding the
eigenvector associated with W(i). The eigenvectors are
normalized so that Z**H*B*Z = I.
If JOBZ = 'N', then Z is not referenced.
LDZ (input) INTEGER
The leading dimension of the array Z. LDZ >= 1, and if
JOBZ = 'V', LDZ >= N.
WORK (workspace) COMPLEX*16 array, dimension (N)
RWORK (workspace) DOUBLE PRECISION 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, and i is:
<= N: then i eigenvectors failed to converge. Their
indices are stored in array IFAIL.
> N: if INFO = N + i, for 1 <= i <= N, then ZPBSTF
returned INFO = i: B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
Further Details
===============
Based on contributions by
Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static doublecomplex c_b1 = {0.,0.};
static doublecomplex c_b2 = {1.,0.};
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
/* Local variables */
static integer indd, inde;
static char vect[1];
static integer itmp1, i__, j, indee;
extern logical lsame_(char *, char *);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), zgemv_(char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *, doublecomplex *, doublecomplex *, integer *);
static logical upper, wantz;
extern /* Subroutine */ int zcopy_(integer *, doublecomplex *, integer *,
doublecomplex *, integer *), zswap_(integer *, doublecomplex *,
integer *, doublecomplex *, integer *);
static integer jj;
static logical alleig, indeig;
static integer indibl;
static logical valeig;
extern /* Subroutine */ int xerbla_(char *, integer *);
static integer indiwk, indisp;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *),
zhbtrd_(char *, char *, integer *, integer *, doublecomplex *,
integer *, doublereal *, doublereal *, doublecomplex *, integer *,
doublecomplex *, integer *);
static integer indrwk, indwrk;
extern /* Subroutine */ int zhbgst_(char *, char *, integer *, integer *,
integer *, doublecomplex *, integer *, doublecomplex *, integer *,
doublecomplex *, integer *, doublecomplex *, doublereal *,
integer *), zlacpy_(char *, integer *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *);
static integer nsplit;
extern /* Subroutine */ int zpbstf_(char *, integer *, integer *,
doublecomplex *, integer *, integer *), zstein_(integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, doublecomplex *, integer *, doublereal *, integer *,
integer *, integer *), zsteqr_(char *, integer *, doublereal *,
doublereal *, doublecomplex *, integer *, doublereal *, integer *);
static doublereal tmp1;
#define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1
#define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
bb_dim1 = *ldbb;
bb_offset = 1 + bb_dim1 * 1;
bb -= bb_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1 * 1;
q -= q_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ka < 0) {
*info = -5;
} else if (*kb < 0 || *kb > *ka) {
*info = -6;
} else if (*ldab < *ka + 1) {
*info = -8;
} else if (*ldbb < *kb + 1) {
*info = -10;
} else if (valeig && *n > 0 && *vu <= *vl) {
*info = -12;
} else if (indeig && *il < 1) {
*info = -13;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -14;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -19;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHBGVX", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
zpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
zhbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&q[q_offset], ldq, &work[1], &rwork[1], &iinfo);
/* Solve the standard eigenvalue problem.
Reduce Hermitian band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indwrk = 1;
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
zhbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &rwork[indd], &rwork[
inde], &q[q_offset], ldq, &work[indwrk], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal
to zero, then call DSTERF or ZSTEQR. If this fails for some
eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
i__1 = *n - 1;
dcopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
if (! wantz) {
dsterf_(n, &w[1], &rwork[indee], info);
} else {
zlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
zsteqr_(jobz, n, &w[1], &rwork[indee], &z__[z_offset], ldz, &
rwork[indrwk], 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 DSTEBZ and, if eigenvectors are desired,
call ZSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
dstebz_(range, order, n, vl, vu, il, iu, abstol, &rwork[indd], &rwork[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &rwork[
indrwk], &iwork[indiwk], info);
if (wantz) {
zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], &
iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[
indiwk], &ifail[1], info);
/* Apply unitary matrix used in reduction to tridiagonal
form to eigenvectors returned by ZSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
zcopy_(n, &z___ref(1, j), &c__1, &work[1], &c__1);
zgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
c_b1, &z___ref(1, j), &c__1);
/* L20: */
}
}
L30:
/* 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;
zswap_(n, &z___ref(1, i__), &c__1, &z___ref(1, j), &c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of ZHBGVX */
} /* zhbgvx_ */
/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n,
integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *
ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu,
doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *iwork, integer *ifail,
integer *info, ftnlen jobz_len, ftnlen range_len, ftnlen uplo_len)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer i__, j, jj;
static doublereal eps, vll, vuu, tmp1;
static integer indd, inde;
static doublereal anrm;
static integer imax;
static doublereal rmin, rmax;
static integer itmp1, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
static doublereal sigma;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *, ftnlen);
static integer iinfo;
static char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
static logical lower, wantz;
extern doublereal dlamch_(char *, ftnlen);
static logical alleig, indeig;
static integer iscale, indibl;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *, ftnlen);
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, ftnlen, ftnlen);
static logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *, ftnlen);
static doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
static doublereal abstll, bignum;
extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, ftnlen, ftnlen);
static integer indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
static integer indiwo;
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *, ftnlen, ftnlen);
static integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
ftnlen);
static integer nsplit;
static doublereal smlnum;
/* -- LAPACK driver routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBEVX 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) DOUBLE PRECISION 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) DOUBLE PRECISION 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) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION */
/* 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*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('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) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) DOUBLE PRECISION 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) DOUBLE PRECISION 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", (ftnlen)1, (ftnlen)1);
alleig = lsame_(range, "A", (ftnlen)1, (ftnlen)1);
valeig = lsame_(range, "V", (ftnlen)1, (ftnlen)1);
indeig = lsame_(range, "I", (ftnlen)1, (ftnlen)1);
lower = lsame_(uplo, "L", (ftnlen)1, (ftnlen)1);
*info = 0;
if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U", (ftnlen)1, (ftnlen)1))) {
*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_("DSBEVX", &i__1, (ftnlen)6);
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.;
}
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum", (ftnlen)12);
eps = dlamch_("Precision", (ftnlen)9);
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1], (ftnlen)
1, (ftnlen)1);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info, (ftnlen)1);
} else {
dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info, (ftnlen)1);
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
&q[q_offset], ldq, &work[indwrk], &iinfo, (ftnlen)1, (ftnlen)1);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try DSTEBZ. */
if ((alleig || indeig && *il == 1 && *iu == *n) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz, (
ftnlen)1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info, (ftnlen)1);
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 DSTEBZ 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;
dstebz_(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, (ftnlen)1, (ftnlen)1);
if (wantz) {
dstein_(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 DSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
c_b34, &z__[j * z_dim1 + 1], &c__1, (ftnlen)1);
/* L20: */
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__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;
dswap_(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 DSBEVX */
} /* dsbevx_ */
