/*! 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; }