/*! calculate generalized eigenvalues\n
w is overwitten and become generalized eigenvalues.
This matrix and matB are also overwritten.
*/
inline long dsymatrix::dsygv(dsymatrix& matB, std::vector<double>& w)
{VERBOSE_REPORT;
#ifdef CPPL_DEBUG
if(matB.n!=n){
ERROR_REPORT;
std::cerr << "The matrix B is not a matrix having the same size as \"this\" matrix." << std::endl
<< "The B matrix is (" << matB.n << "x" << matB.n << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
w.resize(n);
char JOBZ('n'), UPLO('l');
long ITYPE(1), LDA(n), LDB(n), LWORK(-1), INFO(1);
double *WORK(new double[1]);
dsygv_(ITYPE, JOBZ, UPLO, n, array, LDA, matB.array, LDB, &w[0],
WORK, LWORK, INFO);
INFO=1;
LWORK = long(WORK[0]);
delete [] WORK; WORK = new double[LWORK];
dsygv_(ITYPE, JOBZ, UPLO, n, array, LDA, matB.array, LDB, &w[0],
WORK, LWORK, INFO);
delete [] WORK;
if(INFO!=0){
WARNING_REPORT;
std::cerr << "Serious trouble happend. INFO = " << INFO << "." << std::endl;
}
return INFO;
}
int geigs_sym (int di, const float * a, const float * b, float * eigval, float * eigvec)
{
int i, j;
FINTEGER d=di;
double * ad = (double *) memalign (16, sizeof (*ad) * d * d);
double * bd = (double *) memalign (16, sizeof (*bd) * d * d);
/* processing is performed in double precision */
for (i = 0 ; i < d ; i++)
for (j = 0 ; j < d ; j++) {
ad[i * d + j] = (float) a[i * d + j];
bd[i * d + j] = (float) b[i * d + j];
}
/* variable for lapack function */
double workopt = 0;
FINTEGER lwork = -1, info, itype = 1;
double * lambda = (double *) memalign (16, sizeof (*lambda) * d);
dsygv_ (&itype, "V", "L", &d, ad, &d, bd, &d, lambda, &workopt, &lwork, &info );
lwork = (int) workopt;
double * work = (double *) memalign (16, lwork * sizeof (*work));
dsygv_ (&itype, "V", "L", &d, ad, &d, bd, &d, lambda, work, &lwork, &info );
if (info != 0) {
fprintf (stderr, "# eigs_sym: problem while computing eigen-vectors/values info=%d\n",info);
goto error;
}
/* normalize the eigenvectors, copy and free */
double nr = 1;
for (i = 0 ; i < d ; i++) {
if(eigval)
eigval[i] = (float) lambda[i];
if(eigvec)
for (j = 0 ; j < d ; j++)
eigvec[i * d + j] = (float) (ad[i * d + j] / nr);
}
error:
free (ad);
free (bd);
free (lambda);
free (work);
return info;
}
bool generalized_sym_eig(Matrix &MatA, Matrix &MatB, vector<double> &Eig,Matrix &Eigvec){
//This function is only dealing with the cases of A and B both being symmetric.
//Preparing for CLAPACK Opeartions
if(!MatA.symm()||!MatB.symm()){
cout<<"Matrix NOT Symmetric."<<endl;
return false;
}
integer i,j,N,lwork,itype,info;
N = MatA.Getcols();
lwork = 3*N;
itype = 1;
doublereal *A = new doublereal[N*N]();
doublereal *B = new doublereal[N*N]();
doublereal *W = new doublereal[N]();
doublereal *work = new doublereal[lwork]();
for(i=0;i<N;i++){
for(j=0;j<N;j++)
A[i*N+j] = MatA(j,i);
}
for(i=0;i<N;i++){
for(j=0;j<N;j++)
B[i*N+j] = MatB(j,i);
}
dsygv_(&itype,"V","U",&N,A,&N,B,&N,W,work,&lwork,&info);
for(i=0;i<N;i++)
for(j=0;j<N;j++)
Eigvec(i,j) = A[i*N+j];
Eigvec = reverse(Eigvec,2);
for(i=0;i<N;i++)
Eig[i] = W[i];
return true;
}
int dsygv(int itype, char jobz, char uplo, int n,
double *a, int lda, double *b, int ldb, double *w,
double *WORK, int IWORK){
int INFO;
dsygv_(&itype, &jobz, &uplo, &n, a, &lda, b, &ldb, w, WORK, &IWORK, &INFO);
return INFO;
}
int LapackGHEPEPairs(int hn, double* A, double* B, double* lami)
{
char jobzm = 'V' , uplo = 'U';
integer n = hn;
integer lwork=4*n;
double* work = new double[lwork];
integer info;
integer itype =1;
integer lda = n;
integer ldb = n;
dsygv_(&itype,&jobzm,&uplo , &n , A , &lda, B, &ldb, lami, work, &lwork, &info);
if(info != 0)
{
cout << "LapackGHEPEPairs Info " << info << endl;
cout << "n = " << n << endl;
}
delete [] work;
return(info);
}
void LapackGHEP(int hn, double* A, double* B, double* lami)
{
integer n = hn;
double *B1 = new double[n*n];
double *A1 = new double[n*n];
for(int i=0;i<n*n;i++)
{
A1[i] = A[i];
B1[i] = B[i];
}
char jobzm = 'V' , uplo = 'U';
integer lwork=16*n;
double* work = new double[lwork];
integer info;
integer itype =1;
dsygv_(&itype,&jobzm,&uplo , &n , A1 , &n, B1, &n, lami, work, &lwork, &info);
delete[] A1;
delete[] B1;
delete[] work;
}
void QuasiNewton<double>::symmHerDiag(int NTrial, ostream &output){
/*
* Solve S(R)| X(R) > = E(R)| X(R) > (1/ω)
*
* | X(R) > = | X(R)_g >
* | X(R)_u >
*
* The opposite (1/ω vs ω) is solved because the metric is not positive definite
* and can therefore not be solved using DSYGV because of the involved Cholesky
* decomposition.
*
*/
char JOBV = 'V';
char UPLO = 'L';
int iType = 1;
int TwoNTrial = 2*NTrial;
int INFO;
RealCMMap SSuper(this->SSuperMem, 2*NTrial,2*NTrial);
RealCMMap SCPY(this->SCPYMem, TwoNTrial,TwoNTrial);
SCPY = SSuper; // Copy of original matrix to use for re-orthogonalization
// Perform diagonalization of reduced subspace using DSYGV
dsygv_(&iType,&JOBV,&UPLO,&TwoNTrial,this->SSuperMem,&TwoNTrial,
this->ASuperMem,&TwoNTrial,this->ERMem,this->WORK,&this->LWORK,
&INFO);
if(INFO!=0) CErr("DSYGV failed to converge in Davison Iterations",output);
// Grab the "positive paired" roots (throw away other element of the pair)
this->ERMem += NTrial;
RealVecMap ER (this->ERMem,NTrial);
new (&SSuper) RealCMMap(this->SSuperMem+2*NTrial*NTrial,2*NTrial,NTrial);
// Swap the ordering because we solve for (1/ω)
for(auto i = 0 ; i < NTrial; i++) ER(i) = 1.0/ER(i);
for(auto i = 0 ; i < NTrial/2; i++){
SSuper.col(i).swap(SSuper.col(NTrial - i - 1));
double tmp = ER(i);
ER(i) = ER(NTrial - i - 1);
ER(NTrial - i - 1) = tmp;
}
/*
* 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);
} // symmHerDiag
/*! calculate generalized eigenvalues\n
w is overwitten and become generalized eigenvalues.
This matrix and matB are also overwritten.
*/
inline long dsymatrix::dsygv(dsymatrix& matB, std::vector<double>& w,
std::vector<dcovector>& v)
{VERBOSE_REPORT;
#ifdef CPPL_DEBUG
if(matB.n!=n){
ERROR_REPORT;
std::cerr << "The matrix B is not a matrix having the same size as \"this\" matrix." << std::endl
<< "The B matrix is (" << matB.n << "x" << matB.n << ")." << std::endl;
exit(1);
}
#endif//CPPL_DEBUG
w.resize(n);
v.resize(n);
char JOBZ('V'), UPLO('l');
long ITYPE(1), LDA(n), LDB(n), LWORK(-1), INFO(1);
double *WORK(new double[1]);
dsygv_(ITYPE, JOBZ, UPLO, n, array, LDA, matB.array, LDB, &w[0],
WORK, LWORK, INFO);
INFO=1;
LWORK = long(WORK[0]);
std::cout << " LWORK = " << LWORK <<std::endl;
delete [] WORK; WORK = new double[LWORK];
dsygv_(ITYPE, JOBZ, UPLO, n, array, LDA, matB.array, LDB, &w[0],
WORK, LWORK, INFO);
delete [] WORK;
//// reforming ////
for(int i=0; i<n; i++){
v[i].resize(n);
for(int j=0; j<n; j++){
v[i](j) =darray[i][j];
}
}
if(INFO!=0){
WARNING_REPORT;
std::cerr << "Serious trouble happend. INFO = " << INFO << "." << std::endl;
}
return INFO;
}
int main(int argc, char **argv)
{
/********************* variables declaration **************************/
int info, itype, lda, ldb, lwork, order; /* variables for lapack function */
char jobz, uplo; /* variables for lapack function */
int nfreq; /* number of frequencies displayed on the screen */
int d; /* dimension of the problem - determine the size r of the partial basis*/
int shape; /* shape of the body */
int r; /* actual size of the partial basis */
int i, j; /* indices */
int ir1;
int *itab, *ltab, *mtab, *ntab; /* tabulation of indices */
int *irk;
int k;
int ns; /* symmetry of the system */
int hextype; /* type of hexagonal symmetry - VTI or HTI*/
double d1, d2, d3; /* dimension of the sample */
double rho; /* density */
double **cm;
double ****c; /* stiffness tensor */
double **e, **gamma, *work, **w; /* matrices of the eigenvalue problem */
double *wsort;
int outeigen; /* 1 if eigenvectors calculated */
char *eigenfile;
/** FILE *file; */
/********************* end variables declaration **********************/
/* hook up getpar to handle the parameters */
initargs(argc,argv);
requestdoc(1);
/* get required parameters */
if (!getparint("d", &d)) err("must specify d!\n");
if (!getpardouble("d1", &d1)) err("must specify d1!\n");
if (!getpardouble("d2", &d2)) err("must specify d2!\n");
if (!getpardouble("d3", &d3)) err("must specify d3!\n");
if (!getpardouble("rho", &rho)) err("must specify rho!\n");
if (!getparint("ns", &ns)) err("must specify ns!\n");
cm=ealloc2double(6,6);
for (i=0; i<6; ++i)
for (j=0; j<6; ++j)
cm[i][j]=0.0;
if (ns==2) {
/* isotropic */
if (!getpardouble("c11", &cm[0][0])) err("must specify c11!\n");
if (!getpardouble("c44", &cm[3][3])) err("must specify c44!\n");
cm[0][0]=cm[0][0]/100;
cm[3][3]=cm[3][3]/100;
cm[1][1]=cm[2][2]=cm[0][0];
cm[4][4]=cm[5][5]=cm[3][3];
cm[0][1]=cm[0][2]=cm[1][2]=cm[0][0]- 2.0*cm[3][3];
cm[1][0]=cm[2][0]=cm[2][1]=cm[0][0]- 2.0*cm[3][3];
} else if (ns==3) {
/* cubic */
if (!getpardouble("c11", &cm[0][0])) err("must specify c11!\n");
if (!getpardouble("c12", &cm[0][1])) err("must specify c12!\n");
if (!getpardouble("c44", &cm[3][3])) err("must specify c44!\n");
cm[0][0]=cm[0][0]/100;
cm[0][1]=cm[0][1]/100;
cm[3][3]=cm[3][3]/100;
cm[1][1]=cm[2][2]=cm[0][0];
cm[4][4]=cm[5][5]=cm[3][3];
cm[0][2]=cm[1][2]=cm[0][1];
cm[2][0]=cm[2][1]=cm[1][0]=cm[0][1];
} else if (ns==5) {
/* hexagonal */
if (!getparint("hextype", &hextype)) err("must specify hextype!\n");
if (hextype==1) {
/* VTI */
if (!getpardouble("c33", &cm[2][2])) err("must specify c33!\n");
if (!getpardouble("c23", &cm[1][2])) err("must specify c23!\n");
if (!getpardouble("c12", &cm[0][1])) err("must specify c12!\n");
if (!getpardouble("c44", &cm[3][3])) err("must specify c44!\n");
if (!getpardouble("c66", &cm[5][5])) err("must specify c66!\n");
cm[2][2]=cm[2][2]/100;
cm[1][2]=cm[1][2]/100;
cm[0][1]=cm[0][1]/100;
cm[3][3]=cm[3][3]/100;
cm[5][5]=cm[5][5]/100;
cm[0][0]=cm[1][1]=2.0*cm[5][5] + cm[0][1];
cm[0][2]=cm[2][0]=cm[2][1]=cm[1][2];
cm[1][0]=cm[0][1];
cm[4][4]=cm[3][3];
} else if (hextype==2) {
/* HTI */
if (!getpardouble("c11", &cm[0][0])) err("must specify c11!\n");
if (!getpardouble("c33", &cm[2][2])) err("must specify c33!\n");
if (!getpardouble("c12", &cm[0][1])) err("must specify c12!\n");
if (!getpardouble("c44", &cm[3][3])) err("must specify c44!\n");
if (!getpardouble("c66", &cm[5][5])) err("must specify c66!\n");
cm[0][0]=cm[0][0]/100;
cm[2][2]=cm[2][2]/100;
cm[0][1]=cm[0][1]/100;
cm[3][3]=cm[3][3]/100;
cm[5][5]=cm[5][5]/100;
cm[1][2]=cm[2][1]=cm[2][2] - 2.0*cm[3][3];
cm[0][2]=cm[1][0]=cm[2][0]=cm[0][1];
cm[1][1]=cm[2][2];
cm[4][4]=cm[5][5];
}
else {
err("for hexagonal symmetry hextype must equal 1 (VTI) or 2 (HTI)!\n");
}
}
else if (ns==6){
/* tetragonal */
if (!getpardouble("c11", &cm[0][0])) err("must specify c11!\n");
if (!getpardouble("c33", &cm[2][2])) err("must specify c33!\n");
if (!getpardouble("c23", &cm[1][2])) err("must specify c23!\n");
if (!getpardouble("c12", &cm[0][1])) err("must specify c12!\n");
if (!getpardouble("c44", &cm[3][3])) err("must specify c44!\n");
if (!getpardouble("c66", &cm[5][5])) err("must specify c66!\n");
cm[0][0]=cm[0][0]/100;
cm[2][2]=cm[2][2]/100;
cm[1][2]=cm[1][2]/100;
cm[3][3]=cm[3][3]/100;
cm[0][1]=cm[0][1]/100;
cm[5][5]=cm[5][5]/100;
cm[1][1]=cm[0][0];
cm[0][2]=cm[2][0]=cm[1][2];
cm[1][0]=cm[0][1];
cm[2][1]=cm[1][2];
cm[4][4]=cm[3][3];
}
else if (ns==9){/* orthorhombic */
if (!getpardouble("c11", &cm[0][0])) err("must specify c11!\n");
if (!getpardouble("c22", &cm[1][1])) err("must specify c22!\n");
if (!getpardouble("c33", &cm[2][2])) err("must specify c33!\n");
if (!getpardouble("c23", &cm[1][2])) err("must specify c23!\n");
if (!getpardouble("c13", &cm[0][2])) err("must specify c13!\n");
if (!getpardouble("c12", &cm[0][1])) err("must specify c12!\n");
if (!getpardouble("c44", &cm[3][3])) err("must specify c44!\n");
if (!getpardouble("c55", &cm[4][4])) err("must specify c55!\n");
if (!getpardouble("c66", &cm[5][5])) err("must specify c66!\n");
cm[0][0]=cm[0][0]/100;
cm[1][1]=cm[1][1]/100;
cm[2][2]=cm[2][2]/100;
cm[1][2]=cm[1][2]/100;
cm[0][2]=cm[0][2]/100;
cm[0][1]=cm[0][1]/100;
cm[3][3]=cm[3][3]/100;
cm[4][4]=cm[4][4]/100;
cm[5][5]=cm[5][5]/100;
cm[2][0]=cm[0][2];
cm[1][0]=cm[0][1];
cm[2][1]=cm[1][2];
}
else err("given elatic moduli does not fit given ns");
/* get optional parameters */
if (!getparint("outeigen", &outeigen)) outeigen=0;
if (outeigen!=0)
if (!getparstring("eigenfile", &eigenfile))
err("must specify eigenfile since outeigen>0!\n");
if (!getparint("shape", &shape)) shape=1; /* changed from zero default to 1 */
if (!getparint("nfreq", &nfreq)) nfreq=10;
/* dimension of the problem */
r= 3*(d+1)*(d+2)*(d+3)/6;
d1=d1/2.0; /* half sample dimensions are used in calculations */
d2=d2/2.0;
d3=d3/2.0;
/* alloc work space*/
itab=ealloc1int(r);
ltab=ealloc1int(r);
mtab=ealloc1int(r);
ntab=ealloc1int(r);
/* relationship between ir and l,m,n - filling tables */
irk=ealloc1int(8);
index_relationship(itab, ltab, mtab, ntab, d, irk);
/* alloc workspace to solve for eigenvalues and eigenfunctions */
e= (double **) malloc(8*sizeof(double *));
for (k=0; k<8; ++k)
e[k] = ealloc1double(irk[k]*irk[k]);
gamma= (double **) malloc(8*sizeof(double *));
for (k=0; k<8; ++k)
gamma[k] = ealloc1double(irk[k]*irk[k]);
/* filling matrix e */
for (k=0; k<8; ++k)
e_fill(e[k], itab, ltab, mtab, ntab,
r, d1, d2, d3, rho, shape, k, irk);
/* stiffness tensor calculation*/
c= (double ****) malloc(sizeof(double ***)*3);
for (i=0; i<3; ++i)
c[i]=ealloc3double(3,3,3);
stiffness (c, cm);
/* filling matrix gamma */
for (k=0; k<8; ++k)
gamma_fill(gamma[k], itab, ltab, mtab,
ntab, r, d1, d2, d3, c, shape, k, irk);
/* clean workspace */
free1int(itab);
free1int(ltab);
free1int(mtab);
free1int(ntab);
for (i=0; i<3; ++i)
free3double(c[i]);
free(c);
fprintf(stderr,"done preparing matrices\n");
/*-------------------------------------------------------------*/
/*--------- solve the generalized eigenvalue problem ----------*/
/*-------------------------------------------------------------*/
w= (double **) malloc(sizeof(double *)*8);
itype=1;
if (outeigen==0) jobz='N';
else jobz='V';
uplo='U';
for (k=0; k<8; ++k){
w[k] =ealloc1double(irk[k]);
lda=ldb=irk[k];
order=irk[k];
lwork=MAX(1, 3*order-1);
work=ealloc1double(lwork);
/* lapack routine */
dsygv_(&itype, &jobz, &uplo, &order, gamma[k],
&lda, e[k], &ldb, w[k], work, &lwork, &info);
free1double(work);
}
/*-------------------------------------------------------------*/
/*-------------------------------------------------------------*/
/*-------------------------------------------------------------*/
wsort=ealloc1double(r);
for (i=0, k=0; k<8; ++k)
for (ir1=0;ir1<irk[k];++ir1,++i)
wsort[i]=w[k][ir1];
/* sorting the eigenfrequencies */
dqksort(r,wsort);
for (i=0, ir1=0; ir1<nfreq;++i)
if ((wsort[i]>0) && ((sqrt(wsort[i])/(2.0*PI))>0.00001)){
++ir1;
/*fprintf(stderr," f%d = %f\n", ir1, 1000000*sqrt(wsort[i])/(2.0*PI));*/
fprintf(stderr," f%d = %f\n", ir1, 1000000*sqrt(wsort[i])/(2.0*PI));
}
/* modify output of freq values here*/
/* for (k=0;k<8;++k){
for (ir2=0;ir2<irk[k]*irk[k];++ir2){
fprintf(stderr,"gamma[%d][%d]=%f\n",k,ir2,gamma[k][ir2]);
fprintf(stderr,"e[%d][%d]=%f\n",k,ir2,e[k][ir2]);
}
}*/
/******************* write eigenvectors in files ***************/
/*if (outeigen==1){
z=ealloc2double(r,r);
for (ir1=0; ir1<r; ++ir1)
for (ir2=0; ir2<r; ++ir2)
z[ir2][ir1]=gamma[ir1][ir2*r+ir1]; */
/* change the order of the array at the same time */
/* since we go from fortran array */
/* to C array */
/* clean workspace */
/* free1double(gamma);
file = efopen(eigenfile, "w");
efwrite(&irf, sizeof(int), 1, file);
efwrite(w, sizeof(double), r, file);
efwrite(z[0], sizeof(double), r*r, file);
efclose(file);*/
/* clean workspace */
/* free2double(z); */
/* }*/
/* clean workspace */
/* free1double(w); */
/* end of main */
return EXIT_SUCCESS;
}
