/* 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.4.0) -- */
/* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
/* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
/* November 2011 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* ===================================================================== */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. External Functions .. */
/* .. */
/* .. External Subroutines .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* Test the input parameters. */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
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; // , expr subst
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; // , expr subst
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)**T*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**T*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 */
}
void symeigx(double a[],
int n,
double d[],
double v[],
int ell,
int *fl)
{
int itype = 1;
char jobz = 'v';
char range = 'i';
char uplo = 'l';
char trans = 't';
char side = 'l';
char diag = 'n';
char under = 'u';
int nfound;
int *ifail;
int info;
int neig;
double abstol = 2.0 * DLAMCH(under);
double one = 1.0;
double zero = 0.0;
#ifdef CBLAS
double *work;
int lwork;
int *iwork;
char *dsytrd = "DSYTRD";
int monei = -1;
/* int nell = n-ell+1;
int n1 = n;*/
int nell = 1;
int n1 = ell ;
#else
/*int nell = n-ell;
int n1 = n-1;*/
int nell = 0;
int n1 = ell-1;
#endif
ifail = (int *) malloc(sizeof(int) * n);
#ifdef CBLAS
lwork = ilaenv_(&itype, dsytrd, &uplo, &n,
&monei, &monei, &monei, 6L, 1L);
lwork = (lwork+3)*n;
if (lwork < 8*n)
lwork = 8*n;
iwork = (int *) malloc(sizeof(int) * n * 5);
work = (double *) malloc(sizeof(double) * lwork);
dsyevx_(&jobz,&range,&uplo,&n,a,&n,&zero,&zero,&nell,&n1,
&abstol,&nfound,d,v,&n,work,&lwork,iwork,ifail,&info);
free(iwork);
free(work);
#else
dsyevx(jobz, range, uplo, n, a, n, zero, zero, nell, n1, abstol, &nfound,
d, v, n, ifail, &info);
#endif
neig = ell;
if (info > 0)
neig = info - 1;
free(ifail);
printf("%i\n", nfound) ;
*fl = 1;
if (info < 0)
{
fprintf(stderr, "sygvx: Illegal argument %i.\n", info);
*fl = -1;
}
else if ((info > 0) && (info <= n))
{
fprintf(stderr, "sygvx: Convergence failure.\n");
*fl = -1;
}
else if (info > n)
{
fprintf(stderr,
"sygvx: Leading minor of order %i of B not pos. def.\n",
info-n);
*fl = -1;
}
return;
}
bool eigen_lapack(int n, vector_t & A, vector_t & S, matrix_t & V)
{
// Use eigenvalue decomposition instead of SVD
// Get only the highest eigen-values, (par::cluster_mds_dim)
int i1 = n - par::cluster_mds_dim + 1;
int i2 = n;
double z = -1;
// Integer workspace size, 5N
vector<int> iwork(5*n,0);
double optim_lwork;
int lwork = -1;
int out_m;
vector_t out_w( par::cluster_mds_dim , 0 );
vector_t out_z( n * par::cluster_mds_dim ,0 );
int ldz = n;
vector<int> ifail(n,0);
int info=0;
double nz = 0;
// Get workspace
dsyevx_("V" , // get eigenvalues and eigenvectors
"I" , // get interval of selected eigenvalues
"L" , // data stored as upper triangular
&n , // order of matrix
&A[0] , // input matrix
&n , // LDA
&nz , // Vlower
&nz , // Vupper
&i1, // from 1st ...
&i2, // ... to nth eigenvalue
&z , // 0 for ABSTOL
&out_m, // # of eigenvalues found
&out_w[0], // first M entries contain sorted eigen-values
&out_z[0], // array (can be mxm? nxn)
&ldz, // make n at first
&optim_lwork, // Get optimal workspace
&lwork, // size of workspace
&iwork[0], // int workspace
&ifail[0], // output: failed to converge
&info );
// Assign workspace
lwork = (int) optim_lwork;
vector_t work( lwork, 0 );
dsyevx_("V" , // get eigenvalues and eigenvectors
"I" , // get interval of selected eigenvalues
"L" , // data stored as upper triangular
&n , // order of matrix
&A[0] , // input matrix
&n , // LDA
&nz , // Vlower
&nz , // Vupper
&i1, // from 1st ...
&i2, // ... to nth eigenvalue
&z , // 0 for ABSTOL
&out_m, // # of eigenvalues found
&out_w[0], // first M entries contain sorted eigen-values
&out_z[0], // array (can be mxm? nxn)
&ldz, // make n at first
&work[0], // Workspace
&lwork, // size of workspace
&iwork[0], // int workspace
&ifail[0], // output: failed to converge
&info );
// Get eigenvalues, vectors
for (int i=0; i< par::cluster_mds_dim; i++)
S[i] = out_w[i];
for (int i=0; i<n; i++)
for (int j=0;j<par::cluster_mds_dim; j++)
V[i][j] = out_z[ i + j*n ];
return true;
}
/* 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, ftnlen jobz_len, ftnlen range_len,
ftnlen uplo_len)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
/* Local variables */
static integer nb, lopt;
extern logical lsame_(char *, char *, ftnlen, ftnlen);
extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
static char trans[1];
extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
static logical upper, wantz, alleig, indeig, valeig;
extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *,
integer *, integer *, ftnlen), dsygst_(integer *, char *, integer
*, doublereal *, integer *, doublereal *, integer *, integer *,
ftnlen);
static integer lwkopt;
static 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
*, ftnlen, ftnlen, ftnlen);
/* -- LAPACK driver routine (version 3.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* June 30, 1999 */
/* .. Scalar Arguments .. */
/* .. */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* 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 (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", (ftnlen)1, (ftnlen)1);
wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1);
alleig = lsame_(range, "A", (ftnlen)1, (ftnlen)1);
valeig = lsame_(range, "V", (ftnlen)1, (ftnlen)1);
indeig = lsame_(range, "I", (ftnlen)1, (ftnlen)1);
lquery = *lwork == -1;
*info = 0;
if (*itype < 0 || *itype > 3) {
*info = -1;
} else if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
*info = -2;
} else if (! (alleig || valeig || indeig)) {
*info = -3;
} else if (! (upper || lsame_(uplo, "L", (ftnlen)1, (ftnlen)1))) {
*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 && *n > 0) {
if (*vu <= *vl) {
*info = -11;
}
} else if (indeig && *il < 1) {
*info = -12;
} else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
*info = -13;
} else if (*ldz < 1 || wantz && *ldz < *n) {
*info = -18;
} else /* if(complicated condition) */ {
/* Computing MAX */
i__1 = 1, i__2 = *n << 3;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -20;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 3) * *n;
work[1] = (doublereal) lwkopt;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("DSYGVX", &i__1, (ftnlen)6);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
*m = 0;
if (*n == 0) {
work[1] = 1.;
return 0;
}
/* Form a Cholesky factorization of B. */
dpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1);
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, (
ftnlen)1);
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, (ftnlen)1, (ftnlen)1, (ftnlen)1);
lopt = (integer) work[1];
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, (ftnlen)4, (ftnlen)1, (ftnlen)
1, (ftnlen)8);
} 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, (ftnlen)4, (ftnlen)1, (ftnlen)
1, (ftnlen)8);
}
}
/* Set WORK(1) to optimal workspace size. */
work[1] = (doublereal) lwkopt;
return 0;
/* End of DSYGVX */
} /* dsygvx_ */
int matrix_dsyevx(bool compute_eig_vectors ,
dsyevx_eig_enum which_values , /* DSYEVX | DSYEVX_VALUE_INTERVAL | DSYEVX_INDEX_INTERVAL */
dsyevx_uplo_enum uplo,
matrix_type * A , /* The input matrix - is modified by the dsyevx() function. */
double VL , /* Lower limit when using DSYEVX_VALUE_INTERVAL */
double VU , /* Upper limit when using DSYEVX_VALUE_INTERVAL */
int IL , /* Lower index when using DSYEVX_INDEX_INTERVAL */
int IU , /* Upper index when using DSYEVX_INDEX_INTERVAL */
double *eig_values , /* The calcualated eigenvalues */
matrix_type * Z ) { /* The eigenvectors as columns vectors */
int lda = matrix_get_column_stride( A );
int n = matrix_get_rows( A );
char jobz;
char range;
char uplo_c;
if (compute_eig_vectors)
jobz = 'V';
else
jobz = 'N';
switch(which_values) {
case(DSYEVX_ALL):
range = 'A';
break;
case(DSYEVX_VALUE_INTERVAL):
range = 'V';
break;
case(DSYEVX_INDEX_INTERVAL):
range = 'I';
break;
default:
util_abort("%s: internal error \n",__func__);
}
if (uplo == DSYEVX_AUPPER)
uplo_c = 'U';
else if (uplo == DSYEVX_ALOWER)
uplo_c = 'L';
else
util_abort("%s: internal error \n",__func__);
if (!matrix_is_quadratic( A ))
util_abort("%s: matrix A must be quadratic \n",__func__);
{
int num_eigenvalues , ldz, info , worksize;
int * ifail = util_calloc( n , sizeof * ifail );
int * iwork = util_calloc( 5 * n , sizeof * iwork );
double * work = util_calloc( 1 , sizeof * work );
double * z_data;
double abstol = 0.0; /* SHopuld */
if (compute_eig_vectors) {
ldz = matrix_get_column_stride( Z );
z_data = matrix_get_data( Z );
} else {
/* In this case we can accept that Z == NULL */
ldz = 1;
z_data = NULL;
}
/* First call to determine optimal worksize. */
worksize = -1;
info = 0;
dsyevx_( &jobz, /* 1 */
&range, /* 2 */
&uplo_c, /* 3 */
&n, /* 4 */
matrix_get_data( A ), /* 5 */
&lda , /* 6 */
&VL , /* 7 */
&VU , /* 8 */
&IL , /* 9 */
&IU , /* 10 */
&abstol , /* 11 */
&num_eigenvalues , /* 12 */
eig_values , /* 13 */
z_data , /* 14 */
&ldz , /* 15 */
work , /* 16 */
&worksize , /* 17 */
iwork , /* 18 */
ifail , /* 19 */
&info); /* 20 */
worksize = (int) work[0];
{
double * tmp = realloc(work , sizeof * work * worksize );
if (tmp == NULL) {
/*
OK - we could not get the optimal worksize,
try again with the minimum.
*/
worksize = 8 * n;
work = util_realloc(work , sizeof * work * worksize );
} else
work = tmp; /* The request for optimal worksize succeeded */
}
/* Second call: do the job */
info = 0;
dsyevx_( &jobz,
&range,
&uplo_c,
&n,
matrix_get_data( A ),
&lda ,
&VL ,
&VU ,
&IL ,
&IU ,
&abstol ,
&num_eigenvalues ,
eig_values ,
z_data ,
&ldz ,
work ,
&worksize ,
iwork ,
ifail ,
&info);
free( ifail );
free( work );
free( iwork );
return num_eigenvalues;
}
}