/* C front end to LINPACK's dsyevr_() routine.
*
* Calculates the eigenvalues and eigenvectors of the nxn symmetric matrix A.
* The eigenvalues are returned in the vector w.
* The (orthonormal) eigenvectors are returned in the matrix z.
* The ith column of z holds the eigenvector associated with w[i].
* Written by xxxxx and xxxxx
* */
int LP_sym_eigvecs(double *a, int n, double *w, double *z)
{
int lwork=-1, liwork=-1;
double dx, *work = &dx; /* work points to a temporary cell */
int ix, *iwork = &ix; /* iwork points to a temporary cell */
double abstol = -1.0; /* force default */
char jobz='V', range='A', uplo='L';
int il, iu;
double vl, vu;
int info, m;
/* Call dsyevr_() with lwork=-1 and liwork=-1 to query the
* optimal sizes of the work and iwork arrays.
* */
dsyevr_(&jobz, &range, &uplo, &n, a, &n, &vl, &vu, &il, &iu,
&abstol, &m, w, NULL, &n, NULL,
work, &lwork, iwork, &liwork, &info);
if (info!=0) {
REprintf("trouble in file __FILE__, line __LINE__: "
"info = %d\n", info);
}
else {
int *isuppz;
lwork = (int)*work;
liwork = *iwork;
/* allocate optimal sizes for work and iwork */
work = malloc(lwork*sizeof *work);
iwork = malloc(liwork*sizeof *iwork);
isuppz = malloc(2*n*sizeof *isuppz);
if (work==NULL || iwork==NULL || isuppz==NULL) {
REprintf("trouble in file __FILE__, line __LINE__: "
"out of memory!\n");
}
else {
/* now call dsyevr_() in earnest */
dsyevr_(&jobz, &range, &uplo, &n, a, &n, &vl, &vu, &il, &iu,
&abstol, &m, w, z, &n, isuppz,
work, &lwork, iwork, &liwork, &info);
if (info!=0) {
REprintf("trouble in file __FILE__, line __LINE__: "
"info = %d\n", info);
}
}
free(isuppz);
}
free(work);
free(iwork);
return info;
}
nmrSymmetricEigenProblem::Errno
nmrSymmetricEigenProblem
( vctDynamicMatrix<double>& A,
vctDynamicVector<double>& D,
vctDynamicMatrix<double>& V,
nmrSymmetricEigenProblem::Data& data ){
// check if we need to reallocate data
if( ( data.JOBZ == 'N' && data.RANGE == 'U' && data.UPLO == 'L' ) ||
data.N != int(A.rows()) ||
data.ISUPPZ == NULL ||
data.WORK == NULL ||
data.IWORK == NULL ){
data.Free();
data = nmrSymmetricEigenProblem::Data( A, D, V );
}
dsyevr_( &data.JOBZ, &data.RANGE, &data.UPLO,
&data.N, data.A, &data.LDA,
&data.VL, &data.VU,
&data.IL, &data.IU,
&data.ABSTOL,
&data.M, data.W,
data.Z, &data.LDZ, data.ISUPPZ,
data.WORK, &data.LWORK,
data.IWORK, &data.LIWORK,
&data.INFO );
if( data.INFO == 0 ) { return nmrSymmetricEigenProblem::ESUCCESS; }
return nmrSymmetricEigenProblem::EFAILURE;
}
void ProtoMol::Lapack::dsyevr(char *jobz, char *range, char *uplo, int *n,
double *a, int *lda, double *vl, double *vu,
int *il, int *iu, double *abstol, int *m,
double *w, double *z, int *ldz, int *isuppz,
double *work, int *lwork, int *iwork, int *liwork,
int *info) {
FAHCheckIn();
#if defined(HAVE_LAPACK)
dsyevr_(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz,
isuppz, work, lwork, iwork, liwork, info);
#elif defined(HAVE_SIMTK_LAPACK)
dsyevr_(*jobz, *range, *uplo, *n, a, *lda, vl, vu, il, iu, abstol, *m, w, z,
*ldz, isuppz, work, *lwork, iwork, liwork, *info, 1, 1, 1);
#elif defined(HAVE_MKL_LAPACK)
DSYEVR(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz,
isuppz, work, lwork, iwork, liwork, info);
#else
THROW(std::string(__func__) + " not supported");
#endif
}
int dsyevr(char JOBZ, char RANGE, char UPLO, int N,
double *A, int LDA, double VL, double VU,
int IL, int IU, double ABSTOL, int *M,
double *W, double *Z, int LDZ, int *ISUPPZ,
double *WORK, int LWORK, int *IWORK, int LIWORK){
int INFO;
dsyevr_(&JOBZ, &RANGE, &UPLO, &N, A, &LDA, &VL, &VU,
&IL, &IU, &ABSTOL, M, W, Z, &LDZ, ISUPPZ,
WORK, &LWORK, IWORK, &LIWORK, &INFO);
return INFO;
}
nmrSymmetricEigenProblem::Data::Data( vctDynamicMatrix<double>& A,
vctDynamicVector<double>& D,
vctDynamicMatrix<double>& V ) :
JOBZ( 'V' ),
RANGE( 'A' ),
UPLO( 'U' ),
N( A.rows() ),
A( A.Pointer() ),
LDA( A.cols() ),
VL( 0 ),
VU( 0 ),
IL( 0 ),
IU( 0 ),
DLAMCH( 'S' ),
ABSTOL( dlamch_( &DLAMCH ) ),
W( D.Pointer() ),
Z( V.Pointer() ),
LDZ( V.cols() ),
ISUPPZ( new CISSTNETLIB_INTEGER[ 2*N ] ),
WORK( NULL ),
LWORK( -1 ),
IWORK( NULL ),
LIWORK( -1 ){
CheckSystem( A, D, V );
CISSTNETLIB_DOUBLE work;
CISSTNETLIB_INTEGER iwork;
dsyevr_( &JOBZ, &RANGE, &UPLO,
&N, this->A, &LDA,
&VL, &VU,
&IL, &IU,
&ABSTOL,
&M, W,
Z, &LDZ, ISUPPZ,
&work, &LWORK,
&iwork, &LIWORK,
&INFO );
LWORK = work;
WORK = new CISSTNETLIB_DOUBLE[LWORK];
LIWORK = iwork;
IWORK = new CISSTNETLIB_INTEGER[LIWORK];
}
// Wrapper for Lapack eigenvalue function
int dsyevr (char JOBZ, char RANGE, char UPLO, int N,
double *A, int LDA, double VL, double VU,
int IL, int IU, double ABSTOL, int *M,
double *W, double *Z, int LDZ, int *ISUPPZ,
double *WORK, int LWORK, int *IWORK, int LIWORK)
{
extern void dsyevr_ (char *JOBZp, char *RANGEp, char *UPLOp, int *Np,
double *A, int *LDAp, double *VLp, double *VUp,
int *ILp, int *IUp, double *ABSTOLp, int *Mp,
double *W, double *Z, int *LDZp, int *ISUPPZ,
double *WORK, int *LWORKp, int *IWORK, int *LIWORKp,
int *INFOp);
int INFO;
dsyevr_ (&JOBZ, &RANGE, &UPLO, &N, A, &LDA, &VL, &VU,
&IL, &IU, &ABSTOL, M, W, Z, &LDZ, ISUPPZ,
WORK, &LWORK, IWORK, &LIWORK, &INFO);
return INFO;
}
void diagonalize(double *cov, int N, int K, double *val, double *vect)
{
long int n = (long int)N;
long int M = (long int)K;
double abstol = 1e-10;
long int *supp = (long int *) malloc (2 * N * sizeof(long int));
long int lwork = 26*N;
double *work = (double *)calloc(lwork, sizeof(double));
long int liwork = 10*N;
long int *iwork = (long int *)calloc(liwork, sizeof(double));
long int info;
double vl = 0.0, vu = 0.0;
char jobz = 'V', range = 'I', uplo = 'U';
long int il = (long int)N-K+1;
long int ul = (long int)N;
double *valp = (double *) calloc(N, sizeof(double));
double *vectp = (double *) calloc(N * N, sizeof(double));
int i, k;
dsyevr_((char *) (&jobz), (char *) (&range) , (char *) (&uplo), (integer *) (&n), (doublereal *) cov,
(integer *) (&n), (doublereal *) (&vl), (doublereal *) (&vu), (integer *) (&il) , (integer *) (&ul),
(doublereal *) (&abstol), (integer *) (&M), (doublereal *) valp,
(doublereal *) vectp, (integer *) (&n), (integer *)supp, (doublereal *)work,
(integer *) (&lwork), (integer *)iwork, (integer *) (&liwork), (integer *) (&info));
// copy results
for (k = 0; k < K; k++) {
val[k] = valp[K-(k+1)];
if (val[k] < 0 && abs(val[k]) < 1e-10)
val[k] = 0;
}
for (k = 0; k < K; k++)
for (i = 0; i < N; i++)
vect[i * K + k] = vectp[(K - (k + 1)) * N + i];
free(valp);
free(vectp);
free(supp);
free(work);
free(iwork);
}
/* Matrix must be symmetric */
void diagonalize(double *cov, int N, int K, double *val, double *vect){
long int n = (long int)N;
long int M = (long int)K;
double abstol = 1e-10;
long int *supp = (long int *) malloc (2 * N * sizeof(long int));
long int lwork = 26*N;
double *work = (double *)calloc(lwork, sizeof(double));
long int liwork = 10*N;
long int *iwork = (long int *)calloc(liwork, sizeof(double));
long int info;
double vl = 0.0, vu = 0.0;
char jobz = 'V', range = 'I', uplo = 'U';
long int il = (long int)N-K+1;
long int ul = (long int)N;
double *valp = (double *) calloc(N, sizeof(double));
double *vectp = (double *) calloc(N * N, sizeof(double));
int i, k;
double trCov = 0;
for (i=0; i<N; i++) trCov += cov[i*N + i];
dsyevr_((char *) (&jobz), (char *) (&range) , (char *) (&uplo), (integer *) (&n), (doublereal *) cov, (integer *) (&n), (doublereal *) (&vl), (doublereal *) (&vu), (integer *) (&il) , (integer *) (&ul), (doublereal *) (&abstol), (integer *) (&M), (doublereal *) valp, (doublereal *) vectp, (integer *) (&n), (integer *)supp, (doublereal *)work, (integer *) (&lwork), (integer *)iwork, (integer *) (&liwork), (integer *) (&info));
for (k = 0; k < K; k++){
printf("percentage of variance in PC%i: %g\n", k + 1, valp[K - (k + 1)]/trCov);
val[k] = sqrt(valp[K-(k+1)]);
}
for (k = 0; k < K; k++)
for (i = 0; i < N; i++)
vect[i * K + k] = vectp[(K - (k + 1)) * N + i];
free(valp);
free(vectp);
free(supp);
free(work);
free(iwork);
}
void lapack_dsyevr(int nn, char range, dreal vl, dreal vu, int il, int iu, dreal abstol,
dreal *AA, dreal *ww)
{
int lda, ldz, mm, lwork, liwork, info, ii;
char jobz = 'V', uplo = 'U';
int *isuppz = NULL, *iwork = NULL;
dreal *ZZ = NULL, *work = NULL;
lda = (1 > nn) ? 1 : nn;
ldz = lda;
lwork = (1 > 26*nn) ? 1 : 26*nn;
liwork = (1 > 10*nn) ? 1 : 10*nn;
ZZ = (dreal *) calloc(ldz*nn, sizeof(dreal));
check_mem(ZZ, "ZZ");
isuppz = (int *) calloc(2*lda, sizeof(int));
check_mem(isuppz, "isuppz");
work = (dreal *) calloc(lwork, sizeof(dreal));
check_mem(work, "work");
iwork = (int *) calloc(liwork, sizeof(int));
dsyevr_(&jobz, &range, &uplo, &nn, AA, &lda, &vl, &vu, &il, &iu,
&abstol, &mm, ww, ZZ, &ldz, isuppz, work, &lwork,
iwork, &liwork, &info);
for(ii = 0; ii < mm; ++mm)
memcpy(AA+ii*nn, ZZ+ii*nn, nn*sizeof(dreal));
freeup(work);
freeup(isuppz);
freeup(ZZ);
return;
error:
if(work) freeup(work);
if(isuppz) freeup(isuppz);
if(ZZ) freeup(ZZ);
abort();
}
nmrSymmetricEigenProblem::Errno
nmrSymmetricEigenProblem
( vctDynamicMatrix<double>& A,
vctDynamicVector<double>& D,
vctDynamicMatrix<double>& V ){
nmrSymmetricEigenProblem::Data data( A, D, V );
dsyevr_( &data.JOBZ, &data.RANGE, &data.UPLO,
&data.N, data.A, &data.LDA,
&data.VL, &data.VU,
&data.IL, &data.IU,
&data.ABSTOL,
&data.M, data.W,
data.Z, &data.LDZ, data.ISUPPZ,
data.WORK, &data.LWORK,
data.IWORK, &data.LIWORK,
&data.INFO );
data.Free();
if( data.INFO == 0 ) { return nmrSymmetricEigenProblem::ESUCCESS; }
return nmrSymmetricEigenProblem::EFAILURE;
}
