int eigen_decomposition(int n, double* X, double *eigvec, double *eigval) {
/*
This function calculates the eigenvalues and eigenvectors of
the n*n symmetric matrix X.
The matrices have to be in Fortran vector format.
The eigenvectors will be put columnwise in the n*n matrix eigvec,
where the corresponding eigenvalues will be put in the vector
eigval (length n of course). Only the lower triangle of the matrix
X is used. The content of X is not changed.
This function first queries the Lapack routines for optimal workspace
sizes. These memoryblocks are then allocated and the decomposition is
calculated using the Lapack function "dsyevr". The allocated memory
is then freed.
*/
double *WORK, *Xc;
int *ISUPPZ, *IWORK;
int numeig, info, sizeWORK, sizeIWORK;
if (check_input(X, eigvec, "eigen_decomposition")) return 1;
/* Use a copy of X so we don't need to change its value or use its memoryblock */
Xc=(double*) malloc(n*n*sizeof(double));
/* The support of the eigenvectors. We will not use this but the routine needs it */
ISUPPZ = (int*) malloc (2*n*sizeof(int));
/* Allocate temporarily minimally allowed size for workspace arrays */
WORK = (double*) malloc (26*n*sizeof(double));
IWORK = (int*) malloc (10*n*sizeof(int));
/* Check for NULL-pointers. */
if ((Xc==NULL)||(ISUPPZ==NULL)||(WORK==NULL)||(IWORK==NULL)) {
printf("malloc failed in eigen_decomposition\n");
return 2;
}
vector_copy(n*n, X, Xc);
/* Query the Lapack routine for optimal sizes for workspace arrays */
info=dsyevr ('V', 'A', 'L', n, Xc, n, 0, 0, 0, 0, dlamch('S'), &numeig, eigval, eigvec, n, ISUPPZ, WORK, -1, IWORK, -1);
sizeWORK = (int)WORK[0];
sizeIWORK = IWORK[0];
/* Free previous allocation and reallocate preferable workspaces, Check result */
free(WORK);free(IWORK);
WORK = (double*) malloc (sizeWORK*sizeof(double));
IWORK = (int*) malloc (sizeIWORK*sizeof(int));
if ((WORK==NULL)||(IWORK==NULL)) {
printf("malloc failed in eigen_decomposition\n");
return 2;
}
/* Now calculate the eigenvalues and vectors using optimal workspaces */
info=dsyevr ('V', 'A', 'L', n, Xc, n, 0, 0, 0, 0, dlamch('S'), &numeig, eigval, eigvec, n, ISUPPZ, WORK, sizeWORK, IWORK, sizeIWORK);
/* Cleanup and exit */
free(WORK); free(IWORK); free(ISUPPZ); free(Xc);
return info;
}
SymSchurDecomp::SymSchurDecomp(const GeneralMatrix& mata)
: lambda(mata.numRows()), q(mata.numRows())
{
// check mata is square
if (mata.numRows() != mata.numCols())
throw SYLV_MES_EXCEPTION("Matrix is not square in SymSchurDecomp constructor");
// prepare for dsyevr
const char* jobz = "V";
const char* range = "A";
const char* uplo = "U";
lapack_int n = mata.numRows();
GeneralMatrix tmpa(mata);
double* a = tmpa.base();
lapack_int lda = tmpa.getLD();
double dum;
double* vl = &dum;
double* vu = &dum;
lapack_int idum;
lapack_int* il = &idum;
lapack_int* iu = &idum;
double abstol = 0.0;
lapack_int m = n;
double* w = lambda.base();
double* z = q.base();
lapack_int ldz = q.getLD();
lapack_int* isuppz = new lapack_int[2*std::max(1,(int) m)];
double tmpwork;
lapack_int lwork = -1;
lapack_int tmpiwork;
lapack_int liwork = -1;
lapack_int info;
// query for lwork and liwork
dsyevr(jobz, range, uplo, &n, a, &lda, vl, vu, il, iu, &abstol,
&m, w, z, &ldz, isuppz, &tmpwork, &lwork, &tmpiwork, &liwork, &info);
lwork = (int)tmpwork;
liwork = tmpiwork;
// allocate work arrays
double* work = new double[lwork];
lapack_int* iwork = new lapack_int[liwork];
// do the calculation
dsyevr(jobz, range, uplo, &n, a, &lda, vl, vu, il, iu, &abstol,
&m, w, z, &ldz, isuppz, work, &lwork, iwork, &liwork, &info);
if (info < 0)
throw SYLV_MES_EXCEPTION("Internal error in SymSchurDecomp constructor");
if (info > 0)
throw SYLV_MES_EXCEPTION("Internal LAPACK error in DSYEVR");
delete [] work;
delete [] iwork;
delete [] isuppz;
}
void EigenSystemSolverRealSymmetricMatrix(const Array2 <doublevar > & Ain, Array1 <doublevar> & evals, Array2 <doublevar> & evecs){
//returns eigenvalues from largest to lowest and
//eigenvectors, where for i-th eigenvalue, the eigenvector components are evecs(*,i)
#ifdef USE_LAPACK //if LAPACK
int N=Ain.dim[0];
Array2 <doublevar> Ain2(N,N);
//need to copy the array!!
Ain2=Ain;
/* allocate and initialise the matrix */
Array1 <doublevar> W, Z, WORK;
Array1 <int> ISUPPZ, IWORK;
int M;
/* allocate space for the output parameters and workspace arrays */
W.Resize(N);
Z.Resize(N*N);
ISUPPZ.Resize(2*N);
WORK.Resize(26*N);
IWORK.Resize(10*N);
int info;
/* get the eigenvalues and eigenvectors */
info=dsyevr('V', 'A', 'L', N, Ain2.v, N, 0.0, 0.0, 0, 0, dlamch('S'), &M,
W.v, Z.v, N, ISUPPZ.v, WORK.v, 26*N, IWORK.v, 10*N);
if(info>0)
error("Internal error in the LAPACK routine dsyevr");
if(info<0)
error("Problem with the input parameter of LAPACK routine dsyevr in position "-info);
for (int i=0; i<N; i++)
evals(i)=W[N-1-i];
for (int i=0; i<N; i++) {
for (int j=0; j<N; j++) {
evecs(j,i)=Z[j+(N-1-i)*N];
}
}
//END OF LAPACK
#else //IF NO LAPACK
const int n = Ain.dim[0];
Array2 < dcomplex > Ain_complex(n,n);
Array2 <dcomplex> evecs_complex(n,n);
for (int i=0; i < n; i++)
for (int j=0; j < n; j++) {
Ain_complex(i,j)=dcomplex(Ain(i,j),0.0);
}
Jacobi(Ain_complex, evals, evecs_complex);
for (int i=0; i < n; i++)
for (int j=0; j < n; j++){
evecs(i,j)=real(evecs_complex(i,j));
}
#endif //END OF NO LAPACK
}
//=============================================================================//
void eig(matrix& eigevalue,matrix& eigenvector,matrix& t1)
{
int n=t1.rows;
int lda=n;
double vl=0,vu=0;
int il=1, iu=n;
double abstol=1e-14;
int ldz=n;
int lwork=40*n;
int liwork=20*n;
int* iwork=new int[liwork];
double* work=new double[lwork];
int m;
int info;
int* isuppz=new int[2*n];
dsyevr("VECTOR","ALL","LOWER",&n,t1.array1d,&lda,&vl,&vu,&il,&iu,&abstol,&m,eigevalue.array1d,eigenvector.array1d,&ldz,isuppz,work,&lwork,iwork,&liwork,&info);
delete [] iwork;
delete [] work;
delete [] isuppz;
}
