Ejemplo n.º 1
0
/* Subroutine */
int dsygvx_(integer *itype, char *jobz, char *range, char * uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer *m, doublereal *w, doublereal *z__, integer *ldz, doublereal *work, integer *lwork, integer *iwork, integer *ifail, integer *info)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;
    /* Local variables */
    integer nb;
    extern logical lsame_(char *, char *);
    extern /* Subroutine */
    int dtrmm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
    char trans[1];
    extern /* Subroutine */
    int dtrsm_(char *, char *, char *, char *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *);
    logical upper, wantz, alleig, indeig, valeig;
    extern /* Subroutine */
    int xerbla_(char *, integer *);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
    extern /* Subroutine */
    int dpotrf_(char *, integer *, doublereal *, integer *, integer *);
    integer lwkmin;
    extern /* Subroutine */
    int dsygst_(integer *, char *, integer *, doublereal *, integer *, doublereal *, integer *, integer *);
    integer lwkopt;
    logical lquery;
    extern /* Subroutine */
    int dsyevx_(char *, char *, char *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *, integer *, integer *);
    /* -- LAPACK driver routine (version 3.4.0) -- */
    /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
    /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
    /* November 2011 */
    /* .. Scalar Arguments .. */
    /* .. */
    /* .. Array Arguments .. */
    /* .. */
    /* ===================================================================== */
    /* .. Parameters .. */
    /* .. */
    /* .. Local Scalars .. */
    /* .. */
    /* .. External Functions .. */
    /* .. */
    /* .. External Subroutines .. */
    /* .. */
    /* .. Intrinsic Functions .. */
    /* .. */
    /* .. Executable Statements .. */
    /* Test the input parameters. */
    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --w;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    --work;
    --iwork;
    --ifail;
    /* Function Body */
    upper = lsame_(uplo, "U");
    wantz = lsame_(jobz, "V");
    alleig = lsame_(range, "A");
    valeig = lsame_(range, "V");
    indeig = lsame_(range, "I");
    lquery = *lwork == -1;
    *info = 0;
    if (*itype < 1 || *itype > 3)
    {
        *info = -1;
    }
    else if (! (wantz || lsame_(jobz, "N")))
    {
        *info = -2;
    }
    else if (! (alleig || valeig || indeig))
    {
        *info = -3;
    }
    else if (! (upper || lsame_(uplo, "L")))
    {
        *info = -4;
    }
    else if (*n < 0)
    {
        *info = -5;
    }
    else if (*lda < max(1,*n))
    {
        *info = -7;
    }
    else if (*ldb < max(1,*n))
    {
        *info = -9;
    }
    else
    {
        if (valeig)
        {
            if (*n > 0 && *vu <= *vl)
            {
                *info = -11;
            }
        }
        else if (indeig)
        {
            if (*il < 1 || *il > max(1,*n))
            {
                *info = -12;
            }
            else if (*iu < min(*n,*il) || *iu > *n)
            {
                *info = -13;
            }
        }
    }
    if (*info == 0)
    {
        if (*ldz < 1 || wantz && *ldz < *n)
        {
            *info = -18;
        }
    }
    if (*info == 0)
    {
        /* Computing MAX */
        i__1 = 1;
        i__2 = *n << 3; // , expr subst
        lwkmin = max(i__1,i__2);
        nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1);
        /* Computing MAX */
        i__1 = lwkmin;
        i__2 = (nb + 3) * *n; // , expr subst
        lwkopt = max(i__1,i__2);
        work[1] = (doublereal) lwkopt;
        if (*lwork < lwkmin && ! lquery)
        {
            *info = -20;
        }
    }
    if (*info != 0)
    {
        i__1 = -(*info);
        xerbla_("DSYGVX", &i__1);
        return 0;
    }
    else if (lquery)
    {
        return 0;
    }
    /* Quick return if possible */
    *m = 0;
    if (*n == 0)
    {
        return 0;
    }
    /* Form a Cholesky factorization of B. */
    dpotrf_(uplo, n, &b[b_offset], ldb, info);
    if (*info != 0)
    {
        *info = *n + *info;
        return 0;
    }
    /* Transform problem to standard eigenvalue problem and solve. */
    dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info);
    dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol, m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[ 1], info);
    if (wantz)
    {
        /* Backtransform eigenvectors to the original problem. */
        if (*info > 0)
        {
            *m = *info - 1;
        }
        if (*itype == 1 || *itype == 2)
        {
            /* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
            */
            /* backtransform eigenvectors: x = inv(L)**T*y or inv(U)*y */
            if (upper)
            {
                *(unsigned char *)trans = 'N';
            }
            else
            {
                *(unsigned char *)trans = 'T';
            }
            dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] , ldb, &z__[z_offset], ldz);
        }
        else if (*itype == 3)
        {
            /* For B*A*x=(lambda)*x;
            */
            /* backtransform eigenvectors: x = L*y or U**T*y */
            if (upper)
            {
                *(unsigned char *)trans = 'T';
            }
            else
            {
                *(unsigned char *)trans = 'N';
            }
            dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset] , ldb, &z__[z_offset], ldz);
        }
    }
    /* Set WORK(1) to optimal workspace size. */
    work[1] = (doublereal) lwkopt;
    return 0;
    /* End of DSYGVX */
}
Ejemplo n.º 2
0
void symeigx(double a[],    
	      int n,         
	      double d[],    
	      double v[],    
	      int    ell,
	      int    *fl)
{
  int    itype    =   1;
  char   jobz     = 'v';
  char   range    = 'i';
  char   uplo     = 'l';
  char   trans    = 't';
  char   side     = 'l';
  char   diag     = 'n';
  char   under    = 'u';
  int    nfound;
  int    *ifail;
  int    info;
  int    neig;
  double abstol   =  2.0 * DLAMCH(under);
  double one      =  1.0;
  double zero     =  0.0;

#ifdef CBLAS
  double *work;
  int    lwork;
  int    *iwork;            
  char   *dsytrd  = "DSYTRD";
  int    monei    = -1;
  /*  int    nell     = n-ell+1;
      int    n1       = n;*/
  int    nell     = 1;
  int    n1       = ell ;
#else
  /*int    nell     = n-ell;
    int    n1       = n-1;*/
  int    nell     = 0;
  int    n1       = ell-1;
#endif
  
  ifail = (int *) malloc(sizeof(int) * n);

#ifdef CBLAS
  lwork = ilaenv_(&itype, dsytrd, &uplo, &n, 
		  &monei, &monei, &monei, 6L, 1L);
  lwork = (lwork+3)*n;
  if (lwork < 8*n)
    lwork = 8*n;
  iwork = (int *) malloc(sizeof(int) * n * 5);
  work  = (double *) malloc(sizeof(double) * lwork);
  dsyevx_(&jobz,&range,&uplo,&n,a,&n,&zero,&zero,&nell,&n1,
	  &abstol,&nfound,d,v,&n,work,&lwork,iwork,ifail,&info);
  free(iwork);
  free(work);
#else
  dsyevx(jobz, range, uplo, n, a, n, zero, zero, nell, n1, abstol, &nfound,
	 d, v, n, ifail, &info);
#endif
  
  neig = ell;
  if (info > 0)
    neig = info - 1;
  
  free(ifail);
  printf("%i\n", nfound) ;
  *fl = 1;
  if (info < 0) 
    {
      fprintf(stderr, "sygvx: Illegal argument %i.\n", info);
      *fl = -1;
    }
  else if ((info > 0) && (info <= n))
    {
      fprintf(stderr, "sygvx: Convergence failure.\n");
      *fl = -1;
    }
  else if (info > n)
    {
      fprintf(stderr,
	      "sygvx: Leading minor of order %i of B not pos. def.\n", 
	      info-n);
      *fl = -1;
    }
  
  return;
}
Ejemplo n.º 3
0
bool eigen_lapack(int n, vector_t & A, vector_t & S, matrix_t & V)
{
    
  // Use eigenvalue decomposition instead of SVD
  // Get only the highest eigen-values, (par::cluster_mds_dim)
  
  int i1 = n - par::cluster_mds_dim + 1;
  int i2 = n;
  double z = -1;
  
  // Integer workspace size, 5N
  vector<int> iwork(5*n,0);    
  
  double optim_lwork;
  int lwork = -1;
  
  int out_m;
  vector_t out_w( par::cluster_mds_dim , 0 );
  vector_t out_z( n * par::cluster_mds_dim ,0 );
  
  int ldz = n;
  vector<int> ifail(n,0);
  int info=0;
  double nz = 0;
  
  // Get workspace
  
  dsyevx_("V" ,         // get eigenvalues and eigenvectors
	  "I" ,         // get interval of selected eigenvalues
	  "L" ,         // data stored as upper triangular
	  &n  ,         // order of matrix
	  &A[0] ,       // input matrix
	  &n ,          // LDA
	  &nz ,         // Vlower
	  &nz ,         // Vupper
	  &i1,          // from 1st ...
	  &i2,          // ... to nth eigenvalue
	  &z ,          // 0 for ABSTOL
	  &out_m,       // # of eigenvalues found
	  &out_w[0],    // first M entries contain sorted eigen-values
	  &out_z[0],    // array (can be mxm? nxn)
	  &ldz,         // make n at first
	  &optim_lwork, // Get optimal workspace 
	  &lwork,       // size of workspace
	  &iwork[0],    // int workspace
	  &ifail[0],    // output: failed to converge
	  &info );
  
  // Assign workspace
  
  lwork = (int) optim_lwork;
  vector_t work( lwork, 0 );

  dsyevx_("V" ,      // get eigenvalues and eigenvectors
	  "I" ,      // get interval of selected eigenvalues
	  "L" ,      // data stored as upper triangular
	  &n  ,      // order of matrix
	  &A[0] ,    // input matrix
	  &n ,       // LDA
	  &nz ,      // Vlower
	  &nz ,      // Vupper
	  &i1,       // from 1st ...
	  &i2,       // ... to nth eigenvalue
	  &z ,       // 0 for ABSTOL
	  &out_m,    // # of eigenvalues found
	  &out_w[0], // first M entries contain sorted eigen-values
	  &out_z[0], // array (can be mxm? nxn)
	  &ldz,      // make n at first
	  &work[0],  // Workspace
	  &lwork,    // size of workspace
	  &iwork[0], // int workspace
	  &ifail[0], // output: failed to converge
	  &info );      

  // Get eigenvalues, vectors
  for (int i=0; i< par::cluster_mds_dim; i++)
    S[i] = out_w[i];
  
  for (int i=0; i<n; i++)
    for (int j=0;j<par::cluster_mds_dim; j++)
      V[i][j] = out_z[ i + j*n ];
  
  return true;
  
}
Ejemplo n.º 4
0
/* Subroutine */ int dsygvx_(integer *itype, char *jobz, char *range, char *
	uplo, integer *n, doublereal *a, integer *lda, doublereal *b, integer 
	*ldb, doublereal *vl, doublereal *vu, integer *il, integer *iu, 
	doublereal *abstol, integer *m, doublereal *w, doublereal *z__, 
	integer *ldz, doublereal *work, integer *lwork, integer *iwork, 
	integer *ifail, integer *info, ftnlen jobz_len, ftnlen range_len, 
	ftnlen uplo_len)
{
    /* System generated locals */
    integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1, i__2;

    /* Local variables */
    static integer nb, lopt;
    extern logical lsame_(char *, char *, ftnlen, ftnlen);
    extern /* Subroutine */ int dtrmm_(char *, char *, char *, char *, 
	    integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
    static char trans[1];
    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
	    integer *, integer *, doublereal *, doublereal *, integer *, 
	    doublereal *, integer *, ftnlen, ftnlen, ftnlen, ftnlen);
    static logical upper, wantz, alleig, indeig, valeig;
    extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
	    integer *, integer *, ftnlen, ftnlen);
    extern /* Subroutine */ int dpotrf_(char *, integer *, doublereal *, 
	    integer *, integer *, ftnlen), dsygst_(integer *, char *, integer 
	    *, doublereal *, integer *, doublereal *, integer *, integer *, 
	    ftnlen);
    static integer lwkopt;
    static logical lquery;
    extern /* Subroutine */ int dsyevx_(char *, char *, char *, integer *, 
	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
	    integer *, doublereal *, integer *, integer *, integer *, integer 
	    *, ftnlen, ftnlen, ftnlen);


