/* Subroutine */ int chbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; /* Local variables */ integer inde; char vect[1]; integer llwk2; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); integer iinfo, lwmin; logical upper; integer llrwk; logical wantz; integer indwk2; extern /* Subroutine */ int cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, integer *), chbgst_(char *, char *, integer *, integer *, integer *, complex * , integer *, complex *, integer *, complex *, integer *, complex * , real *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *), cpbstf_(char *, integer *, integer *, complex *, integer *, integer *); integer indwrk, liwmin; extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *); integer lrwmin; logical lquery; /* -- 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 .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; bb_dim1 = *ldbb; bb_offset = 1 + bb_dim1; bb -= bb_offset; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; *info = 0; if (*n <= 1) { lwmin = *n + 1; lrwmin = *n + 1; liwmin = 1; } else if (wantz) { /* Computing 2nd power */ i__1 = *n; lwmin = i__1 * i__1 << 1; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n; lrwmin = *n; liwmin = 1; } if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (upper || lsame_(uplo, "L"))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ka < 0) { *info = -4; } else if (*kb < 0 || *kb > *ka) { *info = -5; } else if (*ldab < *ka + 1) { *info = -7; } else if (*ldbb < *kb + 1) { *info = -9; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -12; } if (*info == 0) { work[1].r = (real) lwmin; work[1].i = 0.f; // , expr subst rwork[1] = (real) lrwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -14; } else if (*lrwork < lrwmin && ! lquery) { *info = -16; } else if (*liwork < liwmin && ! lquery) { *info = -18; } } if (*info != 0) { i__1 = -(*info); xerbla_("CHBGVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a split Cholesky factorization of B. */ cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem. */ inde = 1; indwrk = inde + *n; indwk2 = *n * *n + 1; llwk2 = *lwork - indwk2 + 2; llrwk = *lrwork - indwrk + 2; chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo); /* Reduce Hermitian band matrix to tridiagonal form. */ if (wantz) { *(unsigned char *)vect = 'U'; } else { *(unsigned char *)vect = 'N'; } chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], & z__[z_offset], ldz, &work[1], &iinfo); /* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */ if (! wantz) { ssterf_(n, &w[1], &rwork[inde], info); } else { cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], & llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info); cgemm_("N", "N", n, n, n, &c_b1, &z__[z_offset], ldz, &work[1], n, & c_b2, &work[indwk2], n); clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); } work[1].r = (real) lwmin; work[1].i = 0.f; // , expr subst rwork[1] = (real) lrwmin; iwork[1] = liwmin; return 0; /* End of CHBGVD */ }
/* Subroutine */ int chbgvd_(char *jobz, char *uplo, integer *n, integer *ka, integer *kb, complex *ab, integer *ldab, complex *bb, integer *ldbb, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info) { /* System generated locals */ integer ab_dim1, ab_offset, bb_dim1, bb_offset, z_dim1, z_offset, i__1; /* Local variables */ integer inde; char vect[1]; integer llwk2; integer iinfo, lwmin; logical upper; integer llrwk; logical wantz; integer indwk2; integer indwrk, liwmin; integer lrwmin; logical lquery; /* -- LAPACK driver routine (version 3.2) -- */ /* November 2006 */ /* Purpose */ /* ======= */ /* CHBGVD computes all the eigenvalues, and optionally, the eigenvectors */ /* of a complex generalized Hermitian-definite banded eigenproblem, of */ /* the form A*x=(lambda)*B*x. Here A and B are assumed to be Hermitian */ /* and banded, and B is also positive definite. If eigenvectors are */ /* desired, it uses a divide and conquer algorithm. */ /* The divide and conquer algorithm makes very mild assumptions about */ /* floating point arithmetic. It will work on machines with a guard */ /* digit in add/subtract, or on those binary machines without guard */ /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ /* without guard digits, but we know of none. */ /* Arguments */ /* ========= */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangles of A and B are stored; */ /* = 'L': Lower triangles of A and B are stored. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* KA (input) INTEGER */ /* The number of superdiagonals of the matrix A if UPLO = 'U', */ /* or the number of subdiagonals if UPLO = 'L'. KA >= 0. */ /* KB (input) INTEGER */ /* The number of superdiagonals of the matrix B if UPLO = 'U', */ /* or the number of subdiagonals if UPLO = 'L'. KB >= 0. */ /* AB (input/output) COMPLEX array, dimension (LDAB, N) */ /* On entry, the upper or lower triangle of the Hermitian band */ /* matrix A, stored in the first ka+1 rows of the array. The */ /* j-th column of A is stored in the j-th column of the array AB */ /* as follows: */ /* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka). */ /* On exit, the contents of AB are destroyed. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KA+1. */ /* BB (input/output) COMPLEX array, dimension (LDBB, N) */ /* On entry, the upper or lower triangle of the Hermitian band */ /* matrix B, stored in the first kb+1 rows of the array. The */ /* j-th column of B is stored in the j-th column of the array BB */ /* as follows: */ /* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j; */ /* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb). */ /* On exit, the factor S from the split Cholesky factorization */ /* B = S**H*S, as returned by CPBSTF. */ /* LDBB (input) INTEGER */ /* The leading dimension of the array BB. LDBB >= KB+1. */ /* W (output) REAL array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* Z (output) COMPLEX array, dimension (LDZ, N) */ /* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of */ /* eigenvectors, with the i-th column of Z holding the */ /* eigenvector associated with W(i). The eigenvectors are */ /* normalized so that Z**H*B*Z = I. */ /* If JOBZ = 'N', then Z is not referenced. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= N. */ /* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO=0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* If N <= 1, LWORK >= 1. */ /* If JOBZ = 'N' and N > 1, LWORK >= N. */ /* If JOBZ = 'V' and N > 1, LWORK >= 2*N**2. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal sizes of the WORK, RWORK and */ /* IWORK arrays, returns these values as the first entries of */ /* the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */ /* On exit, if INFO=0, RWORK(1) returns the optimal LRWORK. */ /* LRWORK (input) INTEGER */ /* The dimension of array RWORK. */ /* If N <= 1, LRWORK >= 1. */ /* If JOBZ = 'N' and N > 1, LRWORK >= N. */ /* If JOBZ = 'V' and N > 1, LRWORK >= 1 + 5*N + 2*N**2. */ /* If LRWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO=0, IWORK(1) returns the optimal LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of array IWORK. */ /* If JOBZ = 'N' or N <= 1, LIWORK >= 1. */ /* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N. */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i, and i is: */ /* <= N: the algorithm failed to converge: */ /* i off-diagonal elements of an intermediate */ /* tridiagonal form did not converge to zero; */ /* > N: if INFO = N + i, for 1 <= i <= N, then CPBSTF */ /* returned INFO = i: 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 */ /* ===================================================================== */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; bb_dim1 = *ldbb; bb_offset = 1 + bb_dim1; bb -= bb_offset; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); upper = lsame_(uplo, "U"); lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; *info = 0; if (*n <= 1) { lwmin = 1; lrwmin = 1; liwmin = 1; } else if (wantz) { /* Computing 2nd power */ i__1 = *n; lwmin = i__1 * i__1 << 1; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n; lrwmin = *n; liwmin = 1; } if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (upper || lsame_(uplo, "L"))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ka < 0) { *info = -4; } else if (*kb < 0 || *kb > *ka) { *info = -5; } else if (*ldab < *ka + 1) { *info = -7; } else if (*ldbb < *kb + 1) { *info = -9; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -12; } if (*info == 0) { work[1].r = (real) lwmin, work[1].i = 0.f; rwork[1] = (real) lrwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -14; } else if (*lrwork < lrwmin && ! lquery) { *info = -16; } else if (*liwork < liwmin && ! lquery) { *info = -18; } } if (*info != 0) { i__1 = -(*info); xerbla_("CHBGVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Form a split Cholesky factorization of B. */ cpbstf_(uplo, n, kb, &bb[bb_offset], ldbb, info); if (*info != 0) { *info = *n + *info; return 0; } /* Transform problem to standard eigenvalue problem. */ inde = 1; indwrk = inde + *n; indwk2 = *n * *n + 1; llwk2 = *lwork - indwk2 + 2; llrwk = *lrwork - indwrk + 2; chbgst_(jobz, uplo, n, ka, kb, &ab[ab_offset], ldab, &bb[bb_offset], ldbb, &z__[z_offset], ldz, &work[1], &rwork[indwrk], &iinfo); /* Reduce Hermitian band matrix to tridiagonal form. */ if (wantz) { *(unsigned char *)vect = 'U'; } else { *(unsigned char *)vect = 'N'; } chbtrd_(vect, uplo, n, ka, &ab[ab_offset], ldab, &w[1], &rwork[inde], & z__[z_offset], ldz, &work[1], &iinfo); /* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */ if (! wantz) { ssterf_(n, &w[1], &rwork[inde], info); } else { cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], & llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info); cgemm_("N", "N", n, n, n, &c_b1, &z__[z_offset], ldz, &work[1], n, & c_b2, &work[indwk2], n); clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); } work[1].r = (real) lwmin, work[1].i = 0.f; rwork[1] = (real) lrwmin; iwork[1] = liwmin; return 0; /* End of CHBGVD */ } /* chbgvd_ */
/* Subroutine */ int chpevd_(char *jobz, char *uplo, integer *n, complex *ap, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info) { /* System generated locals */ integer z_dim1, z_offset, i__1; real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ real eps; integer inde; real anrm; integer imax; real rmin, rmax, sigma; extern logical lsame_(char *, char *); integer iinfo; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); integer lwmin, llrwk, llwrk; logical wantz; integer iscale; extern real clanhp_(char *, char *, integer *, complex *, real *); extern /* Subroutine */ int cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *); extern real slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *); real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); real bignum; integer indtau; extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *, real *, complex *, integer *); integer indrwk, indwrk, liwmin; extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *); integer lrwmin; extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *, integer *, complex *, complex *, complex *, integer *, complex *, integer *); real smlnum; logical lquery; /* -- 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 */ --ap; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; *info = 0; if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (lsame_(uplo, "L") || lsame_(uplo, "U"))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -7; } if (*info == 0) { if (*n <= 1) { lwmin = 1; liwmin = 1; lrwmin = 1; } else { if (wantz) { lwmin = *n << 1; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n; lrwmin = *n; liwmin = 1; } } work[1].r = (real) lwmin; work[1].i = 0.f; // , expr subst rwork[1] = (real) lrwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -9; } else if (*lrwork < lrwmin && ! lquery) { *info = -11; } else if (*liwork < liwmin && ! lquery) { *info = -13; } } if (*info != 0) { i__1 = -(*info); xerbla_("CHPEVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { w[1] = ap[1].r; if (wantz) { i__1 = z_dim1 + 1; z__[i__1].r = 1.f; z__[i__1].i = 0.f; // , expr subst } return 0; } /* Get machine constants. */ safmin = slamch_("Safe minimum"); eps = slamch_("Precision"); smlnum = safmin / eps; bignum = 1.f / smlnum; rmin = sqrt(smlnum); rmax = sqrt(bignum); /* Scale matrix to allowable range, if necessary. */ anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]); iscale = 0; if (anrm > 0.f && anrm < rmin) { iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { iscale = 1; sigma = rmax / anrm; } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; csscal_(&i__1, &sigma, &ap[1], &c__1); } /* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */ inde = 1; indtau = 1; indrwk = inde + *n; indwrk = indtau + *n; llwrk = *lwork - indwrk + 1; llrwk = *lrwork - indrwk + 1; chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo); /* For eigenvalues only, call SSTERF. For eigenvectors, first call */ /* CUPGTR to generate the orthogonal matrix, then call CSTEDC. */ if (! wantz) { ssterf_(n, &w[1], &rwork[inde], info); } else { cstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[ indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork, info); cupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[indwrk], &iinfo); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { if (*info == 0) { imax = *n; } else { imax = *info - 1; } r__1 = 1.f / sigma; sscal_(&imax, &r__1, &w[1], &c__1); } work[1].r = (real) lwmin; work[1].i = 0.f; // , expr subst rwork[1] = (real) lrwmin; iwork[1] = liwmin; return 0; /* End of CHPEVD */ }
/* Subroutine */ int chpevd_(char *jobz, char *uplo, integer *n, complex *ap, real *w, complex *z__, integer *ldz, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info) { /* System generated locals */ integer z_dim1, z_offset, i__1; real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ real eps; integer inde; real anrm; integer imax; real rmin, rmax, sigma; extern logical lsame_(char *, char *); integer iinfo; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); integer lwmin, llrwk, llwrk; logical wantz; integer iscale; extern doublereal clanhp_(char *, char *, integer *, complex *, real *); extern /* Subroutine */ int cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *); real safmin; extern /* Subroutine */ int xerbla_(char *, integer *); real bignum; integer indtau; extern /* Subroutine */ int chptrd_(char *, integer *, complex *, real *, real *, complex *, integer *); integer indrwk, indwrk, liwmin; extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *); integer lrwmin; extern /* Subroutine */ int cupmtr_(char *, char *, char *, integer *, integer *, complex *, complex *, complex *, integer *, complex *, integer *); real smlnum; logical lquery; /* -- LAPACK driver routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHPEVD computes all the eigenvalues and, optionally, eigenvectors of */ /* a complex Hermitian matrix A in packed storage. If eigenvectors are */ /* desired, it uses a divide and conquer algorithm. */ /* The divide and conquer algorithm makes very mild assumptions about */ /* floating point arithmetic. It will work on machines with a guard */ /* digit in add/subtract, or on those binary machines without guard */ /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ /* without guard digits, but we know of none. */ /* Arguments */ /* ========= */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* AP (input/output) COMPLEX array, dimension (N*(N+1)/2) */ /* On entry, the upper or lower triangle of the Hermitian matrix */ /* A, packed columnwise in a linear array. The j-th column of A */ /* is stored in the array AP as follows: */ /* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j; */ /* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n. */ /* On exit, AP is overwritten by values generated during the */ /* reduction to tridiagonal form. If UPLO = 'U', the diagonal */ /* and first superdiagonal of the tridiagonal matrix T overwrite */ /* the corresponding elements of A, and if UPLO = 'L', the */ /* diagonal and first subdiagonal of T overwrite the */ /* corresponding elements of A. */ /* W (output) REAL array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* Z (output) COMPLEX array, dimension (LDZ, N) */ /* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ /* eigenvectors of the matrix A, with the i-th column of Z */ /* holding the eigenvector associated with W(i). */ /* If JOBZ = 'N', then Z is not referenced. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= max(1,N). */ /* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the required LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of array WORK. */ /* If N <= 1, LWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LWORK must be at least N. */ /* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the required sizes of the WORK, RWORK and */ /* IWORK arrays, returns these values as the first entries of */ /* the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* RWORK (workspace/output) REAL array, dimension (MAX(1,LRWORK)) */ /* On exit, if INFO = 0, RWORK(1) returns the required LRWORK. */ /* LRWORK (input) INTEGER */ /* The dimension of array RWORK. */ /* If N <= 1, LRWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */ /* If JOBZ = 'V' and N > 1, LRWORK must be at least */ /* 1 + 5*N + 2*N**2. */ /* If LRWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the required sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO = 0, IWORK(1) returns the required LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of array IWORK. */ /* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ /* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the required sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the algorithm failed to converge; i */ /* off-diagonal elements of an intermediate tridiagonal */ /* form did not converge to zero. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ --ap; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; *info = 0; if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (lsame_(uplo, "L") || lsame_(uplo, "U"))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -7; } if (*info == 0) { if (*n <= 1) { lwmin = 1; liwmin = 1; lrwmin = 1; } else { if (wantz) { lwmin = *n << 1; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n; lrwmin = *n; liwmin = 1; } } work[1].r = (real) lwmin, work[1].i = 0.f; rwork[1] = (real) lrwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -9; } else if (*lrwork < lrwmin && ! lquery) { *info = -11; } else if (*liwork < liwmin && ! lquery) { *info = -13; } } if (*info != 0) { i__1 = -(*info); xerbla_("CHPEVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { w[1] = ap[1].r; if (wantz) { i__1 = z_dim1 + 1; z__[i__1].r = 1.f, z__[i__1].i = 0.f; } return 0; } /* Get machine constants. */ safmin = slamch_("Safe minimum"); eps = slamch_("Precision"); smlnum = safmin / eps; bignum = 1.f / smlnum; rmin = sqrt(smlnum); rmax = sqrt(bignum); /* Scale matrix to allowable range, if necessary. */ anrm = clanhp_("M", uplo, n, &ap[1], &rwork[1]); iscale = 0; if (anrm > 0.f && anrm < rmin) { iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { iscale = 1; sigma = rmax / anrm; } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; csscal_(&i__1, &sigma, &ap[1], &c__1); } /* Call CHPTRD to reduce Hermitian packed matrix to tridiagonal form. */ inde = 1; indtau = 1; indrwk = inde + *n; indwrk = indtau + *n; llwrk = *lwork - indwrk + 1; llrwk = *lrwork - indrwk + 1; chptrd_(uplo, n, &ap[1], &w[1], &rwork[inde], &work[indtau], &iinfo); /* For eigenvalues only, call SSTERF. For eigenvectors, first call */ /* CUPGTR to generate the orthogonal matrix, then call CSTEDC. */ if (! wantz) { ssterf_(n, &w[1], &rwork[inde], info); } else { cstedc_("I", n, &w[1], &rwork[inde], &z__[z_offset], ldz, &work[ indwrk], &llwrk, &rwork[indrwk], &llrwk, &iwork[1], liwork, info); cupmtr_("L", uplo, "N", n, n, &ap[1], &work[indtau], &z__[z_offset], ldz, &work[indwrk], &iinfo); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { if (*info == 0) { imax = *n; } else { imax = *info - 1; } r__1 = 1.f / sigma; sscal_(&imax, &r__1, &w[1], &c__1); } work[1].r = (real) lwmin, work[1].i = 0.f; rwork[1] = (real) lrwmin; iwork[1] = liwmin; return 0; /* End of CHPEVD */ } /* chpevd_ */
/* Subroutine */ int cheevd_(char *jobz, char *uplo, integer *n, complex *a, integer *lda, real *w, complex *work, integer *lwork, real *rwork, integer *lrwork, integer *iwork, integer *liwork, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2; real r__1; /* Builtin functions */ double sqrt(doublereal); /* Local variables */ real eps; integer inde; real anrm; integer imax; real rmin, rmax; integer lopt; real sigma; extern logical lsame_(char *, char *); integer iinfo; extern /* Subroutine */ int sscal_(integer *, real *, real *, integer *); integer lwmin, liopt; logical lower; integer llrwk, lropt; logical wantz; integer indwk2, llwrk2; extern doublereal clanhe_(char *, char *, integer *, complex *, integer *, real *); integer iscale; extern /* Subroutine */ int clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *), cstedc_(char *, integer *, real *, real *, complex *, integer *, complex *, integer *, real *, integer *, integer *, integer *, integer *); extern doublereal slamch_(char *); extern /* Subroutine */ int chetrd_(char *, integer *, complex *, integer *, real *, real *, complex *, complex *, integer *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *); real safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); extern /* Subroutine */ int xerbla_(char *, integer *); real bignum; integer indtau, indrwk, indwrk, liwmin; extern /* Subroutine */ int ssterf_(integer *, real *, real *, integer *); integer lrwmin; extern /* Subroutine */ int cunmtr_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); integer llwork; real smlnum; logical lquery; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHEEVD computes all eigenvalues and, optionally, eigenvectors of a */ /* complex Hermitian matrix A. If eigenvectors are desired, it uses a */ /* divide and conquer algorithm. */ /* The divide and conquer algorithm makes very mild assumptions about */ /* floating point arithmetic. It will work on machines with a guard */ /* digit in add/subtract, or on those binary machines without guard */ /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ /* without guard digits, but we know of none. */ /* Arguments */ /* ========= */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA, N) */ /* On entry, the Hermitian 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, if JOBZ = 'V', then if INFO = 0, A contains the */ /* orthonormal eigenvectors of the matrix A. */ /* If JOBZ = 'N', then 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). */ /* W (output) REAL array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The length of the array WORK. */ /* If N <= 1, LWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LWORK must be at least N + 1. */ /* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N + N**2. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal sizes of the WORK, RWORK and */ /* IWORK arrays, returns these values as the first entries of */ /* the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* RWORK (workspace/output) REAL array, */ /* dimension (LRWORK) */ /* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */ /* LRWORK (input) INTEGER */ /* The dimension of the array RWORK. */ /* If N <= 1, LRWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */ /* If JOBZ = 'V' and N > 1, LRWORK must be at least */ /* 1 + 5*N + 2*N**2. */ /* If LRWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of the array IWORK. */ /* If N <= 1, LIWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LIWORK must be at least 1. */ /* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N. */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed */ /* to converge; i off-diagonal elements of an intermediate */ /* tridiagonal form did not converge to zero; */ /* if INFO = i and JOBZ = 'V', then the algorithm failed */ /* to compute an eigenvalue while working on the submatrix */ /* lying in rows and columns INFO/(N+1) through */ /* mod(INFO,N+1). */ /* Further Details */ /* =============== */ /* Based on contributions by */ /* Jeff Rutter, Computer Science Division, University of California */ /* at Berkeley, USA */ /* Modified description of INFO. Sven, 16 Feb 05. */ /* ===================================================================== */ /* .. 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; --w; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); lower = lsame_(uplo, "L"); lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; *info = 0; if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (lower || lsame_(uplo, "U"))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } if (*info == 0) { if (*n <= 1) { lwmin = 1; lrwmin = 1; liwmin = 1; lopt = lwmin; lropt = lrwmin; liopt = liwmin; } else { if (wantz) { lwmin = (*n << 1) + *n * *n; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n + 1; lrwmin = *n; liwmin = 1; } /* Computing MAX */ i__1 = lwmin, i__2 = *n + ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1); lopt = max(i__1,i__2); lropt = lrwmin; liopt = liwmin; } work[1].r = (real) lopt, work[1].i = 0.f; rwork[1] = (real) lropt; iwork[1] = liopt; if (*lwork < lwmin && ! lquery) { *info = -8; } else if (*lrwork < lrwmin && ! lquery) { *info = -10; } else if (*liwork < liwmin && ! lquery) { *info = -12; } } if (*info != 0) { i__1 = -(*info); xerbla_("CHEEVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { i__1 = a_dim1 + 1; w[1] = a[i__1].r; if (wantz) { i__1 = a_dim1 + 1; a[i__1].r = 1.f, a[i__1].i = 0.f; } return 0; } /* Get machine constants. */ safmin = slamch_("Safe minimum"); eps = slamch_("Precision"); smlnum = safmin / eps; bignum = 1.f / smlnum; rmin = sqrt(smlnum); rmax = sqrt(bignum); /* Scale matrix to allowable range, if necessary. */ anrm = clanhe_("M", uplo, n, &a[a_offset], lda, &rwork[1]); iscale = 0; if (anrm > 0.f && anrm < rmin) { iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { iscale = 1; sigma = rmax / anrm; } if (iscale == 1) { clascl_(uplo, &c__0, &c__0, &c_b18, &sigma, n, n, &a[a_offset], lda, info); } /* Call CHETRD to reduce Hermitian matrix to tridiagonal form. */ inde = 1; indtau = 1; indwrk = indtau + *n; indrwk = inde + *n; indwk2 = indwrk + *n * *n; llwork = *lwork - indwrk + 1; llwrk2 = *lwork - indwk2 + 1; llrwk = *lrwork - indrwk + 1; chetrd_(uplo, n, &a[a_offset], lda, &w[1], &rwork[inde], &work[indtau], & work[indwrk], &llwork, &iinfo); /* For eigenvalues only, call SSTERF. For eigenvectors, first call */ /* CSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the */ /* tridiagonal matrix, then call CUNMTR to multiply it to the */ /* Householder transformations represented as Householder vectors in */ /* A. */ if (! wantz) { ssterf_(n, &w[1], &rwork[inde], info); } else { cstedc_("I", n, &w[1], &rwork[inde], &work[indwrk], n, &work[indwk2], &llwrk2, &rwork[indrwk], &llrwk, &iwork[1], liwork, info); cunmtr_("L", uplo, "N", n, n, &a[a_offset], lda, &work[indtau], &work[ indwrk], n, &work[indwk2], &llwrk2, &iinfo); clacpy_("A", n, n, &work[indwrk], n, &a[a_offset], lda); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { if (*info == 0) { imax = *n; } else { imax = *info - 1; } r__1 = 1.f / sigma; sscal_(&imax, &r__1, &w[1], &c__1); } work[1].r = (real) lopt, work[1].i = 0.f; rwork[1] = (real) lropt; iwork[1] = liopt; return 0; /* End of CHEEVD */ } /* cheevd_ */
int chbevd_(char *jobz, char *uplo, int *n, int *kd, complex *ab, int *ldab, float *w, complex *z__, int *ldz, complex *work, int *lwork, float *rwork, int *lrwork, int * iwork, int *liwork, int *info) { /* System generated locals */ int ab_dim1, ab_offset, z_dim1, z_offset, i__1; float r__1; /* Builtin functions */ double sqrt(double); /* Local variables */ float eps; int inde; float anrm; int imax; float rmin, rmax; int llwk2; extern int cgemm_(char *, char *, int *, int *, int *, complex *, complex *, int *, complex *, int *, complex *, complex *, int *); float sigma; extern int lsame_(char *, char *); int iinfo; extern int sscal_(int *, float *, float *, int *); int lwmin; int lower; int llrwk; int wantz; int indwk2; extern double clanhb_(char *, char *, int *, int *, complex *, int *, float *); int iscale; extern int clascl_(char *, int *, int *, float *, float *, int *, int *, complex *, int *, int *), cstedc_(char *, int *, float *, float *, complex *, int *, complex *, int *, float *, int *, int *, int *, int *), chbtrd_(char *, char *, int *, int *, complex *, int *, float *, float *, complex *, int *, complex *, int *); extern double slamch_(char *); extern int clacpy_(char *, int *, int *, complex *, int *, complex *, int *); float safmin; extern int xerbla_(char *, int *); float bignum; int indwrk, liwmin; extern int ssterf_(int *, float *, float *, int *); int lrwmin; float smlnum; int lquery; /* -- LAPACK driver routine (version 3.2) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHBEVD computes all the eigenvalues and, optionally, eigenvectors of */ /* a complex Hermitian band matrix A. If eigenvectors are desired, it */ /* uses a divide and conquer algorithm. */ /* The divide and conquer algorithm makes very mild assumptions about */ /* floating point arithmetic. It will work on machines with a guard */ /* digit in add/subtract, or on those binary machines without guard */ /* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or */ /* Cray-2. It could conceivably fail on hexadecimal or decimal machines */ /* without guard digits, but we know of none. */ /* Arguments */ /* ========= */ /* JOBZ (input) CHARACTER*1 */ /* = 'N': Compute eigenvalues only; */ /* = 'V': Compute eigenvalues and eigenvectors. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored; */ /* = 'L': Lower triangle of A is stored. */ /* N (input) INTEGER */ /* The order of the matrix A. N >= 0. */ /* KD (input) INTEGER */ /* The number of superdiagonals of the matrix A if UPLO = 'U', */ /* or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ /* AB (input/output) COMPLEX array, dimension (LDAB, N) */ /* On entry, the upper or lower triangle of the Hermitian band */ /* matrix A, stored in the first KD+1 rows of the array. The */ /* j-th column of A is stored in the j-th column of the array AB */ /* as follows: */ /* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for MAX(1,j-kd)<=i<=j; */ /* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=MIN(n,j+kd). */ /* On exit, AB is overwritten by values generated during the */ /* reduction to tridiagonal form. If UPLO = 'U', the first */ /* superdiagonal and the diagonal of the tridiagonal matrix T */ /* are returned in rows KD and KD+1 of AB, and if UPLO = 'L', */ /* the diagonal and first subdiagonal of T are returned in the */ /* first two rows of AB. */ /* LDAB (input) INTEGER */ /* The leading dimension of the array AB. LDAB >= KD + 1. */ /* W (output) REAL array, dimension (N) */ /* If INFO = 0, the eigenvalues in ascending order. */ /* Z (output) COMPLEX array, dimension (LDZ, N) */ /* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal */ /* eigenvectors of the matrix A, with the i-th column of Z */ /* holding the eigenvector associated with W(i). */ /* If JOBZ = 'N', then Z is not referenced. */ /* LDZ (input) INTEGER */ /* The leading dimension of the array Z. LDZ >= 1, and if */ /* JOBZ = 'V', LDZ >= MAX(1,N). */ /* WORK (workspace/output) COMPLEX array, dimension (MAX(1,LWORK)) */ /* On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ /* LWORK (input) INTEGER */ /* The dimension of the array WORK. */ /* If N <= 1, LWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LWORK must be at least N. */ /* If JOBZ = 'V' and N > 1, LWORK must be at least 2*N**2. */ /* If LWORK = -1, then a workspace query is assumed; the routine */ /* only calculates the optimal sizes of the WORK, RWORK and */ /* IWORK arrays, returns these values as the first entries of */ /* the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* RWORK (workspace/output) REAL array, */ /* dimension (LRWORK) */ /* On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK. */ /* LRWORK (input) INTEGER */ /* The dimension of array RWORK. */ /* If N <= 1, LRWORK must be at least 1. */ /* If JOBZ = 'N' and N > 1, LRWORK must be at least N. */ /* If JOBZ = 'V' and N > 1, LRWORK must be at least */ /* 1 + 5*N + 2*N**2. */ /* If LRWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK)) */ /* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ /* LIWORK (input) INTEGER */ /* The dimension of array IWORK. */ /* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1. */ /* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N . */ /* If LIWORK = -1, then a workspace query is assumed; the */ /* routine only calculates the optimal sizes of the WORK, RWORK */ /* and IWORK arrays, returns these values as the first entries */ /* of the WORK, RWORK and IWORK arrays, and no error message */ /* related to LWORK or LRWORK or LIWORK is issued by XERBLA. */ /* INFO (output) INTEGER */ /* = 0: successful exit. */ /* < 0: if INFO = -i, the i-th argument had an illegal value. */ /* > 0: if INFO = i, the algorithm failed to converge; i */ /* off-diagonal elements of an intermediate tridiagonal */ /* form did not converge to zero. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ ab_dim1 = *ldab; ab_offset = 1 + ab_dim1; ab -= ab_offset; --w; z_dim1 = *ldz; z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; --iwork; /* Function Body */ wantz = lsame_(jobz, "V"); lower = lsame_(uplo, "L"); lquery = *lwork == -1 || *liwork == -1 || *lrwork == -1; *info = 0; if (*n <= 1) { lwmin = 1; lrwmin = 1; liwmin = 1; } else { if (wantz) { /* Computing 2nd power */ i__1 = *n; lwmin = i__1 * i__1 << 1; /* Computing 2nd power */ i__1 = *n; lrwmin = *n * 5 + 1 + (i__1 * i__1 << 1); liwmin = *n * 5 + 3; } else { lwmin = *n; lrwmin = *n; liwmin = 1; } } if (! (wantz || lsame_(jobz, "N"))) { *info = -1; } else if (! (lower || lsame_(uplo, "U"))) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*kd < 0) { *info = -4; } else if (*ldab < *kd + 1) { *info = -6; } else if (*ldz < 1 || wantz && *ldz < *n) { *info = -9; } if (*info == 0) { work[1].r = (float) lwmin, work[1].i = 0.f; rwork[1] = (float) lrwmin; iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { *info = -11; } else if (*lrwork < lrwmin && ! lquery) { *info = -13; } else if (*liwork < liwmin && ! lquery) { *info = -15; } } if (*info != 0) { i__1 = -(*info); xerbla_("CHBEVD", &i__1); return 0; } else if (lquery) { return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (*n == 1) { i__1 = ab_dim1 + 1; w[1] = ab[i__1].r; if (wantz) { i__1 = z_dim1 + 1; z__[i__1].r = 1.f, z__[i__1].i = 0.f; } return 0; } /* Get machine constants. */ safmin = slamch_("Safe minimum"); eps = slamch_("Precision"); smlnum = safmin / eps; bignum = 1.f / smlnum; rmin = sqrt(smlnum); rmax = sqrt(bignum); /* Scale matrix to allowable range, if necessary. */ anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]); iscale = 0; if (anrm > 0.f && anrm < rmin) { iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { iscale = 1; sigma = rmax / anrm; } if (iscale == 1) { if (lower) { clascl_("B", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab, info); } else { clascl_("Q", kd, kd, &c_b13, &sigma, n, n, &ab[ab_offset], ldab, info); } } /* Call CHBTRD to reduce Hermitian band matrix to tridiagonal form. */ inde = 1; indwrk = inde + *n; indwk2 = *n * *n + 1; llwk2 = *lwork - indwk2 + 1; llrwk = *lrwork - indwrk + 1; chbtrd_(jobz, uplo, n, kd, &ab[ab_offset], ldab, &w[1], &rwork[inde], & z__[z_offset], ldz, &work[1], &iinfo); /* For eigenvalues only, call SSTERF. For eigenvectors, call CSTEDC. */ if (! wantz) { ssterf_(n, &w[1], &rwork[inde], info); } else { cstedc_("I", n, &w[1], &rwork[inde], &work[1], n, &work[indwk2], & llwk2, &rwork[indwrk], &llrwk, &iwork[1], liwork, info); cgemm_("N", "N", n, n, n, &c_b2, &z__[z_offset], ldz, &work[1], n, & c_b1, &work[indwk2], n); clacpy_("A", n, n, &work[indwk2], n, &z__[z_offset], ldz); } /* If matrix was scaled, then rescale eigenvalues appropriately. */ if (iscale == 1) { if (*info == 0) { imax = *n; } else { imax = *info - 1; } r__1 = 1.f / sigma; sscal_(&imax, &r__1, &w[1], &c__1); } work[1].r = (float) lwmin, work[1].i = 0.f; rwork[1] = (float) lrwmin; iwork[1] = liwmin; return 0; /* End of CHBEVD */ } /* chbevd_ */