/* Subroutine */ int chbev_(char *jobz, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
complex *work, real *rwork, 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
=======
CHBEV computes all the eigenvalues and, optionally, eigenvectors of
a complex Hermitian band matrix A.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
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) COMPLEX array, dimension (LDAB, N)
On entry, the upper or lower triangle of the Hermitian 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.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX array, dimension (LDZ, N)
If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
eigenvectors of the matrix A, with the i-th column of Z
holding the eigenvector associated with W(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) COMPLEX array, dimension (N)
RWORK (workspace) REAL array, dimension (max(1,3*N-2))
INFO (output) INTEGER
= 0: successful exit.
< 0: if INFO = -i, the i-th argument had an illegal value.
> 0: if INFO = i, the algorithm failed to converge; i
off-diagonal elements of an intermediate tridiagonal
form did not converge to zero.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static real c_b11 = 1.f;
static integer c__1 = 1;
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
static integer inde;
static real anrm;
static integer imax;
static real rmin, rmax, sigma;
extern logical lsame_(char *, char *);
static integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
static logical lower, wantz;
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *);
static integer iscale;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *,
integer *, real *, real *, complex *, integer *, complex *,
integer *);
extern doublereal slamch_(char *);
static real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
static real bignum;
static integer indrwk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), ssterf_(integer
*, real *, real *, integer *);
static real smlnum, eps;
#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)]
#define ab_subscr(a_1,a_2) (a_2)*ab_dim1 + a_1
#define ab_ref(a_1,a_2) ab[ab_subscr(a_1,a_2)]
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1 * 1;
ab -= ab_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1 * 1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (lower) {
i__1 = ab_subscr(1, 1);
w[1] = ab[i__1].r;
} else {
i__1 = ab_subscr(*kd + 1, 1);
w[1] = ab[i__1].r;
}
if (wantz) {
i__1 = z___subscr(1, 1);
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
clascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
clascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
inde = 1;
chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR. */
if (! wantz) {
ssterf_(n, &w[1], &rwork[inde], info);
} else {
indrwk = inde + *n;
csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[
indrwk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
return 0;
/* End of CHBEV */
} /* chbev_ */
/* Subroutine */
int chbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
/* Local variables */
integer inde;
char vect[1];
integer llwk2;
extern /* Subroutine */
int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *);
extern logical lsame_(char *, char *);
integer iinfo, lwmin;
logical upper;
integer llrwk;
logical wantz;
integer indwk2;
extern /* Subroutine */
int cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, integer *), chbgst_(char *, char *, integer *, integer *, integer *, complex * , integer *, complex *, integer *, complex *, integer *, complex * , real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *), cpbstf_(char *, integer *, integer *, complex *, integer *, integer *);
integer indwrk, liwmin;
extern /* Subroutine */
int ssterf_(integer *, real *, real *, integer *);
integer lrwmin;
logical lquery;
/* -- 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 .. */
/* .. */
/* .. 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;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1)
{
lwmin = *n + 1;
lrwmin = *n + 1;
liwmin = 1;
}
else if (wantz)
{
/* Computing 2nd power */
i__1 = *n;
lwmin = i__1 * i__1 << 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
}
else
{
lwmin = *n;
lrwmin = *n;
liwmin = 1;
}
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (upper || lsame_(uplo, "L")))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*ka < 0)
{
*info = -4;
}
else if (*kb < 0 || *kb > *ka)
{
*info = -5;
}
else if (*ldab < *ka + 1)
{
*info = -7;
}
else if (*ldbb < *kb + 1)
{
*info = -9;
}
else if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -12;
}
if (*info == 0)
{
work[1].r = (real) lwmin;
work[1].i = 0.f; // , expr subst
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery)
{
*info = -14;
}
else if (*lrwork < lrwmin && ! lquery)
{
*info = -16;
}
else if (*liwork < liwmin && ! lquery)
{
*info = -18;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHBGVD", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0)
{
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
indwk2 = *n * *n + 1;
llwk2 = *lwork - indwk2 + 2;
llrwk = *lrwork - indwrk + 2;
chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
/* Reduce Hermitian band matrix to tridiagonal form. */
if (wantz)
{
*(unsigned char *)vect = 'U';
}
else
{
*(unsigned char *)vect = 'N';
}
chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], & z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */
if (! wantz)
{
ssterf_(n, &w[1], &rwork[inde], info);
}
else
{
cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], & llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
cgemm_("N", "N", n, n, n, &c_b1, &z__[z_offset], ldz, &work[1], n, & c_b2, &work[indwk2], n);
clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
work[1].r = (real) lwmin;
work[1].i = 0.f; // , expr subst
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHBGVD */
}
/* Subroutine */
int chbgv_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, real *w, complex *z__, integer *ldz, complex *work, real *rwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
/* Local variables */
integer inde;
char vect[1];
extern logical lsame_(char *, char *);
integer iinfo;
logical upper, wantz;
extern /* Subroutine */
int chbtrd_(char *, char *, integer *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, integer *), chbgst_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, real *, integer *), xerbla_(char *, integer *), cpbstf_(char *, integer *, integer *, complex *, integer *, integer *);
integer indwrk;
extern /* Subroutine */
int csteqr_(char *, integer *, real *, real *, complex *, integer *, real *, integer *), ssterf_(integer *, real *, real *, 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 .. */
/* .. */
/* ===================================================================== */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. 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;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (! (wantz || lsame_(jobz, "N")))
{
*info = -1;
}
else if (! (upper || lsame_(uplo, "L")))
{
*info = -2;
}
else if (*n < 0)
{
*info = -3;
}
else if (*ka < 0)
{
*info = -4;
}
else if (*kb < 0 || *kb > *ka)
{
*info = -5;
}
else if (*ldab < *ka + 1)
{
*info = -7;
}
else if (*ldbb < *kb + 1)
{
*info = -9;
}
else if (*ldz < 1 || wantz && *ldz < *n)
{
*info = -12;
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("CHBGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0)
{
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
/* Reduce to tridiagonal form. */
if (wantz)
{
*(unsigned char *)vect = 'U';
}
else
{
*(unsigned char *)vect = 'N';
}
chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], & z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR. */
if (! wantz)
{
ssterf_(n, &w[1], &rwork[inde], info);
}
else
{
csteqr_(jobz, n, &w[1], &rwork[inde], &z__[z_offset], ldz, &rwork[ indwrk], info);
}
return 0;
/* End of CHBGV */
}
/* Subroutine */ int chbevx_(char *jobz, char *range, char *uplo, integer *n,
integer *kd, complex *ab, integer *ldab, complex *q, integer *ldq,
real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *
m, real *w, complex *z__, integer *ldz, complex *work, real *rwork,
integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
i__2;
real r__1, r__2;
/* Local variables */
integer i__, j, jj;
real eps, vll, vuu, tmp1;
integer indd, inde;
real anrm;
integer imax;
real rmin, rmax;
logical test;
complex ctmp1;
integer itmp1, indee;
real sigma;
integer iinfo;
char order[1];
logical lower;
logical wantz;
logical alleig, indeig;
integer iscale, indibl;
logical valeig;
real safmin;
real abstll, bignum;
integer indiwk, indisp;
integer indrwk, indwrk;
integer nsplit;
real smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CHBEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a complex Hermitian 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) COMPLEX array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the Hermitian 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. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD + 1. */
/* Q (output) COMPLEX array, dimension (LDQ, N) */
/* If JOBZ = 'V', the N-by-N unitary matrix used in the */
/* reduction to tridiagonal form. */
/* If JOBZ = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. If JOBZ = 'V', then */
/* LDQ >= max(1,N). */
/* VL (input) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing AB to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*SLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) COMPLEX 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 array, dimension (N) */
/* RWORK (workspace) REAL array, dimension (7*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* 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;
--rwork;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lower = lsame_(uplo, "L");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*kd < 0) {
*info = -5;
} else if (*ldab < *kd + 1) {
*info = -7;
} else if (wantz && *ldq < max(1,*n)) {
*info = -9;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -11;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -12;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -13;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
*m = 1;
if (lower) {
i__1 = ab_dim1 + 1;
ctmp1.r = ab[i__1].r, ctmp1.i = ab[i__1].i;
} else {
i__1 = *kd + 1 + ab_dim1;
ctmp1.r = ab[i__1].r, ctmp1.i = ab[i__1].i;
}
tmp1 = ctmp1.r;
if (valeig) {
if (! (*vl < tmp1 && *vu >= tmp1)) {
*m = 0;
}
}
if (*m == 1) {
w[1] = ctmp1.r;
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
r__1 = sqrt(bignum), r__2 = 1.f / sqrt(sqrt(safmin));
rmax = dmin(r__1,r__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.f;
vuu = 0.f;
}
anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
clascl_("B", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
clascl_("Q", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
if (*abstol > 0.f) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indrwk = inde + *n;
indwrk = 1;
chbtrd_(jobz, uplo, n, kd, &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 SSTERF or CSTEQR. If this fails for some */
/* eigenvalue, then try SSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.f) {
scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
ssterf_(n, &w[1], &rwork[indee], info);
} else {
clacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
csteqr_(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;
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
sstebz_(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) {
cstein_(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 CSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
cgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
c_b1, &z__[j * z_dim1 + 1], &c__1);
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
}
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;
cswap_(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;
}
}
}
}
return 0;
/* End of CHBEVX */
} /* chbevx_ */
/* Subroutine */ int chbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
real *w, complex *z__, integer *ldz, complex *work, integer *lwork,
real *rwork, integer *lrwork, integer *iwork, integer *liwork,
integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
/* Local variables */
integer inde;
char vect[1];
integer llwk2;
integer iinfo, lwmin;
logical upper;
integer llrwk;
logical wantz;
integer indwk2;
integer indwrk, liwmin;
integer lrwmin;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* CHBGVD 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. If eigenvectors are */
/* desired, it uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* 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 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 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 CPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX 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/output) COMPLEX 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. */
/* If N <= 1, LWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LWORK >= N. */
/* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */
/* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of array RWORK. */
/* If N <= 1, LRWORK >= 1. */
/* If JOBZ = 'N' and N > 1, LRWORK >= N. */
/* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of array IWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */
/* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* 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: the algorithm failed to converge: */
/* i off-diagonal elements of an intermediate */
/* tridiagonal form did not converge to zero; */
/* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF */
/* 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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
bb_dim1 = *ldbb;
bb_offset = 1 + bb_dim1;
bb -= bb_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
} else if (wantz) {
/* Computing 2nd power */
i__1 = *n;
lwmin = i__1 * i__1 << 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
} else {
lwmin = *n;
lrwmin = *n;
liwmin = 1;
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ka < 0) {
*info = -4;
} else if (*kb < 0 || *kb > *ka) {
*info = -5;
} else if (*ldab < *ka + 1) {
*info = -7;
} else if (*ldbb < *kb + 1) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -12;
}
if (*info == 0) {
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -14;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -16;
} else if (*liwork < liwmin && ! lquery) {
*info = -18;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBGVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
indwk2 = *n * *n + 1;
llwk2 = *lwork - indwk2 + 2;
llrwk = *lrwork - indwrk + 2;
chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo);
/* Reduce Hermitian band matrix to tridiagonal form. */
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */
if (! wantz) {
ssterf_(n, &w[1], &rwork[inde], info);
} else {
cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
cgemm_("N", "N", n, n, n, &c_b1, &z__[z_offset], ldz, &work[1], n, &
c_b2, &work[indwk2], n);
clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHBGVD */
} /* chbgvd_ */
/* Subroutine */
int chbgvx_(char *jobz, char *range, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, complex *q, integer *ldq, real *vl, real *vu, integer * il, integer *iu, real *abstol, integer *m, real *w, complex *z__, integer *ldz, complex *work, real *rwork, 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;
real tmp1;
integer indd, inde;
char vect[1];
logical test;
integer itmp1, indee;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int cgemv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *);
integer iinfo;
char order[1];
extern /* Subroutine */
int ccopy_(integer *, complex *, integer *, complex *, integer *), cswap_(integer *, complex *, integer *, complex *, integer *);
logical upper;
extern /* Subroutine */
int scopy_(integer *, real *, integer *, real *, integer *);
logical wantz, alleig, indeig;
integer indibl;
extern /* Subroutine */
int chbtrd_(char *, char *, integer *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, integer *);
logical valeig;
extern /* Subroutine */
int chbgst_(char *, char *, integer *, integer *, integer *, complex *, integer *, complex *, integer *, complex *, integer *, complex *, real *, integer *), clacpy_( char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *), cpbstf_( char *, integer *, integer *, complex *, integer *, integer *);
integer indiwk, indisp;
extern /* Subroutine */
int cstein_(integer *, real *, real *, integer *, real *, integer *, integer *, complex *, integer *, real *, integer *, integer *, integer *);
integer indrwk, indwrk;
extern /* Subroutine */
int csteqr_(char *, integer *, real *, real *, complex *, integer *, real *, integer *), ssterf_(integer *, real *, real *, integer *);
integer nsplit;
extern /* Subroutine */
int sstebz_(char *, char *, integer *, real *, real *, integer *, integer *, real *, real *, real *, integer *, integer *, real *, integer *, integer *, real *, 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 */
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;
--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 (*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_("CHBGVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0)
{
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0)
{
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
chbgst_(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';
}
chbtrd_(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 SSTERF or CSTEQR. If this fails for some */
/* eigenvalue, then try SSTEBZ. */
test = FALSE_;
if (indeig)
{
if (*il == 1 && *iu == *n)
{
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.f)
{
scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
if (! wantz)
{
ssterf_(n, &w[1], &rwork[indee], info);
}
else
{
clacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
csteqr_(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 SSTEBZ and, if eigenvectors are desired, */
/* call CSTEIN. */
if (wantz)
{
*(unsigned char *)order = 'B';
}
else
{
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
sstebz_(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)
{
cstein_(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 CSTEIN. */
i__1 = *m;
for (j = 1;
j <= i__1;
++j)
{
ccopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
cgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, & c_b1, &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;
cswap_(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 CHBGVX */
}
/* Subroutine */ int cchkhb_(integer *nsizes, integer *nn, integer *nwdths,
integer *kk, integer *ntypes, logical *dotype, integer *iseed, real *
thresh, integer *nounit, complex *a, integer *lda, real *sd, real *se,
complex *u, integer *ldu, complex *work, integer *lwork, real *rwork,
real *result, integer *info)
{
/* Initialized data */
static integer ktype[15] = { 1,2,4,4,4,4,4,5,5,5,5,5,8,8,8 };
static integer kmagn[15] = { 1,1,1,1,1,2,3,1,1,1,2,3,1,2,3 };
static integer kmode[15] = { 0,0,4,3,1,4,4,4,3,1,4,4,0,0,0 };
/* Format strings */
static char fmt_9999[] = "(\002 CCHKHB: \002,a,\002 returned INFO=\002,i"
"6,\002.\002,/9x,\002N=\002,i6,\002, JTYPE=\002,i6,\002, ISEED="
"(\002,3(i5,\002,\002),i5,\002)\002)";
static char fmt_9998[] = "(/1x,a3,\002 -- Complex Hermitian Banded Tridi"
"agonal Reduction Routines\002)";
static char fmt_9997[] = "(\002 Matrix types (see SCHK23 for details):"
" \002)";
static char fmt_9996[] = "(/\002 Special Matrices:\002,/\002 1=Zero mat"
"rix. \002,\002 5=Diagonal: clustered ent"
"ries.\002,/\002 2=Identity matrix. \002,\002"
" 6=Diagonal: large, evenly spaced.\002,/\002 3=Diagonal: evenl"
"y spaced entries. \002,\002 7=Diagonal: small, evenly spaced."
"\002,/\002 4=Diagonal: geometr. spaced entries.\002)";
static char fmt_9995[] = "(\002 Dense \002,a,\002 Banded Matrices:\002,"
"/\002 8=Evenly spaced eigenvals. \002,\002 12=Small,"
" evenly spaced eigenvals.\002,/\002 9=Geometrically spaced eige"
"nvals. \002,\002 13=Matrix with random O(1) entries.\002,"
"/\002 10=Clustered eigenvalues. \002,\002 14=Matrix"
" with large random entries.\002,/\002 11=Large, evenly spaced ei"
"genvals. \002,\002 15=Matrix with small random entries.\002)";
static char fmt_9994[] = "(/\002 Tests performed: (S is Tridiag, U "
"is \002,a,\002,\002,/20x,a,\002 means \002,a,\002.\002,/\002 UPL"
"O='U':\002,/\002 1= | A - U S U\002,a1,\002 | / ( |A| n ulp ) "
" \002,\002 2= | I - U U\002,a1,\002 | / ( n ulp )\002,/\002 U"
"PLO='L':\002,/\002 3= | A - U S U\002,a1,\002 | / ( |A| n ulp )"
" \002,\002 4= | I - U U\002,a1,\002 | / ( n ulp )\002)";
static char fmt_9993[] = "(\002 N=\002,i5,\002, K=\002,i4,\002, seed="
"\002,4(i4,\002,\002),\002 type \002,i2,\002, test(\002,i2,\002)"
"=\002,g10.3)";
/* System generated locals */
integer a_dim1, a_offset, u_dim1, u_offset, i__1, i__2, i__3, i__4, i__5,
i__6, i__7;
real r__1;
complex q__1;
/* Local variables */
integer i__, j, k, n, jc, jr;
real ulp, cond;
integer jcol, kmax, nmax;
real unfl, ovfl, temp1;
logical badnn;
extern /* Subroutine */ int chbt21_(char *, integer *, integer *, integer
*, complex *, integer *, real *, real *, complex *, integer *,
complex *, real *, real *);
integer imode, iinfo;
real aninv, anorm;
integer nmats, jsize, nerrs, itype, jtype, ntest;
logical badnnb;
extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
complex *, integer *, real *, real *, complex *, integer *,
complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
integer idumma[1];
extern /* Subroutine */ int claset_(char *, integer *, integer *, complex
*, complex *, complex *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int xerbla_(char *, integer *), clatmr_(
integer *, integer *, char *, integer *, char *, complex *,
integer *, real *, complex *, char *, char *, complex *, integer *
, real *, complex *, integer *, real *, char *, integer *,
integer *, integer *, real *, real *, char *, complex *, integer *
, integer *, integer *), clatms_(integer *, integer *, char *, integer *, char *,
real *, integer *, real *, real *, integer *, integer *, char *,
complex *, integer *, complex *, integer *);
integer jwidth;
extern /* Subroutine */ int slasum_(char *, integer *, integer *, integer
*);
real rtunfl, rtovfl, ulpinv;
integer mtypes, ntestt;
/* Fortran I/O blocks */
static cilist io___36 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___37 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___40 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___41 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___42 = { 0, 0, 0, fmt_9997, 0 };
static cilist io___43 = { 0, 0, 0, fmt_9996, 0 };
static cilist io___44 = { 0, 0, 0, fmt_9995, 0 };
static cilist io___45 = { 0, 0, 0, fmt_9994, 0 };
static cilist io___46 = { 0, 0, 0, fmt_9993, 0 };
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CCHKHB tests the reduction of a Hermitian band matrix to tridiagonal */
/* from, used with the Hermitian eigenvalue problem. */
/* CHBTRD factors a Hermitian band matrix A as U S U* , where * means */
/* conjugate transpose, S is symmetric tridiagonal, and U is unitary. */
/* CHBTRD can use either just the lower or just the upper triangle */
/* of A; CCHKHB checks both cases. */
/* When CCHKHB is called, a number of matrix "sizes" ("n's"), a number */
/* of bandwidths ("k's"), and a number of matrix "types" are */
/* specified. For each size ("n"), each bandwidth ("k") less than or */
/* equal to "n", and each type of matrix, one matrix will be generated */
/* and used to test the hermitian banded reduction routine. For each */
/* matrix, a number of tests will be performed: */
/* (1) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with */
/* UPLO='U' */
/* (2) | I - UU* | / ( n ulp ) */
/* (3) | A - V S V* | / ( |A| n ulp ) computed by CHBTRD with */
/* UPLO='L' */
/* (4) | I - UU* | / ( n ulp ) */
/* The "sizes" are specified by an array NN(1:NSIZES); the value of */
/* each element NN(j) specifies one size. */
/* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); */
/* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated. */
/* Currently, the list of possible types is: */
/* (1) The zero matrix. */
/* (2) The identity matrix. */
/* (3) A diagonal matrix with evenly spaced entries */
/* 1, ..., ULP and random signs. */
/* (ULP = (first number larger than 1) - 1 ) */
/* (4) A diagonal matrix with geometrically spaced entries */
/* 1, ..., ULP and random signs. */
/* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP */
/* and random signs. */
/* (6) Same as (4), but multiplied by SQRT( overflow threshold ) */
/* (7) Same as (4), but multiplied by SQRT( underflow threshold ) */
/* (8) A matrix of the form U* D U, where U is unitary and */
/* D has evenly spaced entries 1, ..., ULP with random signs */
/* on the diagonal. */
/* (9) A matrix of the form U* D U, where U is unitary and */
/* D has geometrically spaced entries 1, ..., ULP with random */
/* signs on the diagonal. */
/* (10) A matrix of the form U* D U, where U is unitary and */
/* D has "clustered" entries 1, ULP,..., ULP with random */
/* signs on the diagonal. */
/* (11) Same as (8), but multiplied by SQRT( overflow threshold ) */
/* (12) Same as (8), but multiplied by SQRT( underflow threshold ) */
/* (13) Hermitian matrix with random entries chosen from (-1,1). */
/* (14) Same as (13), but multiplied by SQRT( overflow threshold ) */
/* (15) Same as (13), but multiplied by SQRT( underflow threshold ) */
/* Arguments */
/* ========= */
/* NSIZES (input) INTEGER */
/* The number of sizes of matrices to use. If it is zero, */
/* CCHKHB does nothing. It must be at least zero. */
/* NN (input) INTEGER array, dimension (NSIZES) */
/* An array containing the sizes to be used for the matrices. */
/* Zero values will be skipped. The values must be at least */
/* zero. */
/* NWDTHS (input) INTEGER */
/* The number of bandwidths to use. If it is zero, */
/* CCHKHB does nothing. It must be at least zero. */
/* KK (input) INTEGER array, dimension (NWDTHS) */
/* An array containing the bandwidths to be used for the band */
/* matrices. The values must be at least zero. */
/* NTYPES (input) INTEGER */
/* The number of elements in DOTYPE. If it is zero, CCHKHB */
/* does nothing. It must be at least zero. If it is MAXTYP+1 */
/* and NSIZES is 1, then an additional type, MAXTYP+1 is */
/* defined, which is to use whatever matrix is in A. This */
/* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and */
/* DOTYPE(MAXTYP+1) is .TRUE. . */
/* DOTYPE (input) LOGICAL array, dimension (NTYPES) */
/* If DOTYPE(j) is .TRUE., then for each size in NN a */
/* matrix of that size and of type j will be generated. */
/* If NTYPES is smaller than the maximum number of types */
/* defined (PARAMETER MAXTYP), then types NTYPES+1 through */
/* MAXTYP will not be generated. If NTYPES is larger */
/* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES) */
/* will be ignored. */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry ISEED specifies the seed of the random number */
/* generator. The array elements should be between 0 and 4095; */
/* if not they will be reduced mod 4096. Also, ISEED(4) must */
/* be odd. The random number generator uses a linear */
/* congruential sequence limited to small integers, and so */
/* should produce machine independent random numbers. The */
/* values of ISEED are changed on exit, and can be used in the */
/* next call to CCHKHB to continue the same random number */
/* sequence. */
/* THRESH (input) REAL */
/* A test will count as "failed" if the "error", computed as */
/* described above, exceeds THRESH. Note that the error */
/* is scaled to be O(1), so THRESH should be a reasonably */
/* small multiple of 1, e.g., 10 or 100. In particular, */
/* it should not depend on the precision (single vs. double) */
/* or the size of the matrix. It must be at least zero. */
/* NOUNIT (input) INTEGER */
/* The FORTRAN unit number for printing out error messages */
/* (e.g., if a routine returns IINFO not equal to 0.) */
/* A (input/workspace) REAL array, dimension */
/* (LDA, max(NN)) */
/* Used to hold the matrix whose eigenvalues are to be */
/* computed. */
/* LDA (input) INTEGER */
/* The leading dimension of A. It must be at least 2 (not 1!) */
/* and at least max( KK )+1. */
/* SD (workspace) REAL array, dimension (max(NN)) */
/* Used to hold the diagonal of the tridiagonal matrix computed */
/* by CHBTRD. */
/* SE (workspace) REAL array, dimension (max(NN)) */
/* Used to hold the off-diagonal of the tridiagonal matrix */
/* computed by CHBTRD. */
/* U (workspace) REAL array, dimension (LDU, max(NN)) */
/* Used to hold the unitary matrix computed by CHBTRD. */
/* LDU (input) INTEGER */
/* The leading dimension of U. It must be at least 1 */
/* and at least max( NN ). */
/* WORK (workspace) REAL array, dimension (LWORK) */
/* LWORK (input) INTEGER */
/* The number of entries in WORK. This must be at least */
/* max( LDA+1, max(NN)+1 )*max(NN). */
/* RESULT (output) REAL array, dimension (4) */
/* The values computed by the tests described above. */
/* The values are currently limited to 1/ulp, to avoid */
/* overflow. */
/* INFO (output) INTEGER */
/* If 0, then everything ran OK. */
/* ----------------------------------------------------------------------- */
/* Some Local Variables and Parameters: */
/* ---- ----- --------- --- ---------- */
/* ZERO, ONE Real 0 and 1. */
/* MAXTYP The number of types defined. */
/* NTEST The number of tests performed, or which can */
/* be performed so far, for the current matrix. */
/* NTESTT The total number of tests performed so far. */
/* NMAX Largest value in NN. */
/* NMATS The number of matrices generated so far. */
/* NERRS The number of tests which have exceeded THRESH */
/* so far. */
/* COND, IMODE Values to be passed to the matrix generators. */
/* ANORM Norm of A; passed to matrix generators. */
/* OVFL, UNFL Overflow and underflow thresholds. */
/* ULP, ULPINV Finest relative precision and its inverse. */
/* RTOVFL, RTUNFL Square roots of the previous 2 values. */
/* The following four arrays decode JTYPE: */
/* KTYPE(j) The general type (1-10) for type "j". */
/* KMODE(j) The MODE value to be passed to the matrix */
/* generator for type "j". */
/* KMAGN(j) The order of magnitude ( O(1), */
/* O(overflow^(1/2) ), O(underflow^(1/2) ) */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Local Arrays .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Data statements .. */
/* Parameter adjustments */
--nn;
--kk;
--dotype;
--iseed;
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--sd;
--se;
u_dim1 = *ldu;
u_offset = 1 + u_dim1;
u -= u_offset;
--work;
--rwork;
--result;
/* Function Body */
/* .. */
/* .. Executable Statements .. */
/* Check for errors */
ntestt = 0;
*info = 0;
/* Important constants */
badnn = FALSE_;
nmax = 1;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = nmax, i__3 = nn[j];
nmax = max(i__2,i__3);
if (nn[j] < 0) {
badnn = TRUE_;
}
/* L10: */
}
badnnb = FALSE_;
kmax = 0;
i__1 = *nsizes;
for (j = 1; j <= i__1; ++j) {
/* Computing MAX */
i__2 = kmax, i__3 = kk[j];
kmax = max(i__2,i__3);
if (kk[j] < 0) {
badnnb = TRUE_;
}
/* L20: */
}
/* Computing MIN */
i__1 = nmax - 1;
kmax = min(i__1,kmax);
/* Check for errors */
if (*nsizes < 0) {
*info = -1;
} else if (badnn) {
*info = -2;
} else if (*nwdths < 0) {
*info = -3;
} else if (badnnb) {
*info = -4;
} else if (*ntypes < 0) {
*info = -5;
} else if (*lda < kmax + 1) {
*info = -11;
} else if (*ldu < nmax) {
*info = -15;
} else if ((max(*lda,nmax) + 1) * nmax > *lwork) {
*info = -17;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CCHKHB", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
return 0;
}
/* More Important constants */
unfl = slamch_("Safe minimum");
ovfl = 1.f / unfl;
ulp = slamch_("Epsilon") * slamch_("Base");
ulpinv = 1.f / ulp;
rtunfl = sqrt(unfl);
rtovfl = sqrt(ovfl);
/* Loop over sizes, types */
nerrs = 0;
nmats = 0;
i__1 = *nsizes;
for (jsize = 1; jsize <= i__1; ++jsize) {
n = nn[jsize];
aninv = 1.f / (real) max(1,n);
i__2 = *nwdths;
for (jwidth = 1; jwidth <= i__2; ++jwidth) {
k = kk[jwidth];
if (k > n) {
goto L180;
}
/* Computing MAX */
/* Computing MIN */
i__5 = n - 1;
i__3 = 0, i__4 = min(i__5,k);
k = max(i__3,i__4);
if (*nsizes != 1) {
mtypes = min(15,*ntypes);
} else {
mtypes = min(16,*ntypes);
}
i__3 = mtypes;
for (jtype = 1; jtype <= i__3; ++jtype) {
if (! dotype[jtype]) {
goto L170;
}
++nmats;
ntest = 0;
for (j = 1; j <= 4; ++j) {
ioldsd[j - 1] = iseed[j];
/* L30: */
}
/* Compute "A". */
/* Store as "Upper"; later, we will copy to other format. */
/* Control parameters: */
/* KMAGN KMODE KTYPE */
/* =1 O(1) clustered 1 zero */
/* =2 large clustered 2 identity */
/* =3 small exponential (none) */
/* =4 arithmetic diagonal, (w/ eigenvalues) */
/* =5 random log hermitian, w/ eigenvalues */
/* =6 random (none) */
/* =7 random diagonal */
/* =8 random hermitian */
/* =9 positive definite */
/* =10 diagonally dominant tridiagonal */
if (mtypes > 15) {
goto L100;
}
itype = ktype[jtype - 1];
imode = kmode[jtype - 1];
/* Compute norm */
switch (kmagn[jtype - 1]) {
case 1: goto L40;
case 2: goto L50;
case 3: goto L60;
}
L40:
anorm = 1.f;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
claset_("Full", lda, &n, &c_b1, &c_b1, &a[a_offset], lda);
iinfo = 0;
if (jtype <= 15) {
cond = ulpinv;
} else {
cond = ulpinv * aninv / 10.f;
}
/* Special Matrices -- Identity & Jordan block */
/* Zero */
if (itype == 1) {
iinfo = 0;
} else if (itype == 2) {
/* Identity */
i__4 = n;
for (jcol = 1; jcol <= i__4; ++jcol) {
i__5 = k + 1 + jcol * a_dim1;
a[i__5].r = anorm, a[i__5].i = 0.f;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
a_dim1], lda, &work[1], &iinfo);
} else if (itype == 5) {
/* Hermitian, eigenvalues specified */
clatms_(&n, &n, "S", &iseed[1], "H", &rwork[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &c__0, &c__0, &c_b42, &anorm, "Q", &a[k +
1 + a_dim1], lda, idumma, &iinfo);
} else if (itype == 8) {
/* Hermitian, random eigenvalues */
clatmr_(&n, &n, "S", &iseed[1], "H", &work[1], &c__6, &
c_b32, &c_b2, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &k, &k, &c_b42, &anorm, "Q", &a[a_offset],
lda, idumma, &iinfo);
} else if (itype == 9) {
/* Positive definite, eigenvalues specified. */
clatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[n + 1], &iinfo);
} else if (itype == 10) {
/* Positive definite tridiagonal, eigenvalues specified. */
if (n > 1) {
k = max(1,k);
}
clatms_(&n, &n, "S", &iseed[1], "P", &rwork[1], &imode, &
cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
lda, &work[1], &iinfo);
i__4 = n;
for (i__ = 2; i__ <= i__4; ++i__) {
i__5 = k + 1 + (i__ - 1) * a_dim1;
i__6 = k + 1 + i__ * a_dim1;
q__1.r = a[i__5].r * a[i__6].r - a[i__5].i * a[i__6]
.i, q__1.i = a[i__5].r * a[i__6].i + a[i__5]
.i * a[i__6].r;
temp1 = c_abs(&a[k + i__ * a_dim1]) / sqrt(c_abs(&
q__1));
if (temp1 > .5f) {
i__5 = k + i__ * a_dim1;
i__6 = k + 1 + (i__ - 1) * a_dim1;
i__7 = k + 1 + i__ * a_dim1;
q__1.r = a[i__6].r * a[i__7].r - a[i__6].i * a[
i__7].i, q__1.i = a[i__6].r * a[i__7].i +
a[i__6].i * a[i__7].r;
r__1 = sqrt(c_abs(&q__1)) * .5f;
a[i__5].r = r__1, a[i__5].i = 0.f;
}
/* L90: */
}
} else {
iinfo = 1;
}
if (iinfo != 0) {
io___36.ciunit = *nounit;
s_wsfe(&io___36);
do_fio(&c__1, "Generator", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
return 0;
}
L100:
/* Call CHBTRD to compute S and U from upper triangle. */
i__4 = k + 1;
clacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 1;
chbtrd_("V", "U", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
u_offset], ldu, &work[*lda * n + 1], &iinfo);
if (iinfo != 0) {
io___37.ciunit = *nounit;
s_wsfe(&io___37);
do_fio(&c__1, "CHBTRD(U)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[1] = ulpinv;
goto L150;
}
}
/* Do tests 1 and 2 */
chbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
result[1]);
/* Convert A from Upper-Triangle-Only storage to */
/* Lower-Triangle-Only storage. */
i__4 = n;
for (jc = 1; jc <= i__4; ++jc) {
/* Computing MIN */
i__6 = k, i__7 = n - jc;
i__5 = min(i__6,i__7);
for (jr = 0; jr <= i__5; ++jr) {
i__6 = jr + 1 + jc * a_dim1;
r_cnjg(&q__1, &a[k + 1 - jr + (jc + jr) * a_dim1]);
a[i__6].r = q__1.r, a[i__6].i = q__1.i;
/* L110: */
}
/* L120: */
}
i__4 = n;
for (jc = n + 1 - k; jc <= i__4; ++jc) {
/* Computing MIN */
i__5 = k, i__6 = n - jc;
i__7 = k;
for (jr = min(i__5,i__6) + 1; jr <= i__7; ++jr) {
i__5 = jr + 1 + jc * a_dim1;
a[i__5].r = 0.f, a[i__5].i = 0.f;
/* L130: */
}
/* L140: */
}
/* Call CHBTRD to compute S and U from lower triangle */
i__4 = k + 1;
clacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 3;
chbtrd_("V", "L", &n, &k, &work[1], lda, &sd[1], &se[1], &u[
u_offset], ldu, &work[*lda * n + 1], &iinfo);
if (iinfo != 0) {
io___40.ciunit = *nounit;
s_wsfe(&io___40);
do_fio(&c__1, "CHBTRD(L)", (ftnlen)9);
do_fio(&c__1, (char *)&iinfo, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(integer))
;
e_wsfe();
*info = abs(iinfo);
if (iinfo < 0) {
return 0;
} else {
result[3] = ulpinv;
goto L150;
}
}
ntest = 4;
/* Do tests 3 and 4 */
chbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[1], &rwork[1], &
result[3]);
/* End of Loop -- Check for RESULT(j) > THRESH */
L150:
ntestt += ntest;
/* Print out tests which fail. */
i__4 = ntest;
for (jr = 1; jr <= i__4; ++jr) {
if (result[jr] >= *thresh) {
/* If this is the first test to fail, */
/* print a header to the data file. */
if (nerrs == 0) {
io___41.ciunit = *nounit;
s_wsfe(&io___41);
do_fio(&c__1, "CHB", (ftnlen)3);
e_wsfe();
io___42.ciunit = *nounit;
s_wsfe(&io___42);
e_wsfe();
io___43.ciunit = *nounit;
s_wsfe(&io___43);
e_wsfe();
io___44.ciunit = *nounit;
s_wsfe(&io___44);
do_fio(&c__1, "Hermitian", (ftnlen)9);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "unitary", (ftnlen)7);
do_fio(&c__1, "*", (ftnlen)1);
do_fio(&c__1, "conjugate transpose", (ftnlen)19);
for (j = 1; j <= 4; ++j) {
do_fio(&c__1, "*", (ftnlen)1);
}
e_wsfe();
}
++nerrs;
io___46.ciunit = *nounit;
s_wsfe(&io___46);
do_fio(&c__1, (char *)&n, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&k, (ftnlen)sizeof(integer));
do_fio(&c__4, (char *)&ioldsd[0], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&jtype, (ftnlen)sizeof(integer))
;
do_fio(&c__1, (char *)&jr, (ftnlen)sizeof(integer));
do_fio(&c__1, (char *)&result[jr], (ftnlen)sizeof(
real));
e_wsfe();
}
/* L160: */
}
L170:
;
}
L180:
;
}
/* L190: */
}
/* Summary */
slasum_("CHB", nounit, &nerrs, &ntestt);
return 0;
/* End of CCHKHB */
} /* cchkhb_ */
/* Subroutine */ int chbgv_(char *jobz, char *uplo, integer *n, integer *ka,
integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb,
real *w, complex *z, integer *ldz, complex *work, real *rwork,
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
=======
CHBGV 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.
Arguments
=========
JOBZ (input) CHARACTER*1
= 'N': Compute eigenvalues only;
= 'V': Compute eigenvalues and eigenvectors.
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 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 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 CPBSTF.
LDBB (input) INTEGER
The leading dimension of the array BB. LDBB >= KB+1.
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
Z (output) COMPLEX 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 array, dimension (N)
RWORK (workspace) REAL array, dimension (3*N)
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: the algorithm failed to converge:
i off-diagonal elements of an intermediate
tridiagonal form did not converge to zero;
> N: if INFO = N + i, for 1 <= i <= N, then CPBSTF
returned INFO = i: B is not positive definite.
The factorization of B could not be completed and
no eigenvalues or eigenvectors were computed.
=====================================================================
Test the input parameters.
Parameter adjustments
Function Body */
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1;
/* Local variables */
static integer inde;
static char vect[1];
extern logical lsame_(char *, char *);
static integer iinfo;
static logical upper, wantz;
extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
complex *, integer *, real *, real *, complex *, integer *,
complex *, integer *), chbgst_(char *, char *,
integer *, integer *, integer *, complex *, integer *, complex *,
integer *, complex *, integer *, complex *, real *, integer *), xerbla_(char *, integer *), cpbstf_(char
*, integer *, integer *, complex *, integer *, integer *);
static integer indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), ssterf_(integer
*, real *, real *, integer *);
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define RWORK(I) rwork[(I)-1]
#define AB(I,J) ab[(I)-1 + ((J)-1)* ( *ldab)]
#define BB(I,J) bb[(I)-1 + ((J)-1)* ( *ldbb)]
#define Z(I,J) z[(I)-1 + ((J)-1)* ( *ldz)]
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*ka < 0) {
*info = -4;
} else if (*kb < 0 || *kb > *ka) {
*info = -5;
} else if (*ldab < *ka + 1) {
*info = -7;
} else if (*ldbb < *kb + 1) {
*info = -9;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -12;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &BB(1,1), ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
chbgst_(jobz, uplo, n, ka, kb, &AB(1,1), ldab, &BB(1,1), ldbb,
&Z(1,1), ldz, &WORK(1), &RWORK(indwrk), &iinfo);
/* Reduce to tridiagonal form. */
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
chbtrd_(vect, uplo, n, ka, &AB(1,1), ldab, &W(1), &RWORK(inde), &Z(1,1), ldz, &WORK(1), &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEQR.
*/
if (! wantz) {
ssterf_(n, &W(1), &RWORK(inde), info);
} else {
csteqr_(jobz, n, &W(1), &RWORK(inde), &Z(1,1), ldz, &RWORK(
indwrk), info);
}
return 0;
/* End of CHBGV */
} /* chbgv_ */
/* Subroutine */ int chbgvx_(char *jobz, char *range, char *uplo, integer *n,
integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb,
integer *ldbb, complex *q, integer *ldq, real *vl, real *vu, integer *
il, integer *iu, real *abstol, integer *m, real *w, complex *z__,
integer *ldz, complex *work, real *rwork, 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;
real tmp1;
integer indd, inde;
char vect[1];
logical test;
integer itmp1, indee;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int cgemv_(char *, integer *, integer *, complex *
, complex *, integer *, complex *, integer *, complex *, complex *
, integer *);
integer iinfo;
char order[1];
extern /* Subroutine */ int ccopy_(integer *, complex *, integer *,
complex *, integer *), cswap_(integer *, complex *, integer *,
complex *, integer *);
logical upper;
extern /* Subroutine */ int scopy_(integer *, real *, integer *, real *,
integer *);
logical wantz, alleig, indeig;
integer indibl;
extern /* Subroutine */ int chbtrd_(char *, char *, integer *, integer *,
complex *, integer *, real *, real *, complex *, integer *,
complex *, integer *);
logical valeig;
extern /* Subroutine */ int chbgst_(char *, char *, integer *, integer *,
integer *, complex *, integer *, complex *, integer *, complex *,
integer *, complex *, real *, integer *), clacpy_(
char *, integer *, integer *, complex *, integer *, complex *,
integer *), xerbla_(char *, integer *), cpbstf_(
char *, integer *, integer *, complex *, integer *, integer *);
integer indiwk, indisp;
extern /* Subroutine */ int cstein_(integer *, real *, real *, integer *,
real *, integer *, integer *, complex *, integer *, real *,
integer *, integer *, integer *);
integer indrwk, indwrk;
extern /* Subroutine */ int csteqr_(char *, integer *, real *, real *,
complex *, integer *, real *, integer *), ssterf_(integer
*, real *, real *, integer *);
integer nsplit;
extern /* Subroutine */ int sstebz_(char *, char *, integer *, real *,
real *, integer *, integer *, real *, real *, real *, integer *,
integer *, real *, integer *, integer *, real *, integer *,
integer *);
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHBGVX 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 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 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 CPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* Q (output) COMPLEX 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) REAL */
/* VU (input) REAL */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) REAL */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing AP to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*SLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*SLAMCH('S'). */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX 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 array, dimension (N) */
/* RWORK (workspace) REAL array, dimension (7*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: if INFO = i, 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 CPBSTF */
/* 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 */
/* ===================================================================== */
/* .. 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;
--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 (*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_("CHBGVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
chbgst_(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';
}
chbtrd_(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 SSTERF or CSTEQR. If this fails for some */
/* eigenvalue, then try SSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.f) {
scopy_(n, &rwork[indd], &c__1, &w[1], &c__1);
indee = indrwk + (*n << 1);
i__1 = *n - 1;
scopy_(&i__1, &rwork[inde], &c__1, &rwork[indee], &c__1);
if (! wantz) {
ssterf_(n, &w[1], &rwork[indee], info);
} else {
clacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
csteqr_(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 SSTEBZ and, if eigenvectors are desired, */
/* call CSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwk = indisp + *n;
sstebz_(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) {
cstein_(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 CSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
ccopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
cgemv_("N", n, n, &c_b2, &q[q_offset], ldq, &work[1], &c__1, &
c_b1, &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;
cswap_(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 CHBGVX */
} /* chbgvx_ */
/* Subroutine */ int chbevd_(char *jobz, char *uplo, integer *n, integer *kd,
complex *ab, integer *ldab, real *w, complex *z__, integer *ldz,
complex *work, integer *lwork, real *rwork, integer *lrwork, integer *
iwork, integer *liwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
real r__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
real eps;
integer inde;
real anrm;
integer imax;
real rmin, rmax;
integer llwk2;
extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *,
integer *, complex *, complex *, integer *, complex *, integer *,
complex *, complex *, integer *);
real sigma;
extern logical lsame_(char *, char *);
integer iinfo;
extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *);
integer lwmin;
logical lower;
integer llrwk;
logical wantz;
integer indwk2;
extern doublereal clanhb_(char *, char *, integer *, integer *, complex *,
integer *, real *);
integer iscale;
extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *,
real *, integer *, integer *, complex *, integer *, integer *), cstedc_(char *, integer *, real *, real *, complex *,
integer *, complex *, integer *, real *, integer *, integer *,
integer *, integer *), chbtrd_(char *, char *, integer *,
integer *, complex *, integer *, real *, real *, complex *,
integer *, complex *, integer *);
extern doublereal slamch_(char *);
extern /* Subroutine */ int clacpy_(char *, integer *, integer *, complex
*, integer *, complex *, integer *);
real safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
real bignum;
integer indwrk, liwmin;
extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *);
integer lrwmin;
real smlnum;
logical lquery;
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* CHBEVD computes all the eigenvalues and, optionally, eigenvectors of */
/* a complex Hermitian band matrix A. If eigenvectors are desired, it */
/* uses a divide and conquer algorithm. */
/* The divide and conquer algorithm makes very mild assumptions about */
/* floating point arithmetic. It will work on machines with a guard */
/* digit in add/subtract, or on those binary machines without guard */
/* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */
/* Cray-2. It could conceivably fail on hexadecimal or decimal machines */
/* without guard digits, but we know of none. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* 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) COMPLEX array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the Hermitian 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. */
/* W (output) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) COMPLEX array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */
/* eigenvectors of the matrix A, with the i-th column of Z */
/* holding the eigenvector associated with W(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) COMPLEX 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. */
/* If N <= 1, LWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LWORK must be at least N. */
/* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK, RWORK and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* RWORK (workspace/output) REAL array, */
/* dimension (LRWORK) */
/* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */
/* LRWORK (input) INTEGER */
/* The dimension of array RWORK. */
/* If N <= 1, LRWORK must be at least 1. */
/* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */
/* If JOBZ = 'V' and N > 1, LRWORK must be at least */
/* 1 + 5*N + 2*N**2. */
/* If LRWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of array IWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
/* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N . */
/* If LIWORK = -1, then a workspace query is assumed; the */
/* routine only calculates the optimal sizes of the WORK, RWORK */
/* and IWORK arrays, returns these values as the first entries */
/* of the WORK, RWORK and IWORK arrays, and no error message */
/* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, the algorithm failed to converge; i */
/* off-diagonal elements of an intermediate tridiagonal */
/* form did not converge to zero. */
/* ===================================================================== */
/* .. 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;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--rwork;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1 || *liwork == -1 || *lrwork == -1;
*info = 0;
if (*n <= 1) {
lwmin = 1;
lrwmin = 1;
liwmin = 1;
} else {
if (wantz) {
/* Computing 2nd power */
i__1 = *n;
lwmin = i__1 * i__1 << 1;
/* Computing 2nd power */
i__1 = *n;
lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
liwmin = *n * 5 + 3;
} else {
lwmin = *n;
lrwmin = *n;
liwmin = 1;
}
}
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (lower || lsame_(uplo, "U"))) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*kd < 0) {
*info = -4;
} else if (*ldab < *kd + 1) {
*info = -6;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -9;
}
if (*info == 0) {
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*lrwork < lrwmin && ! lquery) {
*info = -13;
} else if (*liwork < liwmin && ! lquery) {
*info = -15;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("CHBEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
i__1 = ab_dim1 + 1;
w[1] = ab[i__1].r;
if (wantz) {
i__1 = z_dim1 + 1;
z__[i__1].r = 1.f, z__[i__1].i = 0.f;
}
return 0;
}
/* Get machine constants. */
safmin = slamch_("Safe minimum");
eps = slamch_("Precision");
smlnum = safmin / eps;
bignum = 1.f / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]);
iscale = 0;
if (anrm > 0.f && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
clascl_("B", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
clascl_("Q", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */
inde = 1;
indwrk = inde + *n;
indwk2 = *n * *n + 1;
llwk2 = *lwork - indwk2 + 1;
llrwk = *lrwork - indwrk + 1;
chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], &
z__[z_offset], ldz, &work[1], &iinfo);
/* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */
if (! wantz) {
ssterf_(n, &w[1], &rwork[inde], info);
} else {
cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], &
llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info);
cgemm_("N", "N", n, n, n, &c_b2, &z__[z_offset], ldz, &work[1], n, &
c_b1, &work[indwk2], n);
clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
r__1 = 1.f / sigma;
sscal_(&imax, &r__1, &w[1], &c__1);
}
work[1].r = (real) lwmin, work[1].i = 0.f;
rwork[1] = (real) lrwmin;
iwork[1] = liwmin;
return 0;
/* End of CHBEVD */
} /* chbevd_ */