/*  -- LAPACK driver routine (version 3.0) -- */
/*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/*     Courant Institute, Argonne National Lab, and Rice University */
/*     June 30, 1999 */

/*     .. Scalar Arguments .. */
/*     .. */
/*     .. Array Arguments .. */
/*     .. */

/*  Purpose */
/*  ======= */

/*  DSYGVX computes selected eigenvalues, and optionally, eigenvectors */
/*  of a real generalized symmetric-definite eigenproblem, of the form */
/*  A*x=(lambda)*B*x,  A*Bx=(lambda)*x,  or B*A*x=(lambda)*x.  Here A */
/*  and B are assumed to be symmetric and B is also positive definite. */
/*  Eigenvalues and eigenvectors can be selected by specifying either a */
/*  range of values or a range of indices for the desired eigenvalues. */

/*  Arguments */
/*  ========= */

/*  ITYPE   (input) INTEGER */
/*          Specifies the problem type to be solved: */
/*          = 1:  A*x = (lambda)*B*x */
/*          = 2:  A*B*x = (lambda)*x */
/*          = 3:  B*A*x = (lambda)*x */

/*  JOBZ    (input) CHARACTER*1 */
/*          = 'N':  Compute eigenvalues only; */
/*          = 'V':  Compute eigenvalues and eigenvectors. */

