/* Subroutine */ int dtrtri_(char *uplo, char *diag, integer *n, doublereal *
a, integer *lda, integer *info)
{
/* -- LAPACK routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
March 31, 1993
Purpose
=======
DTRTRI computes the inverse of a real upper or lower triangular
matrix A.
This is the Level 3 BLAS version of the algorithm.
Arguments
=========
UPLO (input) CHARACTER*1
= 'U': A is upper triangular;
= 'L': A is lower triangular.
DIAG (input) CHARACTER*1
= 'N': A is non-unit triangular;
= 'U': A is unit triangular.
N (input) INTEGER
The order of the matrix A. N >= 0.
A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
On entry, the triangular matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of the array A contains
the upper triangular matrix, and the strictly lower
triangular part of A is not referenced. If UPLO = 'L', the
leading N-by-N lower triangular part of the array A contains
the lower triangular matrix, and the strictly upper
triangular part of A is not referenced. If DIAG = 'U', the
diagonal elements of A are also not referenced and are
assumed to be 1.
On exit, the (triangular) inverse of the original matrix, in
the same storage format.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: if INFO = i, A(i,i) is exactly zero. The triangular
matrix is singular and its inverse can not be computed.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static integer c__2 = 2;
static doublereal c_b18 = 1.;
static doublereal c_b22 = -1.;
/* System generated locals */
address a__1[2];
integer a_dim1, a_offset, i__1, i__2[2], i__3, i__4, i__5;
char ch__1[2];
/* Builtin functions
Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
/* Local variables */
static integer j;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *), dtrsm_(
char *, char *, char *, char *, integer *, integer *, doublereal *
, doublereal *, integer *, doublereal *, integer *);
static logical upper;
extern /* Subroutine */ int dtrti2_(char *, char *, integer *, doublereal
*, integer *, integer *);
static integer jb, nb, nn;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
static logical nounit;
#define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
nounit = lsame_(diag, "N");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (! nounit && ! lsame_(diag, "U")) {
*info = -2;
} else if (*n < 0) {
*info = -3;
} else if (*lda < max(1,*n)) {
*info = -5;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DTRTRI", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Check for singularity if non-unit. */
if (nounit) {
i__1 = *n;
for (*info = 1; *info <= i__1; ++(*info)) {
if (a_ref(*info, *info) == 0.) {
return 0;
}
/* L10: */
}
*info = 0;
}
/* Determine the block size for this environment.
Writing concatenation */
i__2[0] = 1, a__1[0] = uplo;
i__2[1] = 1, a__1[1] = diag;
s_cat(ch__1, a__1, i__2, &c__2, (ftnlen)2);
nb = ilaenv_(&c__1, "DTRTRI", ch__1, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (
ftnlen)2);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
dtrti2_(uplo, diag, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute inverse of upper triangular matrix */
i__1 = *n;
i__3 = nb;
for (j = 1; i__3 < 0 ? j >= i__1 : j <= i__1; j += i__3) {
/* Computing MIN */
i__4 = nb, i__5 = *n - j + 1;
jb = min(i__4,i__5);
/* Compute rows 1:j-1 of current block column */
i__4 = j - 1;
dtrmm_("Left", "Upper", "No transpose", diag, &i__4, &jb, &
c_b18, &a[a_offset], lda, &a_ref(1, j), lda);
i__4 = j - 1;
dtrsm_("Right", "Upper", "No transpose", diag, &i__4, &jb, &
c_b22, &a_ref(j, j), lda, &a_ref(1, j), lda);
/* Compute inverse of current diagonal block */
dtrti2_("Upper", diag, &jb, &a_ref(j, j), lda, info);
/* L20: */
}
} else {
/* Compute inverse of lower triangular matrix */
nn = (*n - 1) / nb * nb + 1;
i__3 = -nb;
for (j = nn; i__3 < 0 ? j >= 1 : j <= 1; j += i__3) {
/* Computing MIN */
i__1 = nb, i__4 = *n - j + 1;
jb = min(i__1,i__4);
if (j + jb <= *n) {
/* Compute rows j+jb:n of current block column */
i__1 = *n - j - jb + 1;
dtrmm_("Left", "Lower", "No transpose", diag, &i__1, &jb,
&c_b18, &a_ref(j + jb, j + jb), lda, &a_ref(j +
jb, j), lda);
i__1 = *n - j - jb + 1;
dtrsm_("Right", "Lower", "No transpose", diag, &i__1, &jb,
&c_b22, &a_ref(j, j), lda, &a_ref(j + jb, j),
lda);
}
/* Compute inverse of current diagonal block */
dtrti2_("Lower", diag, &jb, &a_ref(j, j), lda, info);
/* L30: */
}
}
}
return 0;
/* End of DTRTRI */
} /* dtrtri_ */
/* Subroutine */ HYPRE_Int dsygv_(integer *itype, char *jobz, char *uplo, integer *
n, doublereal *a, integer *lda, doublereal *b, integer *ldb,
doublereal *w, doublereal *work, integer *lwork, 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
=======
DSYGV computes all the eigenvalues, and optionally, the eigenvectors
of a real generalized symmetric-definite eigenproblem, of the form
A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
Here A and B are assumed to be symmetric and B is also
positive definite.
Arguments
=========
ITYPE (input) INTEGER
Specifies the problem type to be solved:
= 1: A*x = (lambda)*B*x
= 2: A*B*x = (lambda)*x
= 3: B*A*x = (lambda)*x
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.
A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
On entry, the symmetric matrix A. If UPLO = 'U', the
leading N-by-N upper triangular part of A contains the
upper triangular part of the matrix A. If UPLO = 'L',
the leading N-by-N lower triangular part of A contains
the lower triangular part of the matrix A.
On exit, if JOBZ = 'V', then if INFO = 0, A contains the
matrix Z of eigenvectors. The eigenvectors are normalized
as follows:
if ITYPE = 1 or 2, Z**T*B*Z = I;
if ITYPE = 3, Z**T*inv(B)*Z = I.
If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
or the lower triangle (if UPLO='L') of A, including the
diagonal, is destroyed.
LDA (input) INTEGER
The leading dimension of the array A. LDA >= max(1,N).
B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
On entry, the symmetric positive definite matrix B.
If UPLO = 'U', the leading N-by-N upper triangular part of B
contains the upper triangular part of the matrix B.
If UPLO = 'L', the leading N-by-N lower triangular part of B
contains the lower triangular part of the matrix B.
On exit, if INFO <= N, the part of B containing the matrix is
overwritten by the triangular factor U or L from the Cholesky
factorization B = U**T*U or B = L*L**T.
LDB (input) INTEGER
The leading dimension of the array B. LDB >= max(1,N).
W (output) DOUBLE PRECISION array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
LWORK (input) INTEGER
The length of the array WORK. LWORK >= max(1,3*N-1).
For optimal efficiency, LWORK >= (NB+2)*N,
where NB is the blocksize for DSYTRD returned by ILAENV.
If LWORK = -1, then a workspace query is assumed; the routine
only calculates the optimal size of the WORK array, returns
this value as the first entry of the WORK array, and no error
message related to LWORK is issued by XERBLA.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: DPOTRF or DSYEV returned an error code:
<= N: if INFO = i, DSYEV 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 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.
=====================================================================
Test the input parameters.
Parameter adjustments */
/* Table of constant values */
static integer c__1 = 1;
static integer c_n1 = -1;
static doublereal c_b16 = 1.;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer neig;
extern logical lsame_(const char *,const char *);
extern /* Subroutine */ HYPRE_Int dtrmm_(const char *,const char *,const char *,const char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static char trans[1];
extern /* Subroutine */ HYPRE_Int dtrsm_(const char *,const char *,const char *,const char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
static logical upper;
extern /* Subroutine */ HYPRE_Int dsyev_(const char *,const char *, integer *, doublereal *
, integer *, doublereal *, doublereal *, integer *, integer *);
static logical wantz;
static integer nb;
extern /* Subroutine */ HYPRE_Int xerbla_(const char *, integer *);
extern integer ilaenv_(integer *,const char *,const char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ HYPRE_Int dpotrf_(const char *, integer *, doublereal *,
integer *, integer *), dsygst_(integer *,const char *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *);
static integer lwkopt;
static logical lquery;
a_dim1 = *lda;
a_offset = 1 + a_dim1 * 1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1 * 1;
b -= b_offset;
--w;
--work;
/* Function Body */
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -3;
} else if (*n < 0) {
*info = -4;
} else if (*lda < max(1,*n)) {
*info = -6;
} else if (*ldb < max(1,*n)) {
*info = -8;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 2) * *n;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
dpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
dsyev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
neig = *n;
if (*info > 0) {
neig = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
dtrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
b_offset], ldb, &a[a_offset], lda);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x;
backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
dtrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYGV */
} /* dsygv_ */
/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char *
uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer
*ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu,
doublereal *abstol, integer *m, doublereal *w, doublereal *z__,
integer *ldz, doublereal *work, integer *lwork, integer *iwork,
integer *ifail, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
/* Local variables */
integer nb;
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
char trans[1];
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
logical upper, wantz, alleig, indeig, valeig;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
integer *, integer *);
integer lwkmin;
extern /* Subroutine */ int dsygst_(integer *, char *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */ int dsyevx_(char *, char *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
integer *, doublereal *, integer *, integer *, 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 */
/* ======= */
/* DSYGVX computes selected eigenvalues, and optionally, eigenvectors */
/* of a real generalized symmetric-definite eigenproblem, of the form */
/* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A */
/* and B are assumed to be symmetric and B is also positive definite. */
/* Eigenvalues and eigenvectors can be selected by specifying either a */
/* range of values or a range of indices for the desired eigenvalues. */
/* Arguments */
/* ========= */
/* ITYPE (input) INTEGER */
/* Specifies the problem type to be solved: */
/* = 1: A*x = (lambda)*B*x */
/* = 2: A*B*x = (lambda)*x */
/* = 3: B*A*x = (lambda)*x */
/* 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 and B are stored; */
/* = 'L': Lower triangle of A and B are stored. */
/* N (input) INTEGER */
/* The order of the matrix pencil (A,B). N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the symmetric matrix A. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of A contains the */
/* upper triangular part of the matrix A. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of A contains */
/* the lower triangular part of the matrix A. */
/* On exit, the lower triangle (if UPLO='L') or the upper */
/* triangle (if UPLO='U') of A, including the diagonal, is */
/* destroyed. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* B (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/* On entry, the symmetric matrix B. If UPLO = 'U', the */
/* leading N-by-N upper triangular part of B contains the */
/* upper triangular part of the matrix B. If UPLO = 'L', */
/* the leading N-by-N lower triangular part of B contains */
/* the lower triangular part of the matrix B. */
/* On exit, if INFO <= N, the part of B containing the matrix is */
/* overwritten by the triangular factor U or L from the Cholesky */
/* factorization B = U**T*U or B = L*L**T. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. LDB >= 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) */
/* On normal exit, the first M elements contain the selected */
/* eigenvalues in ascending order. */
/* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
/* If JOBZ = 'N', then Z is not referenced. */
/* 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). */
/* The eigenvectors are normalized as follows: */
/* if ITYPE = 1 or 2, Z**T*B*Z = I; */
/* if ITYPE = 3, Z**T*inv(B)*Z = 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. */
/* Note: the user must ensure that at least max(1,M) columns are */
/* supplied in the array Z; if RANGE = 'V', the exact value of M */
/* is not known in advance and an upper bound must be used. */
/* LDZ (input) INTEGER */
/* The leading dimension of the array Z. LDZ >= 1, and if */
/* JOBZ = 'V', LDZ >= max(1,N). */
/* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
/* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
/* LWORK (input) INTEGER */
/* The length of the array WORK. LWORK >= max(1,8*N). */
/* For optimal efficiency, LWORK >= (NB+3)*N, */
/* where NB is the blocksize for DSYTRD returned by ILAENV. */
/* If LWORK = -1, then a workspace query is assumed; the routine */
/* only calculates the optimal size of the WORK array, returns */
/* this value as the first entry of the WORK array, and no error */
/* message related to LWORK is issued by XERBLA. */
/* IWORK (workspace) INTEGER array, dimension (5*N) */
/* IFAIL (output) INTEGER array, dimension (N) */
/* If JOBZ = 'V', then if INFO = 0, the first M elements of */
/* IFAIL are zero. If INFO > 0, then IFAIL contains the */
/* indices of the eigenvectors that failed to converge. */
/* If JOBZ = 'N', then IFAIL is not referenced. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: DPOTRF or DSYEVX returned an error code: */
/* <= N: if INFO = i, DSYEVX failed to converge; */
/* i eigenvectors failed to converge. Their indices */
/* are stored in array IFAIL. */
/* > N: 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--w;
z_dim1 = *ldz;
z_offset = 1 + z_dim1;
z__ -= z_offset;
--work;
--iwork;
--ifail;
/* Function Body */
upper = lsame_(uplo, "U");
wantz = lsame_(jobz, "V");
alleig = lsame_(range, "A");
valeig = lsame_(range, "V");
indeig = lsame_(range, "I");
lquery = *lwork == -1;
*info = 0;
if (*itype < 1 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N"))) {
*info = -2;
} else if (! (alleig || valeig || indeig)) {
*info = -3;
} else if (! (upper || lsame_(uplo, "L"))) {
*info = -4;
} else if (*n < 0) {
*info = -5;
} else if (*lda < max(1,*n)) {
*info = -7;
} else if (*ldb < 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) {
/* Computing MAX */
i__1 = 1, i__2 = *n << 3;
lwkmin = max(i__1,i__2);
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkmin, i__2 = (nb + 3) * *n;
lwkopt = max(i__1,i__2);
work[1] = (doublereal) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -20;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGVX", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
dpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol,
m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[
1], info);
if (wantz) {
/* Backtransform eigenvectors to the original problem. */
if (*info > 0) {
*m = *info - 1;
}
if (*itype == 1 || *itype == 2) {
/* For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */
if (upper) {
*(unsigned char *)trans = 'N';
} else {
*(unsigned char *)trans = 'T';
}
dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
, ldb, &z__[z_offset], ldz);
} else if (*itype == 3) {
/* For B*A*x=(lambda)*x; */
/* backtransform eigenvectors: x = L*y or U'*y */
if (upper) {
*(unsigned char *)trans = 'T';
} else {
*(unsigned char *)trans = 'N';
}
dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
, ldb, &z__[z_offset], ldz);
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYGVX */
} /* dsygvx_ */
/* Subroutine */ int dlarhs_(char *path, char *xtype, char *uplo, char *trans,
integer *m, integer *n, integer *kl, integer *ku, integer *nrhs,
doublereal *a, integer *lda, doublereal *x, integer *ldx, doublereal *
b, integer *ldb, integer *iseed, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1;
/* Builtin functions */
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer j;
char c1[1], c2[2];
integer mb, nx;
logical gen, tri, qrs, sym, band;
char diag[1];
logical tran;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *),
dgbmv_(char *, integer *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dsbmv_(char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dtbmv_(char *,
char *, char *, integer *, integer *, doublereal *, integer *,
doublereal *, integer *), dtrmm_(char *,
char *, char *, char *, integer *, integer *, doublereal *,
doublereal *, integer *, doublereal *, integer *), dspmv_(char *, integer *, doublereal *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dsymm_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, integer *,
doublereal *, doublereal *, integer *), dtpmv_(
char *, char *, char *, integer *, doublereal *, doublereal *,
integer *), dlacpy_(char *, integer *,
integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dlarnv_(integer *, integer *, integer *,
doublereal *);
logical notran;
/* -- LAPACK test routine (version 3.1) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARHS chooses a set of NRHS random solution vectors and sets */
/* up the right hand sides for the linear system */
/* op( A ) * X = B, */
/* where op( A ) may be A or A' (transpose of A). */
/* Arguments */
/* ========= */
/* PATH (input) CHARACTER*3 */
/* The type of the real matrix A. PATH may be given in any */
/* combination of upper and lower case. Valid types include */
/* xGE: General m x n matrix */
/* xGB: General banded matrix */
/* xPO: Symmetric positive definite, 2-D storage */
/* xPP: Symmetric positive definite packed */
/* xPB: Symmetric positive definite banded */
/* xSY: Symmetric indefinite, 2-D storage */
/* xSP: Symmetric indefinite packed */
/* xSB: Symmetric indefinite banded */
/* xTR: Triangular */
/* xTP: Triangular packed */
/* xTB: Triangular banded */
/* xQR: General m x n matrix */
/* xLQ: General m x n matrix */
/* xQL: General m x n matrix */
/* xRQ: General m x n matrix */
/* where the leading character indicates the precision. */
/* XTYPE (input) CHARACTER*1 */
/* Specifies how the exact solution X will be determined: */
/* = 'N': New solution; generate a random X. */
/* = 'C': Computed; use value of X on entry. */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the upper or lower triangular part of the */
/* matrix A is stored, if A is symmetric. */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* TRANS (input) CHARACTER*1 */
/* Specifies the operation applied to the matrix A. */
/* = 'N': System is A * x = b */
/* = 'T': System is A'* x = b */
/* = 'C': System is A'* x = b */
/* M (input) INTEGER */
/* The number or rows of the matrix A. M >= 0. */
/* N (input) INTEGER */
/* The number of columns of the matrix A. N >= 0. */
/* KL (input) INTEGER */
/* Used only if A is a band matrix; specifies the number of */
/* subdiagonals of A if A is a general band matrix or if A is */
/* symmetric or triangular and UPLO = 'L'; specifies the number */
/* of superdiagonals of A if A is symmetric or triangular and */
/* UPLO = 'U'. 0 <= KL <= M-1. */
/* KU (input) INTEGER */
/* Used only if A is a general band matrix or if A is */
/* triangular. */
/* If PATH = xGB, specifies the number of superdiagonals of A, */
/* and 0 <= KU <= N-1. */
/* If PATH = xTR, xTP, or xTB, specifies whether or not the */
/* matrix has unit diagonal: */
/* = 1: matrix has non-unit diagonal (default) */
/* = 2: matrix has unit diagonal */
/* NRHS (input) INTEGER */
/* The number of right hand side vectors in the system A*X = B. */
/* A (input) DOUBLE PRECISION array, dimension (LDA,N) */
/* The test matrix whose type is given by PATH. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. */
/* If PATH = xGB, LDA >= KL+KU+1. */
/* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */
/* Otherwise, LDA >= max(1,M). */
/* X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS) */
/* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */
/* the exact solution to the system of linear equations. */
/* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */
/* with random values. */
/* LDX (input) INTEGER */
/* The leading dimension of the array X. If TRANS = 'N', */
/* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */
/* B (output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
/* The right hand side vector(s) for the system of equations, */
/* computed from B = op(A) * X, where op(A) is determined by */
/* TRANS. */
/* LDB (input) INTEGER */
/* The leading dimension of the array B. If TRANS = 'N', */
/* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* The seed vector for the random number generator (used in */
/* DLATMS). Modified on exit. */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
x_dim1 = *ldx;
x_offset = 1 + x_dim1;
x -= x_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
--iseed;
/* Function Body */
*info = 0;
*(unsigned char *)c1 = *(unsigned char *)path;
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
tran = lsame_(trans, "T") || lsame_(trans, "C");
notran = ! tran;
gen = lsame_(path + 1, "G");
qrs = lsame_(path + 1, "Q") || lsame_(path + 2,
"Q");
sym = lsame_(path + 1, "P") || lsame_(path + 1,
"S");
tri = lsame_(path + 1, "T");
band = lsame_(path + 2, "B");
if (! lsame_(c1, "Double precision")) {
*info = -1;
} else if (! (lsame_(xtype, "N") || lsame_(xtype,
"C"))) {
*info = -2;
} else if ((sym || tri) && ! (lsame_(uplo, "U") ||
lsame_(uplo, "L"))) {
*info = -3;
} else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) {
*info = -4;
} else if (*m < 0) {
*info = -5;
} else if (*n < 0) {
*info = -6;
} else if (band && *kl < 0) {
*info = -7;
} else if (band && *ku < 0) {
*info = -8;
} else if (*nrhs < 0) {
*info = -9;
} else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < *
kl + 1 || band && gen && *lda < *kl + *ku + 1) {
*info = -11;
} else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) {
*info = -13;
} else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) {
*info = -15;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLARHS", &i__1);
return 0;
}
/* Initialize X to NRHS random vectors unless XTYPE = 'C'. */
if (tran) {
nx = *m;
mb = *n;
} else {
nx = *n;
mb = *m;
}
if (! lsame_(xtype, "C")) {
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dlarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]);
/* L10: */
}
}
/* Multiply X by op( A ) using an appropriate */
/* matrix multiply routine. */
if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2,
"QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") ||
lsamen_(&c__2, c2, "RQ")) {
/* General matrix */
dgemm_(trans, "N", &mb, nrhs, &nx, &c_b32, &a[a_offset], lda, &x[
x_offset], ldx, &c_b33, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "PO") || lsamen_(&
c__2, c2, "SY")) {
/* Symmetric matrix, 2-D storage */
dsymm_("Left", uplo, n, nrhs, &c_b32, &a[a_offset], lda, &x[x_offset],
ldx, &c_b33, &b[b_offset], ldb);
} else if (lsamen_(&c__2, c2, "GB")) {
/* General matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dgbmv_(trans, &mb, &nx, kl, ku, &c_b32, &a[a_offset], lda, &x[j *
x_dim1 + 1], &c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
/* L20: */
}
} else if (lsamen_(&c__2, c2, "PB")) {
/* Symmetric matrix, band storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dsbmv_(uplo, n, kl, &c_b32, &a[a_offset], lda, &x[j * x_dim1 + 1],
&c__1, &c_b33, &b[j * b_dim1 + 1], &c__1);
/* L30: */
}
} else if (lsamen_(&c__2, c2, "PP") || lsamen_(&
c__2, c2, "SP")) {
/* Symmetric matrix, packed storage */
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dspmv_(uplo, n, &c_b32, &a[a_offset], &x[j * x_dim1 + 1], &c__1, &
c_b33, &b[j * b_dim1 + 1], &c__1);
/* L40: */
}
} else if (lsamen_(&c__2, c2, "TR")) {
/* Triangular matrix. Note that for triangular matrices, */
/* KU = 1 => non-unit triangular */
/* KU = 2 => unit triangular */
dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
dtrmm_("Left", uplo, trans, diag, n, nrhs, &c_b32, &a[a_offset], lda,
&b[b_offset], ldb)
;
} else if (lsamen_(&c__2, c2, "TP")) {
/* Triangular matrix, packed storage */
dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dtpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], &
c__1);
/* L50: */
}
} else if (lsamen_(&c__2, c2, "TB")) {
/* Triangular matrix, banded storage */
dlacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb);
if (*ku == 2) {
*(unsigned char *)diag = 'U';
} else {
*(unsigned char *)diag = 'N';
}
i__1 = *nrhs;
for (j = 1; j <= i__1; ++j) {
dtbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1
+ 1], &c__1);
/* L60: */
}
} else {
/* If PATH is none of the above, return with an error code. */
*info = -1;
i__1 = -(*info);
xerbla_("DLARHS", &i__1);
}
return 0;
/* End of DLARHS */
} /* dlarhs_ */
/* Subroutine */ int dlauum_(char *uplo, integer *n, doublereal *a, integer *
lda, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
/* Local variables */
integer i__, ib, nb;
extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *,
integer *, doublereal *, doublereal *, integer *, doublereal *,
integer *, doublereal *, doublereal *, integer *);
extern logical lsame_(char *, char *);
extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *);
logical upper;
extern /* Subroutine */ int dsyrk_(char *, char *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
integer *), dlauu2_(char *, integer *,
doublereal *, integer *, integer *), xerbla_(char *,
integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *);
/* -- LAPACK auxiliary routine (version 3.2) -- */
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
/* November 2006 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLAUUM computes the product U * U' or L' * L, where the triangular */
/* factor U or L is stored in the upper or lower triangular part of */
/* the array A. */
/* If UPLO = 'U' or 'u' then the upper triangle of the result is stored, */
/* overwriting the factor U in A. */
/* If UPLO = 'L' or 'l' then the lower triangle of the result is stored, */
/* overwriting the factor L in A. */
/* This is the blocked form of the algorithm, calling Level 3 BLAS. */
/* Arguments */
/* ========= */
/* UPLO (input) CHARACTER*1 */
/* Specifies whether the triangular factor stored in the array A */
/* is upper or lower triangular: */
/* = 'U': Upper triangular */
/* = 'L': Lower triangular */
/* N (input) INTEGER */
/* The order of the triangular factor U or L. N >= 0. */
/* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
/* On entry, the triangular factor U or L. */
/* On exit, if UPLO = 'U', the upper triangle of A is */
/* overwritten with the upper triangle of the product U * U'; */
/* if UPLO = 'L', the lower triangle of A is overwritten with */
/* the lower triangle of the product L' * L. */
/* LDA (input) INTEGER */
/* The leading dimension of the array A. LDA >= max(1,N). */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -k, the k-th argument had an illegal value */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
*info = 0;
upper = lsame_(uplo, "U");
if (! upper && ! lsame_(uplo, "L")) {
*info = -1;
} else if (*n < 0) {
*info = -2;
} else if (*lda < max(1,*n)) {
*info = -4;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DLAUUM", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Determine the block size for this environment. */
nb = ilaenv_(&c__1, "DLAUUM", uplo, n, &c_n1, &c_n1, &c_n1);
if (nb <= 1 || nb >= *n) {
/* Use unblocked code */
dlauu2_(uplo, n, &a[a_offset], lda, info);
} else {
/* Use blocked code */
if (upper) {
/* Compute the product U * U'. */
i__1 = *n;
i__2 = nb;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
dtrmm_("Right", "Upper", "Transpose", "Non-unit", &i__3, &ib,
&c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ * a_dim1
+ 1], lda)
;
dlauu2_("Upper", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
dgemm_("No transpose", "Transpose", &i__3, &ib, &i__4, &
c_b15, &a[(i__ + ib) * a_dim1 + 1], lda, &a[i__ +
(i__ + ib) * a_dim1], lda, &c_b15, &a[i__ *
a_dim1 + 1], lda);
i__3 = *n - i__ - ib + 1;
dsyrk_("Upper", "No transpose", &ib, &i__3, &c_b15, &a[
i__ + (i__ + ib) * a_dim1], lda, &c_b15, &a[i__ +
i__ * a_dim1], lda);
}
/* L10: */
}
} else {
/* Compute the product L' * L. */
i__2 = *n;
i__1 = nb;
for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
/* Computing MIN */
i__3 = nb, i__4 = *n - i__ + 1;
ib = min(i__3,i__4);
i__3 = i__ - 1;
dtrmm_("Left", "Lower", "Transpose", "Non-unit", &ib, &i__3, &
c_b15, &a[i__ + i__ * a_dim1], lda, &a[i__ + a_dim1],
lda);
dlauu2_("Lower", &ib, &a[i__ + i__ * a_dim1], lda, info);
if (i__ + ib <= *n) {
i__3 = i__ - 1;
i__4 = *n - i__ - ib + 1;
dgemm_("Transpose", "No transpose", &ib, &i__3, &i__4, &
c_b15, &a[i__ + ib + i__ * a_dim1], lda, &a[i__ +
ib + a_dim1], lda, &c_b15, &a[i__ + a_dim1], lda);
i__3 = *n - i__ - ib + 1;
dsyrk_("Lower", "Transpose", &ib, &i__3, &c_b15, &a[i__ +
ib + i__ * a_dim1], lda, &c_b15, &a[i__ + i__ *
a_dim1], lda);
}
/* L20: */
}
}
}
return 0;
/* End of DLAUUM */
} /* dlauum_ */
