loos::RealMatrix rsv(std::vector<loos::AtomicGroup>& ensemble, ExtractPolicy& extractor) {
loos::RealMatrix M = extractor(ensemble);
loos::RealMatrix C = loos::Math::MMMultiply(M, M, false, true);
// Compute [U,D] = eig(C)
char jobz = 'V';
char uplo = 'L';
f77int n = M.rows();
f77int lda = n;
float dummy;
loos::RealMatrix W(n, 1);
f77int lwork = -1;
f77int info;
ssyev_(&jobz, &uplo, &n, C.get(), &lda, W.get(), &dummy, &lwork, &info);
if (info != 0)
throw(loos::NumericalError("ssyev failed in loos::pca()", info));
lwork = static_cast<f77int>(dummy);
float *work = new float[lwork+1];
ssyev_(&jobz, &uplo, &n, C.get(), &lda, W.get(), work, &lwork, &info);
if (info != 0)
throw(loos::NumericalError("ssyev failed in loos::pca()", info));
reverseColumns(C);
reverseRows(W);
// Correctly scale the eigenvalues
for (uint j=0; j<W.rows(); ++j)
W[j] = W[j] < 0 ? 0.0 : sqrt(W[j]);
// Multiply eigenvectors by inverse eigenvalues
for (uint i=0; i<C.cols(); ++i) {
double konst = (W[i] > 0.0) ? (1.0/W[i]) : 0.0;
for (uint j=0; j<C.rows(); ++j)
C(j, i) *= konst;
}
W.reset();
loos::RealMatrix Vt = loos::Math::MMMultiply(C, M, true, false);
loos::RealMatrix V = loos::Math::transpose(Vt);
return(V);
}
void THLapack_(syev)(char jobz, char uplo, int n, real *a, int lda, real *w, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#else
ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#endif
#else
THError("syev : Lapack library not found in compile time\n");
#endif
}
boost::tuple<loos::RealMatrix, loos::RealMatrix> pca(std::vector<loos::AtomicGroup>& ensemble, ExtractPolicy& extractor) {
loos::RealMatrix M = extractor(ensemble);
loos::RealMatrix C = loos::Math::MMMultiply(M, M, false, true);
// Compute [U,D] = eig(C)
char jobz = 'V';
char uplo = 'L';
f77int n = M.rows();
f77int lda = n;
float dummy;
loos::RealMatrix W(n, 1);
f77int lwork = -1;
f77int info;
ssyev_(&jobz, &uplo, &n, C.get(), &lda, W.get(), &dummy, &lwork, &info);
if (info != 0)
throw(loos::NumericalError("ssyev failed in loos::pca()", info));
lwork = static_cast<f77int>(dummy);
float *work = new float[lwork+1];
ssyev_(&jobz, &uplo, &n, C.get(), &lda, W.get(), work, &lwork, &info);
if (info != 0)
throw(loos::NumericalError("ssyev failed in loos::pca()", info));
reverseColumns(C);
reverseRows(W);
// Zap negative eigenvalues...
for (uint j=0; j<W.rows(); ++j)
if (W[j] < 0.0)
W[j] = 0.0;
boost::tuple<loos::RealMatrix, loos::RealMatrix> result(W, C);
return(result);
}
void THLapack_(syev)(char jobz, char uplo, int n, real *a, int lda, real *w, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dsyev_(char *jobz, char *uplo, int *n, double *a, int *lda, double *w, double *work, int *lwork, int *info);
dsyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#else
extern void ssyev_(char *jobz, char *uplo, int *n, float *a, int *lda, float *w, float *work, int *lwork, int *info);
ssyev_(&jobz, &uplo, &n, a, &lda, w, work, &lwork, info);
#endif
#else
THError("syev : Lapack library not found in compile time\n");
#endif
}
/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer *
n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work,
integer *lwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, neig;
char trans[1];
logical upper;
logical wantz;
integer lwkmin;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* SSYGV 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) REAL 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) REAL 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) REAL array, dimension (N) */
/* If INFO = 0, the eigenvalues in ascending order. */
/* WORK (workspace/output) REAL 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,3*N-1). */
/* For optimal efficiency, LWORK >= (NB+2)*N, */
/* where NB is the blocksize for SSYTRD 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: SPOTRF or SSYEV returned an error code: */
/* <= N: if INFO = i, SSYEV 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 */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
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;
}
if (*info == 0) {
/* Computing MAX */
i__1 = 1, i__2 = *n * 3 - 1;
lwkmin = max(i__1,i__2);
nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = lwkmin, i__2 = (nb + 2) * *n;
lwkopt = max(i__1,i__2);
work[1] = (real) lwkopt;
if (*lwork < lwkmin && ! lquery) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSYGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
spotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
ssygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
ssyev_(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';
}
strsm_("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';
}
strmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b16, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1] = (real) lwkopt;
return 0;
/* End of SSYGV */
} /* ssygv_ */
/* Subroutine */ int ssygv_(integer *itype, char *jobz, char *uplo, integer *
n, real *a, integer *lda, real *b, integer *ldb, real *w, real *work,
integer *lwork, integer *info)
{
/* -- LAPACK driver routine (version 2.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
September 30, 1994
Purpose
=======
SSYGV 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) REAL 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) REAL array, dimension (LDB, 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).
W (output) REAL array, dimension (N)
If INFO = 0, the eigenvalues in ascending order.
WORK (workspace/output) REAL 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 SSYTRD returned by ILAENV.
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: SPOTRF or SSYEV returned an error code:
<= N: if INFO = i, SSYEV 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
Function Body */
/* Table of constant values */
static real c_b11 = 1.f;
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
static integer neig;
extern logical lsame_(char *, char *);
static char trans[1];
static logical upper;
extern /* Subroutine */ int strmm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
);
static logical wantz;
extern /* Subroutine */ int strsm_(char *, char *, char *, char *,
integer *, integer *, real *, real *, integer *, real *, integer *
), ssyev_(char *, char *, integer
*, real *, integer *, real *, real *, integer *, integer *), xerbla_(char *, integer *), spotrf_(char
*, integer *, real *, integer *, integer *), ssygst_(
integer *, char *, integer *, real *, integer *, real *, integer *
, integer *);
#define W(I) w[(I)-1]
#define WORK(I) work[(I)-1]
#define A(I,J) a[(I)-1 + ((J)-1)* ( *lda)]
#define B(I,J) b[(I)-1 + ((J)-1)* ( *ldb)]
wantz = lsame_(jobz, "V");
upper = lsame_(uplo, "U");
*info = 0;
if (*itype < 0 || *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)) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("SSYGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
spotrf_(uplo, n, &B(1,1), ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
ssygst_(itype, uplo, n, &A(1,1), lda, &B(1,1), ldb, info);
ssyev_(jobz, uplo, n, &A(1,1), 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';
}
strsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b11, &B(1,1), ldb, &A(1,1), 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';
}
strmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b11, &B(1,1), ldb, &A(1,1), lda);
}
}
return 0;
/* End of SSYGV */
} /* ssygv_ */
GURLS_EXPORT void syev( char* jobz, char* uplo, int* n, float* a, int* lda, float* w, float* work, int* lwork, int* info)
{
ssyev_(jobz, uplo, n, a, lda, w, work, lwork, info);
}