/*  RANGE   (input) CHARACTER*1 */
/*          = 'A': all eigenvalues will be found. */
/*          = 'V': all eigenvalues in the half-open interval (VL,VU] */
/*                 will be found. */
/*          = 'I': the IL-th through IU-th eigenvalues will be found. */

/*  UPLO    (input) CHARACTER*1 */
/*          = 'U':  Upper triangle of A and B are stored; */
/*          = 'L':  Lower triangle of A and B are stored. */

/*  N       (input) INTEGER */
/*          The order of the matrix pencil (A,B).  N >= 0. */

/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/*          On entry, the symmetric matrix A.  If UPLO = 'U', the */
/*          leading N-by-N upper triangular part of A contains the */
/*          upper triangular part of the matrix A.  If UPLO = 'L', */
/*          the leading N-by-N lower triangular part of A contains */
/*          the lower triangular part of the matrix A. */

/*          On exit, the lower triangle (if UPLO='L') or the upper */
/*          triangle (if UPLO='U') of A, including the diagonal, is */
/*          destroyed. */

/*  LDA     (input) INTEGER */
/*          The leading dimension of the array A.  LDA >= max(1,N). */

/*  B       (input/output) DOUBLE PRECISION array, dimension (LDA, N) */
/*          On entry, the symmetric matrix B.  If UPLO = 'U', the */
/*          leading N-by-N upper triangular part of B contains the */
/*          upper triangular part of the matrix B.  If UPLO = 'L', */
/*          the leading N-by-N lower triangular part of B contains */
/*          the lower triangular part of the matrix B. */

