Exemplo n.º 1
0
/* C front end to LINPACK's dsyevr_() routine.
 *
 * Calculates the eigenvalues and eigenvectors of the nxn symmetric matrix A.
 * The eigenvalues are returned in the vector w.
 * The (orthonormal) eigenvectors are returned in the matrix z.
 * The ith column of z holds the eigenvector associated with w[i].
 * Written by xxxxx and xxxxx
 * */
int LP_sym_eigvecs(double *a, int n, double *w, double *z)
{
        int lwork=-1, liwork=-1;
        double dx, *work = &dx;         /* work points to a temporary cell */
        int ix, *iwork = &ix;           /* iwork points to a temporary cell */
        double abstol = -1.0;           /* force default */
        char jobz='V', range='A', uplo='L';
        int il, iu;
        double vl, vu;
        int info, m;

        /* Call dsyevr_() with lwork=-1 and liwork=-1 to query the
         * optimal sizes of the work and iwork arrays.
         * */
        dsyevr_(&jobz, &range, &uplo, &n, a, &n, &vl, &vu, &il, &iu,
                        &abstol, &m, w, NULL, &n, NULL, 
                        work, &lwork, iwork, &liwork, &info);

        if (info!=0) {
                REprintf("trouble in file __FILE__, line __LINE__: "
                                "info = %d\n", info);
        }
	else {
	  int *isuppz;
	  lwork = (int)*work;
	  liwork = *iwork;
	  
	  /* allocate optimal sizes for work and iwork */
	  work = malloc(lwork*sizeof *work);
	  iwork = malloc(liwork*sizeof *iwork);
	  isuppz = malloc(2*n*sizeof *isuppz);
	  
	  if (work==NULL || iwork==NULL || isuppz==NULL) {
	      REprintf("trouble in file __FILE__, line __LINE__: "
		    "out of memory!\n");
	  }
	  else {
	    /* now call dsyevr_() in earnest */
	    dsyevr_(&jobz, &range, &uplo, &n, a, &n, &vl, &vu, &il, &iu,
		    &abstol, &m, w, z, &n, isuppz, 
		    work, &lwork, iwork, &liwork, &info);
	    
	    if (info!=0) {
	      REprintf("trouble in file __FILE__, line __LINE__: "
		      "info = %d\n", info);
	    }
	  }
	  free(isuppz);
	}
        free(work);
        free(iwork);

        return info;
}
Exemplo n.º 2
0
nmrSymmetricEigenProblem::Errno
nmrSymmetricEigenProblem
( vctDynamicMatrix<double>& A,
  vctDynamicVector<double>& D,
  vctDynamicMatrix<double>& V,
  nmrSymmetricEigenProblem::Data& data ){

  // check if we need to reallocate data
  if( ( data.JOBZ == 'N' && data.RANGE == 'U' && data.UPLO == 'L' ) ||
      data.N != int(A.rows())  ||
      data.ISUPPZ == NULL || 
      data.WORK == NULL   || 
      data.IWORK == NULL ){
    data.Free();
    data = nmrSymmetricEigenProblem::Data( A, D, V );
  }    

  dsyevr_( &data.JOBZ, &data.RANGE, &data.UPLO,
	   &data.N, data.A, &data.LDA, 
	   &data.VL, &data.VU, 
	   &data.IL, &data.IU, 
	   &data.ABSTOL, 
	   &data.M, data.W,
	   data.Z, &data.LDZ, data.ISUPPZ,
	   data.WORK, &data.LWORK,
	   data.IWORK, &data.LIWORK, 
	   &data.INFO );

  if( data.INFO == 0 ) { return nmrSymmetricEigenProblem::ESUCCESS; }
  return nmrSymmetricEigenProblem::EFAILURE;

}
Exemplo n.º 3
0
void ProtoMol::Lapack::dsyevr(char *jobz, char *range, char *uplo, int *n,
                              double *a, int *lda, double *vl, double *vu,
                              int *il, int *iu, double *abstol, int *m,
                              double *w, double *z,  int *ldz, int *isuppz,
                              double *work, int *lwork, int *iwork, int *liwork,
                              int *info) {
  FAHCheckIn();
#if defined(HAVE_LAPACK)
  dsyevr_(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz,
          isuppz, work, lwork, iwork, liwork, info);
#elif defined(HAVE_SIMTK_LAPACK)
  dsyevr_(*jobz, *range, *uplo, *n, a, *lda, vl, vu, il, iu, abstol, *m, w, z,
          *ldz, isuppz, work, *lwork, iwork, liwork, *info, 1, 1, 1);
#elif defined(HAVE_MKL_LAPACK)
  DSYEVR(jobz, range, uplo, n, a, lda, vl, vu, il, iu, abstol, m, w, z, ldz,
         isuppz, work, lwork, iwork, liwork, info);
#else
  THROW(std::string(__func__) + " not supported");
#endif
}
int dsyevr(char JOBZ, char RANGE, char UPLO, int N,
           double *A, int LDA, double VL, double VU,
           int IL, int IU, double ABSTOL, int *M,
           double *W, double *Z, int LDZ, int *ISUPPZ,
           double *WORK, int LWORK, int *IWORK, int LIWORK){
  
  int INFO;
  dsyevr_(&JOBZ, &RANGE, &UPLO, &N, A, &LDA, &VL, &VU,
          &IL, &IU, &ABSTOL, M, W, Z, &LDZ, ISUPPZ,
          WORK, &LWORK, IWORK, &LIWORK, &INFO);
  return INFO;
}
Exemplo n.º 5
0
nmrSymmetricEigenProblem::Data::Data( vctDynamicMatrix<double>& A,
				      vctDynamicVector<double>& D,
				      vctDynamicMatrix<double>& V ) :
  JOBZ( 'V' ),
  RANGE( 'A' ),
  UPLO( 'U' ),

  N( A.rows() ),
  A( A.Pointer() ),
  LDA( A.cols() ),

  VL( 0 ),
  VU( 0 ),
  IL( 0 ),
  IU( 0 ),

  DLAMCH( 'S' ),
  ABSTOL( dlamch_( &DLAMCH ) ),
  
  W( D.Pointer() ),
  Z( V.Pointer() ),
  LDZ( V.cols() ),
  
  ISUPPZ( new CISSTNETLIB_INTEGER[ 2*N ] ),
  WORK( NULL ),
  LWORK( -1 ),

  IWORK( NULL ),
  LIWORK( -1 ){

  CheckSystem( A, D, V );

  CISSTNETLIB_DOUBLE work;
  CISSTNETLIB_INTEGER iwork;

  dsyevr_( &JOBZ, &RANGE, &UPLO,
	   &N, this->A, &LDA, 
	   &VL, &VU, 
	   &IL, &IU, 
	   &ABSTOL, 
	   &M, W, 
	   Z, &LDZ, ISUPPZ,
	   &work, &LWORK,
	   &iwork, &LIWORK, 
	   &INFO );

  LWORK = work;
  WORK = new CISSTNETLIB_DOUBLE[LWORK];

  LIWORK = iwork;
  IWORK = new CISSTNETLIB_INTEGER[LIWORK];
  
}
Exemplo n.º 6
0
  // Wrapper for Lapack eigenvalue function
  int dsyevr (char JOBZ, char RANGE, char UPLO, int N,
	      double *A, int LDA, double VL, double VU,
	      int IL, int IU, double ABSTOL, int *M,
	      double *W, double *Z, int LDZ, int *ISUPPZ,
	      double *WORK, int LWORK, int *IWORK, int LIWORK)
  {
    extern void dsyevr_ (char *JOBZp, char *RANGEp, char *UPLOp, int *Np,
			 double *A, int *LDAp, double *VLp, double *VUp,
			 int *ILp, int *IUp, double *ABSTOLp, int *Mp,
			 double *W, double *Z, int *LDZp, int *ISUPPZ,
			 double *WORK, int *LWORKp, int *IWORK, int *LIWORKp,
			 int *INFOp);
    int INFO;
    dsyevr_ (&JOBZ, &RANGE, &UPLO, &N, A, &LDA, &VL, &VU,
	     &IL, &IU, &ABSTOL, M, W, Z, &LDZ, ISUPPZ,
	     WORK, &LWORK, IWORK, &LIWORK, &INFO);

    return INFO;
  }
