/* Subroutine */ int dsbevd_(char *jobz, char *uplo, integer *n, integer *kd,
doublereal *ab, integer *ldab, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *lwork, integer *iwork,
integer *liwork, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
doublereal d__1;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
doublereal eps;
integer inde;
doublereal anrm, rmin, rmax;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *), dgemm_(char *, char *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
integer iinfo, lwmin;
logical lower, wantz;
integer indwk2, llwrk2;
extern doublereal dlamch_(char *);
integer iscale;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, integer *), dlacpy_(char *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal bignum;
extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *), dsterf_(
integer *, doublereal *, doublereal *, integer *);
integer indwrk, liwmin;
doublereal 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 */
/* ======= */
/* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of */
/* a real symmetric 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) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, AB is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the first */
/* superdiagonal and the diagonal of the tridiagonal matrix T */
/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/* the diagonal and first subdiagonal of T are returned in the */
/* first two rows of AB. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD + 1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the 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) DOUBLE PRECISION array, */
/* dimension (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 > 2, LWORK must be at least 2*N. */
/* If JOBZ = 'V' and N > 2, LWORK must be at least */
/* ( 1 + 5*N + 2*N**2 ). */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK 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 the array LIWORK. */
/* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */
/* If JOBZ = 'V' and N > 2, 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 and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK 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;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
lower = lsame_(uplo, "L");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
} else {
if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 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] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -11;
} else if (*liwork < liwmin && ! lquery) {
*info = -13;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSBEVD", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
w[1] = ab[ab_dim1 + 1];
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
inde = 1;
indwrk = inde + *n;
indwk2 = indwrk + *n * *n;
llwrk2 = *lwork - indwk2 + 1;
dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
z_offset], ldz, &work[indwrk], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
llwrk2, &iwork[1], liwork, info);
dgemm_("N", "N", n, n, n, &c_b11, &z__[z_offset], ldz, &work[indwrk],
n, &c_b18, &work[indwk2], n);
dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
d__1 = 1. / sigma;
dscal_(n, &d__1, &w[1], &c__1);
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSBEVD */
} /* dsbevd_ */
/* Subroutine */ int dsbev_(char *jobz, char *uplo, integer *n, integer *kd,
doublereal *ab, integer *ldab, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, z_dim1, z_offset, i__1;
doublereal d__1;
/* Local variables */
doublereal eps;
integer inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
doublereal sigma;
integer iinfo;
logical lower, wantz;
integer iscale;
doublereal safmin;
doublereal bignum;
integer indwrk;
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* DSBEV computes all the eigenvalues and, optionally, eigenvectors of */
/* a real symmetric 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) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, AB is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the first */
/* superdiagonal and the diagonal of the tridiagonal matrix T */
/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/* the diagonal and first subdiagonal of T are returned in the */
/* first two rows of AB. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD + 1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the 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) DOUBLE PRECISION 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 */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
/* 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_("DSBEV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
if (*n == 1) {
if (lower) {
w[1] = ab[ab_dim1 + 1];
} else {
w[1] = ab[*kd + 1 + ab_dim1];
}
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
rmax = sqrt(bignum);
/* Scale matrix to allowable range, if necessary. */
anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
iscale = 0;
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
dlascl_("B", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
dlascl_("Q", kd, kd, &c_b11, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
}
/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
inde = 1;
indwrk = inde + *n;
dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
z_offset], ldz, &work[indwrk], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
indwrk], info);
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
if (iscale == 1) {
if (*info == 0) {
imax = *n;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
return 0;
/* End of DSBEV */
} /* dsbev_ */
int main(void)
{
/* Local scalars */
char vect, vect_i;
char uplo, uplo_i;
lapack_int n, n_i;
lapack_int kd, kd_i;
lapack_int ldab, ldab_i;
lapack_int ldab_r;
lapack_int ldq, ldq_i;
lapack_int ldq_r;
lapack_int info, info_i;
lapack_int i;
int failed;
/* Local arrays */
double *ab = NULL, *ab_i = NULL;
double *d = NULL, *d_i = NULL;
double *e = NULL, *e_i = NULL;
double *q = NULL, *q_i = NULL;
double *work = NULL, *work_i = NULL;
double *ab_save = NULL;
double *d_save = NULL;
double *e_save = NULL;
double *q_save = NULL;
double *ab_r = NULL;
double *q_r = NULL;
/* Iniitialize the scalar parameters */
init_scalars_dsbtrd( &vect, &uplo, &n, &kd, &ldab, &ldq );
ldab_r = n+2;
ldq_r = n+2;
vect_i = vect;
uplo_i = uplo;
n_i = n;
kd_i = kd;
ldab_i = ldab;
ldq_i = ldq;
/* Allocate memory for the LAPACK routine arrays */
ab = (double *)LAPACKE_malloc( ldab*n * sizeof(double) );
d = (double *)LAPACKE_malloc( n * sizeof(double) );
e = (double *)LAPACKE_malloc( (n-1) * sizeof(double) );
q = (double *)LAPACKE_malloc( ldq*n * sizeof(double) );
work = (double *)LAPACKE_malloc( n * sizeof(double) );
/* Allocate memory for the C interface function arrays */
ab_i = (double *)LAPACKE_malloc( ldab*n * sizeof(double) );
d_i = (double *)LAPACKE_malloc( n * sizeof(double) );
e_i = (double *)LAPACKE_malloc( (n-1) * sizeof(double) );
q_i = (double *)LAPACKE_malloc( ldq*n * sizeof(double) );
work_i = (double *)LAPACKE_malloc( n * sizeof(double) );
/* Allocate memory for the backup arrays */
ab_save = (double *)LAPACKE_malloc( ldab*n * sizeof(double) );
d_save = (double *)LAPACKE_malloc( n * sizeof(double) );
e_save = (double *)LAPACKE_malloc( (n-1) * sizeof(double) );
q_save = (double *)LAPACKE_malloc( ldq*n * sizeof(double) );
/* Allocate memory for the row-major arrays */
ab_r = (double *)LAPACKE_malloc( (kd+1)*(n+2) * sizeof(double) );
q_r = (double *)LAPACKE_malloc( n*(n+2) * sizeof(double) );
/* Initialize input arrays */
init_ab( ldab*n, ab );
init_d( n, d );
init_e( (n-1), e );
init_q( ldq*n, q );
init_work( n, work );
/* Backup the ouptut arrays */
for( i = 0; i < ldab*n; i++ ) {
ab_save[i] = ab[i];
}
for( i = 0; i < n; i++ ) {
d_save[i] = d[i];
}
for( i = 0; i < (n-1); i++ ) {
e_save[i] = e[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_save[i] = q[i];
}
/* Call the LAPACK routine */
dsbtrd_( &vect, &uplo, &n, &kd, ab, &ldab, d, e, q, &ldq, work, &info );
/* Initialize input data, call the column-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldab*n; i++ ) {
ab_i[i] = ab_save[i];
}
for( i = 0; i < n; i++ ) {
d_i[i] = d_save[i];
}
for( i = 0; i < (n-1); i++ ) {
e_i[i] = e_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
for( i = 0; i < n; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_dsbtrd_work( LAPACK_COL_MAJOR, vect_i, uplo_i, n_i, kd_i,
ab_i, ldab_i, d_i, e_i, q_i, ldq_i, work_i );
failed = compare_dsbtrd( ab, ab_i, d, d_i, e, e_i, q, q_i, info, info_i,
ldab, ldq, n, vect );
if( failed == 0 ) {
printf( "PASSED: column-major middle-level interface to dsbtrd\n" );
} else {
printf( "FAILED: column-major middle-level interface to dsbtrd\n" );
}
/* Initialize input data, call the column-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldab*n; i++ ) {
ab_i[i] = ab_save[i];
}
for( i = 0; i < n; i++ ) {
d_i[i] = d_save[i];
}
for( i = 0; i < (n-1); i++ ) {
e_i[i] = e_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
for( i = 0; i < n; i++ ) {
work_i[i] = work[i];
}
info_i = LAPACKE_dsbtrd( LAPACK_COL_MAJOR, vect_i, uplo_i, n_i, kd_i, ab_i,
ldab_i, d_i, e_i, q_i, ldq_i );
failed = compare_dsbtrd( ab, ab_i, d, d_i, e, e_i, q, q_i, info, info_i,
ldab, ldq, n, vect );
if( failed == 0 ) {
printf( "PASSED: column-major high-level interface to dsbtrd\n" );
} else {
printf( "FAILED: column-major high-level interface to dsbtrd\n" );
}
/* Initialize input data, call the row-major middle-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldab*n; i++ ) {
ab_i[i] = ab_save[i];
}
for( i = 0; i < n; i++ ) {
d_i[i] = d_save[i];
}
for( i = 0; i < (n-1); i++ ) {
e_i[i] = e_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
for( i = 0; i < n; i++ ) {
work_i[i] = work[i];
}
LAPACKE_dge_trans( LAPACK_COL_MAJOR, kd+1, n, ab_i, ldab, ab_r, n+2 );
if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) {
LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_i, ldq, q_r, n+2 );
}
info_i = LAPACKE_dsbtrd_work( LAPACK_ROW_MAJOR, vect_i, uplo_i, n_i, kd_i,
ab_r, ldab_r, d_i, e_i, q_r, ldq_r, work_i );
LAPACKE_dge_trans( LAPACK_ROW_MAJOR, kd+1, n, ab_r, n+2, ab_i, ldab );
if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) {
LAPACKE_dge_trans( LAPACK_ROW_MAJOR, n, n, q_r, n+2, q_i, ldq );
}
failed = compare_dsbtrd( ab, ab_i, d, d_i, e, e_i, q, q_i, info, info_i,
ldab, ldq, n, vect );
if( failed == 0 ) {
printf( "PASSED: row-major middle-level interface to dsbtrd\n" );
} else {
printf( "FAILED: row-major middle-level interface to dsbtrd\n" );
}
/* Initialize input data, call the row-major high-level
* interface to LAPACK routine and check the results */
for( i = 0; i < ldab*n; i++ ) {
ab_i[i] = ab_save[i];
}
for( i = 0; i < n; i++ ) {
d_i[i] = d_save[i];
}
for( i = 0; i < (n-1); i++ ) {
e_i[i] = e_save[i];
}
for( i = 0; i < ldq*n; i++ ) {
q_i[i] = q_save[i];
}
for( i = 0; i < n; i++ ) {
work_i[i] = work[i];
}
/* Init row_major arrays */
LAPACKE_dge_trans( LAPACK_COL_MAJOR, kd+1, n, ab_i, ldab, ab_r, n+2 );
if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) {
LAPACKE_dge_trans( LAPACK_COL_MAJOR, n, n, q_i, ldq, q_r, n+2 );
}
info_i = LAPACKE_dsbtrd( LAPACK_ROW_MAJOR, vect_i, uplo_i, n_i, kd_i, ab_r,
ldab_r, d_i, e_i, q_r, ldq_r );
LAPACKE_dge_trans( LAPACK_ROW_MAJOR, kd+1, n, ab_r, n+2, ab_i, ldab );
if( LAPACKE_lsame( vect, 'u' ) || LAPACKE_lsame( vect, 'v' ) ) {
LAPACKE_dge_trans( LAPACK_ROW_MAJOR, n, n, q_r, n+2, q_i, ldq );
}
failed = compare_dsbtrd( ab, ab_i, d, d_i, e, e_i, q, q_i, info, info_i,
ldab, ldq, n, vect );
if( failed == 0 ) {
printf( "PASSED: row-major high-level interface to dsbtrd\n" );
} else {
printf( "FAILED: row-major high-level interface to dsbtrd\n" );
}
/* Release memory */
if( ab != NULL ) {
LAPACKE_free( ab );
}
if( ab_i != NULL ) {
LAPACKE_free( ab_i );
}
if( ab_r != NULL ) {
LAPACKE_free( ab_r );
}
if( ab_save != NULL ) {
LAPACKE_free( ab_save );
}
if( d != NULL ) {
LAPACKE_free( d );
}
if( d_i != NULL ) {
LAPACKE_free( d_i );
}
if( d_save != NULL ) {
LAPACKE_free( d_save );
}
if( e != NULL ) {
LAPACKE_free( e );
}
if( e_i != NULL ) {
LAPACKE_free( e_i );
}
if( e_save != NULL ) {
LAPACKE_free( e_save );
}
if( q != NULL ) {
LAPACKE_free( q );
}
if( q_i != NULL ) {
LAPACKE_free( q_i );
}
if( q_r != NULL ) {
LAPACKE_free( q_r );
}
if( q_save != NULL ) {
LAPACKE_free( q_save );
}
if( work != NULL ) {
LAPACKE_free( work );
}
if( work_i != NULL ) {
LAPACKE_free( work_i );
}
return 0;
}
/* Subroutine */ int dsbgv_(char *jobz, char *uplo, integer *n, integer *ka,
integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
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 xerbla_(char *, integer *), dpbstf_(
char *, integer *, integer *, doublereal *, integer *, integer *), dsbtrd_(char *, char *, integer *, integer *, doublereal
*, integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dsbgst_(char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dsterf_(integer *, doublereal *,
doublereal *, integer *);
integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
/* -- LAPACK driver routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBGV computes all the eigenvalues, and optionally, the eigenvectors */
/* of a real generalized symmetric-definite banded eigenproblem, of */
/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
/* and banded, and B is also positive definite. */
/* 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) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first ka+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
/* On exit, the contents of AB are destroyed. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KA+1. */
/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix B, stored in the first kb+1 rows of the array. The */
/* j-th column of B is stored in the j-th column of the array BB */
/* as follows: */
/* if UPLO = 'U', BB(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**T*S, as returned by DPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors, with the i-th column of Z holding the */
/* eigenvector associated with W(i). The eigenvectors are */
/* normalized so that Z**T*B*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= N. */
/* WORK (workspace) DOUBLE PRECISION 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 DPBSTF */
/* returned INFO = i: B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* ===================================================================== */
/* .. 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;
/* 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_("DSBGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
inde = 1;
indwrk = inde + *n;
dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&z__[z_offset], ldz, &work[indwrk], &iinfo)
;
/* Reduce to tridiagonal form. */
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
z_offset], ldz, &work[indwrk], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dsteqr_(jobz, n, &w[1], &work[inde], &z__[z_offset], ldz, &work[
indwrk], info);
}
return 0;
/* End of DSBGV */
} /* dsbgv_ */
/* Subroutine */ int dchksb_(integer *nsizes, integer *nn, integer *nwdths,
integer *kk, integer *ntypes, logical *dotype, integer *iseed,
doublereal *thresh, integer *nounit, doublereal *a, integer *lda,
doublereal *sd, doublereal *se, doublereal *u, integer *ldu,
doublereal *work, integer *lwork, doublereal *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 DCHKSB: \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 -- Real Symmetric Banded Tridiago"
"nal Reduction Routines\002)";
static char fmt_9997[] = "(\002 Matrix types (see DCHKSB 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;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
integer i__, j, k, n, jc, jr;
doublereal ulp, cond;
integer jcol, kmax, nmax;
doublereal unfl, ovfl, temp1;
logical badnn;
integer imode;
extern /* Subroutine */ int dsbt21_(char *, integer *, integer *, integer
*, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *);
integer iinfo;
doublereal aninv, anorm;
integer nmats, jsize, nerrs, itype, jtype, ntest;
logical badnnb;
extern doublereal dlamch_(char *);
integer idumma[1];
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
integer ioldsd[4];
extern /* Subroutine */ int dlaset_(char *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *),
xerbla_(char *, integer *), dsbtrd_(char *, char *,
integer *, integer *, doublereal *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *), dlatmr_(integer *, integer *, char *, integer *,
char *, doublereal *, integer *, doublereal *, doublereal *, char
*, char *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, char *, integer *, integer *, integer *,
doublereal *, doublereal *, char *, doublereal *, integer *,
integer *, integer *), dlatms_(integer *, integer *, char *, integer *, char *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, char *, doublereal *, integer *, doublereal *, integer
*), dlasum_(char *, integer *, integer *,
integer *);
integer jwidth;
doublereal 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 */
/* ======= */
/* DCHKSB tests the reduction of a symmetric band matrix to tridiagonal */
/* form, used with the symmetric eigenvalue problem. */
/* DSBTRD factors a symmetric band matrix A as U S U' , where ' means */
/* transpose, S is symmetric tridiagonal, and U is orthogonal. */
/* DSBTRD can use either just the lower or just the upper triangle */
/* of A; DCHKSB checks both cases. */
/* When DCHKSB 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 symmetric banded reduction routine. For each */
/* matrix, a number of tests will be performed: */
/* (1) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with */
/* UPLO='U' */
/* (2) | I - UU' | / ( n ulp ) */
/* (3) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD 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 orthogonal 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 orthogonal 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 orthogonal 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) Symmetric 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, */
/* DCHKSB 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, */
/* DCHKSB 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, DCHKSB */
/* 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 DCHKSB to continue the same random number */
/* sequence. */
/* THRESH (input) DOUBLE PRECISION */
/* 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) DOUBLE PRECISION 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) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the diagonal of the tridiagonal matrix computed */
/* by DSBTRD. */
/* SE (workspace) DOUBLE PRECISION array, dimension (max(NN)) */
/* Used to hold the off-diagonal of the tridiagonal matrix */
/* computed by DSBTRD. */
/* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN)) */
/* Used to hold the orthogonal matrix computed by DSBTRD. */
/* LDU (input) INTEGER */
/* The leading dimension of U. It must be at least 1 */
/* and at least max( NN ). */
/* WORK (workspace) DOUBLE PRECISION 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) DOUBLE PRECISION 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;
--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_("DCHKSB", &i__1);
return 0;
}
/* Quick return if possible */
if (*nsizes == 0 || *ntypes == 0 || *nwdths == 0) {
return 0;
}
/* More Important constants */
unfl = dlamch_("Safe minimum");
ovfl = 1. / unfl;
ulp = dlamch_("Epsilon") * dlamch_("Base");
ulpinv = 1. / 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. / (doublereal) 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 symmetric, w/ eigenvalues */
/* =6 random (none) */
/* =7 random diagonal */
/* =8 random symmetric */
/* =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.;
goto L70;
L50:
anorm = rtovfl * ulp * aninv;
goto L70;
L60:
anorm = rtunfl * n * ulpinv;
goto L70;
L70:
dlaset_("Full", lda, &n, &c_b18, &c_b18, &a[a_offset], lda);
iinfo = 0;
if (jtype <= 15) {
cond = ulpinv;
} else {
cond = ulpinv * aninv / 10.;
}
/* 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) {
a[k + 1 + jcol * a_dim1] = anorm;
/* L80: */
}
} else if (itype == 4) {
/* Diagonal Matrix, [Eigen]values Specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &
cond, &anorm, &c__0, &c__0, "Q", &a[k + 1 +
a_dim1], lda, &work[n + 1], &iinfo);
} else if (itype == 5) {
/* Symmetric, eigenvalues specified */
dlatms_(&n, &n, "S", &iseed[1], "S", &work[1], &imode, &
cond, &anorm, &k, &k, "Q", &a[a_offset], lda, &
work[n + 1], &iinfo);
} else if (itype == 7) {
/* Diagonal, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &
c_b32, &c_b32, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &c__0, &c__0, &c_b18, &anorm, "Q", &a[k +
1 + a_dim1], lda, idumma, &iinfo);
} else if (itype == 8) {
/* Symmetric, random eigenvalues */
dlatmr_(&n, &n, "S", &iseed[1], "S", &work[1], &c__6, &
c_b32, &c_b32, "T", "N", &work[n + 1], &c__1, &
c_b32, &work[(n << 1) + 1], &c__1, &c_b32, "N",
idumma, &k, &k, &c_b18, &anorm, "Q", &a[a_offset],
lda, idumma, &iinfo);
} else if (itype == 9) {
/* Positive definite, eigenvalues specified. */
dlatms_(&n, &n, "S", &iseed[1], "P", &work[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);
}
dlatms_(&n, &n, "S", &iseed[1], "P", &work[1], &imode, &
cond, &anorm, &c__1, &c__1, "Q", &a[k + a_dim1],
lda, &work[n + 1], &iinfo);
i__4 = n;
for (i__ = 2; i__ <= i__4; ++i__) {
temp1 = (d__1 = a[k + i__ * a_dim1], abs(d__1)) /
sqrt((d__2 = a[k + 1 + (i__ - 1) * a_dim1] *
a[k + 1 + i__ * a_dim1], abs(d__2)));
if (temp1 > .5) {
a[k + i__ * a_dim1] = sqrt((d__1 = a[k + 1 + (i__
- 1) * a_dim1] * a[k + 1 + i__ * a_dim1],
abs(d__1))) * .5;
}
/* 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 DSBTRD to compute S and U from upper triangle. */
i__4 = k + 1;
dlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 1;
dsbtrd_("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, "DSBTRD(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 */
dsbt21_("Upper", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[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) {
a[jr + 1 + jc * a_dim1] = a[k + 1 - jr + (jc + jr) *
a_dim1];
/* 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) {
a[jr + 1 + jc * a_dim1] = 0.;
/* L130: */
}
/* L140: */
}
/* Call DSBTRD to compute S and U from lower triangle */
i__4 = k + 1;
dlacpy_(" ", &i__4, &n, &a[a_offset], lda, &work[1], lda);
ntest = 3;
dsbtrd_("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, "DSBTRD(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 */
dsbt21_("Lower", &n, &k, &c__1, &a[a_offset], lda, &sd[1], &
se[1], &u[u_offset], ldu, &work[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, "DSB", (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, "Symmetric", (ftnlen)9);
e_wsfe();
io___45.ciunit = *nounit;
s_wsfe(&io___45);
do_fio(&c__1, "orthogonal", (ftnlen)10);
do_fio(&c__1, "'", (ftnlen)1);
do_fio(&c__1, "transpose", (ftnlen)9);
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(
doublereal));
e_wsfe();
}
/* L160: */
}
L170:
;
}
L180:
;
}
/* L190: */
}
/* Summary */
dlasum_("DSB", nounit, &nerrs, &ntestt);
return 0;
/* End of DCHKSB */
} /* dchksb_ */
/* Subroutine */ int dsbgvd_(char *jobz, char *uplo, integer *n, integer *ka,
integer *kb, doublereal *ab, integer *ldab, doublereal *bb, integer *
ldbb, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
integer *lwork, 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];
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
integer iinfo, lwmin;
logical upper, wantz;
integer indwk2, llwrk2;
extern /* Subroutine */ int dstedc_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
integer *, integer *, integer *), dlacpy_(char *, integer
*, integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *), dpbstf_(char *,
integer *, integer *, doublereal *, integer *, integer *),
dsbtrd_(char *, char *, integer *, integer *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dsbgst_(char *, char *,
integer *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, doublereal *,
integer *), dsterf_(integer *, doublereal *,
doublereal *, integer *);
integer indwrk, liwmin;
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 */
/* ======= */
/* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors */
/* of a real generalized symmetric-definite banded eigenproblem, of the */
/* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and */
/* banded, and B is also positive definite. 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) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first ka+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
/* On exit, the contents of AB are destroyed. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KA+1. */
/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix B, stored in the first kb+1 rows of the array. The */
/* j-th column of B is stored in the j-th column of the array BB */
/* as follows: */
/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
/* On exit, the factor S from the split Cholesky factorization */
/* B = S**T*S, as returned by DPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors, with the i-th column of Z holding the */
/* eigenvector associated with W(i). The eigenvectors are */
/* normalized so Z**T*B*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (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 >= 3*N. */
/* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal sizes of the WORK and IWORK */
/* arrays, returns these values as the first entries of the WORK */
/* and IWORK arrays, and no error message related to LWORK or */
/* LIWORK is issued by XERBLA. */
/* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */
/* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK. */
/* LIWORK (input) INTEGER */
/* The dimension of the 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 and */
/* IWORK arrays, returns these values as the first entries of */
/* the WORK and IWORK arrays, and no error message related to */
/* LWORK 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 DPBSTF */
/* 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 .. */
/* .. */
/* .. 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;
--iwork;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1 || *liwork == -1;
*info = 0;
if (*n <= 1) {
liwmin = 1;
lwmin = 1;
} else if (wantz) {
liwmin = *n * 5 + 3;
/* Computing 2nd power */
i__1 = *n;
lwmin = *n * 5 + 1 + (i__1 * i__1 << 1);
} else {
liwmin = 1;
lwmin = *n << 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] = (doublereal) lwmin;
iwork[1] = liwmin;
if (*lwork < lwmin && ! lquery) {
*info = -14;
} else if (*liwork < liwmin && ! lquery) {
*info = -16;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSBGVD", &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. */
dpbstf_(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 = indwrk + *n * *n;
llwrk2 = *lwork - indwk2 + 1;
dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&z__[z_offset], ldz, &work[indwrk], &iinfo)
;
/* Reduce to tridiagonal form. */
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &work[inde], &z__[
z_offset], ldz, &work[indwrk], &iinfo);
/* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC. */
if (! wantz) {
dsterf_(n, &w[1], &work[inde], info);
} else {
dstedc_("I", n, &w[1], &work[inde], &work[indwrk], n, &work[indwk2], &
llwrk2, &iwork[1], liwork, info);
dgemm_("N", "N", n, n, n, &c_b12, &z__[z_offset], ldz, &work[indwrk],
n, &c_b13, &work[indwk2], n);
dlacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz);
}
work[1] = (doublereal) lwmin;
iwork[1] = liwmin;
return 0;
/* End of DSBGVD */
} /* dsbgvd_ */
/* Subroutine */ int dsbgvx_(char *jobz, char *range, char *uplo, integer *n,
integer *ka, integer *kb, doublereal *ab, integer *ldab, doublereal *
bb, integer *ldbb, doublereal *q, integer *ldq, doublereal *vl,
doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer
*m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work,
integer *iwork, integer *ifail, integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, bb_dim1, bb_offset, q_dim1, q_offset, z_dim1,
z_offset, i__1, i__2;
/* Local variables */
integer i__, j, jj;
doublereal tmp1;
integer indd, inde;
char vect[1];
logical test;
integer itmp1, indee;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical upper, wantz, alleig, indeig;
integer indibl;
logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *),
xerbla_(char *, integer *), dpbstf_(char *, integer *,
integer *, doublereal *, integer *, integer *), dsbtrd_(
char *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *, integer *, doublereal *,
integer *);
integer indisp;
extern /* Subroutine */ int dsbgst_(char *, char *, integer *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *),
dstein_(integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *, integer *, integer *);
integer indiwo;
extern /* Subroutine */ int dsterf_(integer *, doublereal *, doublereal *,
integer *), dstebz_(char *, char *, integer *, doublereal *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer nsplit;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBGVX computes selected eigenvalues, and optionally, eigenvectors */
/* of a real generalized symmetric-definite banded eigenproblem, of */
/* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric */
/* and banded, and B is also positive definite. Eigenvalues and */
/* eigenvectors can be selected by specifying either all eigenvalues, */
/* a range of values or a range of indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found. */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found. */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangles of A and B are stored; */
/* = 'L': Lower triangles of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrices A and B. N >= 0. */
/* KA (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */
/* KB (input) INTEGER */
/* The number of superdiagonals of the matrix B if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first ka+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */
/* On exit, the contents of AB are destroyed. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KA+1. */
/* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix B, stored in the first kb+1 rows of the array. The */
/* j-th column of B is stored in the j-th column of the array BB */
/* as follows: */
/* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */
/* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */
/* On exit, the factor S from the split Cholesky factorization */
/* B = S**T*S, as returned by DPBSTF. */
/* LDBB (input) INTEGER */
/* The leading dimension of the array BB. LDBB >= KB+1. */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */
/* If JOBZ = 'V', the n-by-n matrix used in the reduction of */
/* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x, */
/* and consequently C to tridiagonal form. */
/* If JOBZ = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. If JOBZ = 'N', */
/* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N). */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) DOUBLE PRECISION */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing A to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('S'). */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, N) */
/* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */
/* eigenvectors, with the i-th column of Z holding the */
/* eigenvector associated with W(i). The eigenvectors are */
/* normalized so Z**T*B*Z = I. */
/* If JOBZ = 'N', then Z is not referenced. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N) */
/* IWORK (workspace/output) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (M) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvalues that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0 : successful exit */
/* < 0 : if INFO = -i, the i-th argument had an illegal value */
/* <= N: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in IFAIL. */
/* > N : DPBSTF returned an error code; i.e., */
/* if INFO = N + i, for 1 <= i <= N, then the leading */
/* minor of order i of B is not positive definite. */
/* The factorization of B could not be completed and */
/* no eigenvalues or eigenvectors were computed. */
/* Further Details */
/* =============== */
/* Based on contributions by */
/* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
bb_dim1 = *ldbb;
bb_offset = 1 + bb_dim1;
bb -= bb_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
*info = 0;
if (! (wantz || lsame_(jobz, "N"))) {
*info = -1;
} else if (! (alleig || valeig || indeig)) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*ka < 0) {
*info = -5;
} else if (*kb < 0 || *kb > *ka) {
*info = -6;
} else if (*ldab < *ka + 1) {
*info = -8;
} else if (*ldbb < *kb + 1) {
*info = -10;
} else if (*ldq < 1 || wantz && *ldq < *n) {
*info = -12;
} else {
if (valeig) {
if (*n > 0 && *vu <= *vl) {
*info = -14;
}
} else if (indeig) {
if (*il < 1 || *il > max(1,*n)) {
*info = -15;
} else if (*iu < min(*n,*il) || *iu > *n) {
*info = -16;
}
}
}
if (*info == 0) {
if (*ldz < 1 || wantz && *ldz < *n) {
*info = -21;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSBGVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Form a split Cholesky factorization of B. */
dpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem. */
dsbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb,
&q[q_offset], ldq, &work[1], &iinfo);
/* Reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
if (wantz) {
*(unsigned char *)vect = 'U';
} else {
*(unsigned char *)vect = 'N';
}
dsbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &work[indd], &work[inde],
&q[q_offset], ldq, &work[indwrk], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
if (! wantz) {
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, */
/* call DSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, vl, vu, il, iu, abstol, &work[indd], &work[inde],
m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk],
&iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply transformation matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
dgemv_("N", n, n, &c_b25, &q[q_offset], ldq, &work[1], &c__1, &
c_b27, &z__[j * z_dim1 + 1], &c__1);
/* L20: */
}
}
L30:
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of DSBGVX */
} /* dsbgvx_ */
/* Subroutine */ int dsbevx_(char *jobz, char *range, char *uplo, integer *n,
integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *
ldq, doublereal *vl, doublereal *vu, integer *il, integer *iu,
doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *iwork, integer *ifail,
integer *info)
{
/* System generated locals */
integer ab_dim1, ab_offset, q_dim1, q_offset, z_dim1, z_offset, i__1,
i__2;
doublereal d__1, d__2;
/* Builtin functions */
double sqrt(doublereal);
/* Local variables */
integer i__, j, jj;
doublereal eps, vll, vuu, tmp1;
integer indd, inde;
doublereal anrm;
integer imax;
doublereal rmin, rmax;
logical test;
integer itmp1, indee;
extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *,
integer *);
doublereal sigma;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dgemv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
integer iinfo;
char order[1];
extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *,
doublereal *, integer *), dswap_(integer *, doublereal *, integer
*, doublereal *, integer *);
logical lower, wantz;
extern doublereal dlamch_(char *);
logical alleig, indeig;
integer iscale, indibl;
extern /* Subroutine */ int dlascl_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
integer *, integer *);
extern doublereal dlansb_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *);
logical valeig;
extern /* Subroutine */ int dlacpy_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, integer *);
doublereal safmin;
extern /* Subroutine */ int xerbla_(char *, integer *);
doublereal abstll, bignum;
extern /* Subroutine */ int dsbtrd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *);
integer indisp;
extern /* Subroutine */ int dstein_(integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, doublereal *,
integer *, doublereal *, integer *, integer *, integer *),
dsterf_(integer *, doublereal *, doublereal *, integer *);
integer indiwo;
extern /* Subroutine */ int dstebz_(char *, char *, integer *, doublereal
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, integer *, doublereal *, integer *,
integer *, doublereal *, integer *, integer *);
integer indwrk;
extern /* Subroutine */ int dsteqr_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, integer *);
integer nsplit;
doublereal smlnum;
/* -- LAPACK driver routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DSBEVX computes selected eigenvalues and, optionally, eigenvectors */
/* of a real symmetric band matrix A. Eigenvalues and eigenvectors can */
/* be selected by specifying either a range of values or a range of */
/* indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* JOBZ (input) CHARACTER*1 */
/* = 'N': Compute eigenvalues only; */
/* = 'V': Compute eigenvalues and eigenvectors. */
/* RANGE (input) CHARACTER*1 */
/* = 'A': all eigenvalues will be found; */
/* = 'V': all eigenvalues in the half-open interval (VL,VU] */
/* will be found; */
/* = 'I': the IL-th through IU-th eigenvalues will be found. */
/* UPLO (input) CHARACTER*1 */
/* = 'U': Upper triangle of A is stored; */
/* = 'L': Lower triangle of A is stored. */
/* N (input) INTEGER */
/* The order of the matrix A. N >= 0. */
/* KD (input) INTEGER */
/* The number of superdiagonals of the matrix A if UPLO = 'U', */
/* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */
/* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N) */
/* On entry, the upper or lower triangle of the symmetric band */
/* matrix A, stored in the first KD+1 rows of the array. The */
/* j-th column of A is stored in the j-th column of the array AB */
/* as follows: */
/* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j; */
/* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd). */
/* On exit, AB is overwritten by values generated during the */
/* reduction to tridiagonal form. If UPLO = 'U', the first */
/* superdiagonal and the diagonal of the tridiagonal matrix T */
/* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */
/* the diagonal and first subdiagonal of T are returned in the */
/* first two rows of AB. */
/* LDAB (input) INTEGER */
/* The leading dimension of the array AB. LDAB >= KD + 1. */
/* Q (output) DOUBLE PRECISION array, dimension (LDQ, N) */
/* If JOBZ = 'V', the N-by-N orthogonal matrix used in the */
/* reduction to tridiagonal form. */
/* If JOBZ = 'N', the array Q is not referenced. */
/* LDQ (input) INTEGER */
/* The leading dimension of the array Q. If JOBZ = 'V', then */
/* LDQ >= max(1,N). */
/* VL (input) DOUBLE PRECISION */
/* VU (input) DOUBLE PRECISION */
/* If RANGE='V', the lower and upper bounds of the interval to */
/* be searched for eigenvalues. VL < VU. */
/* Not referenced if RANGE = 'A' or 'I'. */
/* IL (input) INTEGER */
/* IU (input) INTEGER */
/* If RANGE='I', the indices (in ascending order) of the */
/* smallest and largest eigenvalues to be returned. */
/* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/* Not referenced if RANGE = 'A' or 'V'. */
/* ABSTOL (input) DOUBLE PRECISION */
/* The absolute error tolerance for the eigenvalues. */
/* An approximate eigenvalue is accepted as converged */
/* when it is determined to lie in an interval [a,b] */
/* of width less than or equal to */
/* ABSTOL + EPS * max( |a|,|b| ) , */
/* where EPS is the machine precision. If ABSTOL is less than */
/* or equal to zero, then EPS*|T| will be used in its place, */
/* where |T| is the 1-norm of the tridiagonal matrix obtained */
/* by reducing AB to tridiagonal form. */
/* Eigenvalues will be computed most accurately when ABSTOL is */
/* set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/* If this routine returns with INFO>0, indicating that some */
/* eigenvectors did not converge, try setting ABSTOL to */
/* 2*DLAMCH('S'). */
/* See "Computing Small Singular Values of Bidiagonal Matrices */
/* with Guaranteed High Relative Accuracy," by Demmel and */
/* Kahan, LAPACK Working Note #3. */
/* M (output) INTEGER */
/* The total number of eigenvalues found. 0 <= M <= N. */
/* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */
/* W (output) DOUBLE PRECISION array, dimension (N) */
/* The first M elements contain the selected eigenvalues in */
/* ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/* contain the orthonormal eigenvectors of the matrix A */
/* corresponding to the selected eigenvalues, with the i-th */
/* column of Z holding the eigenvector associated with W(i). */
/* If an eigenvector fails to converge, then that column of Z */
/* contains the latest approximation to the eigenvector, and the */
/* index of the eigenvector is returned in IFAIL. */
/* If JOBZ = 'N', then Z is not referenced. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace) DOUBLE PRECISION array, dimension (7*N) */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit. */
/* < 0: if INFO = -i, the i-th argument had an illegal value. */
/* > 0: if INFO = i, then i eigenvectors failed to converge. */
/* Their indices are stored in array IFAIL. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
ab_dim1 = *ldab;
ab_offset = 1 + ab_dim1;
ab -= ab_offset;
q_dim1 = *ldq;
q_offset = 1 + q_dim1;
q -= q_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
wantz = lsame_(jobz, "V");
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_("DSBEVX", &i__1);
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
if (*n == 1) {
*m = 1;
if (lower) {
tmp1 = ab[ab_dim1 + 1];
} else {
tmp1 = ab[*kd + 1 + ab_dim1];
}
if (valeig) {
if (! (*vl < tmp1 && *vu >= tmp1)) {
*m = 0;
}
}
if (*m == 1) {
w[1] = tmp1;
if (wantz) {
z__[z_dim1 + 1] = 1.;
}
}
return 0;
}
/* Get machine constants. */
safmin = dlamch_("Safe minimum");
eps = dlamch_("Precision");
smlnum = safmin / eps;
bignum = 1. / smlnum;
rmin = sqrt(smlnum);
/* Computing MIN */
d__1 = sqrt(bignum), d__2 = 1. / sqrt(sqrt(safmin));
rmax = min(d__1,d__2);
/* Scale matrix to allowable range, if necessary. */
iscale = 0;
abstll = *abstol;
if (valeig) {
vll = *vl;
vuu = *vu;
} else {
vll = 0.;
vuu = 0.;
}
anrm = dlansb_("M", uplo, n, kd, &ab[ab_offset], ldab, &work[1]);
if (anrm > 0. && anrm < rmin) {
iscale = 1;
sigma = rmin / anrm;
} else if (anrm > rmax) {
iscale = 1;
sigma = rmax / anrm;
}
if (iscale == 1) {
if (lower) {
dlascl_("B", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info);
} else {
dlascl_("Q", kd, kd, &c_b14, &sigma, n, n, &ab[ab_offset], ldab,
info);
}
if (*abstol > 0.) {
abstll = *abstol * sigma;
}
if (valeig) {
vll = *vl * sigma;
vuu = *vu * sigma;
}
}
/* Call DSBTRD to reduce symmetric band matrix to tridiagonal form. */
indd = 1;
inde = indd + *n;
indwrk = inde + *n;
dsbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &work[indd], &work[inde],
&q[q_offset], ldq, &work[indwrk], &iinfo);
/* If all eigenvalues are desired and ABSTOL is less than or equal */
/* to zero, then call DSTERF or SSTEQR. If this fails for some */
/* eigenvalue, then try DSTEBZ. */
test = FALSE_;
if (indeig) {
if (*il == 1 && *iu == *n) {
test = TRUE_;
}
}
if ((alleig || test) && *abstol <= 0.) {
dcopy_(n, &work[indd], &c__1, &w[1], &c__1);
indee = indwrk + (*n << 1);
if (! wantz) {
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsterf_(n, &w[1], &work[indee], info);
} else {
dlacpy_("A", n, n, &q[q_offset], ldq, &z__[z_offset], ldz);
i__1 = *n - 1;
dcopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1);
dsteqr_(jobz, n, &w[1], &work[indee], &z__[z_offset], ldz, &work[
indwrk], info);
if (*info == 0) {
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__) {
ifail[i__] = 0;
/* L10: */
}
}
}
if (*info == 0) {
*m = *n;
goto L30;
}
*info = 0;
}
/* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN. */
if (wantz) {
*(unsigned char *)order = 'B';
} else {
*(unsigned char *)order = 'E';
}
indibl = 1;
indisp = indibl + *n;
indiwo = indisp + *n;
dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[
inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[
indwrk], &iwork[indiwo], info);
if (wantz) {
dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[
indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &
ifail[1], info);
/* Apply orthogonal matrix used in reduction to tridiagonal */
/* form to eigenvectors returned by DSTEIN. */
i__1 = *m;
for (j = 1; j <= i__1; ++j) {
dcopy_(n, &z__[j * z_dim1 + 1], &c__1, &work[1], &c__1);
dgemv_("N", n, n, &c_b14, &q[q_offset], ldq, &work[1], &c__1, &
c_b34, &z__[j * z_dim1 + 1], &c__1);
/* L20: */
}
}
/* If matrix was scaled, then rescale eigenvalues appropriately. */
L30:
if (iscale == 1) {
if (*info == 0) {
imax = *m;
} else {
imax = *info - 1;
}
d__1 = 1. / sigma;
dscal_(&imax, &d__1, &w[1], &c__1);
}
/* If eigenvalues are not in order, then sort them, along with */
/* eigenvectors. */
if (wantz) {
i__1 = *m - 1;
for (j = 1; j <= i__1; ++j) {
i__ = 0;
tmp1 = w[j];
i__2 = *m;
for (jj = j + 1; jj <= i__2; ++jj) {
if (w[jj] < tmp1) {
i__ = jj;
tmp1 = w[jj];
}
/* L40: */
}
if (i__ != 0) {
itmp1 = iwork[indibl + i__ - 1];
w[i__] = w[j];
iwork[indibl + i__ - 1] = iwork[indibl + j - 1];
w[j] = tmp1;
iwork[indibl + j - 1] = itmp1;
dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1],
&c__1);
if (*info != 0) {
itmp1 = ifail[i__];
ifail[i__] = ifail[j];
ifail[j] = itmp1;
}
}
/* L50: */
}
}
return 0;
/* End of DSBEVX */
} /* dsbevx_ */
