// -----------------------------------------------------------------
// Take log of hermitian part of decomposition to define scalar field
void matrix_log(matrix *in, matrix *out) {
char V = 'V'; // Ask LAPACK for both eigenvalues and eigenvectors
char U = 'U'; // Have LAPACK store upper triangle of in
int row, col, Npt = NCOL, stat = 0, Nwork = 2 * NCOL;
matrix evecs, tmat;
// Convert in to column-major double array used by LAPACK
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
store[2 * (col * NCOL + row)] = in->e[row][col].real;
store[2 * (col * NCOL + row) + 1] = in->e[row][col].imag;
}
}
// Compute eigenvalues and eigenvectors of in
zheev_(&V, &U, &Npt, store, &Npt, eigs, work, &Nwork, Rwork, &stat);
if (stat != 0)
printf("WARNING: zheev returned error message %d\n", stat);
// Move the results back into matrix structures
// Use evecs to hold the eigenvectors for projection
clear_mat(out);
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
evecs.e[row][col].real = store[2 * (col * NCOL + row)];
evecs.e[row][col].imag = store[2 * (col * NCOL + row) + 1];
}
out->e[row][row].real = log(eigs[row]);
}
// Inverse of eigenvector matrix is simply adjoint
mult_na(out, &evecs, &tmat);
mult_nn(&evecs, &tmat, out);
}
void lapack_zheev(int nn, dcmplx *AA, dreal *ww)
{
int lda, lwork, rsize, info;
char jobz = 'V', uplo = 'U';
dreal *rwork = NULL;
dcmplx *work = NULL;
lda = (1 > nn) ? 1 : nn;
lwork = (1 > 2*nn-1) ? 1 : 2*nn-1;
rsize = (1 > 3*nn-2) ? 1 : 3*nn-2;
work = (dcmplx *) calloc(lwork, sizeof(dcmplx));
check_mem(work, "work");
rwork = (dreal *) calloc(rsize, sizeof(dreal));
check_mem(rwork, "rwork");
zheev_(&jobz, &uplo, &nn, AA, &lda, ww, work, &lwork, rwork, &info);
freeup(rwork);
freeup(work);
return;
error:
if(rwork) freeup(rwork);
if(work) freeup(work);
abort();
}
void snake::math::SSMED(COMPLEX* Matrix,int Dim,double* EigenValue)
{
assert(Dim>0);
char jobz = 'V';
char uplo = 'U';
const int n = Dim;
const int lda = n;
int info = 0;
int lwork = 2*Dim;
double*rwork = new double[3*Dim];
assert(rwork);
COMPLEX *work = new COMPLEX[lwork];
assert(work);
zheev_(jobz,uplo,n,Matrix,lda,EigenValue,work,lwork,rwork,info);
delete []rwork;
delete []work;
//if(info == 0) std::cout<<"successful in SSMDiag"<<std::endl;
//
//else std::cout<<"fail in SSMDiag"<<std::endl;
//
}
void QuasiNewton<dcomplex>::stdHerDiag(int NTrial, ostream &output){
// Solve E(R)| X(R) > = | X(R) > ω
char JOBV = 'V';
char UPLO = 'L';
int INFO;
ComplexCMMap A(this->XTSigmaRMem,NTrial,NTrial);
//cout << "HERE" << endl;
//cout << endl << A << endl;
zheev_(&JOBV,&UPLO,&NTrial,this->XTSigmaRMem,&NTrial,
this->RealEMem,this->WORK,&this->LWORK,this->RWORK,
&INFO);
if(INFO!=0) CErr("ZHEEV failed to converge in Davison Iterations",output);
} // stdHerDiag
//hermitian matrix, each row in output is an eigenvector, the input matrix is stored in column-major
void diag(double complex *mat, double *e, int n)
{
char jobz='V'; //also eigenvectors
char uplo='U'; //upper triangle
int info;
int lwork=4*n;
double complex *work;
double *rwork;
work=(double complex *)malloc(sizeof(double complex)*lwork);
rwork=(double *)malloc(sizeof(double)*(3*n-2));
zheev_(&jobz,&uplo,&n,mat,&n,e,work,&lwork,rwork,&info);
if(info!=0){
printf("matrix diag fail\n");
exit(1);
}
free(work);
free(rwork);
}
/* Subroutine */
int zhegv_(integer *itype, char *jobz, char *uplo, integer * n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb, doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork, integer *info)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
/* Local variables */
integer nb, neig;
extern logical lsame_(char *, char *);
extern /* Subroutine */
int zheev_(char *, char *, integer *, doublecomplex *, integer *, doublereal *, doublecomplex *, integer *, doublereal *, integer *);
char trans[1];
logical upper, wantz;
extern /* Subroutine */
int ztrmm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), ztrsm_(char *, char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *), xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
extern /* Subroutine */
int zhegst_(integer *, char *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *);
integer lwkopt;
logical lquery;
extern /* Subroutine */
int zpotrf_(char *, integer *, doublecomplex *, 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;
--work;
--rwork;
/* 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)
{
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1;
i__2 = (nb + 1) * *n; // , expr subst
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
/* Computing MAX */
i__1 = 1;
i__2 = (*n << 1) - 1; // , expr subst
if (*lwork < max(i__1,i__2) && ! lquery)
{
*info = -11;
}
}
if (*info != 0)
{
i__1 = -(*info);
xerbla_("ZHEGV ", &i__1);
return 0;
}
else if (lquery)
{
return 0;
}
/* Quick return if possible */
if (*n == 0)
{
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0)
{
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1] , 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)**H *y or inv(U)*y */
if (upper)
{
*(unsigned char *)trans = 'N';
}
else
{
*(unsigned char *)trans = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &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**H *y */
if (upper)
{
*(unsigned char *)trans = 'C';
}
else
{
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[ b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lwkopt;
work[1].i = 0.; // , expr subst
return 0;
/* End of ZHEGV */
}
/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *
n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
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, wantz;
integer lwkopt;
logical lquery;
/* -- LAPACK driver routine (version 3.2) -- */
/* November 2006 */
/* Purpose */
/* ======= */
/* ZHEGV computes all the eigenvalues, and optionally, the eigenvectors */
/* of a complex generalized Hermitian-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 Hermitian 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) COMPLEX*16 array, dimension (LDA, N) */
/* On entry, the Hermitian 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**H*B*Z = I; */
/* if ITYPE = 3, Z**H*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) COMPLEX*16 array, dimension (LDB, N) */
/* On entry, the Hermitian 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**H*U or B = L*L**H. */
/* 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) COMPLEX*16 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,2*N-1). */
/* For optimal efficiency, LWORK >= (NB+1)*N, */
/* where NB is the blocksize for ZHETRD 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. */
/* RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2)) */
/* INFO (output) INTEGER */
/* = 0: successful exit */
/* < 0: if INFO = -i, the i-th argument had an illegal value */
/* > 0: ZPOTRF or ZHEEV returned an error code: */
/* <= N: if INFO = i, ZHEEV 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;
--rwork;
/* 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) {
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1);
/* Computing MAX */
i__1 = 1, i__2 = (nb + 1) * *n;
lwkopt = max(i__1,i__2);
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
/* Computing MAX */
i__1 = 1, i__2 = (*n << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGV ", &i__1);
return 0;
} else if (lquery) {
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
, 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 = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &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 = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZHEGV */
} /* zhegv_ */
void RealTime<double>::formUTrans() {
//
// Form the unitary transformation matrix:
// U = exp(-i*dT*F)
//
auto NTCSxNBASIS = this->nTCS_*this->nBasis_;
// Set up Eigen Maps
ComplexMap uTransA(this->uTransAMem_,NTCSxNBASIS,NTCSxNBASIS);
ComplexMap scratch(this->scratchMem_,NTCSxNBASIS,NTCSxNBASIS);
ComplexMap uTransB(this->uTransBMem_,0,0);
if(!this->isClosedShell_ && this->Ref_ != SingleSlater<double>::TCS) {
new (&uTransB) ComplexMap(this->uTransBMem_,NTCSxNBASIS,NTCSxNBASIS);
}
// FIXME: Eigen's Eigensolver is terrible, replace with LAPACK routines
if (this->methFormU_ == EigenDecomp) {
// Eigen-decomposition
char JOBZ = 'V';
char UPLO = 'L';
int INFO;
dcomplex *A = this->scratchMem_;
double *W = this->REAL_LAPACK_SCR;
double *RWORK = W + std::max(1,3*NTCSxNBASIS-2);
dcomplex *WORK = this->CMPLX_LAPACK_SCR;
RealVecMap E(W,NTCSxNBASIS);
ComplexMap V(A,NTCSxNBASIS,NTCSxNBASIS);
ComplexMap S(WORK,NTCSxNBASIS,NTCSxNBASIS);
E.setZero();
V.setZero();
S.setZero();
std::memcpy(A,this->ssPropagator_->fockA()->data(),
NTCSxNBASIS*NTCSxNBASIS*sizeof(dcomplex));
V.transposeInPlace(); // BC Col major
zheev_(&JOBZ,&UPLO,&NTCSxNBASIS,A,&NTCSxNBASIS,W,WORK,&this->lWORK,RWORK,
&INFO);
V.transposeInPlace(); // BC Col major
std::memcpy(WORK,A,NTCSxNBASIS*NTCSxNBASIS*sizeof(dcomplex));
for(auto i = 0; i < NTCSxNBASIS; i++) {
S.col(i) *= dcomplex(std::cos(this->deltaT_ * W[i]),
-std::sin(this->deltaT_ * W[i]));
}
uTransA = S * V.adjoint();
if(!this->isClosedShell_ && this->Ref_ != SingleSlater<dcomplex>::TCS) {
E.setZero();
V.setZero();
S.setZero();
std::memcpy(A,this->ssPropagator_->fockB()->data(),
NTCSxNBASIS*NTCSxNBASIS*sizeof(dcomplex));
V.transposeInPlace(); // BC Col major
zheev_(&JOBZ,&UPLO,&NTCSxNBASIS,A,&NTCSxNBASIS,W,WORK,&this->lWORK,RWORK,
&INFO);
V.transposeInPlace(); // BC Col major
std::memcpy(WORK,A,NTCSxNBASIS*NTCSxNBASIS*sizeof(dcomplex));
for(auto i = 0; i < NTCSxNBASIS; i++) {
S.col(i) *= dcomplex(std::cos(this->deltaT_ * W[i]),
-std::sin(this->deltaT_ * W[i]));
}
uTransB = S * V.adjoint();
}
} else if (this->methFormU_ == Taylor) {
// Taylor expansion
CErr("Taylor expansion NYI",this->fileio_->out);
/* This is not taylor and breaks with the new memory scheme
scratch = -math.ii * deltaT_ * (*this->ssPropagator_->fockA());
uTransA = scratch.exp(); // FIXME
if(!this->isClosedShell_ && this->Ref_ != SingleSlater<double>::TCS) {
scratch = -math.ii * deltaT_ * (*this->ssPropagator_->fockB());
uTransB = scratch.exp(); // FIXME
}
*/
}
// prettyPrint(this->fileio_->out,(*this->uTransA_),"uTransA");
// if(!this->isClosedShell_ && this->Ref_ != SingleSlater<double>::TCS) prettyPrint(this->fileio_->out,(*this->uTransB_),"uTransB");
};
///
/// Function to take a complex my_Matrix and diag it
///
void diagWithLapack(Array<complex<double>, 2>& DMpart,
vector<double>& EigenVals)
{
int rows_=DMpart.rows();
int cols_=DMpart.cols();
///
/// CLAPACK function to diagonalize an Hermitian matrix
///
char jobz='V';
char uplo='U';
int n=cols_;
int lda=rows_;
int info;
int elems=rows_*cols_;
//
// DMPart is hermitian so we use it to get the fortran array
//
complex<double>* a;
a=( DMpart.transpose(secondDim,firstDim) ).data();
//
// Output
//
//for (int j=0; j<elems; j++) cout<<j<<" "<<" "<<a[j]<<endl;
//
// Prepare to do a workspace query
//
int lwork=-1;
int lwork_=1;
complex<double> *work_query= new complex<double> [lwork_];
double rwork[(3*n-2)];
//
// Workspace query
//
double w[n];
int info_=zheev_(&jobz, &uplo, &n, a, &lda, w, work_query,
&lwork, rwork, &info);
//
// Get sizes of the workspace and reallocate
//
lwork_=(int)abs((work_query[0]).real());
//cout<<"after query\n"<<" work_query[0] "<<lwork<<endl;
delete[] work_query;
complex<double> *work= new complex<double> [lwork_];
//
// Call to zheev_
//
info_=zheev_(&jobz, &uplo, &n, a, &lda, w, work,
&lwork_, rwork, &info);
//
// Free all
//
delete[] work;
//
// Transpose the DM part (a is row ordered)
//
DMpart.transposeSelf(secondDim,firstDim);
//
// Output
//
for(int i=0; i<n; i++) EigenVals.push_back(w[i]);
//
// Output
//
//for (int j=0; j<elems; j++) cout<<j<<" "<<" "<<a[j]<<endl;
//for(int i=0; i<EigenVals.size(); i++) cout<<EigenVals[i]<<endl;
//cout<<"Info "<<info<<endl;
};
/* Subroutine */ int zhegv_(integer *itype, char *jobz, char *uplo, integer *
n, doublecomplex *a, integer *lda, doublecomplex *b, integer *ldb,
doublereal *w, doublecomplex *work, integer *lwork, doublereal *rwork,
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
=======
ZHEGV computes all the eigenvalues, and optionally, the eigenvectors
of a complex generalized Hermitian-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 Hermitian 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) COMPLEX*16 array, dimension (LDA, N)
On entry, the Hermitian 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**H*B*Z = I;
if ITYPE = 3, Z**H*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) COMPLEX*16 array, dimension (LDB, N)
On entry, the Hermitian 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**H*U or B = L*L**H.
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) COMPLEX*16 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,2*N-1).
For optimal efficiency, LWORK >= (NB+1)*N,
where NB is the blocksize for ZHETRD 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.
RWORK (workspace) DOUBLE PRECISION array, dimension (max(1, 3*N-2))
INFO (output) INTEGER
= 0: successful exit
< 0: if INFO = -i, the i-th argument had an illegal value
> 0: ZPOTRF or ZHEEV returned an error code:
<= N: if INFO = i, ZHEEV 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 doublecomplex c_b1 = {1.,0.};
static integer c__1 = 1;
static integer c_n1 = -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_(char *, char *);
extern /* Subroutine */ int zheev_(char *, char *, integer *,
doublecomplex *, integer *, doublereal *, doublecomplex *,
integer *, doublereal *, integer *);
static char trans[1];
static logical upper, wantz;
extern /* Subroutine */ int ztrmm_(char *, char *, char *, char *,
integer *, integer *, doublecomplex *, doublecomplex *, integer *,
doublecomplex *, integer *),
ztrsm_(char *, char *, char *, char *, integer *, integer *,
doublecomplex *, doublecomplex *, integer *, doublecomplex *,
integer *);
static integer nb;
extern /* Subroutine */ int xerbla_(char *, integer *);
extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
integer *, integer *, ftnlen, ftnlen);
extern /* Subroutine */ int zhegst_(integer *, char *, integer *,
doublecomplex *, integer *, doublecomplex *, integer *, integer *);
static integer lwkopt;
static logical lquery;
extern /* Subroutine */ int zpotrf_(char *, integer *, doublecomplex *,
integer *, integer *);
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;
--rwork;
/* 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 << 1) - 1;
if (*lwork < max(i__1,i__2) && ! lquery) {
*info = -11;
}
}
if (*info == 0) {
nb = ilaenv_(&c__1, "ZHETRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
(ftnlen)1);
lwkopt = (nb + 1) * *n;
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
}
if (*info != 0) {
i__1 = -(*info);
xerbla_("ZHEGV ", &i__1);
return 0;
}
/* Quick return if possible */
if (*n == 0) {
return 0;
}
/* Form a Cholesky factorization of B. */
zpotrf_(uplo, n, &b[b_offset], ldb, info);
if (*info != 0) {
*info = *n + *info;
return 0;
}
/* Transform problem to standard eigenvalue problem and solve. */
zhegst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
zheev_(jobz, uplo, n, &a[a_offset], lda, &w[1], &work[1], lwork, &rwork[1]
, 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 = 'C';
}
ztrsm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &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 = 'C';
} else {
*(unsigned char *)trans = 'N';
}
ztrmm_("Left", uplo, trans, "Non-unit", n, &neig, &c_b1, &b[
b_offset], ldb, &a[a_offset], lda);
}
}
work[1].r = (doublereal) lwkopt, work[1].i = 0.;
return 0;
/* End of ZHEGV */
} /* zhegv_ */
// -----------------------------------------------------------------
// Given matrix in = P.u, calculate the unitary matrix u = [1 / P].in
// and the positive P = sqrt[in.in^dag]
// We diagonalize PSq = in.in^dag using LAPACK,
// then project out its inverse square root
void polar(matrix *in, matrix *u, matrix *P) {
char V = 'V'; // Ask LAPACK for both eigenvalues and eigenvectors
char U = 'U'; // Have LAPACK store upper triangle of U.Ubar
int row, col, Npt = NCOL, stat = 0, Nwork = 2 * NCOL;
matrix PSq, Pinv, tmat;
// Convert PSq to column-major double array used by LAPACK
mult_na(in, in, &PSq);
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
store[2 * (col * NCOL + row)] = PSq.e[row][col].real;
store[2 * (col * NCOL + row) + 1] = PSq.e[row][col].imag;
}
}
// Compute eigenvalues and eigenvectors of PSq
zheev_(&V, &U, &Npt, store, &Npt, eigs, work, &Nwork, Rwork, &stat);
// Check for degenerate eigenvalues (broke previous Jacobi algorithm)
for (row = 0; row < NCOL; row++) {
for (col = row + 1; col < NCOL; col++) {
if (fabs(eigs[row] - eigs[col]) < IMAG_TOL)
printf("WARNING: w[%d] = w[%d] = %.8g\n", row, col, eigs[row]);
}
}
// Move the results back into matrix structures
// Overwrite PSq to hold the eigenvectors for projection
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
PSq.e[row][col].real = store[2 * (col * NCOL + row)];
PSq.e[row][col].imag = store[2 * (col * NCOL + row) + 1];
P->e[row][col] = cmplx(0.0, 0.0);
Pinv.e[row][col] = cmplx(0.0, 0.0);
}
P->e[row][row].real = sqrt(eigs[row]);
Pinv.e[row][row].real = 1.0 / sqrt(eigs[row]);
}
mult_na(P, &PSq, &tmat);
mult_nn(&PSq, &tmat, P);
// Now project out 1 / sqrt[in.in^dag] to find u = [1 / P].in
mult_na(&Pinv, &PSq, &tmat);
mult_nn(&PSq, &tmat, &Pinv);
mult_nn(&Pinv, in, u);
#ifdef DEBUG_CHECK
// Check unitarity of u
mult_na(u, u, &PSq);
c_scalar_add_diag(&PSq, &minus1);
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
if (cabs_sq(&(PSq.e[row][col])) > SQ_TOL) {
printf("Error getting unitary piece: ");
printf("%.4g > %.4g for [%d, %d]\n",
cabs(&(PSq.e[row][col])), IMAG_TOL, row, col);
dumpmat(in);
dumpmat(u);
dumpmat(P);
return;
}
}
}
#endif
#ifdef DEBUG_CHECK
// Check hermiticity of P
adjoint(P, &tmat);
sub_matrix(P, &tmat, &PSq);
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
if (cabs_sq(&(PSq.e[row][col])) > SQ_TOL) {
printf("Error getting hermitian piece: ");
printf("%.4g > %.4g for [%d, %d]\n",
cabs(&(PSq.e[row][col])), IMAG_TOL, row, col);
dumpmat(in);
dumpmat(u);
dumpmat(P);
return;
}
}
}
#endif
#ifdef DEBUG_CHECK
// Check that in = P.u
mult_nn(P, u, &tmat);
sub_matrix(in, &tmat, &PSq);
for (row = 0; row < NCOL; row++) {
for (col = 0; col < NCOL; col++) {
if (cabs_sq(&(PSq.e[row][col])) > SQ_TOL) {
printf("Error reconstructing initial matrix: ");
printf("%.4g > %.4g for [%d, %d]\n",
cabs(&(PSq.e[row][col])), IMAG_TOL, row, col);
dumpmat(in);
dumpmat(u);
dumpmat(P);
return;
}
}
}
#endif
}