/*          On exit, if INFO <= N, the part of B containing the matrix is */
/*          overwritten by the triangular factor U or L from the Cholesky */
/*          factorization B = U**T*U or B = L*L**T. */

/*  LDB     (input) INTEGER */
/*          The leading dimension of the array B.  LDB >= max(1,N). */

/*  VL      (input) DOUBLE PRECISION */
/*  VU      (input) DOUBLE PRECISION */
/*          If RANGE='V', the lower and upper bounds of the interval to */
/*          be searched for eigenvalues. VL < VU. */
/*          Not referenced if RANGE = 'A' or 'I'. */

/*  IL      (input) INTEGER */
/*  IU      (input) INTEGER */
/*          If RANGE='I', the indices (in ascending order) of the */
/*          smallest and largest eigenvalues to be returned. */
/*          1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0. */
/*          Not referenced if RANGE = 'A' or 'V'. */

/*  ABSTOL  (input) DOUBLE PRECISION */
/*          The absolute error tolerance for the eigenvalues. */
/*          An approximate eigenvalue is accepted as converged */
/*          when it is determined to lie in an interval [a,b] */
/*          of width less than or equal to */

/*                  ABSTOL + EPS *   max( |a|,|b| ) , */

/*          where EPS is the machine precision.  If ABSTOL is less than */
/*          or equal to zero, then  EPS*|T|  will be used in its place, */
/*          where |T| is the 1-norm of the tridiagonal matrix obtained */
/*          by reducing A to tridiagonal form. */