void diagonalize(double *cov, int N, int K, double *val, double *vect)
{
	long int n = (long int)N;
	long int M = (long int)K;
	double abstol = 1e-10;
	long int *supp = (long int *) malloc (2 * N * sizeof(long int));
	long int lwork = 26*N;
	double *work = (double *)calloc(lwork, sizeof(double));
	long int liwork = 10*N;
	long int *iwork = (long int *)calloc(liwork, sizeof(double));
	long int info;
	double vl = 0.0, vu = 0.0;
	char jobz = 'V', range = 'I', uplo = 'U';
	long int il =  (long int)N-K+1;
	long int ul = (long int)N;
	double *valp = (double *) calloc(N, sizeof(double));
	double *vectp = (double *) calloc(N * N, sizeof(double));
	int i, k;

	dsyevr_((char *) (&jobz), (char *) (&range) , (char *) (&uplo), (integer *) (&n), (doublereal *) cov, 
	(integer *) (&n), (doublereal *) (&vl), (doublereal *) (&vu), (integer *) (&il) , (integer *) (&ul), 
	(doublereal *) (&abstol), (integer *) (&M), (doublereal *) valp,
        (doublereal *) vectp, (integer *) (&n), (integer *)supp, (doublereal *)work,
        (integer *) (&lwork), (integer *)iwork, (integer *) (&liwork), (integer *) (&info));

	// copy results
	for (k = 0; k < K; k++) {
		val[k] = valp[K-(k+1)];
		if (val[k] < 0 && abs(val[k]) < 1e-10) 
			val[k] = 0;
	}
	
	for (k = 0; k < K; k++)
		for (i = 0; i < N; i++)
			vect[i * K + k] = vectp[(K - (k + 1)) * N + i];

	free(valp);
	free(vectp);
	free(supp);
	free(work);
	free(iwork);
}
Exemplo n.º 8
0
/* Matrix must be symmetric */
void diagonalize(double *cov, int N, int K, double *val, double *vect){

        long int n = (long int)N;
        long int M = (long int)K;
        double abstol = 1e-10;
        long int *supp = (long int *) malloc (2 * N * sizeof(long int));
        long int lwork = 26*N;
        double *work = (double *)calloc(lwork, sizeof(double));
        long int liwork = 10*N;
        long int *iwork = (long int *)calloc(liwork, sizeof(double));
        long int info;
        double vl = 0.0, vu = 0.0;
        char jobz = 'V', range = 'I', uplo = 'U';
        long int il =  (long int)N-K+1;
        long int ul = (long int)N;
        double *valp = (double *) calloc(N, sizeof(double));
        double *vectp = (double *) calloc(N * N, sizeof(double));
        int i, k;
	double trCov = 0;

	for (i=0; i<N; i++) trCov += cov[i*N + i];

        dsyevr_((char *) (&jobz), (char *) (&range) , (char *) (&uplo), (integer *) (&n), (doublereal *) cov, (integer *) (&n), (doublereal *) (&vl), (doublereal *) (&vu), (integer *) (&il) , (integer *) (&ul), (doublereal *) (&abstol), (integer *) (&M), (doublereal *) valp, (doublereal *) vectp, (integer *) (&n), (integer *)supp, (doublereal *)work, (integer *) (&lwork), (integer *)iwork, (integer *) (&liwork), (integer *) (&info));

        for (k = 0; k < K; k++){
		printf("percentage of variance in PC%i: %g\n", k + 1, valp[K - (k + 1)]/trCov);
                val[k] = sqrt(valp[K-(k+1)]);
	}

        for (k = 0; k < K; k++)
                for (i = 0; i < N; i++)
                        vect[i * K + k] = vectp[(K - (k + 1)) * N + i];

        free(valp);
        free(vectp);
        free(supp);
        free(work);
        free(iwork);

}
Exemplo n.º 9
0
void lapack_dsyevr(int nn, char range, dreal vl, dreal vu, int il, int iu, dreal abstol,
                   dreal *AA, dreal *ww)
{
  int   lda, ldz, mm, lwork, liwork, info, ii;
  char  jobz = 'V', uplo = 'U';
  int   *isuppz = NULL, *iwork = NULL;
  dreal *ZZ = NULL, *work = NULL;
  
  lda = (1 > nn) ? 1 : nn;
  ldz = lda;
  lwork = (1 > 26*nn) ? 1 : 26*nn;
  liwork = (1 > 10*nn) ? 1 : 10*nn;
  ZZ = (dreal *) calloc(ldz*nn, sizeof(dreal));
  check_mem(ZZ, "ZZ");
  isuppz = (int *) calloc(2*lda, sizeof(int));
  check_mem(isuppz, "isuppz");
  work = (dreal *) calloc(lwork, sizeof(dreal));
  check_mem(work, "work");
  iwork = (int *) calloc(liwork, sizeof(int));
  
  dsyevr_(&jobz, &range, &uplo, &nn, AA, &lda, &vl, &vu, &il, &iu,
          &abstol, &mm, ww, ZZ, &ldz, isuppz, work, &lwork,
          iwork, &liwork, &info);
  
  for(ii = 0; ii < mm; ++mm)
    memcpy(AA+ii*nn, ZZ+ii*nn, nn*sizeof(dreal));
  
  freeup(work);
  freeup(isuppz);
  freeup(ZZ);
  
  return;
  
 error:
  if(work) freeup(work);
  if(isuppz) freeup(isuppz);
  if(ZZ) freeup(ZZ);
  abort();
}
Exemplo n.º 10
0
nmrSymmetricEigenProblem::Errno
nmrSymmetricEigenProblem
( vctDynamicMatrix<double>& A,
  vctDynamicVector<double>& D,
  vctDynamicMatrix<double>& V ){

  nmrSymmetricEigenProblem::Data data( A, D, V );
  dsyevr_( &data.JOBZ, &data.RANGE, &data.UPLO,
	   &data.N, data.A, &data.LDA, 
	   &data.VL, &data.VU, 
	   &data.IL, &data.IU, 
	   &data.ABSTOL, 
	   &data.M, data.W,
	   data.Z, &data.LDZ, data.ISUPPZ,
	   data.WORK, &data.LWORK,
	   data.IWORK, &data.LIWORK, 
	   &data.INFO );

  data.Free();

  if( data.INFO == 0 ) { return nmrSymmetricEigenProblem::ESUCCESS; }
  return nmrSymmetricEigenProblem::EFAILURE;

}