void eigen_(int nVar, double* a, double* evals, double* evecs)
{
/*for(int i(0);i<nVar;++i)
{
for(int j(0);j<nVar;++j)
{
std::cerr<<a[i*nVar+j]<<", ";
}
std::cerr<<std::endl;
}*/
char jobvl('N'),jobvr('V'); // compute only right eigenvectors;
int n(nVar),lda(nVar),ldvl(nVar),ldvr(nVar),lwork(-1),info(0);
double* wr(evals);
double* wi(evals+nVar);
double* vr(evecs);
double workSize;
// query for optimal work length first
dgeev_(&jobvl,&jobvr,&n,a,&lda,wr,wi,NULL,&ldvl,vr,&ldvr,&workSize,&lwork,&info);
lwork=int(workSize);
double* work(new double[size_t(lwork)]);
// get eigenvalues and eigenvectors
dgeev_(&jobvl,&jobvr,&n,a,&lda,wr,wi,NULL,&ldvl,vr,&ldvr,work,&lwork,&info);
delete[] work;
}
int
mad_mat_eigen (const num_t x[], cnum_t w[], num_t vl[], num_t vr[], ssz_t n)
{
assert( x && w && vl && vr );
int info=0;
const int nn=n;
num_t sz;
int lwork=-1;
mad_alloc_tmp(num_t, wr, n);
mad_alloc_tmp(num_t, wi, n);
mad_alloc_tmp(num_t, ra, n*n);
mad_mat_trans(x, ra, n, n);
dgeev_("V", "V", &nn, ra, &nn, wr, wi, vl, &nn, vr, &nn, &sz, &lwork, &info); // query
mad_alloc_tmp(num_t, wk, lwork=sz);
dgeev_("V", "V", &nn, ra, &nn, wr, wi, vl, &nn, vr, &nn, wk, &lwork, &info); // compute
mad_vec_cvec(wr, wi, w, n);
mad_free_tmp(wk); mad_free_tmp(ra);
mad_free_tmp(wi); mad_free_tmp(wr);
mad_mat_trans(vl, vl, n, n);
mad_mat_trans(vr, vr, n, n);
if (info < 0) error("invalid input argument");
if (info > 0) warn ("eigen failed to compute all eigenvalues");
return info;
}
void roots(const double* ar, int size, double* rootR, double* rootI,
int* nbRoots)
{
// remember input polynomials is ar[0], ar[1], ar[2], ..., ar[size-1]
// Strip trailing zeros, but remember them as roots at zero.
// int nbRootsZeros;
// while (size>0 && ar[size-1]==0)
// {
// size--;
// nbRootsZeros++;
// }
// build companion matrix
int N = size - 1;
double* a = new double[N * N];
memset(a, 0, N*N * sizeof(double));
for (int i = 0; i < N; i++)
a[i * N] = -ar[1 + i] / ar[0];
for (int i = 0; i < N - 1; i++)
a[(1 + i) + i * N] = 1;
// allocate work space
int lWork = 10 * N;
double work[10 * N];
int info;
// call lapack routine
dgeev_("N", "N", &N, a, &N, rootR, rootI, NULL,&N, NULL,&N, work, &lWork,
&info);
// release companion matrix
delete[] a;
// return nbRoots
*nbRoots = N;
}
int dgeev(char JOBVL, char JOBVR,int N,doublevar * A,int lda,
doublevar * WR, doublevar * WI, doublevar* VL, int LDVL,doublevar * VR, int LDVR,
doublevar * WORK, int LWORK) {
int INFO;
dgeev_(&JOBVL,&JOBVR, &N,A,&lda,WR,WI,VL,&LDVL,VR,&LDVR,WORK, &LWORK,&INFO);
return INFO;
}
void dgeev(double **H, int n, double *Er, double *Ei, double **Evecs)
{
char jobvl, jobvr;
int lda, ldvl, ldvr, lwork, info;
double *a, *vl, *vr, *work;
jobvl = 'N';
jobvr = 'V';
lda = n;
a = dgeev_ctof(H, n, lda);
ldvl = n;
vl = new double[n*n];
ldvr = n;
vr = new double[n*n];
work = new double[4*n];
lwork = 4*n;
dgeev_(&jobvl, &jobvr, &n, a, &lda, Er, Ei, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
dgeev_ftoc(vr, Evecs, n, ldvr);
dgeev_sort(Er, Ei, Evecs, n);
delete [] a;
delete [] vl;
delete [] vr;
delete [] work;
}
void dgeev(double **H, int n, double *Er, double *Ei)
{
char jobvl, jobvr;
int lda, ldvl, ldvr, lwork, info;
double *a, *vl, *vr, *work;
jobvl = 'N'; // V/N to calculate/not calculate the left eigenvectors of the matrix H.
jobvr = 'N'; // As above, but for the right eigenvectors.
lda = n; // The leading dimension of the matrix a.
a = dgeev_ctof(H, n, lda); // Convert the matrix H from double pointer C form to single pointer Fortran form.
/* Whether we want them or not, we need to define the matrices
for the eigenvectors, and give their leading dimensions.
We also create a vector for work space. */
ldvl = n;
vl = new double[n*n];
ldvr = n;
vr = new double[n*n];
work = new double[4*n];
lwork = 4*n;
dgeev_(&jobvl, &jobvr, &n, a, &lda, Er, Ei, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
dgeev_sort(Er, Ei, n); //Sort the results by eigenvalue in decreasing magnitude.
delete [] a;
delete [] vl;
delete [] vr;
delete [] work;
}
//----- Calculation of eigen vectors and eigen values -----
int calcEigenVectors(const dmatrix &_a, dmatrix &_evec, dvector &_eval)
{
assert( _a.cols() == _a.rows() );
typedef dmatrix mlapack;
typedef dvector vlapack;
mlapack a = _a; // <-
mlapack evec = _evec;
vlapack eval = _eval;
int n = (int)_a.cols();
double *wi = new double[n];
double *vl = new double[n*n];
double *work = new double[4*n];
int lwork = 4*n;
int info;
dgeev_("N","V", &n, &(a(0,0)), &n, &(eval(0)), wi, vl, &n, &(evec(0,0)), &n, work, &lwork, &info);
_evec = evec.transpose();
_eval = eval;
delete [] wi;
delete [] vl;
delete [] work;
return info;
}
/*! calculate eigenvalues\n
All of the arguments need not to be initialized.
wr and wi are overwitten and become
real and imaginary part of eigenvalues, respectively.
This matrix is also overwritten.
*/
inline long dgematrix::dgeev(std::vector<double>& wr, std::vector<double>& wi)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] dgematrix::dgeev(std::vector<double>&, std::vector<double>&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(M!=N){
std::cerr << "[ERROR] dgematrix::dgeev"
<< "(vector<double>&, vector<double>&) " << std::endl
<< "This matrix is not a square matrix." << std::endl
<< "This matrix is (" << M << "x" << N << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
wr.resize(N); wi.resize(N);
char JOBVL('N'), JOBVR('N');
long LDA(N), LDVL(1), LDVR(1), LWORK(3*N), INFO(1);
double *VL(NULL), *VR(NULL), *WORK(new double[LWORK]);
dgeev_(JOBVL, JOBVR, N, Array, LDA, &wr[0], &wi[0],
VL, LDVL, VR, LDVR, WORK, LWORK, INFO);
delete [] WORK; delete [] VL; delete [] VL;
if(INFO!=0){
std::cerr << "[WARNING] dgematrix::dgeev"
<< "(vector<double>&, vector<double>&)"
<< std::endl
<< "Serious trouble happend. INFO = " << INFO << "."
<< std::endl;
}
return INFO;
}
/*! calculate left eigenvalues and left eigenvectors\n
All of the arguments need not to be initialized.
wr, wi, vrr, vri are overwitten and become
real and imaginary part of left eigenvalues and left eigenvectors,
respectively.
This matrix is also overwritten.
*/
inline long dgematrix::dgeev(std::vector<double>& wr, std::vector<double>& wi,
std::vector<drovector>& vlr,
std::vector<drovector>& vli)
{
#ifdef CPPL_VERBOSE
std::cerr << "# [MARK] dgematrix::dgeev(std::vector<double>&, std::vector<double>&, std::vector<drovector>&, std::vector<drovector>&)"
<< std::endl;
#endif//CPPL_VERBOSE
#ifdef CPPL_DEBUG
if(M!=N){
std::cerr << "[ERROR] dgematrix::dgeev"
<< "(vector<double>&, vector<double>&, "
<< "vector<drovector>&, vector<drovector>&) "
<< std::endl
<< "This matrix is not a square matrix." << std::endl
<< "This matrix is (" << M << "x" << N << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
wr.resize(N); wi.resize(N); vlr.resize(N); vli.resize(N);
for(long i=0; i<N; i++){ vlr[i].resize(N); vli[i].resize(N); }
dgematrix VL(N,N);
char JOBVL('V'), JOBVR('N');
long LDA(N), LDVL(N), LDVR(1), LWORK(4*N), INFO(1);
double *VR(NULL), *WORK(new double[LWORK]);
dgeev_(JOBVL, JOBVR, N, Array, LDA, &wr[0], &wi[0],
VL.Array, LDVL, VR, LDVR, WORK, LWORK, INFO);
delete [] WORK; delete [] VR;
//// forming ////
for(long j=0; j<N; j++){
if(fabs(wi[j])<1e-10){
for(long i=0; i<N; i++){
vlr[j](i) = VL(i,j); vli[j](i) = 0.0;
}
}
else{
for(long i=0; i<N; i++){
vlr[j](i) = VL(i,j); vli[j](i) =-VL(i,j+1);
vlr[j+1](i) = VL(i,j); vli[j+1](i) = VL(i,j+1);
}
j++;
}
}
if(INFO!=0){
std::cerr << "[WARNING] dgematrix::dgeev"
<< "(vector<double>&, vector<double>&, "
<< "vector<drovector>&, vector<drovector>&) "
<< std::endl
<< "Serious trouble happend. INFO = " << INFO << "."
<< std::endl;
}
return INFO;
}
void QuasiNewton<double>::symmNonHerDiag(int NTrial, ostream &output){
char JOBVL = 'N';
char JOBVR = 'V';
int TwoNTrial = 2*NTrial;
int *IPIV = new int[TwoNTrial];
int INFO;
RealCMMap SSuper(this->SSuperMem, TwoNTrial,TwoNTrial);
RealCMMap ASuper(this->ASuperMem, TwoNTrial,TwoNTrial);
RealCMMap SCPY(this->SCPYMem, TwoNTrial,TwoNTrial);
RealCMMap NHrProd(this->NHrProdMem,TwoNTrial,TwoNTrial);
SCPY = SSuper; // Copy of original matrix to use for re-orthogonalization
// Invert the metric (maybe not needed?)
dgetrf_(&TwoNTrial,&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,&INFO);
dgetri_(&TwoNTrial,this->SSuperMem,&TwoNTrial,IPIV,this->WORK,&this->LWORK,&INFO);
delete [] IPIV;
NHrProd = SSuper * ASuper;
//cout << endl << "PROD" << endl << NHrProd << endl;
dgeev_(&JOBVL,&JOBVR,&TwoNTrial,NHrProd.data(),&TwoNTrial,this->ERMem,this->EIMem,
this->SSuperMem,&TwoNTrial,this->SSuperMem,&TwoNTrial,this->WORK,&this->LWORK,
&INFO);
// Sort eigensystem using Bubble Sort
RealVecMap ER(this->ERMem,TwoNTrial);
RealVecMap EI(this->EIMem,TwoNTrial);
RealCMMap VR(this->SSuperMem,TwoNTrial,TwoNTrial);
// cout << endl << ER << endl;
this->eigSrt(VR,ER);
// cout << endl << ER << endl;
// Grab the "positive paired" roots (throw away other element of the pair)
this->ERMem += NTrial;
new (&ER ) RealVecMap(this->ERMem,NTrial);
new (&SSuper) RealCMMap(this->SSuperMem+2*NTrial*NTrial,2*NTrial,NTrial);
/*
* Re-orthogonalize the eigenvectors with respect to the metric S(R)
* because DSYGV orthogonalzies the vectors with respect to E(R)
* because we solve the opposite problem.
*
* Gramm-Schmidt
*/
this->metBiOrth(SSuper,SCPY);
// Separate the eigenvectors into gerade and ungerade parts
RealCMMap XTSigmaR(this->XTSigmaRMem,NTrial,NTrial);
RealCMMap XTSigmaL(this->XTSigmaLMem,NTrial,NTrial);
XTSigmaR = SSuper.block(0, 0,NTrial,NTrial);
XTSigmaL = SSuper.block(NTrial,0,NTrial,NTrial);
//cout << endl << "ER" << endl << ER << endl << endl;
//cout << endl << "CR" << endl << XTSigmaR << endl << endl;
//cout << endl << "CR" << endl << XTSigmaL << endl << endl;
// CErr();
}
/* finds the eigenvalues of a matrix using CLAPACK
* \param: square matrix
* \param: matrix dimension
* \param: (output) vector of real values
* \param: (output) vector of imaginary values
* \return: 0 = failure 1 = success
*/
int eigenvalues(double * A, int N, double * wr, double * wi)
{
int ret = 1;
char jobv_ = 'N';
doublereal *U,*work,work_size,*Ui,*D;
integer lwork,info;
integer n = (integer)N;
//wi = (doublereal*) malloc( n*sizeof(doublereal));
//wr = (doublereal*) malloc( n*sizeof(doublereal));
U = (doublereal*) calloc( n*n,sizeof(doublereal));
Ui = (doublereal*) calloc( n*n,sizeof(doublereal));
lwork = -1;
dgeev_(&jobv_,&jobv_,&n,A,&n,wr,wi,U,&n,Ui,&n,&work_size,&lwork,&info);
if (info == 0)
{
lwork = (integer)work_size;
work = (doublereal*) calloc( lwork , sizeof( doublereal) );
dgeev_(&jobv_,&jobv_,&n,A,&n,wr,wi,U,&n,Ui,&n,work,&lwork,&info);
/*if (info == 0)
{
(*reals) = (double*)wr;
(*im) = (double*)wi;
}
else ret = 0;*/
}
else ret = 0;
/*if (ret == 0)
{
free(wi);
free(wr);
}*/
free(U);
free(Ui);
free(work);
return (ret);
}
void THLapack_(geev)(char jobvl, char jobvr, int n, real *a, int lda, real *wr, real *wi, real* vl, int ldvl, real *vr, int ldvr, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
dgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info);
#else
sgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info);
#endif
#else
THError("geev : Lapack library not found in compile time\n");
#endif
}
void THLapack_(geev)(char jobvl, char jobvr, int n, real *a, int lda, real *wr, real *wi, real* vl, int ldvl, real *vr, int ldvr, real *work, int lwork, int *info)
{
#ifdef USE_LAPACK
#if defined(TH_REAL_IS_DOUBLE)
extern void dgeev_(char *jobvl, char *jobvr, int *n, double *a, int *lda, double *wr, double *wi, double* vl, int *ldvl, double *vr, int *ldvr, double *work, int *lwork, int *info);
dgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info);
#else
extern void sgeev_(char *jobvl, char *jobvr, int *n, float *a, int *lda, float *wr, float *wi, float* vl, int *ldvl, float *vr, int *ldvr, float *work, int *lwork, int *info);
sgeev_(&jobvl, &jobvr, &n, a, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, info);
#endif
#else
THError("geev : Lapack library not found in compile time\n");
#endif
}
//matrices are column major
void Normal::eigenvalue(int N,double* A,double* lambda_real,double* lambda_imag,double* v) {
int info,ldvl=1,ldvr=N,lwork=15*N;
double *work = new double[lwork]();
char jobvl = 'N', jobvr = 'V';
dgeev_(&jobvl,&jobvr, &N, A, &N, lambda_real, lambda_imag,
NULL,&ldvl, v, &ldvr ,work, &lwork, &info);
// printf("info: %d\n",info);
// printf("optimal: %f\n",work[0]);
if (info!=0) {
printf("Error in subroutine dgeev_ (info=%d)\n",info);
}
delete[] work;
}
int main(int argc, char *argv[])
{
int n,i,j,*pivot,info,lwork;
double *A,*wr,*wi,*vl,*vr,*work;
char jobvl,jobvr;
int seed;
FILE *fp;
/* Comamnd line arguments: matrix size, RNG seed */
if (argc!=3) {
fprintf(stderr,"usage: %s n seed\n",argv[0]);
return -1;
}
n=atoi(argv[1]);
seed=atoi(argv[2]);
/* Allocate space. Note that matrix A is essentially a 1D array */
A=(double *)malloc((size_t)n*n*sizeof(double));
pivot=(int *)malloc((size_t)n*sizeof(int));
wr=(double *)malloc((size_t)n*sizeof(double));
wi=(double *)malloc((size_t)n*sizeof(double));
vl=(double *)malloc((size_t)n*n*sizeof(double));
vr=(double *)malloc((size_t)n*n*sizeof(double));
lwork=10*n;
work=(double *)malloc((size_t)lwork*sizeof(double));
jobvl='N';
jobvr='N';
/* Fill the matrix with random numbers */
fill_matrix(A,n,seed);
/* ---- The eigenvalue calculation proper ---- */
dgeev_(&jobvl,&jobvr, &n, A, &n, wr, wi, vl, &n, vr, &n, work, &lwork, &info);
/* Print eigenvalues to file "evalues.datc" */
fp=fopen("evalues.datc","w");
for (i=0; i<n; i++) fprintf(fp,"%12.8g %12.8g\n", wr[i],wi[i]);
fclose(fp);
return 0;
}
bool aoMaxEig(double A[], double v[]) {
char jobvl = 'N';
char jobvr = 'V';
int n = 4;
int lda = n;
double wr[4], wi[4];
int ldvl = 1;
double vr[16];
int ldvr = 4;
double work[16];
int lwork = 16;
int info;
//call lapack function
dgeev_(&jobvl, &jobvr, &n, A, &lda, wr, wi, 0, &ldvl, vr, &ldvr, work, &lwork, &info);
if (info < 0)
warn("Error in call to dgeev (argument %d was invalid\n", -info);
else if (info > 0)
warn("Error: not all eigenvalues have converged\n");
int i, max_i = -1;
double max_val = 0;
for (i = 0; i < 4; ++i) {
if (wi[i] == 0.0) {
if (wr[i] > max_val) {
max_val = wr[i];
max_i = i;
}
}
}
if (max_i < 0)
return false;
double* pvr = vr + 4 * max_i;
v[0] = pvr[0];
v[1] = pvr[1];
v[2] = pvr[2];
v[3] = pvr[3];
return true;
}
/*******************************************************************
Subroutine to compute the Eigenvalue and Eigenvector
by using CLAPACK subroutine - dgeev_()
matrix *A: the pointer to the matrix
matrix *eigvec_re: the pointer to the real part of eigenvectors
matrix *eigvec_im: the pointer to the imaginary part of eigenvectors
vector *eigval_re: the pointer to the real part of eigenvalues
vector *eigval_im: the pointer to the imaginary part of eigenvalues
return value: '1' - successfully exit
'0' - cannot get the valid eigenvalue
*******************************************************************/
int eig(matrix *A, matrix *eigvec_re, matrix *eigvec_im,
vector *eigval_re, vector *eigval_im)
{
char jobvl, jobvr;
integer n, lda, ldvl, ldvr, lwork, info, i, j, size;
double *AT;
double *dummy;
double *vrT;
double *vr;
double *work;
double *ap;
double *eigrp;
double *eigip;
if (A->m != A->n) {
printf(" Warning: Eig() is failed since the matrix is not square matrix. \n");
return 0;
}
n = A->n;
lda = n;
ldvl = n;
ldvr = n;
lwork = 5*n;
size = n*n;
ap = A->pr;
eigrp = eigval_re->pr;
eigip = eigval_im->pr;
// only compute the right eigenvector
jobvl = 'N';
jobvr = 'V';
AT = new double[size];
dummy = new double[size];
vrT = new double[size];
vr = new double[size];
work = new double[5*n];
// to call a Fortran routine from C we have to transform the matrix
for (i=0; i<n; i++) {
for (j=0; j<n; j++) {
AT[n*i+j] = ap[n*j+i];
}
}
dgeev_(&jobvl, &jobvr, &n, AT, &lda, eigrp, eigip, dummy, &ldvl, vrT,
&ldvr, work, &lwork, &info);
if (info != 0) {
printf(" Warning: Eig() is failed. \n");
return 0;
}
// to output a Fortran matrix to C we have to transform the matrix
for (i=0; i<n; i++) {
for (j=0; j<n; j++) {
vr[n*i+j] = vrT[n*j+i];
}
}
// If the j-th eigenvalue is real, then v(j) = VR(:,j),
// the j-th column of VR.
// If the j-th and (j+1)-st eigenvalues form a complex
// conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
// v(j+1) = VR(:,j) - i*VR(:,j+1).
double *eigvec_rp;
double *eigvec_ip;
j = 0;
while (j < n) {
eigvec_rp = eigvec_re->pr + j;
eigvec_ip = eigvec_im->pr + j;
if (*(eigip+j) == 0) { // j-th real eigenvector
for (i=0; i<n; i++) {
*(eigvec_rp + i*n) = vr[i*n+j];
*(eigvec_ip + i*n) = 0;
};
j++;
} else { // j-th and (j+1)-st complex eigenvector
for (i=0; i<n; i++) {
*(eigvec_rp + i*n) = vr[i*n+j];
*(eigvec_ip + i*n) = vr[i*n+j+1];
};
for (i=0; i<n; i++) {
*(eigvec_rp + i*n + 1) = vr[i*n+j];
*(eigvec_ip + i*n + 1) = -vr[i*n+j+1];
};
j += 2;
}
}
delete []AT;
delete []dummy;
delete []vrT;
delete []vr;
delete []work;
return 1;
}
short EXeigasym(
DBint n,
DBfloat m[],
DBfloat eval[],
DBfloat evec[])
/* Create a transformation matrix by array of points.
*
* In: n => Order of given matrix.
* m => nxn real non-symmetric matrix.
*
* Out: eval => Real eigen values array.
* evec => Real eigen vectors array, one after one.
*
*
* (C) Örebo university 15/04/2009 Mohamed Rahayem
*
******************************************************!*/
{
short status;
DBint i;
char jobvl = 'N';
char jobvr = 'V';
DBfloat wr[n];
DBfloat wi[n];
DBfloat vl[n*3];
DBint ldvl = n;
DBfloat vr[n*3];
DBint ldvr = n;
DBint lwork = (2+n)*n;
DBfloat work[lwork];
DBint info;
/*
*** Call Lapack function.
*/
dgeev_(&jobvl, &jobvr, &n, m, &n, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
/*
*** Check if one or more of the eigen values is an complex.
*/
for(i = 0; i < n; i++)
{
if (wi[i] != 0.0)
{
status = -2;
return(status);
}
}
/*
*** Store eigen values and eigen vectors in the returned arraya.
*/
if (info == 0)
{
status = info;
for (i = 0; i < n; i++)
{
eval[i] = wr[i];
}
for (i = 0; i < 3*n; i++)
{
evec[i] = vr[i];
}
}
else
{
status = info;
}
/*
*** Return status.
*/
return(status);
}
void bob::math::eig_(const blitz::Array<double,2>& A,
blitz::Array<std::complex<double>,2>& V,
blitz::Array<std::complex<double>,1>& D)
{
// Size variable
const int N = A.extent(0);
// Prepares to call LAPACK function
// Initialises LAPACK variables
const char jobvl = 'N'; // Do NOT compute left eigen-vectors
const char jobvr = 'V'; // Compute right eigen-vectors
int info = 0;
const int lda = N;
const int ldvr = N;
double VL = 0; // notice we don't compute the left eigen-values
const int ldvl = 1;
// Initialises LAPACK arrays
blitz::Array<double,2> A_lapack = bob::core::array::ccopy(const_cast<blitz::Array<double,2>&>(A).transpose(1,0));
// temporary arrays to receive LAPACK's eigen-values and eigen-vectors
blitz::Array<double,1> WR(D.shape()); //real part
blitz::Array<double,1> WI(D.shape()); //imaginary part
blitz::Array<double,2> VR(A.shape()); //right eigen-vectors
// Calls the LAPACK function
// A/ Queries the optimal size of the working arrays
const int lwork_query = -1;
double work_query;
dgeev_( &jobvl, &jobvr, &N, A_lapack.data(), &lda, WR.data(), WI.data(),
&VL, &ldvl, VR.data(), &ldvr, &work_query, &lwork_query, &info);
// B/ Computes the eigenvalue decomposition
const int lwork = static_cast<int>(work_query);
boost::shared_array<double> work(new double[lwork]);
dgeev_( &jobvl, &jobvr, &N, A_lapack.data(), &lda, WR.data(), WI.data(),
&VL, &ldvl, VR.data(), &ldvr, work.get(), &lwork, &info);
// Checks info variable
if (info != 0) {
throw std::runtime_error("the QR algorithm failed to compute all the eigenvalues, and no eigenvectors have been computed.");
}
// Copy results back from WR, WI => D
blitz::real(D) = WR;
blitz::imag(D) = WI;
// Copy results back from VR => V, with two rules:
// 1) If the j-th eigenvalue is real, then v(j) = VR(:,j), the j-th column of
// VR.
// 2) If the j-th and (j+1)-st eigenvalues form a complex conjugate pair,
// then v(j) = VR(:,j) + i*VR(:,j+1) and v(j+1) = VR(:,j) - i*VR(:,j+1).
blitz::Range a = blitz::Range::all();
int i=0;
while (i<N) {
if (std::imag(D(i)) == 0.) { //real eigen-value, consume 1
blitz::real(V(a,i)) = VR(i,a);
blitz::imag(V(a,i)) = 0.;
++i;
}
else { //complex eigen-value, consume 2
blitz::real(V(a,i)) = VR(i,a);
blitz::imag(V(a,i)) = VR(i+1,a);
blitz::real(V(a,i+1)) = VR(i,a);
blitz::imag(V(a,i+1)) = -VR(i+1,a);
i += 2;
}
}
}
/* A: nxn real matrix
* ret_Er: RETURN: vector of eigenvalues, real part, allocated 0..n-1
* ret_Ei: RETURN: vector of eigenvalues, imaginary part, allocated 0..n-1
* ret_VL: RETURN: left eigenvectors
* ret_VR: RETURN: right eigenvectors
*/
int
esl_lapack_dgeev(ESL_DMATRIX *A, double **ret_Er, double **ret_Ei, ESL_DMATRIX **ret_VL, ESL_DMATRIX **ret_VR)
{
double *Er = NULL;
double *Ei = NULL;
ESL_DMATRIX *VL = NULL;
ESL_DMATRIX *VR = NULL;
double *work = NULL;
char jobvl, jobvr;
int lda;
int ldvl, ldvr;
int lwork;
int info;
int status;
if ((VL = esl_dmatrix_Create(A->n,A->n)) == NULL) { status = eslEMEM; goto ERROR; }
if ((VR = esl_dmatrix_Create(A->n,A->n)) == NULL) { status = eslEMEM; goto ERROR; }
ESL_ALLOC(Er, sizeof(double) * A->n);
ESL_ALLOC(Ei, sizeof(double) * A->n);
ESL_ALLOC(work, sizeof(double) * 4 * A->n);
jobvl = (ret_VL == NULL) ? 'N' : 'V'; /* do we want left eigenvectors? */
jobvr = (ret_VR == NULL) ? 'N' : 'V'; /* do we want right eigenvectors? */
lda = A->n;
ldvl = A->n;
ldvr = A->n;
lwork = 4*A->n;
/* Fortran convention is colxrow, not rowxcol; so transpose
* A before passing it to a Fortran routine.
*/
esl_dmx_Transpose(A);
/* The actual Fortran77 interface call to LAPACK.
* All args must be passed by reference.
* Fortran 2D arrays are 1D: so pass the A[0] part of a DSMX.
*/
dgeev_(&jobvl, &jobvr, &(A->n), A->mx[0], &lda, Er, Ei, VL->mx[0], &ldvl, VR->mx[0], &ldvr, work, &lwork, &info);
/* Now, VL, VR are transposed (col x row), so transpose them back to
* C convention.
*/
esl_dmx_Transpose(VL);
esl_dmx_Transpose(VR);
if (ret_VL != NULL) *ret_VL = VL; else esl_dmatrix_Destroy(VL);
if (ret_VR != NULL) *ret_VR = VR; else esl_dmatrix_Destroy(VR);
if (ret_Er != NULL) *ret_Er = Er; else free(Er);
if (ret_Ei != NULL) *ret_Ei = Ei; else free(Ei);
free(work);
return eslOK;
ERROR:
if (ret_VL != NULL) *ret_VL = NULL;
if (ret_VR != NULL) *ret_VR = NULL;
if (ret_Er != NULL) *ret_Er = NULL;
if (ret_Ei != NULL) *ret_Ei = NULL;
if (VL != NULL) free(VL);
if (VR != NULL) free(VR);
if (Er != NULL) free(Er);
if (Ei != NULL) free(Ei);
if (work != NULL) free(work);
return status;
}
static int doEig(Tcl_Interp *interp, Tcl_Obj *matrix, Tcl_Obj **ev, Tcl_Obj **V) {
/* Compute eigen decomposition of matrix.
* Return eigenvalues in ev. If V is not NULL,
* also compute the eigenvectors */
/* Convert matrix to VecTcl object */
NumArrayInfo *info = NumArrayGetInfoFromObj(interp, matrix);
if (!info) { return TCL_ERROR; }
/* Check that it is a square matrix */
if (info->nDim != 2) {
/* Could be a scalar. In this case return the trivial
* decomposition */
if (ISSCALARINFO(info)) {
*ev = Tcl_DuplicateObj(matrix);
*V = Tcl_NewDoubleObj(1.0);
return TCL_OK;
}
Tcl_SetResult(interp, "Eigendecomposition is only defined for square matrix", NULL);
return TCL_ERROR;
}
/* get matrix dimensions */
long int m = info->dims[0];
long int n = info->dims[1];
if (m != n) {
Tcl_SetResult(interp, "Eigendecomposition is only defined for square matrix", NULL);
return TCL_ERROR;
}
int wantvectors = (V!=NULL);
char *jobvr = wantvectors ? "V" : "N";
char *jobvl = "N";
/* Never compute left vectors */
if (info->type != NumArray_Complex128) {
/* Real-valued matrix, prepare for dgeev */
/* create a column-major copy of matrix
* This also converts an integer matrix to double */
Tcl_Obj *A = NumArrayNewMatrixColMaj(NumArray_Float64, m, n);
NumArrayObjCopy(interp, matrix, A);
Tcl_Obj *Vr = NULL; /* the right eigenvectors */
if (wantvectors) {
/* create a real matrix for the eigenvectors Vr */
Vr = NumArrayNewMatrixColMaj(NumArray_Float64, m, m);
}
/* Extract the raw pointers from the VecTcl objects */
double *Aptr = NumArrayGetPtrFromObj(interp, A);
double *Vrptr=NULL;
if (wantvectors) {
Vrptr = NumArrayGetPtrFromObj(interp, Vr);
}
/* Space to store the eigenvalues */
doublereal *wr = ckalloc(sizeof(doublereal)*n);
doublereal *wi = ckalloc(sizeof(doublereal)*n);
/* setup workspace arrays */
integer lwork = 4*n;
doublereal* work=ckalloc(sizeof(doublereal)*lwork);
/* Leading dimensions of A and Vr
* Don't compute left vectors. */
integer lda = n;
integer ldvr = n;
integer ldvl = n;
integer info;
/* Subroutine int dgeev_ (Tcl_Interp *interp, char *jobvl, char *jobvr,
* integer *n, doublereal * a, integer *lda, doublereal *wr, doublereal *wi,
* doublereal *vl, integer *ldvl, doublereal *vr, integer *ldvr,
* doublereal *work, integer *lwork, integer *info); */
/* call out to dgeev */
int errcode=dgeev_(interp, jobvl, jobvr,
&n, Aptr, &lda, wr, wi,
NULL, &ldvl, Vrptr, &ldvr,
work, &lwork, &info);
/* free workspace */
ckfree(work);
/* A is overwritten with junk */
Tcl_DecrRefCount(A);
if (errcode != TCL_OK) {
/* release temporary storage for result */
if (wantvectors) {
Tcl_DecrRefCount(Vr);
}
ckfree(wr); ckfree(wi);
if (errcode > 0) {
RESULTPRINTF(("DGEEV failed to converge at eigenvector %d ", info));
}
return TCL_ERROR;
}
/* Now check, if the result is complex or real */
int real = 1; int i;
for (i=0; i<n; i++) {
if (wi[i]!=0.0) {
real = 0;
break;
}
}
if (real) {
/* create a real vector for the eigenvalues */
*ev = NumArrayNewVector(NumArray_Float64, n);
double *evptr = NumArrayGetPtrFromObj(interp, *ev);
/* Copy eigenvalues into this vector */
int i;
for (i=0; i<n; i++) {
evptr[i] = wr[i];
}
/* Eigenvectors are contained in Vr */
if (wantvectors) {
*V = Vr;
}
} else {
/* create a complex vector for the eigenvalues */
*ev = NumArrayNewVector(NumArray_Complex128, n);
NumArray_Complex *evptr = NumArrayGetPtrFromObj(interp, *ev);
/* Copy eigenvalues into this vector */
int i, j;
for (i=0; i<n; i++) {
evptr[i] = NumArray_mkComplex(wr[i], wi[i]);
}
/* Create a complex matrix for the eigenvectors */
*V = NumArrayNewMatrixColMaj(NumArray_Complex128, n, n);
/* Now, for real eigenvectors the columns of V contain
* the vector. For complex conjugate pairs, the two columns
* contain real and imaginary part of the conjugate pair (grumpf) */
NumArray_Complex *Vptr = NumArrayGetPtrFromObj(NULL, *V);
#define V(i,j) Vptr[(i)+(j)*n]
#define Vr(i, j) Vrptr[(i)+(j)*n]
for (j=0; j<n; j++) {
if (wi[j]==0.0) {
/* real eigenvalue */
for (i=0; i<n; i++) {
V(i,j) = NumArray_mkComplex(Vr(i,j), 0.0);
}
} else {
/* complex conjugate pair */
for (i=0; i<n; i++) {
V(i,j) = NumArray_mkComplex(Vr(i,j), Vr(i,j+1));
V(i,j+1) = NumArray_mkComplex(Vr(i,j), -Vr(i,j+1));
}
j++;
}
}
#undef V
#undef Vr
Tcl_DecrRefCount(Vr);
}
ckfree(wr); ckfree(wi);
return TCL_OK;
} else {
/* Complex matrix, prepare for zgeev */
/* create a column-major copy of matrix */
Tcl_Obj *A = NumArrayNewMatrixColMaj(NumArray_Complex128, m, n);
NumArrayObjCopy(interp, matrix, A);
if (wantvectors) {
/* create a real matrix for the eigenvectors Vr */
*V = NumArrayNewMatrixColMaj(NumArray_Complex128, m, m);
}
/* Extract the raw pointers from the VecTcl objects */
doublecomplex *Aptr = NumArrayGetPtrFromObj(interp, A);
doublecomplex *Vrptr=NULL;
if (wantvectors) {
Vrptr = NumArrayGetPtrFromObj(interp, *V);
}
/* Space to store the eigenvalues */
*ev = NumArrayNewVector(NumArray_Complex128, n);
doublecomplex *w = NumArrayGetPtrFromObj(NULL, *ev);
/* setup workspace arrays */
integer lwork = 2*n;
doublecomplex *work=ckalloc(sizeof(doublecomplex)*lwork);
doublereal *rwork=ckalloc(sizeof(doublereal)*lwork);
/* Leading dimensions of A and Vr
* Don't compute left vectors. */
integer lda = n;
integer ldvr = n;
integer ldvl = n;
integer info;
/* Subroutine int zgeev_(Tcl_Interp *interp, char *jobvl, char *jobvr,
* integer *n, doublecomplex *a, integer *lda, doublecomplex *w,
* doublecomplex *vl, integer *ldvl, doublecomplex *vr, integer *ldvr,
* doublecomplex *work, integer *lwork, doublereal *rwork, integer *info) */
/* call out to zgeev */
int errcode=zgeev_(interp, jobvl, jobvr,
&n, Aptr, &lda, w,
NULL, &ldvl, Vrptr, &ldvr,
work, &lwork, rwork, &info);
/* free workspace */
ckfree(work);
ckfree(rwork);
/* A is overwritten with junk */
Tcl_DecrRefCount(A);
if (errcode != TCL_OK) {
/* release temporary storage for result */
if (wantvectors) {
Tcl_DecrRefCount(*V);
}
Tcl_DecrRefCount(*ev);
if (errcode > 0) {
RESULTPRINTF(("ZGEEV failed to converge at eigenvector %d ", info));
}
return TCL_ERROR;
}
return TCL_OK;
}
}
/*!
* A const function that for every value in a vector calculates the matrix
* exponential of the matrix multiplied with that value
* The exponential is calculated by finding the eigenvalues and eigenvectors
* of the matrix, exponentiating the eigenvalues. The eigenvalues is stored in
* a matrix V, eigenvectors is stored in a matrix A, inv(A) is calculated.
* The product A*V*inv(A) is returned.
* @param s A vector with values to be multiplied with the matrix before
* the exponent is calculated.
* @return A vector with the exponential of the matrix multiplied with every
* value in s
*/
MatVec Matrix::expm(const DblVec &s) const {
// Can only calculate eigenvalues and vectors of square matrices
if (get_rows() != get_cols())
throw std::out_of_range("Matrix needs to be square");
int size = get_rows();
DblVec eg_val_real(size, 0); // Real part of eigenvalues
DblVec eg_val_im(size, 0); // Imaginary part of eigenvalues
// should be zero
double dummy[1];
int dummy_size = 1;
double dummy_one = 1;
int info[1];
char n = 'N'; // Do not want to use this argument
char v = 'V'; // Want to use this argument
double workspace_size[1];
int w_query = -1;
// Need to make a copy of the data in Q to send into dgeev_ because
// the data sent in is overwritten
int data_size = get_rows()*get_cols();
DblVec data(m_data);
// Matrix for the eigenvectors
Matrix t_mat = Matrix(size, size);
//workspace-query
// SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
// LDVR, WORK, LWORK, INFO )
dgeev_(&n, &v, &size, &data[0], &size, &eg_val_real[0], &eg_val_im[0], dummy,
&dummy_size, &t_mat.m_data[0], &size, workspace_size, &w_query, info);
DblVec workspace_vec(static_cast<int>(workspace_size[0]), 0);
int w_size = static_cast<int>(workspace_size[0]);
// Real calculation of eigenvalues and eigenvectors for Q
dgeev_(&n, &v, &size, &data[0], &size, &eg_val_real[0], &eg_val_im[0], dummy,
&dummy_size, &t_mat.m_data[0], &size, &workspace_vec[0], &w_size, info);
// Calculating inverse of matrix with eigenvectors
Matrix t_mat_inv(t_mat);
int ipiv[size];
// LU factorization, t_mat_inv.m_data is overwritten with the LU factorization
dgetrf_(&size, &size, &t_mat_inv.m_data[0], &size, ipiv, info);
//workspace-query, nothing happens with t_mat_inv.m_data
dgetri_(&size, &t_mat_inv.m_data[0], &size, ipiv, workspace_size, &w_query, info);
double workspace_vec2[static_cast<int>(workspace_size[0])];
w_size = static_cast<int>(workspace_size[0]);
// Inverse calculation from LU values, the inverse is stored in t_mat_inv.m_data
dgetri_(&size, &t_mat_inv.m_data[0], &size, ipiv, workspace_vec2, &w_size, info);
MatVec result;
result.reserve(s.size());
// e^(this) = T*D*T^-1
// T = matrix with eigenvectors (t_mat), D = matrix with exponentiated eigenvalues
// Calculate for every value in incoming vector s
DblVec eg_val_exp;
eg_val_exp.reserve(size);
for (DblVec::const_iterator it=s.begin(); it != s.end(); it++){
for (int i=0; i<size; i++)
eg_val_exp.push_back(exp(eg_val_real[i]*(*it)));
Matrix left = Matrix::mult(t_mat, Matrix(eg_val_exp));
Matrix res = Matrix::mult( left, t_mat_inv);
result.push_back(res);
eg_val_exp.clear();
}
return result;
}
/* Subroutine */ int derred_(char *path, integer *nunit)
{
/* Format strings */
static char fmt_9999[] = "(1x,a6,\002 passed the tests of the error exit"
"s (\002,i3,\002 tests done)\002)";
static char fmt_9998[] = "(\002 *** \002,a6,\002 failed the tests of the"
" error exits ***\002)";
/* Builtin functions */
integer s_wsle(cilist *), e_wsle(void);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void);
/* Local variables */
static integer info, sdim;
static doublereal a[16] /* was [4][4] */;
static logical b[4];
static integer i__, j;
static doublereal s[4], u[16] /* was [4][4] */, w[16];
extern /* Subroutine */ int dgees_(char *, char *, L_fp, integer *,
doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, logical *,
integer *), dgeev_(char *, char *, integer *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *,
integer *, doublereal *, integer *, doublereal *, integer *,
integer *);
static doublereal abnrm;
static char c2[2];
static doublereal r1[4], r2[4];
extern /* Subroutine */ int dgesdd_(char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *);
static integer iw[8];
static doublereal wi[4];
static integer nt;
static doublereal vl[16] /* was [4][4] */, vr[16] /* was [4][4]
*/, wr[4], vt[16] /* was [4][4] */;
extern /* Subroutine */ int dgesvd_(char *, char *, integer *, integer *,
doublereal *, integer *, doublereal *, doublereal *, integer *,
doublereal *, integer *, doublereal *, integer *, integer *);
extern logical dslect_();
extern /* Subroutine */ int dgeesx_(char *, char *, L_fp, char *, integer
*, doublereal *, integer *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, doublereal *, doublereal *
, integer *, integer *, integer *, logical *, integer *);
extern logical lsamen_(integer *, char *, char *);
extern /* Subroutine */ int dgeevx_(char *, char *, char *, char *,
integer *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *, integer *, doublereal *, integer *, integer *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *, integer *, integer *, integer *), chkxer_(char *, integer *, integer *, logical *,
logical *);
static integer ihi, ilo;
/* Fortran I/O blocks */
static cilist io___1 = { 0, 0, 0, 0, 0 };
static cilist io___24 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___25 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___26 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___27 = { 0, 0, 0, fmt_9998, 0 };
static cilist io___28 = { 0, 0, 0, fmt_9999, 0 };
static cilist io___29 = { 0, 0, 0, fmt_9998, 0 };
#define a_ref(a_1,a_2) a[(a_2)*4 + a_1 - 5]
/* -- LAPACK test routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
December 22, 1999
Purpose
=======
DERRED tests the error exits for the eigenvalue driver routines for
DOUBLE PRECISION matrices:
PATH driver description
---- ------ -----------
SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A
SES DGEES find eigenvalues/Schur form for nonsymmetric A
SVX DGEEVX SGEEV + balancing and condition estimation
SSX DGEESX SGEES + balancing and condition estimation
DBD DGESVD compute SVD of an M-by-N matrix A
DGESDD compute SVD of an M-by-N matrix A (by divide and
conquer)
Arguments
=========
PATH (input) CHARACTER*3
The LAPACK path name for the routines to be tested.
NUNIT (input) INTEGER
The unit number for output.
===================================================================== */
infoc_1.nout = *nunit;
io___1.ciunit = infoc_1.nout;
s_wsle(&io___1);
e_wsle();
s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2);
/* Initialize A */
for (j = 1; j <= 4; ++j) {
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, j) = 0.;
/* L10: */
}
/* L20: */
}
for (i__ = 1; i__ <= 4; ++i__) {
a_ref(i__, i__) = 1.;
/* L30: */
}
infoc_1.ok = TRUE_;
nt = 0;
if (lsamen_(&c__2, c2, "EV")) {
/* Test DGEEV */
s_copy(srnamc_1.srnamt, "DGEEV ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeev_("X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeev_("N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgeev_("N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__1, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeev_("N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__6, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgeev_("V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgeev_("N", "V", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &c__1, w, &
c__8, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgeev_("V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &c__1, w, &
c__3, &info);
chkxer_("DGEEV ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "ES")) {
/* Test DGEES */
s_copy(srnamc_1.srnamt, "DGEES ", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgees_("X", "N", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgees_("N", "X", (L_fp)dslect_, &c__0, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgees_("N", "S", (L_fp)dslect_, &c_n1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__1, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgees_("N", "S", (L_fp)dslect_, &c__2, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgees_("V", "S", (L_fp)dslect_, &c__2, a, &c__2, &sdim, wr, wi, vl, &
c__1, w, &c__6, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgees_("N", "S", (L_fp)dslect_, &c__1, a, &c__1, &sdim, wr, wi, vl, &
c__1, w, &c__2, b, &info);
chkxer_("DGEES ", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 6;
} else if (lsamen_(&c__2, c2, "VX")) {
/* Test DGEEVX */
s_copy(srnamc_1.srnamt, "DGEEVX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeevx_("X", "N", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeevx_("N", "X", "N", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgeevx_("N", "N", "X", "N", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeevx_("N", "N", "N", "X", &c__0, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeevx_("N", "N", "N", "N", &c_n1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgeevx_("N", "N", "N", "N", &c__2, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgeevx_("N", "V", "N", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 13;
dgeevx_("N", "N", "V", "N", &c__2, a, &c__2, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__6, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
dgeevx_("N", "N", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__1, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
dgeevx_("N", "V", "N", "N", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__2, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 21;
dgeevx_("N", "N", "V", "V", &c__1, a, &c__1, wr, wi, vl, &c__1, vr, &
c__1, &ilo, &ihi, s, &abnrm, r1, r2, w, &c__3, iw, &info);
chkxer_("DGEEVX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 11;
} else if (lsamen_(&c__2, c2, "SX")) {
/* Test DGEESX */
s_copy(srnamc_1.srnamt, "DGEESX", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgeesx_("X", "N", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgeesx_("N", "X", (L_fp)dslect_, "N", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgeesx_("N", "N", (L_fp)dslect_, "X", &c__0, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgeesx_("N", "N", (L_fp)dslect_, "N", &c_n1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__1, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 7;
dgeesx_("N", "N", (L_fp)dslect_, "N", &c__2, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 12;
dgeesx_("V", "N", (L_fp)dslect_, "N", &c__2, a, &c__2, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__6, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 16;
dgeesx_("N", "N", (L_fp)dslect_, "N", &c__1, a, &c__1, &sdim, wr, wi,
vl, &c__1, r1, r2, w, &c__2, iw, &c__1, b, &info);
chkxer_("DGEESX", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 7;
} else if (lsamen_(&c__2, c2, "BD")) {
/* Test DGESVD */
s_copy(srnamc_1.srnamt, "DGESVD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgesvd_("X", "N", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgesvd_("N", "X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgesvd_("O", "O", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgesvd_("N", "N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 4;
dgesvd_("N", "N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__1, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 6;
dgesvd_("N", "N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 9;
dgesvd_("A", "N", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 11;
dgesvd_("N", "A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &
c__5, &info);
chkxer_("DGESVD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += 8;
if (infoc_1.ok) {
io___24.ciunit = infoc_1.nout;
s_wsfe(&io___24);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___25.ciunit = infoc_1.nout;
s_wsfe(&io___25);
e_wsfe();
}
/* Test DGESDD */
s_copy(srnamc_1.srnamt, "DGESDD", (ftnlen)6, (ftnlen)6);
infoc_1.infot = 1;
dgesdd_("X", &c__0, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 2;
dgesdd_("N", &c_n1, &c__0, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 3;
dgesdd_("N", &c__0, &c_n1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__1,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 5;
dgesdd_("N", &c__2, &c__1, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 8;
dgesdd_("A", &c__2, &c__1, a, &c__2, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
infoc_1.infot = 10;
dgesdd_("A", &c__1, &c__2, a, &c__1, s, u, &c__1, vt, &c__1, w, &c__5,
iw, &info);
chkxer_("DGESDD", &infoc_1.infot, &infoc_1.nout, &infoc_1.lerr, &
infoc_1.ok);
nt += -2;
if (infoc_1.ok) {
io___26.ciunit = infoc_1.nout;
s_wsfe(&io___26);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___27.ciunit = infoc_1.nout;
s_wsfe(&io___27);
e_wsfe();
}
}
/* Print a summary line. */
if (! lsamen_(&c__2, c2, "BD")) {
if (infoc_1.ok) {
io___28.ciunit = infoc_1.nout;
s_wsfe(&io___28);
do_fio(&c__1, srnamc_1.srnamt, (ftnlen)6);
do_fio(&c__1, (char *)&nt, (ftnlen)sizeof(integer));
e_wsfe();
} else {
io___29.ciunit = infoc_1.nout;
s_wsfe(&io___29);
e_wsfe();
}
}
return 0;
/* End of DERRED */
} /* derred_ */
int run_coupled_twiss_output(RUN *run, LINE_LIST *beamline, double *starting_coord)
{
char JOBVL, JOBVR;
int N, LDA, LDVL, LDVR, lwork, info, i, j, k;
double A[36], WR[6], WI[6], VL[36], VR[36], work[1000];
double emit[3], Norm[3], Vnorm[36];
double Amatrix[108], SigmaMatrix[6][6];
int matDim, eigenModesNumber;
double transferMatrix[36];
VMATRIX *M, *M1;
double **R;
ELEMENT_LIST *eptr, *eptr0;
long nElements, lastNElements, iElement;
double betax1, betax2, betay1, betay2, etax, etay, tilt;
if (!initialized)
return 0;
if (verbosity>1)
fprintf(stdout, "\n* Computing coupled sigma matrix\n");
if (emittances_from_twiss_command) {
if (!(beamline->flags&BEAMLINE_TWISS_DONE)) {
fprintf(stderr, "emittances_from_twiss_command was set but twiss calculations not seen");
return(1);
}
if (!(beamline->flags&BEAMLINE_RADINT_DONE)) {
fprintf(stderr, "emittances_from_twiss_command was set but radiation integral calculations not seen");
return(1);
}
emit_x = beamline->radIntegrals.ex0;
sigma_dp = beamline->radIntegrals.sigmadelta;
if (verbosity>1)
fprintf(stdout, "Raw emittance = %e, momentum spread = %e\n", emit_x, sigma_dp);
}
fflush(stdout);
emit[0] = emit_x;
emit[1] = emit_x*emittance_ratio;
/* Count the number of elements from the recirc element to the end. */
/* Also store the pointer to the recirc element. */
eptr = eptr0 = &(beamline->elem);
nElements = lastNElements = beamline->n_elems;
while (eptr) {
if (eptr->type==T_RECIRC) {
lastNElements = nElements;
eptr0 = eptr;
}
eptr = eptr->succ;
nElements--;
}
nElements = lastNElements;
if (starting_coord) {
/* use the closed orbit to compute the on-orbit R matrix */
M1 = tmalloc(sizeof(*M1));
initialize_matrices(M1, 1);
for (i=0; i<6; i++) {
M1->C[i] = starting_coord[i];
M1->R[i][i] = 1;
}
M = accumulate_matrices(eptr0, run, M1, concat_order, 0);
free_matrices(M1);
free(M1);
M1 = NULL;
} else
M = accumulate_matrices(eptr0, run, NULL, concat_order, 0);
R = M->R;
if (verbosity > 2) {
long order;
order = M->order;
M->order = 1;
print_matrices(stdout, "One-turn matrix:", M);
M->order = order;
}
/* Determination of matrix dimension for these calculations. */
if (calculate_3d_coupling != 1) {
matDim=4;
} else {
if (abs(R[4][4])+abs(R[5][5])>=2) {
printf("Either there is no cavity or 3rd mode is unstable. Only 2 modes will be calculated.\n");
matDim=4;
} else {
matDim=6;
}
}
eigenModesNumber=matDim/2;
/*--- Reducing matrix dimensions, A is reduced R */
for (i=0; i<matDim; i++) {
for (j=0; j<matDim; j++) {
A[i*matDim+j]=R[j][i];
}
}
free_matrices(M);
free(M);
M = NULL;
/*--- Changing time sign for symplecticity... */
if (matDim == 6) {
for (i=0; i<6; i++) {
A[24+i]=-1.0*A[24+i];
A[i*6+4]=-1.0*A[i*6+4];
}
}
if (verbosity > 3) {
MatrixPrintout((double*)&A, &matDim, &matDim, 1);
}
/*--- Calculating eigenvectors using dgeev_ ... */
JOBVL='N';
JOBVR='V';
N=matDim;
LDA=matDim;
LDVL=1;
LDVR=matDim;
lwork=204;
#if defined(SUNPERF) || defined(LAPACK) || defined(CLAPACK)
dgeev_((char*)&JOBVL, (char*)&JOBVR, (int*)&N, (double*)&A,
(int*)&LDA, (double*)&WR, (double*)&WI, (double*)&VL,
(int*)&LDVL, (double*)&VR, (int*)&LDVR, (double*)&work,
(int*)&lwork, (int*)&info);
#else
fprintf(stderr, "Error calling dgeev. You will need to install LAPACK and rebuild elegant\n");
return(1);
#endif
if (info != 0) {
if (info < 0) {
printf("Error calling dgeev, argument %d.\n", abs(info));
}
if (info > 0) {
printf("Error running dgeev, calculation of eigenvalue number %d failed.\n", info);
}
return(1);
}
if (verbosity > 0) {
printf("Info: %d ; %f \n", info, work[0]);
for(i=0; i<matDim; i++) {
printf("%d: %9.6f + i* %10.6f\n",i,WR[i],WI[i]);
}
fflush(stdout);
}
if (verbosity > 1) {
printf("Non-normalized vectors:\n");
MatrixPrintout((double*)&VR, &matDim, &matDim, 1);
fflush(stdout);
}
/*--- Sorting of eigenvalues and eigenvectors according to (x,y,z)... */
SortEigenvalues((double*)&WR, (double*)&WI, (double*)&VR, matDim, eigenModesNumber, verbosity);
/*--- Normalization of eigenvectors... */
for (k=0; k<eigenModesNumber; k++) {
Norm[k]=0;
for (i=0; i<eigenModesNumber; i++) {
/* Index = Irow*matDim + Icolumn */
Norm[k]+=VR[2*k*matDim+2*i+1]*VR[(2*k+1)*matDim+2*i]-VR[2*k*matDim+2*i]*VR[(2*k+1)*matDim+2*i+1];
}
Norm[k]=1.0/sqrt(fabs(Norm[k]));
if (verbosity > 2) {
printf("Norm[%d]= %12.4e \n",k,Norm[k]);
}
}
for (k=0; k<eigenModesNumber; k++) {
for (i=0; i<matDim; i++) {
Vnorm[k*2*matDim+i]=VR[k*2*matDim+i]*Norm[k];
Vnorm[(k*2+1)*matDim+i]=VR[(k*2+1)*matDim+i]*Norm[k];
}
}
if (verbosity > 1) {
printf("Normalized vectors:\n");
MatrixPrintout((double*)&Vnorm, &matDim, &matDim, 1);
}
if (SDDScoupledInitialized) {
/*--- Prepare the output file */
if (!SDDS_StartPage(&SDDScoupled, nElements)) {
fflush(stdout);
SDDS_PrintErrors(stderr, SDDS_VERBOSE_PrintErrors);
return(1);
}
}
/*--- Loop over elements */
iElement=0;
eptr = eptr0;
while (eptr) {
if (verbosity > 0) {
printf("\nElement number %ld: %s\n", iElement, eptr->name);
fflush(stdout);
}
if (!eptr->accumMatrix) {
fprintf(stderr, "Error: no accumulated matrix found for element %s", eptr->name);
return(1);
}
/*--- Reducing matrix dimensions */
R = eptr->accumMatrix->R;
for (i=0; i<matDim; i++) {
for (j=0; j<matDim; j++) {
transferMatrix[i*matDim+j]=R[j][i];
}
}
/*--- Changing time sign for symplecticity... */
if (matDim == 6) {
for (i=0; i<6; i++) {
transferMatrix[24+i]= -1.0*transferMatrix[24+i];
transferMatrix[i*6+4]=-1.0*transferMatrix[i*6+4];
}
}
/*--- Calculating A matrices (product of eigenvectors)... */
GetAMatrix((double*)&Vnorm, (double*)&transferMatrix, (double*)&Amatrix, &eigenModesNumber, &matDim);
if (verbosity > 1) {
for (k=0; k<eigenModesNumber; k++) {
printf("A matrix for mode %d\n", k);
MatrixPrintout((double*)&Amatrix[k*matDim*matDim], &matDim, &matDim, 1);
}
}
/*--- Calculating sigma matrix... */
if (eigenModesNumber == 3) {
emit[2]=sigma_dp*sigma_dp*Amatrix[2*matDim*matDim+4*matDim+4];
}
for (i=0; i<matDim; i++) {
for (j=0; j<matDim; j++) {
SigmaMatrix[i][j]=0;
for (k=0; k<eigenModesNumber; k++) {
SigmaMatrix[i][j]+=emit[k]*Amatrix[k*matDim*matDim+i*matDim+j];
}
}
}
if (verbosity > 0) {
printf("Sigma matrix:\n");
MatrixPrintout((double*)&SigmaMatrix, &matDim, &matDim, 2);
}
tilt=0.5*atan(2*SigmaMatrix[0][2]/(SigmaMatrix[0][0]-SigmaMatrix[2][2]));
if (SDDScoupledInitialized) {
/*--- Calculating beam sizes: 0-SigmaX, 1-SigmaXP, 2-SigmaY, 3-SigmaYP, 4-BeamTilt, 5-BunchLength */
if (!SDDS_SetRowValues(&SDDScoupled, SDDS_SET_BY_NAME|SDDS_PASS_BY_VALUE,
iElement,
"ElementName", eptr->name,
"s", eptr->end_pos,
"Sx", sqrt(SigmaMatrix[0][0]),
"Sxp", sqrt(SigmaMatrix[1][1]),
"Sy", sqrt(SigmaMatrix[2][2]),
"Syp", sqrt(SigmaMatrix[3][3]),
"xyTilt", tilt,
"Ss", eigenModesNumber==3?sqrt(SigmaMatrix[4][4]):-1,
NULL)) {
SDDS_PrintErrors(stderr, SDDS_VERBOSE_PrintErrors);
return(1);
}
}
if (verbosity > 0) {
printf("SigmaX = %12.4e, SigmaY = %12.4e, Beam tilt = %12.4e \n",
sqrt(SigmaMatrix[0][0]), sqrt(SigmaMatrix[2][2]),
0.5*atan(2*SigmaMatrix[0][2]/(SigmaMatrix[0][0]-SigmaMatrix[2][2])));
printf("SigmaXP = %12.4e, SigmaYP = %12.4e, \n", sqrt(SigmaMatrix[1][1]), sqrt(SigmaMatrix[3][3]));
if (eigenModesNumber==3) {
printf("Bunch length = %12.4e \n", sqrt(SigmaMatrix[4][4]));
}
}
betax1 = Amatrix[0];
betax2 = Amatrix[1*matDim*matDim];
betay1 = Amatrix[2*matDim+2];
betay2 = Amatrix[1*matDim*matDim+2*matDim+2];
etax = sqrt(Amatrix[2*matDim*matDim]*Amatrix[2*matDim*matDim+4*matDim+4]);
etay = sqrt(Amatrix[2*matDim*matDim+2*matDim+2]*Amatrix[2*matDim*matDim+4*matDim+4]);
if (SDDScoupledInitialized) {
if (!SDDS_SetRowValues(&SDDScoupled, SDDS_SET_BY_NAME|SDDS_PASS_BY_VALUE,
iElement,
"betax1", betax1,
"betax2", betax2,
"betay1", betay1,
"betay2", betay2,
"etax", etax,
"etay", etay,
NULL)) {
SDDS_PrintErrors(stderr, SDDS_VERBOSE_PrintErrors);
return(1);
}
if (output_sigma_matrix) {
char name[100];
for (i=0; i<matDim; i++)
for (j=i; j<matDim; j++) {
sprintf(name, "S%d%d", i+1, j+1);
if (!SDDS_SetRowValues(&SDDScoupled, SDDS_SET_BY_NAME|SDDS_PASS_BY_VALUE,
iElement, name, SigmaMatrix[i][j], NULL)) {
SDDS_PrintErrors(stderr, SDDS_VERBOSE_PrintErrors);
return(1);
}
}
}
}
if (verbosity > 0) {
printf("betax_1 = %12.4e, betax_2 = %12.4e \n",
Amatrix[0], Amatrix[1*matDim*matDim]);
printf("betay_1 = %12.4e, betay_2 = %12.4e \n",
Amatrix[2*matDim+2], Amatrix[1*matDim*matDim+2*matDim+2]);
printf("etax = %12.4e, etay = %12.4e \n",
sqrt(Amatrix[2*matDim*matDim]*Amatrix[2*matDim*matDim+4*matDim+4]),
sqrt(Amatrix[2*matDim*matDim+2*matDim+2]*Amatrix[2*matDim*matDim+4*matDim+4]));
fflush(stdout);
}
if (eptr->type==T_MARK && ((MARK*)eptr->p_elem)->fitpoint)
store_fitpoint_ctwiss_parameters((MARK*)eptr->p_elem, eptr->name, eptr->occurence, betax1, betax2, betay1, betay2, etax, etay,
tilt);
iElement++;
eptr = eptr->succ;
}
if (SDDScoupledInitialized && !SDDS_WritePage(&SDDScoupled)) {
SDDS_PrintErrors(stderr, SDDS_VERBOSE_PrintErrors);
return(1);
}
return(0);
}
int dgeev2_(char *jobvl, char *jobvr, long int *n, double *
a, long int *lda, double *wr, double *wi, double *vl,
long int *ldvl, double *vr, long int *ldvr, double *work,
long int *lwork, long int *info) {
return dgeev_(jobvl, jobvr, n, a, lda, wr, wi, vl, ldvl, vr, ldvr, work, lwork, info);
}
int dgeev_driver(int n, double *A, double *evec, double *eval) {
char jobvl = 'N'; /* Don't compute left eigenvectors */
char jobvr = 'V'; /* Do compute right eigenvectors */
int lda = n;
double *Atmp = malloc(sizeof(double) * n * n);
double *wr = malloc(sizeof(double) * n);
double *wi = malloc(sizeof(double) * n);
double *vl = NULL;
int ldvl = 1;
double *vr = malloc(sizeof(double) * n * n);
int ldvr = n;
int lwork;
double *work, work_query[1];
int info;
int i, j, count = 0;
/* Transpose the matrix for FORTRAN */
for (i = 0; i < n; i++) {
for (j = 0; j < n; j++) {
if (A[i * n + j] != A[i * n + j]) {
printf("[dgeev_driver] Error: nan encountered\n");
free(Atmp);
free(wr);
free(wi);
free(vr);
return 0;
}
Atmp[j * n + i] = A[i * n + j];
}
}
/* Query dgeev for the optimal value of lwork */
lwork = -1;
dgeev_(&jobvl, &jobvr, &n, Atmp, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work_query, &lwork, &info);
lwork = (int) work_query[0];
work = malloc(sizeof(double) * lwork);
/* Make the call to dgeev */
dgeev_(&jobvl, &jobvr, &n, Atmp, &lda, wr, wi, vl, &ldvl, vr, &ldvr, work, &lwork, &info);
if (info < 0)
printf("Error in call to dgeev (argument %d was invalid\n", -info);
else if (info > 0)
printf("Error: not all eigenvalues have converged\n");
/* Check that all eigenvalues are real */
for (i = 0; i < n; i++) {
if (wi[i] != 0.0) {
// printf("[dgeev] Eigenvalue has non-zero imaginary part\n");
} else {
eval[count] = wr[i];
for (j = 0; j < n; j++)
evec[count * n + j] = vr[i * n + j];
count++;
}
}
/* Clean up */
free(work);
free(Atmp);
free(wr);
free(wi);
free(vr);
return count;
}
/// \brief Solve the det Ax^2+Bx+C = 0 problem using the Manocha and Canny method (1994)
///
/// matcoeffs is of length 54*3, for 3 matrices
static inline void solvedialyticpoly8qep(const IkReal* matcoeffs, IkReal* rawroots, int& numroots)
{
const IkReal tol = 128.0*std::numeric_limits<IkReal>::epsilon();
IkReal IKFAST_ALIGNED16(M[16*16]) = {0};
IkReal IKFAST_ALIGNED16(A[8*8]);
IkReal IKFAST_ALIGNED16(work[16*16*15]);
int ipiv[8];
int info, coeffindex;
const int worksize=16*16*15;
const int matrixdim = 8;
const int matrixdim2 = 16;
numroots = 0;
// first setup M = [0 I; -C -B] and A
coeffindex = 0;
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
M[matrixdim+(j+4)+2*matrixdim*k] = M[matrixdim+j+2*matrixdim*(k+2)] = -matcoeffs[coeffindex++];
}
}
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
M[matrixdim+(j+4)+2*matrixdim*k+matrixdim*2*matrixdim] = M[matrixdim+j+2*matrixdim*(k+2)+matrixdim*2*matrixdim] = -matcoeffs[coeffindex++];
}
}
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
A[(j+4)+matrixdim*k] = A[j+matrixdim*(k+2)] = matcoeffs[coeffindex++];
}
for(int k = 0; k < 2; ++k) {
A[j+matrixdim*k] = A[(j+4)+matrixdim*(k+6)] = 0;
}
}
const IkReal lfpossibilities[4][4] = {{1,-1,1,1},{1,0,-2,1},{1,1,2,0},{1,-1,4,1}};
int lfindex = -1;
bool bsingular = true;
do {
dgetrf_(&matrixdim,&matrixdim,A,&matrixdim,&ipiv[0],&info);
if( info == 0 ) {
bsingular = false;
for(int j = 0; j < matrixdim; ++j) {
if( IKabs(A[j*matrixdim+j]) < 100*tol ) {
bsingular = true;
break;
}
}
if( !bsingular ) {
break;
}
}
if( lfindex == 3 ) {
break;
}
// transform by the linear functional
lfindex++;
const IkReal* lf = lfpossibilities[lfindex];
// have to reinitialize A
coeffindex = 0;
for(int j = 0; j < 4; ++j) {
for(int k = 0; k < 6; ++k) {
IkReal a = matcoeffs[coeffindex+48], b = matcoeffs[coeffindex+24], c = matcoeffs[coeffindex];
A[(j+4)+matrixdim*k] = A[j+matrixdim*(k+2)] = lf[0]*lf[0]*a+lf[0]*lf[2]*b+lf[2]*lf[2]*c;
M[matrixdim+(j+4)+2*matrixdim*k] = M[matrixdim+j+2*matrixdim*(k+2)] = -(lf[1]*lf[1]*a + lf[1]*lf[3]*b + lf[3]*lf[3]*c);
M[matrixdim+(j+4)+2*matrixdim*k+matrixdim*2*matrixdim] = M[matrixdim+j+2*matrixdim*(k+2)+matrixdim*2*matrixdim] = -(2*lf[0]*lf[1]*a + (lf[0]*lf[3]+lf[1]*lf[2])*b + 2*lf[2]*lf[3]*c);
coeffindex++;
}
for(int k = 0; k < 2; ++k) {
A[j+matrixdim*k] = A[(j+4)+matrixdim*(k+6)] = 0;
}
}
} while(lfindex<4);
if( bsingular ) {
return;
}
dgetrs_("No transpose", &matrixdim, &matrixdim2, A, &matrixdim, &ipiv[0], &M[matrixdim], &matrixdim2, &info);
if( info != 0 ) {
return;
}
// set identity in upper corner
for(int j = 0; j < matrixdim; ++j) {
M[matrixdim*2*matrixdim+j+matrixdim*2*j] = 1;
}
IkReal IKFAST_ALIGNED16(wr[16]);
IkReal IKFAST_ALIGNED16(wi[16]);
IkReal IKFAST_ALIGNED16(vr[16*16]);
int one=1;
dgeev_("N", "V", &matrixdim2, M, &matrixdim2, wr, wi,NULL, &one, vr, &matrixdim2, work, &worksize, &info);
if( info != 0 ) {
return;
}
IkReal Breal[matrixdim-1];
for(int i = 0; i < matrixdim2; ++i) {
if( IKabs(wi[i]) < tol*100 ) {
IkReal* ev = vr+matrixdim2*i;
if( IKabs(wr[i]) > 1 ) {
ev += matrixdim;
}
// consistency has to be checked!!
if( IKabs(ev[0]) < tol ) {
continue;
}
IkReal iconst = 1/ev[0];
for(int j = 1; j < matrixdim; ++j) {
Breal[j-1] = ev[j]*iconst;
}
if( checkconsistency8(Breal) ) {
if( lfindex >= 0 ) {
const IkReal* lf = lfpossibilities[lfindex];
rawroots[numroots++] = (wr[i]*lf[0]+lf[1])/(wr[i]*lf[2]+lf[3]);
}
else {
rawroots[numroots++] = wr[i];
}
bool bsmall0=IKabs(ev[0]) > IKabs(ev[2]);
bool bsmall1=IKabs(ev[0]) > IKabs(ev[1]);
if( bsmall0 && bsmall1 ) {
rawroots[numroots++] = ev[2]/ev[0];
rawroots[numroots++] = ev[1]/ev[0];
}
else if( bsmall0 && !bsmall1 ) {
rawroots[numroots++] = ev[3]/ev[1];
rawroots[numroots++] = ev[1]/ev[0];
}
else if( !bsmall0 && bsmall1 ) {
rawroots[numroots++] = ev[6]/ev[4];
rawroots[numroots++] = ev[7]/ev[6];
}
else if( !bsmall0 && !bsmall1 ) {
rawroots[numroots++] = ev[7]/ev[5];
rawroots[numroots++] = ev[7]/ev[6];
}
}
}
}
}};