/*          Eigenvalues will be computed most accurately when ABSTOL is */
/*          set to twice the underflow threshold 2*DLAMCH('S'), not zero. */
/*          If this routine returns with INFO>0, indicating that some */
/*          eigenvectors did not converge, try setting ABSTOL to */
/*          2*DLAMCH('S'). */

/*  M       (output) INTEGER */
/*          The total number of eigenvalues found.  0 <= M <= N. */
/*          If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */

/*  W       (output) DOUBLE PRECISION array, dimension (N) */
/*          On normal exit, the first M elements contain the selected */
/*          eigenvalues in ascending order. */

/*  Z       (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M)) */
/*          If JOBZ = 'N', then Z is not referenced. */
/*          If JOBZ = 'V', then if INFO = 0, the first M columns of Z */
/*          contain the orthonormal eigenvectors of the matrix A */
/*          corresponding to the selected eigenvalues, with the i-th */
/*          column of Z holding the eigenvector associated with W(i). */
/*          The eigenvectors are normalized as follows: */
/*          if ITYPE = 1 or 2, Z**T*B*Z = I; */
/*          if ITYPE = 3, Z**T*inv(B)*Z = I. */

/*          If an eigenvector fails to converge, then that column of Z */
/*          contains the latest approximation to the eigenvector, and the */
/*          index of the eigenvector is returned in IFAIL. */
/*          Note: the user must ensure that at least max(1,M) columns are */
/*          supplied in the array Z; if RANGE = 'V', the exact value of M */
/*          is not known in advance and an upper bound must be used. */

/*  LDZ     (input) INTEGER */
/*          The leading dimension of the array Z.  LDZ >= 1, and if */
/*          JOBZ = 'V', LDZ >= max(1,N). */

/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (LWORK) */
/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */

/*  LWORK   (input) INTEGER */
/*          The length of the array WORK.  LWORK >= max(1,8*N). */
/*          For optimal efficiency, LWORK >= (NB+3)*N, */
/*          where NB is the blocksize for DSYTRD returned by ILAENV. */

/*          If LWORK = -1, then a workspace query is assumed; the routine */
/*          only calculates the optimal size of the WORK array, returns */
/*          this value as the first entry of the WORK array, and no error */
/*          message related to LWORK is issued by XERBLA. */

/*  IWORK   (workspace) INTEGER array, dimension (5*N) */

/*  IFAIL   (output) INTEGER array, dimension (N) */
/*          If JOBZ = 'V', then if INFO = 0, the first M elements of */
/*          IFAIL are zero.  If INFO > 0, then IFAIL contains the */
/*          indices of the eigenvectors that failed to converge. */
/*          If JOBZ = 'N', then IFAIL is not referenced. */

/*  INFO    (output) INTEGER */
/*          = 0:  successful exit */
/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
/*          > 0:  DPOTRF or DSYEVX returned an error code: */
/*             <= N:  if INFO = i, DSYEVX failed to converge; */
/*                    i eigenvectors failed to converge.  Their indices */
/*                    are stored in array IFAIL. */
/*             > N:   if INFO = N + i, for 1 <= i <= N, then the leading */
/*                    minor of order i of B is not positive definite. */
/*                    The factorization of B could not be completed and */
/*                    no eigenvalues or eigenvectors were computed. */

/*  Further Details */
/*  =============== */

/*  Based on contributions by */
/*     Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA */

/* ===================================================================== */

/*     .. Parameters .. */
/*     .. */
/*     .. Local Scalars .. */
/*     .. */
/*     .. External Functions .. */
/*     .. */
/*     .. External Subroutines .. */
/*     .. */
/*     .. Intrinsic Functions .. */
/*     .. */
/*     .. Executable Statements .. */

