예제 #1
0
파일: eigen.cpp 프로젝트: rhoelzel/scigma
    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;
    }	  
예제 #2
0
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;
}
예제 #3
0
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;
}
예제 #5
0
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;
}
예제 #6
0
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;
		}
예제 #8
0
/*! 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;
}
예제 #9
0
/*! 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();
  }
예제 #11
0
파일: eigen.c 프로젝트: mgaldzic/copasi_api
/* 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);
}
예제 #12
0
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
}
예제 #13
0
파일: THLapack.c 프로젝트: stokasto/torch
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
}
예제 #14
0
//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;
}
예제 #15
0
파일: eigendouble.c 프로젝트: ccrepaldi/HPC
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;
}
예제 #17
0
파일: mathtool.cpp 프로젝트: NCIP/visda
/*******************************************************************
 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;
   
}
예제 #18
0
       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);
  }
예제 #19
0
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;
    }
  }
}
예제 #20
0
/* 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;
}
예제 #21
0
파일: eig.c 프로젝트: auriocus/VecTcl
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;

	}

}
예제 #22
0
/*! 
 *  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;
}
예제 #23
0
파일: derred.c 프로젝트: zangel/uquad
/* 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_ */
예제 #24
0
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);
}
예제 #25
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);
}
예제 #26
0
파일: matrix.c 프로젝트: Johnson13/xLearn
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];
                }
            }
        }
    }
}};