/*     Test the input parameters. */

    /* Parameter adjustments */
    a_dim1 = *lda;
    a_offset = 1 + a_dim1;
    a -= a_offset;
    b_dim1 = *ldb;
    b_offset = 1 + b_dim1;
    b -= b_offset;
    --w;
    z_dim1 = *ldz;
    z_offset = 1 + z_dim1;
    z__ -= z_offset;
    --work;
    --iwork;
    --ifail;

    /* Function Body */
    upper = lsame_(uplo, "U", (ftnlen)1, (ftnlen)1);
    wantz = lsame_(jobz, "V", (ftnlen)1, (ftnlen)1);
    alleig = lsame_(range, "A", (ftnlen)1, (ftnlen)1);
    valeig = lsame_(range, "V", (ftnlen)1, (ftnlen)1);
    indeig = lsame_(range, "I", (ftnlen)1, (ftnlen)1);
    lquery = *lwork == -1;

    *info = 0;
    if (*itype < 0 || *itype > 3) {
	*info = -1;
    } else if (! (wantz || lsame_(jobz, "N", (ftnlen)1, (ftnlen)1))) {
	*info = -2;
    } else if (! (alleig || valeig || indeig)) {
	*info = -3;
    } else if (! (upper || lsame_(uplo, "L", (ftnlen)1, (ftnlen)1))) {
	*info = -4;
    } else if (*n < 0) {
	*info = -5;
    } else if (*lda < max(1,*n)) {
	*info = -7;
    } else if (*ldb < max(1,*n)) {
	*info = -9;
    } else if (valeig && *n > 0) {
	if (*vu <= *vl) {
	    *info = -11;
	}
    } else if (indeig && *il < 1) {
	*info = -12;
    } else if (indeig && (*iu < min(*n,*il) || *iu > *n)) {
	*info = -13;
    } else if (*ldz < 1 || wantz && *ldz < *n) {
	*info = -18;
    } else /* if(complicated condition) */ {
/* Computing MAX */
	i__1 = 1, i__2 = *n << 3;
	if (*lwork < max(i__1,i__2) && ! lquery) {
	    *info = -20;
	}
    }

    if (*info == 0) {
	nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6,
		 (ftnlen)1);
	lwkopt = (nb + 3) * *n;
	work[1] = (doublereal) lwkopt;
    }

    if (*info != 0) {
	i__1 = -(*info);
	xerbla_("DSYGVX", &i__1, (ftnlen)6);
	return 0;
    } else if (lquery) {
	return 0;
    }

/*     Quick return if possible */

    *m = 0;
    if (*n == 0) {
	work[1] = 1.;
	return 0;
    }

/*     Form a Cholesky factorization of B. */

    dpotrf_(uplo, n, &b[b_offset], ldb, info, (ftnlen)1);
    if (*info != 0) {
	*info = *n + *info;
	return 0;
    }

/*     Transform problem to standard eigenvalue problem and solve. */

    dsygst_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info, (
	    ftnlen)1);
    dsyevx_(jobz, range, uplo, n, &a[a_offset], lda, vl, vu, il, iu, abstol, 
	    m, &w[1], &z__[z_offset], ldz, &work[1], lwork, &iwork[1], &ifail[
	    1], info, (ftnlen)1, (ftnlen)1, (ftnlen)1);
    lopt = (integer) work[1];

    if (wantz) {

/*        Backtransform eigenvectors to the original problem. */

	if (*info > 0) {
	    *m = *info - 1;
	}
	if (*itype == 1 || *itype == 2) {

/*           For A*x=(lambda)*B*x and A*B*x=(lambda)*x; */
/*           backtransform eigenvectors: x = inv(L)'*y or inv(U)*y */

	    if (upper) {
		*(unsigned char *)trans = 'N';
	    } else {
		*(unsigned char *)trans = 'T';
	    }

	    dtrsm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
		    , ldb, &z__[z_offset], ldz, (ftnlen)4, (ftnlen)1, (ftnlen)
		    1, (ftnlen)8);

	} else if (*itype == 3) {

/*           For B*A*x=(lambda)*x; */
/*           backtransform eigenvectors: x = L*y or U'*y */

	    if (upper) {
		*(unsigned char *)trans = 'T';
	    } else {
		*(unsigned char *)trans = 'N';
	    }

	    dtrmm_("Left", uplo, trans, "Non-unit", n, m, &c_b19, &b[b_offset]
		    , ldb, &z__[z_offset], ldz, (ftnlen)4, (ftnlen)1, (ftnlen)
		    1, (ftnlen)8);
	}
    }

/*     Set WORK(1) to optimal workspace size. */

    work[1] = (doublereal) lwkopt;

    return 0;

/*     End of DSYGVX */

} /* dsygvx_ */
Ejemplo n.º 5
0
int  matrix_dsyevx(bool             compute_eig_vectors , 
                   dsyevx_eig_enum  which_values        , /* DSYEVX | DSYEVX_VALUE_INTERVAL | DSYEVX_INDEX_INTERVAL */ 
                   dsyevx_uplo_enum uplo, 
                   matrix_type    * A ,                   /* The input matrix - is modified by the dsyevx() function. */ 
                   double VL          ,                   /* Lower limit when using DSYEVX_VALUE_INTERVAL */
                   double VU          ,                   /* Upper limit when using DSYEVX_VALUE_INTERVAL */
                   int    IL          ,                   /* Lower index when using DSYEVX_INDEX_INTERVAL */ 
                   int    IU          ,                   /* Upper index when using DSYEVX_INDEX_INTERVAL */
                   double *eig_values ,                   /* The calcualated eigenvalues                  */
                   matrix_type * Z    ) {                 /* The eigenvectors as columns vectors          */ 

  int lda  = matrix_get_column_stride( A );
  int n    = matrix_get_rows( A );
  char jobz;
  char range;
  char uplo_c;
  
  if (compute_eig_vectors)
    jobz = 'V';
  else
    jobz = 'N';
  
  switch(which_values) {
  case(DSYEVX_ALL):
    range = 'A';
    break;
  case(DSYEVX_VALUE_INTERVAL):
    range = 'V';
    break;
  case(DSYEVX_INDEX_INTERVAL):
    range = 'I';
    break;
  default:
    util_abort("%s: internal error \n",__func__);
  }

  if (uplo == DSYEVX_AUPPER)
    uplo_c = 'U';
  else if (uplo == DSYEVX_ALOWER)
    uplo_c = 'L';
  else
    util_abort("%s: internal error \n",__func__);
  
  
  if (!matrix_is_quadratic( A ))
    util_abort("%s: matrix A must be quadratic \n",__func__);
  
  {
    int      num_eigenvalues , ldz, info , worksize;
    int    * ifail = util_calloc( n     , sizeof * ifail );
    int    * iwork = util_calloc( 5 * n , sizeof * iwork );
    double * work  = util_calloc( 1     , sizeof * work  );
    double * z_data;
    double   abstol = 0.0; /* SHopuld */


    if (compute_eig_vectors) {
      ldz    = matrix_get_column_stride( Z );
      z_data = matrix_get_data( Z );
    } else {
      /* In this case we can accept that Z == NULL */
      ldz    = 1;
      z_data = NULL;
    }
    
    /* First call to determine optimal worksize. */
    worksize = -1;
    info     = 0;
    dsyevx_( &jobz,                /*  1 */
             &range,               /*  2 */
             &uplo_c,              /*  3 */
             &n,                   /*  4 */   
             matrix_get_data( A ), /*  5 */
             &lda ,                /*  6 */
             &VL ,                 /*  7 */
             &VU ,                 /*  8 */
             &IL ,                 /*  9 */
             &IU ,                 /* 10 */   
             &abstol ,             /* 11 */
             &num_eigenvalues ,    /* 12 */
             eig_values ,          /* 13 */
             z_data ,              /* 14 */
             &ldz ,                /* 15 */
             work ,                /* 16 */
             &worksize ,           /* 17 */
             iwork ,               /* 18 */
             ifail ,               /* 19 */
             &info);               /* 20 */
    
    
    worksize = (int) work[0];
    {
      double * tmp = realloc(work , sizeof * work * worksize );
      if (tmp == NULL) {
        /* 
           OK - we could not get the optimal worksize, 
           try again with the minimum.
        */
        worksize = 8 * n;
        work = util_realloc(work , sizeof * work * worksize );
      } else
        work = tmp; /* The request for optimal worksize succeeded */
    }
    /* Second call: do the job */
    info     = 0;
    dsyevx_( &jobz,
             &range,
             &uplo_c,
             &n,
             matrix_get_data( A ),
             &lda , 
             &VL ,
             &VU , 
             &IL , 
             &IU , 
             &abstol , 
             &num_eigenvalues , 
             eig_values ,  
             z_data , 
             &ldz , 
             work , 
             &worksize , 
             iwork , 
             ifail , 
             &info);

    free( ifail );
    free( work );
    free( iwork );
    return num_eigenvalues;
  }
}