From 5f8f271c582255ace8539c26e4e624b87b5ff8e4 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 27 Oct 2026 01:12:47 +0100 Subject: [PATCH 1/2] Fix rescaling after a partial failure in the ?STEBZ-based drivers (Reference-LAPACK PR 1384) --- lapack-netlib/SRC/chbevx.c | 71 +-- lapack-netlib/SRC/chbevx.f | 38 +- lapack-netlib/SRC/chbevx_2stage.c | 413 ++---------------- lapack-netlib/SRC/chbevx_2stage.f | 28 +- lapack-netlib/SRC/cheevr.c | 131 +++--- lapack-netlib/SRC/cheevr.f | 54 ++- lapack-netlib/SRC/cheevr_2stage.c | 502 ++-------------------- lapack-netlib/SRC/cheevr_2stage.f | 39 +- lapack-netlib/SRC/cheevx.c | 87 ++-- lapack-netlib/SRC/cheevx.f | 35 +- lapack-netlib/SRC/cheevx_2stage.c | 383 ++--------------- lapack-netlib/SRC/cheevx_2stage.f | 25 +- lapack-netlib/SRC/chpevx.c | 96 ++--- lapack-netlib/SRC/chpevx.f | 31 +- lapack-netlib/SRC/cstein.c | 88 ++-- lapack-netlib/SRC/cstein.f | 29 +- lapack-netlib/SRC/dsbevx.c | 67 +-- lapack-netlib/SRC/dsbevx.f | 34 +- lapack-netlib/SRC/dsbevx_2stage.c | 376 ++-------------- lapack-netlib/SRC/dsbevx_2stage.f | 46 +- lapack-netlib/SRC/dspevx.c | 74 ++-- lapack-netlib/SRC/dspevx.f | 31 +- lapack-netlib/SRC/dstein.c | 57 ++- lapack-netlib/SRC/dstein.f | 28 +- lapack-netlib/SRC/dstevr.c | 48 +-- lapack-netlib/SRC/dstevr.f | 34 +- lapack-netlib/SRC/dstevx.c | 75 ++-- lapack-netlib/SRC/dstevx.f | 34 +- lapack-netlib/SRC/dsyevr.c | 98 +++-- lapack-netlib/SRC/dsyevr.f | 48 ++- lapack-netlib/SRC/dsyevr_2stage.c | 444 ++----------------- lapack-netlib/SRC/dsyevr_2stage.f | 40 +- lapack-netlib/SRC/dsyevx.c | 64 +-- lapack-netlib/SRC/dsyevx.f | 32 +- lapack-netlib/SRC/dsyevx_2stage.c | 346 ++------------- lapack-netlib/SRC/dsyevx_2stage.f | 41 +- lapack-netlib/SRC/ssbevx.c | 315 ++------------ lapack-netlib/SRC/ssbevx.f | 34 +- lapack-netlib/SRC/ssbevx_2stage.c | 632 ++------------------------- lapack-netlib/SRC/ssbevx_2stage.f | 34 +- lapack-netlib/SRC/sspevx.c | 324 ++------------ lapack-netlib/SRC/sspevx.f | 31 +- lapack-netlib/SRC/sstein.c | 313 ++------------ lapack-netlib/SRC/sstein.f | 32 +- lapack-netlib/SRC/sstevr.c | 298 +------------ lapack-netlib/SRC/sstevr.f | 37 +- lapack-netlib/SRC/sstevx.c | 325 ++------------ lapack-netlib/SRC/sstevx.f | 34 +- lapack-netlib/SRC/ssyevr.c | 338 ++------------- lapack-netlib/SRC/ssyevr.f | 53 ++- lapack-netlib/SRC/ssyevr_2stage.c | 690 ++---------------------------- lapack-netlib/SRC/ssyevr_2stage.f | 42 +- lapack-netlib/SRC/ssyevx.c | 321 ++------------ lapack-netlib/SRC/ssyevx.f | 35 +- lapack-netlib/SRC/ssyevx_2stage.c | 604 ++------------------------ lapack-netlib/SRC/ssyevx_2stage.f | 27 +- lapack-netlib/SRC/zhbevx.c | 62 +-- lapack-netlib/SRC/zhbevx.f | 34 +- lapack-netlib/SRC/zhbevx_2stage.c | 371 ++-------------- lapack-netlib/SRC/zhbevx_2stage.f | 42 +- lapack-netlib/SRC/zheevr.c | 94 ++-- lapack-netlib/SRC/zheevr.f | 17 +- lapack-netlib/SRC/zheevr_2stage.c | 468 ++------------------ lapack-netlib/SRC/zheevr_2stage.f | 17 +- lapack-netlib/SRC/zheevx.c | 72 ++-- lapack-netlib/SRC/zheevx.f | 34 +- lapack-netlib/SRC/zheevx_2stage.c | 363 ++-------------- lapack-netlib/SRC/zheevx_2stage.f | 43 +- lapack-netlib/SRC/zhpevx.c | 78 ++-- lapack-netlib/SRC/zhpevx.f | 31 +- lapack-netlib/SRC/zstein.c | 68 ++- lapack-netlib/SRC/zstein.f | 25 +- 72 files changed, 1870 insertions(+), 8535 deletions(-) diff --git a/lapack-netlib/SRC/chbevx.c b/lapack-netlib/SRC/chbevx.c index 9774952e70..6a9605c4ac 100644 --- a/lapack-netlib/SRC/chbevx.c +++ b/lapack-netlib/SRC/chbevx.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static complex c_b1 = {0.f,0.f}; @@ -243,7 +241,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHBEVX + dependencies */ /* > */ @@ -254,7 +251,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -483,8 +479,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > CSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -495,9 +494,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complexOTHEReigen */ +/* > \ingroup hbevx */ /* ===================================================================== */ /* Subroutine */ void chbevx_(char *jobz, char *range, char *uplo, integer *n, @@ -512,13 +509,13 @@ f"> */ real r__1, r__2; /* Local variables */ + integer imyscale, i__, j, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; complex ctmp1; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); extern /* Subroutine */ void cgemv_(char *, integer *, integer *, complex * @@ -534,11 +531,10 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *); logical wantz; - integer jj; extern real clanhb_(char *, char *, integer *, integer *, complex *, integer *, real *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; extern /* Subroutine */ void clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *), chbtrd_(char *, char *, integer *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, @@ -563,13 +559,12 @@ f"> */ real *, integer *, integer *, real *, real *, real *, integer *, integer *, real *, integer *, integer *, real *, integer *, integer *); - real smlnum, eps, vll, vuu, tmp1; + real smlnum; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -579,14 +574,14 @@ f"> */ /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -685,7 +680,7 @@ f"> */ /* Scale matrix to allowable range, if necessary. */ - iscale = 0; + imyscale = 0; abstll = *abstol; if (valeig) { vll = *vl; @@ -696,13 +691,17 @@ f"> */ } anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]); if (anrm > 0.f && anrm < rmin) { - iscale = 1; + imyscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + imyscale = 1; + } } - if (iscale == 1) { + if (imyscale == 1) { if (lower) { clascl_("B", kd, kd, &c_b16, &sigma, n, n, &ab[ab_offset], ldab, info); @@ -778,12 +777,21 @@ f"> */ indiwk = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by CSTEIN. */ @@ -800,14 +808,9 @@ f"> */ /* If matrix was scaled, then rescale eigenvalues appropriately. */ L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } + if (imyscale == 1) { r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/chbevx.f b/lapack-netlib/SRC/chbevx.f index 3c42309204..59b941eab3 100644 --- a/lapack-netlib/SRC/chbevx.f +++ b/lapack-netlib/SRC/chbevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHBEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -261,12 +259,14 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHEReigen +*> \ingroup hbevx * * ===================================================================== - SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, + SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, + $ VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -296,9 +296,9 @@ SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, - $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1, - $ J, JJ, NSPLIT + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, + $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, + $ ITMP1, J, JJ, NSPLIT REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU COMPLEX CTMP1 @@ -309,7 +309,8 @@ SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, EXTERNAL LSAME, CLANHB, SLAMCH * .. * .. External Subroutines .. - EXTERNAL CCOPY, CGEMV, CHBTRD, CLACPY, CLASCL, CSTEIN, + EXTERNAL CCOPY, CGEMV, CHBTRD, CLACPY, CLASCL, + $ CSTEIN, $ CSTEQR, CSWAP, SCOPY, SSCAL, SSTEBZ, SSTERF, $ XERBLA * .. @@ -414,14 +415,19 @@ SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -514,14 +520,8 @@ SUBROUTINE CHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/chbevx_2stage.c b/lapack-netlib/SRC/chbevx_2stage.c index 4577a3e369..d469ad337a 100644 --- a/lapack-netlib/SRC/chbevx_2stage.c +++ b/lapack-netlib/SRC/chbevx_2stage.c @@ -174,33 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -226,9 +208,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -247,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static complex c_b1 = {0.f,0.f}; @@ -260,330 +237,6 @@ static integer c__4 = 4; static real c_b26 = 1.f; static integer c__1 = 1; -/* > \brief CHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - OTHER matrices */ - -/* @generated from zhbevx_2stage.f, fortran z -> c, Sat Nov 5 23:18:22 2016 */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download CHBEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, */ -/* Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, */ -/* Z, LDZ, WORK, LWORK, RWORK, IWORK, */ -/* IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK */ -/* REAL ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* REAL RWORK( * ), W( * ) */ -/* COMPLEX AB( LDAB, * ), Q( LDQ, * ), WORK( * ), */ -/* $ Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > CHBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian band matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors */ -/* > can be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] KD */ -/* > \verbatim */ -/* > KD is INTEGER */ -/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] AB */ -/* > \verbatim */ -/* > AB is 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 f2cmax(1,j-kd)<=i<=j; */ -/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ -/* > */ -/* > On exit, AB is overwritten by values generated during the */ -/* > reduction to tridiagonal form. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDAB */ -/* > \verbatim */ -/* > LDAB is INTEGER */ -/* > The leading dimension of the array AB. LDAB >= KD + 1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Q */ -/* > \verbatim */ -/* > Q is COMPLEX array, dimension (LDQ, N) */ -/* > If JOBZ = 'V', the N-by-N unitary matrix used in the */ -/* > reduction to tridiagonal form. */ -/* > If JOBZ = 'N', the array Q is not referenced. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDQ */ -/* > \verbatim */ -/* > LDQ is INTEGER */ -/* > The leading dimension of the array Q. If JOBZ = 'V', then */ -/* > LDQ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is REAL */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is REAL */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is REAL */ -/* > 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 * f2cmax( |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 AB to tridiagonal form. */ -/* > */ -/* > Eigenvalues will be computed most accurately when ABSTOL is */ -/* > set to twice the underflow threshold 2*SLAMCH('S'), not zero. */ -/* > If this routine returns with INFO>0, indicating that some */ -/* > eigenvectors did not converge, try setting ABSTOL to */ -/* > 2*SLAMCH('S'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is REAL array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is COMPLEX array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is COMPLEX array, dimension (LWORK) */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, dimension) where */ -/* > dimension = (2KD+1)*N + KD*NTHREADS */ -/* > where KD is the size of the band. */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] RWORK */ -/* > \verbatim */ -/* > RWORK is REAL array, dimension (7*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup complexOTHEReigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void chbevx_2stage_(char *jobz, char *range, char *uplo, integer *n, integer *kd, complex *ab, integer *ldab, complex *q, integer *ldq, real *vl, real *vu, integer *il, integer *iu, real * @@ -597,18 +250,18 @@ static integer c__1 = 1; real r__1, r__2; /* Local variables */ + integer imyscale, i__, j, ib, jj; + real eps, vll, vuu, tmp1; extern /* Subroutine */ void chetrd_hb2st_(char *, char *, char *, integer *, integer *, complex *, integer *, real *, real *, complex *, integer *, complex *, integer *, integer *); integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; complex ctmp1; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); extern /* Subroutine */ void cgemv_(char *, integer *, integer *, complex * @@ -627,11 +280,10 @@ static integer c__1 = 1; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *); logical wantz; - integer ib, jj; extern real clanhb_(char *, char *, integer *, integer *, complex *, integer *, real *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; extern /* Subroutine */ void clascl_(char *, integer *, integer *, real *, real *, integer *, integer *, complex *, integer *, integer *); logical valeig; @@ -656,16 +308,14 @@ static integer c__1 = 1; integer *, real *, integer *, integer *, real *, integer *, integer *); logical lquery; - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer indhous; - real tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -675,14 +325,14 @@ static integer c__1 = 1; /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -734,7 +384,8 @@ static integer c__1 = 1; if (*info == 0) { if (*n <= 1) { lwmin = 1; - work[1].r = (real) lwmin, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; } else { ib = ilaenv2stage_(&c__2, "CHETRD_HB2ST", jobz, n, kd, &c_n1, & c_n1); @@ -743,7 +394,8 @@ static integer c__1 = 1; lwtrd = ilaenv2stage_(&c__4, "CHETRD_HB2ST", jobz, n, kd, &ib, & c_n1); lwmin = lhtrd + lwtrd; - work[1].r = (real) lwmin, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; } if (*lwork < lwmin && ! lquery) { @@ -804,7 +456,7 @@ static integer c__1 = 1; /* Scale matrix to allowable range, if necessary. */ - iscale = 0; + imyscale = 0; abstll = *abstol; if (valeig) { vll = *vl; @@ -815,13 +467,17 @@ static integer c__1 = 1; } anrm = clanhb_("M", uplo, n, kd, &ab[ab_offset], ldab, &rwork[1]); if (anrm > 0.f && anrm < rmin) { - iscale = 1; + imyscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + imyscale = 1; + } } - if (iscale == 1) { + if (imyscale == 1) { if (lower) { clascl_("B", kd, kd, &c_b26, &sigma, n, n, &ab[ab_offset], ldab, info); @@ -902,12 +558,21 @@ static integer c__1 = 1; indiwk = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by CSTEIN. */ @@ -924,14 +589,9 @@ static integer c__1 = 1; /* If matrix was scaled, then rescale eigenvalues appropriately. */ L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } + if (imyscale == 1) { r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -971,7 +631,8 @@ static integer c__1 = 1; /* Set WORK(1) to optimal workspace size. */ - work[1].r = (real) lwmin, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; return; diff --git a/lapack-netlib/SRC/chbevx_2stage.f b/lapack-netlib/SRC/chbevx_2stage.f index 3156265047..9398baf1fe 100644 --- a/lapack-netlib/SRC/chbevx_2stage.f +++ b/lapack-netlib/SRC/chbevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHBEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -359,7 +357,7 @@ SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, $ LQUERY CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1, $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, $ J, JJ, NSPLIT @@ -375,7 +373,8 @@ SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CCOPY, + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, + $ CCOPY, $ CGEMV, CLACPY, CLASCL, CSTEIN, CSTEQR, $ CSWAP, CHETRD_HB2ST * .. @@ -502,14 +501,19 @@ SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL CLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL CLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -607,14 +611,8 @@ SUBROUTINE CHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/cheevr.c b/lapack-netlib/SRC/cheevr.c index fff6cdc3b0..6c7ad579ae 100644 --- a/lapack-netlib/SRC/cheevr.c +++ b/lapack-netlib/SRC/cheevr.c @@ -174,31 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -242,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -261,7 +243,6 @@ rices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHEEVR + dependencies */ /* > */ @@ -272,7 +253,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -296,9 +276,16 @@ f"> */ /* > \verbatim */ /* > */ /* > CHEEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ +/* > of a complex Hermitian matrix A. Eigenvalues and eigenvectors can be */ +/* > selected by specifying either a range of values or a range of indices */ +/* > for the desired eigenvalues. Invocations with different choices for */ +/* > these parameters may result in the computation of slightly different */ +/* > eigenvalues and/or eigenvectors for the same matrix. The reason for */ +/* > this behavior is that there exists a variety of algorithms (each */ +/* > performing best for a particular set of options) with CHEEVR */ +/* > attempting to select the best based on the various parameters. In all */ +/* > cases, the computed values are accurate within the limits of finite */ +/* > precision arithmetic. */ /* > */ /* > CHEEVR first reduces the matrix A to tridiagonal form T with a call */ /* > to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute */ @@ -330,7 +317,7 @@ f"> */ /* > The desired accuracy of the output can be specified by the input */ /* > parameter ABSTOL. */ /* > */ -/* > For more details, see DSTEMR's documentation and: */ +/* > For more details, see CSTEMR's documentation and: */ /* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ /* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ /* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ @@ -362,6 +349,9 @@ f"> */ /* > JOBZ is CHARACTER*1 */ /* > = 'N': Compute eigenvalues only; */ /* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] RANGE */ @@ -373,6 +363,9 @@ f"> */ /* > = 'I': the IL-th through IU-th eigenvalues will be found. */ /* > For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */ /* > CSTEIN are called */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] UPLO */ @@ -497,6 +490,7 @@ f"> */ /* > Note: the user must ensure that at least f2cmax(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. */ +/* > Supplying N columns is always safe. */ /* > \endverbatim */ /* > */ /* > \param[in] LDZ */ @@ -527,7 +521,8 @@ f"> */ /* > \param[in] LWORK */ /* > \verbatim */ /* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= f2cmax(1,2*N). */ +/* > The length of the array WORK. */ +/* > If N <= 1, LWORK >= 1, else LWORK >= 2*N. */ /* > For optimal efficiency, LWORK >= (NB+1)*N, */ /* > where NB is the f2cmax of the blocksize for CHETRD and for */ /* > CUNMTR as returned by ILAENV. */ @@ -549,7 +544,8 @@ f"> */ /* > \param[in] LRWORK */ /* > \verbatim */ /* > LRWORK is INTEGER */ -/* > The length of the array RWORK. LRWORK >= f2cmax(1,24*N). */ +/* > The length of the array RWORK. */ +/* > If N <= 1, LRWORK >= 1, else LRWORK >= 24*N. */ /* > */ /* > If LRWORK = -1, then a workspace query is assumed; the */ /* > routine only calculates the optimal sizes of the WORK, RWORK */ @@ -568,7 +564,8 @@ f"> */ /* > \param[in] LIWORK */ /* > \verbatim */ /* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK >= 1, else LIWORK >= 10*N. */ /* > */ /* > If LIWORK = -1, then a workspace query is assumed; the */ /* > routine only calculates the optimal sizes of the WORK, RWORK */ @@ -593,9 +590,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complexHEeigen */ +/* > \ingroup heevr */ /* > \par Contributors: */ /* ================== */ @@ -619,11 +614,10 @@ f"> */ real r__1, r__2; /* Local variables */ - real anrm; - integer imax; - real rmin, rmax; + integer imyscale, i__, j, nb, jj; + real eps, vll, vuu, tmp1, anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indrd, indre; + integer itmp1, indrd, indre; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -636,10 +630,8 @@ f"> */ logical lower; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *); - logical wantz; - integer nb, jj; - logical alleig, indeig; - integer iscale, ieeeok, indibl, indrdd, indifl, indree; + logical wantz, alleig, indeig; + integer ieeeok, indibl, indrdd, indifl, indree; logical valeig; extern real slamch_(char *); extern /* Subroutine */ void chetrd_(char *, integer *, complex *, integer @@ -673,15 +665,13 @@ f"> */ integer *, real *, integer *, integer *); logical lquery; integer lwkopt; - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer llrwork; - real tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -691,11 +681,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -714,15 +704,15 @@ f"> */ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 24; - lrwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n << 1; - lwmin = f2cmax(i__1,i__2); + if (*n <= 1) { + lwmin = 1; + lrwmin = 1; + liwmin = 1; + } else { + lwmin = *n << 1; + lrwmin = *n * 24; + liwmin = *n * 10; + } *info = 0; if (! (wantz || lsame_(jobz, "N"))) { @@ -764,8 +754,9 @@ f"> */ /* Computing MAX */ i__1 = (nb + 1) * *n; lwkopt = f2cmax(i__1,lwmin); - work[1].r = (real) lwkopt, work[1].i = 0.f; - rwork[1] = (real) lrwmin; + r__1 = sroundup_lwork__(&lwkopt); + work[1].r = r__1, work[1].i = 0.f; + rwork[1] = sroundup_lwork__(&lrwmin); iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { @@ -794,7 +785,7 @@ f"> */ } if (*n == 1) { - work[1].r = 2.f, work[1].i = 0.f; + work[1].r = 1.f, work[1].i = 0.f; if (alleig || indeig) { *m = 1; i__1 = a_dim1 + 1; @@ -830,7 +821,7 @@ f"> */ /* Scale matrix to allowable range, if necessary. */ - iscale = 0; + imyscale = 0; abstll = *abstol; if (valeig) { vll = *vl; @@ -838,13 +829,17 @@ f"> */ } anrm = clansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]); if (anrm > 0.f && anrm < rmin) { - iscale = 1; + imyscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + imyscale = 1; + } } - if (iscale == 1) { + if (imyscale == 1) { if (lower) { i__1 = *n; for (j = 1; j <= i__1; ++j) { @@ -931,7 +926,7 @@ f"> */ scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1); scopy_(n, &rwork[indrd], &c__1, &rwork[indrdd], &c__1); - if (*abstol <= *n * 2.f * eps) { + if (*abstol <= (real) (*n) * 2.f * eps) { tryrac = TRUE_; } else { tryrac = FALSE_; @@ -988,14 +983,9 @@ f"> */ /* If matrix was scaled, then rescale eigenvalues appropriately. */ L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } + if (imyscale == 1) { r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1030,8 +1020,9 @@ f"> */ /* Set WORK(1) to optimal workspace size. */ - work[1].r = (real) lwkopt, work[1].i = 0.f; - rwork[1] = (real) lrwmin; + r__1 = sroundup_lwork__(&lwkopt); + work[1].r = r__1, work[1].i = 0.f; + rwork[1] = sroundup_lwork__(&lrwmin); iwork[1] = liwmin; return; diff --git a/lapack-netlib/SRC/cheevr.f b/lapack-netlib/SRC/cheevr.f index ad5c8cd4aa..c8d8179d41 100644 --- a/lapack-netlib/SRC/cheevr.f +++ b/lapack-netlib/SRC/cheevr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHEEVR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -41,9 +39,16 @@ *> \verbatim *> *> CHEEVR computes selected eigenvalues and, optionally, eigenvectors -*> of a complex Hermitian matrix A. Eigenvalues and eigenvectors can -*> be selected by specifying either a range of values or a range of -*> indices for the desired eigenvalues. +*> of a complex Hermitian matrix A. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. Invocations with different choices for +*> these parameters may result in the computation of slightly different +*> eigenvalues and/or eigenvectors for the same matrix. The reason for +*> this behavior is that there exists a variety of algorithms (each +*> performing best for a particular set of options) with CHEEVR +*> attempting to select the best based on the various parameters. In all +*> cases, the computed values are accurate within the limits of finite +*> precision arithmetic. *> *> CHEEVR first reduces the matrix A to tridiagonal form T with a call *> to CHETRD. Then, whenever possible, CHEEVR calls CSTEMR to compute @@ -107,6 +112,9 @@ *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. +*> +*> This parameter influences the choice of the algorithm and +*> may alter the computed values. *> \endverbatim *> *> \param[in] RANGE @@ -118,6 +126,9 @@ *> = 'I': the IL-th through IU-th eigenvalues will be found. *> For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and *> CSTEIN are called +*> +*> This parameter influences the choice of the algorithm and +*> may alter the computed values. *> \endverbatim *> *> \param[in] UPLO @@ -242,6 +253,7 @@ *> 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. +*> Supplying N columns is always safe. *> \endverbatim *> *> \param[in] LDZ @@ -354,9 +366,11 @@ *> California at Berkeley, USA \n *> * ===================================================================== - SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ RWORK, LRWORK, IWORK, LIWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -384,7 +398,7 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ, TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, + INTEGER I, IEEEOK, IINFO, INDIBL, INDIFL, INDISP, $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, @@ -396,10 +410,12 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL LSAME INTEGER ILAENV REAL CLANSY, SLAMCH, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, CLANSY, SLAMCH, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, CLANSY, SLAMCH, + $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL CHETRD, CSSCAL, CSTEMR, CSTEIN, CSWAP, CUNMTR, + EXTERNAL CHETRD, CSSCAL, CSTEMR, CSTEIN, CSWAP, + $ CUNMTR, $ SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA * .. * .. Intrinsic Functions .. @@ -533,8 +549,11 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -620,7 +639,7 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) CALL SCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) * - IF (ABSTOL .LE. TWO*N*EPS) THEN + IF (ABSTOL .LE. TWO*REAL( N )*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. @@ -676,21 +695,16 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * INDWKN = INDWK LLWRKN = LWORK - INDWKN + 1 - CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/cheevr_2stage.c b/lapack-netlib/SRC/cheevr_2stage.c index 2d6b46ae24..cd3fa485c2 100644 --- a/lapack-netlib/SRC/cheevr_2stage.c +++ b/lapack-netlib/SRC/cheevr_2stage.c @@ -174,33 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -226,9 +208,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -247,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -258,409 +235,6 @@ static integer c__3 = 3; static integer c__4 = 4; static integer c_n1 = -1; -/* > \brief CHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - HE matrices */ - -/* @generated from zheevr_2stage.f, fortran z -> c, Sat Nov 5 23:18:11 2016 */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download CHEEVR_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, */ -/* WORK, LWORK, RWORK, LRWORK, IWORK, */ -/* LIWORK, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, */ -/* $ M, N */ -/* REAL ABSTOL, VL, VU */ -/* INTEGER ISUPPZ( * ), IWORK( * ) */ -/* REAL RWORK( * ), W( * ) */ -/* COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > CHEEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > */ -/* > CHEEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call */ -/* > to CHETRD. Then, whenever possible, CHEEVR_2STAGE calls CSTEMR to compute */ -/* > eigenspectrum using Relatively Robust Representations. CSTEMR */ -/* > computes eigenvalues by the dqds algorithm, while orthogonal */ -/* > eigenvectors are computed from various "good" L D L^T representations */ -/* > (also known as Relatively Robust Representations). Gram-Schmidt */ -/* > orthogonalization is avoided as far as possible. More specifically, */ -/* > the various steps of the algorithm are as follows. */ -/* > */ -/* > For each unreduced block (submatrix) of T, */ -/* > (a) Compute T - sigma I = L D L^T, so that L and D */ -/* > define all the wanted eigenvalues to high relative accuracy. */ -/* > This means that small relative changes in the entries of D and L */ -/* > cause only small relative changes in the eigenvalues and */ -/* > eigenvectors. The standard (unfactored) representation of the */ -/* > tridiagonal matrix T does not have this property in general. */ -/* > (b) Compute the eigenvalues to suitable accuracy. */ -/* > If the eigenvectors are desired, the algorithm attains full */ -/* > accuracy of the computed eigenvalues only right before */ -/* > the corresponding vectors have to be computed, see steps c) and d). */ -/* > (c) For each cluster of close eigenvalues, select a new */ -/* > shift close to the cluster, find a new factorization, and refine */ -/* > the shifted eigenvalues to suitable accuracy. */ -/* > (d) For each eigenvalue with a large enough relative separation compute */ -/* > the corresponding eigenvector by forming a rank revealing twisted */ -/* > factorization. Go back to (c) for any clusters that remain. */ -/* > */ -/* > The desired accuracy of the output can be specified by the input */ -/* > parameter ABSTOL. */ -/* > */ -/* > For more details, see DSTEMR's documentation and: */ -/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* > 2004. Also LAPACK Working Note 154. */ -/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* > tridiagonal eigenvalue/eigenvector problem", */ -/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* > UC Berkeley, May 1997. */ -/* > */ -/* > */ -/* > Note 1 : CHEEVR_2STAGE calls CSTEMR when the full spectrum is requested */ -/* > on machines which conform to the ieee-754 floating point standard. */ -/* > CHEEVR_2STAGE calls SSTEBZ and CSTEIN on non-ieee machines and */ -/* > when partial spectrum requests are made. */ -/* > */ -/* > Normal execution of CSTEMR may create NaNs and infinities and */ -/* > hence may abort due to a floating point exception in environments */ -/* > which do not handle NaNs and infinities in the ieee standard default */ -/* > manner. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */ -/* > CSTEIN are called */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is 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, the lower triangle (if UPLO='L') or the upper */ -/* > triangle (if UPLO='U') of A, including the diagonal, is */ -/* > destroyed. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is REAL */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is REAL */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is REAL */ -/* > 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 * f2cmax( |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. */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > */ -/* > If high relative accuracy is important, set ABSTOL to */ -/* > SLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* > eigenvalues are computed to high relative accuracy when */ -/* > possible in future releases. The current code does not */ -/* > make any guarantees about high relative accuracy, but */ -/* > future releases will. See J. Barlow and J. Demmel, */ -/* > "Computing Accurate Eigensystems of Scaled Diagonally */ -/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* > of which matrices define their eigenvalues to high relative */ -/* > accuracy. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is REAL array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is COMPLEX array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] ISUPPZ */ -/* > \verbatim */ -/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ -/* > The support of the eigenvectors in Z, i.e., the indices */ -/* > indicating the nonzero elements in Z. The i-th eigenvector */ -/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* > ISUPPZ( 2*i ). This is an output of CSTEMR (tridiagonal */ -/* > matrix). The support of the eigenvectors of A is typically */ -/* > 1:N because of the unitary transformations applied by CUNMTR. */ -/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The dimension of the array WORK. */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 26*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] RWORK */ -/* > \verbatim */ -/* > RWORK is REAL array, dimension (MAX(1,LRWORK)) */ -/* > On exit, if INFO = 0, RWORK(1) returns the optimal */ -/* > (and minimal) LRWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LRWORK */ -/* > \verbatim */ -/* > LRWORK is INTEGER */ -/* > The length of the array RWORK. LRWORK >= f2cmax(1,24*N). */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ -/* > On exit, if INFO = 0, IWORK(1) returns the optimal */ -/* > (and minimal) LIWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LIWORK */ -/* > \verbatim */ -/* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: Internal error */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup complexHEeigen */ - -/* > \par Contributors: */ -/* ================== */ -/* > */ -/* > Inderjit Dhillon, IBM Almaden, USA \n */ -/* > Osni Marques, LBNL/NERSC, USA \n */ -/* > Ken Stanley, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > Jason Riedy, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > */ -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void cheevr_2stage_(char *jobz, char *range, char *uplo, integer *n, complex *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z__, @@ -673,13 +247,13 @@ static integer c_n1 = -1; real r__1, r__2; /* Local variables */ + integer imyscale, i__, j, ib, kd, jj; + real eps, vll, vuu, tmp1; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j; + integer itmp1; extern /* Subroutine */ void chetrd_2stage_(char *, char *, integer *, complex *, integer *, real *, real *, complex *, complex *, integer *, complex *, integer *, integer *); @@ -697,10 +271,8 @@ static integer c_n1 = -1; integer lwtrd; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *); - logical wantz; - integer ib, kd, jj; - logical alleig, indeig; - integer iscale, ieeeok, indibl, indrdd, indifl, indree; + logical wantz, alleig, indeig; + integer ieeeok, indibl, indrdd, indifl, indree; logical valeig; extern real slamch_(char *); extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer @@ -733,16 +305,14 @@ static integer c_n1 = -1; integer *, integer *, complex *, integer *, complex *, complex *, integer *, complex *, integer *, integer *); logical lquery; - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer indhous, llrwork; - real tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -752,11 +322,11 @@ static integer c_n1 = -1; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -779,13 +349,16 @@ static integer c_n1 = -1; ib = ilaenv2stage_(&c__2, "CHETRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); lhtrd = ilaenv2stage_(&c__3, "CHETRD_2STAGE", jobz, n, &kd, &ib, &c_n1); lwtrd = ilaenv2stage_(&c__4, "CHETRD_2STAGE", jobz, n, &kd, &ib, &c_n1); - lwmin = *n + lhtrd + lwtrd; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 24; - lrwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); + + if (*n <= 1) { + lwmin = 1; + lrwmin = 1; + liwmin = 1; + } else { + lwmin = *n + lhtrd + lwtrd; + lrwmin = *n * 24; + liwmin = *n * 10; + } *info = 0; if (! lsame_(jobz, "N")) { @@ -818,8 +391,9 @@ static integer c_n1 = -1; } if (*info == 0) { - work[1].r = (real) lwmin, work[1].i = 0.f; - rwork[1] = (real) lrwmin; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; + rwork[1] = sroundup_lwork__(&lrwmin); iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { @@ -848,7 +422,7 @@ static integer c_n1 = -1; } if (*n == 1) { - work[1].r = 2.f, work[1].i = 0.f; + work[1].r = 1.f, work[1].i = 0.f; if (alleig || indeig) { *m = 1; i__1 = a_dim1 + 1; @@ -884,7 +458,7 @@ static integer c_n1 = -1; /* Scale matrix to allowable range, if necessary. */ - iscale = 0; + imyscale = 0; abstll = *abstol; if (valeig) { vll = *vl; @@ -892,13 +466,17 @@ static integer c_n1 = -1; } anrm = clansy_("M", uplo, n, &a[a_offset], lda, &rwork[1]); if (anrm > 0.f && anrm < rmin) { - iscale = 1; + imyscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + imyscale = 1; + } } - if (iscale == 1) { + if (imyscale == 1) { if (lower) { i__1 = *n; for (j = 1; j <= i__1; ++j) { @@ -987,7 +565,7 @@ static integer c_n1 = -1; scopy_(&i__1, &rwork[indre], &c__1, &rwork[indree], &c__1); scopy_(n, &rwork[indrd], &c__1, &rwork[indrdd], &c__1); - if (*abstol <= *n * 2.f * eps) { + if (*abstol <= (real) (*n) * 2.f * eps) { tryrac = TRUE_; } else { tryrac = FALSE_; @@ -1044,14 +622,9 @@ static integer c_n1 = -1; /* If matrix was scaled, then rescale eigenvalues appropriately. */ L30: - if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } + if (imyscale == 1) { r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1086,8 +659,9 @@ static integer c_n1 = -1; /* Set WORK(1) to optimal workspace size. */ - work[1].r = (real) lwmin, work[1].i = 0.f; - rwork[1] = (real) lrwmin; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; + rwork[1] = sroundup_lwork__(&lrwmin); iwork[1] = liwmin; return; diff --git a/lapack-netlib/SRC/cheevr_2stage.f b/lapack-netlib/SRC/cheevr_2stage.f index e06925fcd0..f2ac021c73 100644 --- a/lapack-netlib/SRC/cheevr_2stage.f +++ b/lapack-netlib/SRC/cheevr_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHEEVR_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -435,7 +433,7 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ, TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, + INTEGER I, IEEEOK, IINFO, INDIBL, INDIFL, INDISP, $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, @@ -451,7 +449,8 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CSSCAL, + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, + $ CSSCAL, $ CHETRD_2STAGE, CSTEMR, CSTEIN, CSWAP, CUNMTR * .. * .. Intrinsic Functions .. @@ -472,10 +471,14 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LRWORK.EQ.-1 ) .OR. $ ( LIWORK.EQ.-1 ) ) * - KD = ILAENV2STAGE( 1, 'CHETRD_2STAGE', JOBZ, N, -1, -1, -1 ) - IB = ILAENV2STAGE( 2, 'CHETRD_2STAGE', JOBZ, N, KD, -1, -1 ) - LHTRD = ILAENV2STAGE( 3, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) - LWTRD = ILAENV2STAGE( 4, 'CHETRD_2STAGE', JOBZ, N, KD, IB, -1 ) + KD = ILAENV2STAGE( 1, 'CHETRD_2STAGE', JOBZ, N, -1, -1, + $ -1 ) + IB = ILAENV2STAGE( 2, 'CHETRD_2STAGE', JOBZ, N, KD, -1, + $ -1 ) + LHTRD = ILAENV2STAGE( 3, 'CHETRD_2STAGE', JOBZ, N, KD, IB, + $ -1 ) + LWTRD = ILAENV2STAGE( 4, 'CHETRD_2STAGE', JOBZ, N, KD, IB, + $ -1 ) * IF( N.LE.1 ) THEN LWMIN = 1 @@ -587,8 +590,11 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -677,7 +683,7 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) CALL SCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) * - IF ( ABSTOL .LE. TWO*N*EPS ) THEN + IF ( ABSTOL .LE. TWO*REAL( N )*EPS ) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. @@ -733,21 +739,16 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * INDWKN = INDWK LLWRKN = LWORK - INDWKN + 1 - CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/cheevx.c b/lapack-netlib/SRC/cheevx.c index 1efdbb0b0a..b17eaba4d1 100644 --- a/lapack-netlib/SRC/cheevx.c +++ b/lapack-netlib/SRC/cheevx.c @@ -174,29 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -240,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -255,7 +239,6 @@ rices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHEEVX + dependencies */ /* > */ @@ -266,7 +249,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -487,8 +469,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > CSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -499,9 +484,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complexHEeigen */ +/* > \ingroup heevx */ /* ===================================================================== */ /* Subroutine */ void cheevx_(char *jobz, char *range, char *uplo, integer *n, @@ -515,12 +498,12 @@ f"> */ real r__1, r__2; /* Local variables */ + integer iscale, i__, j, nb, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -532,11 +515,10 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *); logical wantz; - integer nb, jj; extern real clanhe_(char *, char *, integer *, complex *, integer *, real *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; extern real slamch_(char *); extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer @@ -569,13 +551,12 @@ f"> */ integer *); integer lwkopt; logical lquery; - real eps, vll, vuu, tmp1; + extern real sroundup_lwork__(integer *); -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -585,11 +566,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -637,7 +618,7 @@ f"> */ if (*info == 0) { if (*n <= 1) { lwkmin = 1; - work[1].r = (real) lwkmin, work[1].i = 0.f; + lwkopt = 1; } else { lwkmin = *n << 1; nb = ilaenv_(&c__1, "CHETRD", uplo, n, &c_n1, &c_n1, &c_n1, ( @@ -646,11 +627,10 @@ f"> */ i__1 = nb, i__2 = ilaenv_(&c__1, "CUNMTR", uplo, n, &c_n1, &c_n1, &c_n1, (ftnlen)6, (ftnlen)1); nb = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = (nb + 1) * *n; - lwkopt = f2cmax(i__1,i__2); - work[1].r = (real) lwkopt, work[1].i = 0.f; + lwkopt = (nb + 1) * *n; } + r__1 = sroundup_lwork__(&lwkopt); + work[1].r = r__1, work[1].i = 0.f; if (*lwork < lwkmin && ! lquery) { *info = -17; @@ -717,8 +697,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -807,12 +791,21 @@ f"> */ indiwk = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by CSTEIN. */ @@ -825,13 +818,8 @@ f"> */ L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -871,7 +859,8 @@ f"> */ /* Set WORK(1) to optimal complex workspace size. */ - work[1].r = (real) lwkopt, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwkopt); + work[1].r = r__1, work[1].i = 0.f; return; diff --git a/lapack-netlib/SRC/cheevx.f b/lapack-netlib/SRC/cheevx.f index 0293ad9123..15d24ce646 100644 --- a/lapack-netlib/SRC/cheevx.f +++ b/lapack-netlib/SRC/cheevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHEEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -256,9 +254,11 @@ *> \ingroup heevx * * ===================================================================== - SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -287,7 +287,7 @@ SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LWKMIN, LWKOPT, NB, $ NSPLIT @@ -298,10 +298,12 @@ SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, CLANHE, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, SLAMCH, CLANHE, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SLAMCH, + $ CLANHE, SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CSSCAL, + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, + $ CSSCAL, $ CHETRD, CLACPY, CSTEIN, CSTEQR, CSWAP, CUNGTR, $ CUNMTR * .. @@ -355,7 +357,8 @@ SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ELSE LWKMIN = 2*N NB = ILAENV( 1, 'CHETRD', UPLO, N, -1, -1, -1 ) - NB = MAX( NB, ILAENV( 1, 'CUNMTR', UPLO, N, -1, -1, -1 ) ) + NB = MAX( NB, ILAENV( 1, 'CUNMTR', UPLO, N, -1, + $ -1, -1 ) ) LWKOPT = ( NB + 1 )*N END IF WORK( 1 ) = SROUNDUP_LWORK( LWKOPT ) @@ -416,8 +419,11 @@ SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -514,21 +520,16 @@ SUBROUTINE CHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * Apply unitary matrix used in reduction to tridiagonal * form to eigenvectors returned by CSTEIN. * - CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/cheevx_2stage.c b/lapack-netlib/SRC/cheevx_2stage.c index d848c9a17a..b0cda9b3ae 100644 --- a/lapack-netlib/SRC/cheevx_2stage.c +++ b/lapack-netlib/SRC/cheevx_2stage.c @@ -174,33 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -226,9 +208,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -247,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -257,310 +234,6 @@ static integer c__2 = 2; static integer c__3 = 3; static integer c__4 = 4; -/* > \brief CHEEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - HE matrices */ - -/* @generated from zheevx_2stage.f, fortran z -> c, Sat Nov 5 23:18:09 2016 */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download CHEEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */ -/* LWORK, RWORK, IWORK, IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N */ -/* REAL ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* REAL RWORK( * ), W( * ) */ -/* COMPLEX A( LDA, * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > CHEEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is 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, the lower triangle (if UPLO='L') or the upper */ -/* > triangle (if UPLO='U') of A, including the diagonal, is */ -/* > destroyed. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is REAL */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is REAL */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is REAL */ -/* > 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 * f2cmax( |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*SLAMCH('S'), not zero. */ -/* > If this routine returns with INFO>0, indicating that some */ -/* > eigenvectors did not converge, try setting ABSTOL to */ -/* > 2*SLAMCH('S'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is REAL array, dimension (N) */ -/* > On normal exit, the first M elements contain the selected */ -/* > eigenvalues in ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is COMPLEX array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is COMPLEX array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 8*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] RWORK */ -/* > \verbatim */ -/* > RWORK is REAL array, dimension (7*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup complexHEeigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void cheevx_2stage_(char *jobz, char *range, char *uplo, integer *n, complex *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, complex *z__, @@ -572,14 +245,14 @@ static integer c__4 = 4; real r__1, r__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + real eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j; + integer itmp1; extern /* Subroutine */ void chetrd_2stage_(char *, char *, integer *, complex *, integer *, real *, real *, complex *, complex *, integer *, complex *, integer *, integer *); @@ -598,11 +271,10 @@ static integer c__4 = 4; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *); logical wantz; - integer ib, kd, jj; extern real clanhe_(char *, char *, integer *, complex *, integer *, real *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; extern real slamch_(char *); extern /* Subroutine */ void csscal_(integer *, real *, complex *, integer @@ -630,16 +302,14 @@ static integer c__4 = 4; integer *, real *, integer *, integer *, real *, integer *, integer *); logical lquery; - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer indhous; - real tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -649,11 +319,11 @@ static integer c__4 = 4; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -701,7 +371,8 @@ static integer c__4 = 4; if (*info == 0) { if (*n <= 1) { lwmin = 1; - work[1].r = (real) lwmin, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; } else { kd = ilaenv2stage_(&c__1, "CHETRD_2STAGE", jobz, n, &c_n1, &c_n1, &c_n1); @@ -712,7 +383,8 @@ static integer c__4 = 4; lwtrd = ilaenv2stage_(&c__4, "CHETRD_2STAGE", jobz, n, &kd, &ib, & c_n1); lwmin = *n + lhtrd + lwtrd; - work[1].r = (real) lwmin, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; } if (*lwork < lwmin && ! lquery) { @@ -780,8 +452,12 @@ static integer c__4 = 4; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -873,12 +549,21 @@ static integer c__4 = 4; indiwk = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by CSTEIN. */ @@ -891,13 +576,8 @@ static integer c__4 = 4; L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -937,7 +617,8 @@ static integer c__4 = 4; /* Set WORK(1) to optimal complex workspace size. */ - work[1].r = (real) lwmin, work[1].i = 0.f; + r__1 = sroundup_lwork__(&lwmin); + work[1].r = r__1, work[1].i = 0.f; return; diff --git a/lapack-netlib/SRC/cheevx_2stage.f b/lapack-netlib/SRC/cheevx_2stage.f index 7d0d0325f4..cde12aa1d5 100644 --- a/lapack-netlib/SRC/cheevx_2stage.f +++ b/lapack-netlib/SRC/cheevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHEEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -336,7 +334,7 @@ SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS @@ -351,7 +349,8 @@ SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, CSSCAL, + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA, + $ CSSCAL, $ CLACPY, CSTEIN, CSTEQR, CSWAP, CUNGTR, CUNMTR, $ CHETRD_2STAGE * .. @@ -471,8 +470,11 @@ SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -573,21 +575,16 @@ SUBROUTINE CHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * Apply unitary matrix used in reduction to tridiagonal * form to eigenvectors returned by CSTEIN. * - CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL CUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/chpevx.c b/lapack-netlib/SRC/chpevx.c index 2621088a70..5655171b5e 100644 --- a/lapack-netlib/SRC/chpevx.c +++ b/lapack-netlib/SRC/chpevx.c @@ -174,33 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -226,9 +208,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -247,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -261,7 +238,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CHPEVX + dependencies */ /* > */ @@ -272,7 +248,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -474,8 +449,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > CSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -486,9 +464,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complexOTHEReigen */ +/* > \ingroup hpevx */ /* ===================================================================== */ /* Subroutine */ void chpevx_(char *jobz, char *range, char *uplo, integer *n, @@ -501,12 +477,12 @@ f"> */ real r__1, r__2; /* Local variables */ + integer iscale, i__, j, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -515,10 +491,7 @@ f"> */ extern /* Subroutine */ void cswap_(integer *, complex *, integer *, complex *, integer *), scopy_(integer *, real *, integer *, real * , integer *); - logical wantz; - integer jj; - logical alleig, indeig; - integer iscale, indibl; + logical wantz, alleig, indeig; extern real clanhp_(char *, char *, integer *, complex *, real *); logical valeig; extern real slamch_(char *); @@ -546,13 +519,11 @@ f"> */ real *, integer *, integer *, real *, real *, real *, integer *, integer *, real *, integer *, integer *, real *, integer *, integer *); - real eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -564,7 +535,7 @@ f"> */ --ap; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -663,8 +634,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; @@ -734,17 +709,25 @@ f"> */ } else { *(unsigned char *)order = 'E'; } - indibl = 1; - indisp = indibl + *n; + indisp = *n + 1; indiwk = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & - rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[inde], m, &nsplit, &w[1], &iwork[1], &iwork[indisp], &rwork[ + indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L20; + } + } if (wantz) { - cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & - iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + cstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[1], &iwork[ + indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[indiwk], + &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by CSTEIN. */ @@ -758,13 +741,8 @@ f"> */ L20: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -785,11 +763,11 @@ f"> */ } if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; + itmp1 = iwork[i__]; w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + iwork[i__] = iwork[j]; w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; + iwork[j] = itmp1; cswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); if (*info != 0) { diff --git a/lapack-netlib/SRC/chpevx.f b/lapack-netlib/SRC/chpevx.f index a64907d8a3..428084bf34 100644 --- a/lapack-netlib/SRC/chpevx.f +++ b/lapack-netlib/SRC/chpevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CHPEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -234,12 +232,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHEReigen +*> \ingroup hpevx * * ===================================================================== SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, $ IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -267,7 +266,7 @@ SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, + INTEGER I, IINFO, INDD, INDE, INDEE, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, $ ITMP1, J, JJ, NSPLIT REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -279,7 +278,8 @@ SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, EXTERNAL LSAME, CLANHP, SLAMCH * .. * .. External Subroutines .. - EXTERNAL CHPTRD, CSSCAL, CSTEIN, CSTEQR, CSWAP, CUPGTR, + EXTERNAL CHPTRD, CSSCAL, CSTEIN, CSTEQR, CSWAP, + $ CUPGTR, $ CUPMTR, SCOPY, SSCAL, SSTEBZ, SSTERF, XERBLA * .. * .. Intrinsic Functions .. @@ -299,7 +299,8 @@ SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. + $ LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -3 ELSE IF( N.LT.0 ) THEN @@ -372,8 +373,11 @@ SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL CSSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) @@ -460,21 +464,16 @@ SUBROUTINE CHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * form to eigenvectors returned by CSTEIN. * INDWRK = INDTAU + N - CALL CUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, + CALL CUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, + $ LDZ, $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/cstein.c b/lapack-netlib/SRC/cstein.c index eeb97a942b..06ed5c4dc7 100644 --- a/lapack-netlib/SRC/cstein.c +++ b/lapack-netlib/SRC/cstein.c @@ -174,33 +174,15 @@ typedef struct Namelist Namelist; #define bit_set(a,b) ((a) | ((uinteger)1 << (b))) #define abort_() { sig_die("Fortran abort routine called", 1); } -#define c_abs(z) (cabsf(Cf(z))) -#define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); } -#ifdef _MSC_VER -#define c_div(c, a, b) {float nenn=crealf(_FCmulcc(Cf(b),conjf(Cf(b)))); _Fcomplex zaehl=_FCmulcc(Cf(a),conjf(Cf(b))); pCf(c)=_FCbuild(crealf(zaehl)/nenn,cimagf(zaehl)/nenn);} -#define z_div(c, a, b) {double nenn=creal(_Cmulcc(Cd(b),conj(Cd(b)))); _Dcomplex zaehl=_Cmulcc(Cd(a),conj(Cd(b))); pCd(c)=_Cbuild(creal(zaehl)/nenn,cimag(zaehl)/nenn);} -#else -#define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);} -#define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);} -#endif -#define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));} -#define c_log(R, Z) {pCf(R) = clogf(Cf(Z));} -#define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));} -//#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));} -#define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));} #define d_abs(x) (fabs(*(x))) #define d_acos(x) (acos(*(x))) #define d_asin(x) (asin(*(x))) #define d_atan(x) (atan(*(x))) #define d_atn2(x, y) (atan2(*(x),*(y))) -#define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); } -#define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); } #define d_cos(x) (cos(*(x))) #define d_cosh(x) (cosh(*(x))) #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) #define d_exp(x) (exp(*(x))) -#define d_imag(z) (cimag(Cd(z))) -#define r_imag(z) (cimagf(Cf(z))) #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) @@ -226,9 +208,6 @@ typedef struct Namelist Namelist; #define pow_si(B,E) spow_ui(*(B),*(E)) #define pow_ri(B,E) spow_ui(*(B),*(E)) #define pow_di(B,E) dpow_ui(*(B),*(E)) -#define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));} -#define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));} -#define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));} #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } @@ -247,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__2 = 2; @@ -262,7 +239,6 @@ static integer c_n1 = -1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download CSTEIN + dependencies */ /* > */ @@ -273,7 +249,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -353,6 +328,8 @@ f"> */ /* > the first submatrix from the top, =2 if W(i) belongs to */ /* > the second submatrix, etc. ( The output array IBLOCK */ /* > from SSTEBZ is expected here. ) */ +/* > A negative entry, with which SSTEBZ flags an eigenvalue that */ +/* > did not converge, is treated as its absolute value. */ /* > \endverbatim */ /* > */ /* > \param[in] ISPLIT */ @@ -430,9 +407,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complexOTHERcomputational */ +/* > \ingroup stein */ /* ===================================================================== */ /* Subroutine */ void cstein_(integer *n, real *d__, real *e, integer *m, real @@ -441,23 +416,23 @@ f"> */ { /* System generated locals */ integer z_dim1, z_offset, i__1, i__2, i__3, i__4, i__5; - real r__1=0., r__2=0., r__3=0., r__4=0., r__5=0.; - complex q__1={0.,0.}; + real r__1, r__2, r__3, r__4, r__5; + complex q__1; /* Local variables */ + integer i__, j, b1, j1, bn, jr; + real xj, scl, eps, ctr, sep, nrm, tol; + integer its; + real xjm, eps1; integer jblk, nblk, jmax; extern real snrm2_(integer *, real *, integer *); - integer i__, j, iseed[4], gpind, iinfo; - extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); - integer b1, j1; - extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, - integer *); + integer iseed[4], gpind, iinfo; + extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *), + scopy_(integer *, real *, integer *, real *, integer *); real ortol; - integer indrv1, indrv2, indrv3, indrv4, indrv5, bn, jr; - real xj; + integer indrv1, indrv2, indrv3, indrv4, indrv5; extern real slamch_(char *); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void slagtf_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), slagtf_( integer *, real *, real *, real *, real *, real *, real *, integer *, integer *); integer nrmchk; @@ -468,15 +443,12 @@ f"> */ real onenrm, pertol; extern /* Subroutine */ void slarnv_(integer *, integer *, integer *, real *); - real stpcrt, scl, eps, ctr, sep, nrm, tol; - integer its; - real xjm, eps1; + real stpcrt; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -491,7 +463,7 @@ f"> */ --iblock; --isplit; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -514,11 +486,13 @@ f"> */ } else { i__1 = *m; for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) < (i__3 = iblock[j - 1], abs( + i__3))) { *info = -6; goto L30; } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) == (i__3 = iblock[j - 1], abs( + i__3)) && w[j] < w[j - 1]) { *info = -5; goto L30; } @@ -566,8 +540,8 @@ f"> */ /* Compute eigenvectors of matrix blocks. */ j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { + i__2 = (i__1 = iblock[*m], abs(i__1)); + for (nblk = 1; nblk <= i__2; ++nblk) { /* Find starting and ending indices of block nblk. */ @@ -590,8 +564,8 @@ f"> */ r__3 = onenrm, r__4 = (r__1 = d__[bn], abs(r__1)) + (r__2 = e[bn - 1], abs(r__2)); onenrm = f2cmax(r__3,r__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { + i__1 = bn - 1; + for (i__ = b1 + 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__4 = onenrm, r__5 = (r__1 = d__[i__], abs(r__1)) + (r__2 = e[ i__ - 1], abs(r__2)) + (r__3 = e[i__], abs(r__3)); @@ -600,15 +574,15 @@ f"> */ } ortol = onenrm * .001f; - stpcrt = sqrt(.1f / blksiz); + stpcrt = sqrt(.1f / (real) blksiz); /* Loop through eigenvalues of block nblk. */ L60: jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { + i__1 = *m; + for (j = j1; j <= i__1; ++j) { + if ((i__3 = iblock[j], abs(i__3)) != nblk) { j1 = j; goto L180; } @@ -668,8 +642,8 @@ f"> */ jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); /* Computing MAX */ r__3 = eps, r__4 = (r__1 = work[indrv4 + blksiz], abs(r__1)); - scl = blksiz * onenrm * f2cmax(r__3,r__4) / (r__2 = work[indrv1 + - jmax], abs(r__2)); + scl = (real) blksiz * onenrm * f2cmax(r__3,r__4) / (r__2 = work[ + indrv1 + jmax], abs(r__2)); sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); /* Solve the system LU = Pb. */ diff --git a/lapack-netlib/SRC/cstein.f b/lapack-netlib/SRC/cstein.f index 5609efb014..974b790404 100644 --- a/lapack-netlib/SRC/cstein.f +++ b/lapack-netlib/SRC/cstein.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download CSTEIN + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -97,6 +95,8 @@ *> the first submatrix from the top, =2 if W(i) belongs to *> the second submatrix, etc. ( The output array IBLOCK *> from SSTEBZ is expected here. ) +*> A negative entry, with which SSTEBZ flags an eigenvalue that +*> did not converge, is treated as its absolute value. *> \endverbatim *> *> \param[in] ISPLIT @@ -174,11 +174,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complexOTHERcomputational +*> \ingroup stein * * ===================================================================== SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -222,7 +223,8 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, EXTERNAL ISAMAX, SLAMCH, SNRM2 * .. * .. External Subroutines .. - EXTERNAL SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL, XERBLA + EXTERNAL SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, CMPLX, MAX, REAL, SQRT @@ -244,11 +246,12 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, INFO = -9 ELSE DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN + IF( ABS( IBLOCK( J ) ).LT.ABS( IBLOCK( J-1 ) ) ) THEN INFO = -6 GO TO 30 END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) + IF( ABS( IBLOCK( J ) ).EQ.ABS( IBLOCK( J-1 ) ) .AND. + $ W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 @@ -292,7 +295,7 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute eigenvectors of matrix blocks. * J1 = 1 - DO 180 NBLK = 1, IBLOCK( M ) + DO 180 NBLK = 1, ABS( IBLOCK( M ) ) * * Find starting and ending indices of block nblk. * @@ -317,14 +320,14 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, 50 CONTINUE ORTOL = ODM3*ONENRM * - STPCRT = SQRT( ODM1 / BLKSIZ ) + STPCRT = SQRT( ODM1 / REAL( BLKSIZ ) ) * * Loop through eigenvalues of block nblk. * 60 CONTINUE JBLK = 0 DO 170 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN + IF( ABS( IBLOCK( J ) ).NE.NBLK ) THEN J1 = J GO TO 180 END IF @@ -365,7 +368,8 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO - CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), + CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * @@ -379,14 +383,15 @@ SUBROUTINE CSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Normalize and scale the righthand side vector Pb. * JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - SCL = BLKSIZ*ONENRM*MAX( EPS, + SCL = REAL( BLKSIZ )*ONENRM*MAX( EPS, $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / $ ABS( WORK( INDRV1+JMAX ) ) CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) * * Solve the system LU = Pb. * - CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), + CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * diff --git a/lapack-netlib/SRC/dsbevx.c b/lapack-netlib/SRC/dsbevx.c index d41e786f33..9bc28b6faf 100644 --- a/lapack-netlib/SRC/dsbevx.c +++ b/lapack-netlib/SRC/dsbevx.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublereal c_b14 = 1.; @@ -242,7 +240,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSBEVX + dependencies */ /* > */ @@ -253,7 +250,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -480,8 +476,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit. */ /* > < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > DSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -492,9 +491,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup doubleOTHEReigen */ +/* > \ingroup hbevx */ /* ===================================================================== */ /* Subroutine */ void dsbevx_(char *jobz, char *range, char *uplo, integer *n, @@ -510,12 +507,12 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -529,15 +526,14 @@ f"> */ doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *); logical lower, wantz; - integer jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; - extern doublereal dlansb_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *); + integer indibl; extern /* Subroutine */ void dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); logical valeig; extern /* Subroutine */ void dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); @@ -561,13 +557,12 @@ f"> */ extern /* Subroutine */ void dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *); integer nsplit; - doublereal smlnum, eps, vll, vuu, tmp1; + doublereal smlnum; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -577,14 +572,14 @@ f"> */ /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -692,8 +687,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -770,12 +769,21 @@ f"> */ indiwo = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by DSTEIN. */ @@ -793,13 +801,8 @@ f"> */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dsbevx.f b/lapack-netlib/SRC/dsbevx.f index 6f185cb129..20ea91e786 100644 --- a/lapack-netlib/SRC/dsbevx.f +++ b/lapack-netlib/SRC/dsbevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSBEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -259,12 +257,14 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHEReigen +*> \ingroup hbevx * * ===================================================================== - SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, + SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, + $ VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -290,7 +290,7 @@ SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, $ NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -302,7 +302,8 @@ SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, EXTERNAL LSAME, DLAMCH, DLANSB * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL, + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, + $ DSCAL, $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -405,14 +406,19 @@ SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -504,14 +510,8 @@ SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/dsbevx_2stage.c b/lapack-netlib/SRC/dsbevx_2stage.c index 78f7dfbab9..4d0e91b07a 100644 --- a/lapack-netlib/SRC/dsbevx_2stage.c +++ b/lapack-netlib/SRC/dsbevx_2stage.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__2 = 2; @@ -238,326 +236,6 @@ static doublereal c_b24 = 1.; static integer c__1 = 1; static doublereal c_b45 = 0.; -/* > \brief DSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - OTHER matrices */ - -/* @precisions fortran d -> s */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download DSBEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, */ -/* LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, */ -/* LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK */ -/* DOUBLE PRECISION ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), */ -/* $ Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > DSBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric band matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] KD */ -/* > \verbatim */ -/* > KD is INTEGER */ -/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] AB */ -/* > \verbatim */ -/* > AB is DOUBLE PRECISION array, dimension (LDAB, N) */ -/* > On entry, the upper or lower triangle of the symmetric 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 f2cmax(1,j-kd)<=i<=j; */ -/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDAB */ -/* > \verbatim */ -/* > LDAB is INTEGER */ -/* > The leading dimension of the array AB. LDAB >= KD + 1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Q */ -/* > \verbatim */ -/* > Q is DOUBLE PRECISION array, dimension (LDQ, N) */ -/* > If JOBZ = 'V', the N-by-N orthogonal matrix used in the */ -/* > reduction to tridiagonal form. */ -/* > If JOBZ = 'N', the array Q is not referenced. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDQ */ -/* > \verbatim */ -/* > LDQ is INTEGER */ -/* > The leading dimension of the array Q. If JOBZ = 'V', then */ -/* > LDQ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is DOUBLE PRECISION */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is DOUBLE PRECISION */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is 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 * f2cmax( |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 AB 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'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is DOUBLE PRECISION array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is DOUBLE PRECISION array, dimension (LWORK) */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 7*N, dimension) where */ -/* > dimension = (2KD+1)*N + KD*NTHREADS + 2*N */ -/* > where KD is the size of the band. */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit. */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup doubleOTHEReigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void dsbevx_2stage_(char *jobz, char *range, char *uplo, integer *n, integer *kd, doublereal *ab, integer *ldab, doublereal *q, integer *ldq, doublereal *vl, doublereal *vu, integer *il, integer * @@ -571,18 +249,18 @@ static doublereal c_b45 = 0.; doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, ib, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; extern /* Subroutine */ void dsytrd_sb2st_(char *, char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *, integer *); - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -600,15 +278,14 @@ static doublereal c_b45 = 0.; logical lower; integer lwtrd; logical wantz; - integer ib, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; - extern doublereal dlansb_(char *, char *, integer *, integer *, - doublereal *, integer *, doublereal *); + integer indibl; extern /* Subroutine */ void dlascl_(char *, integer *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); + extern doublereal dlansb_(char *, char *, integer *, integer *, + doublereal *, integer *, doublereal *); logical valeig; extern /* Subroutine */ void dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); @@ -631,16 +308,13 @@ static doublereal c_b45 = 0.; integer nsplit, llwork; doublereal smlnum; logical lquery; - doublereal eps, vll, vuu; integer indhous; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -650,14 +324,14 @@ static doublereal c_b45 = 0.; /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -727,7 +401,7 @@ static doublereal c_b45 = 0.; if (*info != 0) { i__1 = -(*info); - xerbla_("DSBEVX_2STAGE ", &i__1, (ftnlen)13); + xerbla_("DSBEVX_2STAGE ", &i__1, (ftnlen)14); return; } else if (lquery) { return; @@ -788,8 +462,12 @@ static doublereal c_b45 = 0.; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -870,12 +548,21 @@ static doublereal c_b45 = 0.; indiwo = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by DSTEIN. */ @@ -893,13 +580,8 @@ static doublereal c_b45 = 0.; L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dsbevx_2stage.f b/lapack-netlib/SRC/dsbevx_2stage.f index 4f578f6c88..b54675f35f 100644 --- a/lapack-netlib/SRC/dsbevx_2stage.f +++ b/lapack-netlib/SRC/dsbevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSBEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -235,7 +233,7 @@ *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= 1, when N <= 1; -*> otherwise +*> otherwise *> If JOBZ = 'N' and N > 1, LWORK must be queried. *> LWORK = MAX(1, 7*N, dimension) where *> dimension = (2KD+1)*N + KD*NTHREADS + 2*N @@ -284,7 +282,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHEReigen +*> \ingroup hbevx_2stage * *> \par Further Details: * ===================== @@ -302,7 +300,7 @@ *> http://doi.acm.org/10.1145/2063384.2063394 *> *> A. Haidar, J. Kurzak, P. Luszczek, 2013. -*> An improved parallel singular value algorithm and its implementation +*> An improved parallel singular value algorithm and its implementation *> for multicore hardware, In Proceedings of 2013 International Conference *> for High Performance Computing, Networking, Storage and Analysis (SC '13). *> Denver, Colorado, USA, 2013. @@ -310,16 +308,17 @@ *> http://doi.acm.org/10.1145/2503210.2503292 *> *> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. -*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure *> calculations based on fine-grained memory aware tasks. *> International Journal of High Performance Computing Applications. *> Volume 28 Issue 2, Pages 196-209, May 2014. -*> http://hpc.sagepub.com/content/28/2/196 +*> http://hpc.sagepub.com/content/28/2/196 *> *> \endverbatim * * ===================================================================== - SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, + SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, + $ Q, $ LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) * @@ -350,7 +349,7 @@ SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, $ LQUERY CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, $ NSPLIT @@ -364,7 +363,8 @@ SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, EXTERNAL LSAME, DLAMCH, DLANSB, ILAENV2STAGE * .. * .. External Subroutines .. - EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSCAL, + EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, + $ DSCAL, $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, $ DSYTRD_SB2ST * .. @@ -490,14 +490,19 @@ SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -515,8 +520,9 @@ SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, INDWRK = INDHOUS + LHTRD LLWORK = LWORK - INDWRK + 1 * - CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), - $ WORK( INDE ), WORK( INDHOUS ), LHTRD, + CALL DSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, + $ WORK( INDD ), + $ WORK( INDE ), WORK( INDHOUS ), LHTRD, $ WORK( INDWRK ), LLWORK, IINFO ) * * If all eigenvalues are desired and ABSTOL is less than or equal @@ -593,14 +599,8 @@ SUBROUTINE DSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/dspevx.c b/lapack-netlib/SRC/dspevx.c index dc3d2fa4a1..db36cc6751 100644 --- a/lapack-netlib/SRC/dspevx.c +++ b/lapack-netlib/SRC/dspevx.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -240,7 +238,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSPEVX + dependencies */ /* > */ @@ -251,7 +248,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -447,8 +443,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > DSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -459,9 +458,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup doubleOTHEReigen */ +/* > \ingroup hpevx */ /* ===================================================================== */ /* Subroutine */ void dspevx_(char *jobz, char *range, char *uplo, integer *n, @@ -475,12 +472,12 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -491,11 +488,8 @@ f"> */ doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *); logical wantz; - integer jj; extern doublereal dlamch_(char *); - logical alleig, indeig; - integer iscale, indibl; - logical valeig; + logical alleig, indeig, valeig; doublereal safmin; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal abstll, bignum; @@ -520,13 +514,12 @@ f"> */ integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *); integer nsplit; - doublereal smlnum, eps, vll, vuu, tmp1; + doublereal smlnum; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -538,7 +531,7 @@ f"> */ --ap; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -635,8 +628,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; @@ -704,17 +701,25 @@ f"> */ } else { *(unsigned char *)order = 'E'; } - indibl = 1; - indisp = indibl + *n; + indisp = *n + 1; indiwo = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + inde], m, &nsplit, &w[1], &iwork[1], &iwork[indisp], &work[indwrk] + , &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L20; + } + } if (wantz) { - dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[1], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by DSTEIN. */ @@ -727,13 +732,8 @@ f"> */ L20: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -754,11 +754,11 @@ f"> */ } if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; + itmp1 = iwork[i__]; w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + iwork[i__] = iwork[j]; w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; + iwork[j] = itmp1; dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); if (*info != 0) { diff --git a/lapack-netlib/SRC/dspevx.f b/lapack-netlib/SRC/dspevx.f index 58189e6d56..11c71990f6 100644 --- a/lapack-netlib/SRC/dspevx.f +++ b/lapack-netlib/SRC/dspevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSPEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -228,12 +226,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHEReigen +*> \ingroup hpevx * * ===================================================================== SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -258,7 +257,7 @@ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, + INTEGER I, IINFO, INDD, INDE, INDEE, $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1, $ J, JJ, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -270,7 +269,8 @@ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, EXTERNAL LSAME, DLAMCH, DLANSP * .. * .. External Subroutines .. - EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ, + EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, + $ DSTEBZ, $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -290,7 +290,8 @@ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. + $ LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -3 ELSE IF( N.LT.0 ) THEN @@ -363,8 +364,11 @@ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) @@ -449,21 +453,16 @@ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by DSTEIN. * - CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, + CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, + $ LDZ, $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/dstein.c b/lapack-netlib/SRC/dstein.c index 743c2badaf..0905d925f9 100644 --- a/lapack-netlib/SRC/dstein.c +++ b/lapack-netlib/SRC/dstein.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__2 = 2; @@ -241,7 +239,6 @@ static integer c_n1 = -1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSTEIN + dependencies */ /* > */ @@ -252,7 +249,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -325,6 +321,8 @@ f"> */ /* > the first submatrix from the top, =2 if W(i) belongs to */ /* > the second submatrix, etc. ( The output array IBLOCK */ /* > from DSTEBZ is expected here. ) */ +/* > A negative entry, with which DSTEBZ flags an eigenvalue that */ +/* > did not converge, is treated as its absolute value. */ /* > \endverbatim */ /* > */ /* > \param[in] ISPLIT */ @@ -401,9 +399,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup doubleOTHERcomputational */ +/* > \ingroup stein */ /* ===================================================================== */ /* Subroutine */ void dstein_(integer *n, doublereal *d__, doublereal *e, @@ -416,46 +412,41 @@ f"> */ doublereal d__1, d__2, d__3, d__4, d__5; /* Local variables */ + integer i__, j, b1, j1, bn; + doublereal xj, scl, eps, sep, nrm, tol; + integer its; + doublereal xjm, ztr, eps1; integer jblk, nblk; extern doublereal ddot_(integer *, doublereal *, integer *, doublereal *, integer *); integer jmax; extern doublereal dnrm2_(integer *, doublereal *, integer *); - integer i__, j; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); integer iseed[4], gpind, iinfo; extern /* Subroutine */ void dcopy_(integer *, doublereal *, integer *, - doublereal *, integer *); - integer b1; - extern /* Subroutine */ void daxpy_(integer *, doublereal *, doublereal *, - integer *, doublereal *, integer *); - integer j1; + doublereal *, integer *), daxpy_(integer *, doublereal *, + doublereal *, integer *, doublereal *, integer *); doublereal ortol; - integer indrv1, indrv2, indrv3, indrv4, indrv5, bn; + integer indrv1, indrv2, indrv3, indrv4, indrv5; extern doublereal dlamch_(char *); extern /* Subroutine */ void dlagtf_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer * , integer *); - doublereal xj; extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void dlagts_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), dlagts_( integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *); integer nrmchk; extern /* Subroutine */ void dlarnv_(integer *, integer *, integer *, doublereal *); integer blksiz; - doublereal onenrm, dtpcrt, pertol, scl, eps, sep, nrm, tol; - integer its; - doublereal xjm, ztr, eps1; + doublereal dtpcrt, onenrm, pertol; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -470,7 +461,7 @@ f"> */ --iblock; --isplit; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -493,11 +484,13 @@ f"> */ } else { i__1 = *m; for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) < (i__3 = iblock[j - 1], abs( + i__3))) { *info = -6; goto L30; } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) == (i__3 = iblock[j - 1], abs( + i__3)) && w[j] < w[j - 1]) { *info = -5; goto L30; } @@ -544,8 +537,8 @@ f"> */ /* Compute eigenvectors of matrix blocks. */ j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { + i__2 = (i__1 = iblock[*m], abs(i__1)); + for (nblk = 1; nblk <= i__2; ++nblk) { /* Find starting and ending indices of block nblk. */ @@ -568,8 +561,8 @@ f"> */ d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1], abs(d__2)); onenrm = f2cmax(d__3,d__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { + i__1 = bn - 1; + for (i__ = b1 + 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3)); @@ -584,9 +577,9 @@ f"> */ L60: jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { + i__1 = *m; + for (j = j1; j <= i__1; ++j) { + if ((i__3 = iblock[j], abs(i__3)) != nblk) { j1 = j; goto L160; } diff --git a/lapack-netlib/SRC/dstein.f b/lapack-netlib/SRC/dstein.f index 6506be92ac..bb7eb0eb39 100644 --- a/lapack-netlib/SRC/dstein.f +++ b/lapack-netlib/SRC/dstein.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSTEIN + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -90,6 +88,8 @@ *> the first submatrix from the top, =2 if W(i) belongs to *> the second submatrix, etc. ( The output array IBLOCK *> from DSTEBZ is expected here. ) +*> A negative entry, with which DSTEBZ flags an eigenvalue that +*> did not converge, is treated as its absolute value. *> \endverbatim *> *> \param[in] ISPLIT @@ -166,11 +166,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHERcomputational +*> \ingroup stein * * ===================================================================== SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -210,7 +211,8 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, EXTERNAL IDAMAX, DDOT, DLAMCH, DNRM2 * .. * .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, + EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, + $ DSCAL, $ XERBLA * .. * .. Intrinsic Functions .. @@ -233,11 +235,12 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, INFO = -9 ELSE DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN + IF( ABS( IBLOCK( J ) ).LT.ABS( IBLOCK( J-1 ) ) ) THEN INFO = -6 GO TO 30 END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) + IF( ABS( IBLOCK( J ) ).EQ.ABS( IBLOCK( J-1 ) ) .AND. + $ W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 @@ -281,7 +284,7 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute eigenvectors of matrix blocks. * J1 = 1 - DO 160 NBLK = 1, IBLOCK( M ) + DO 160 NBLK = 1, ABS( IBLOCK( M ) ) * * Find starting and ending indices of block nblk. * @@ -313,7 +316,7 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, 60 CONTINUE JBLK = 0 DO 150 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN + IF( ABS( IBLOCK( J ) ).NE.NBLK ) THEN J1 = J GO TO 160 END IF @@ -354,7 +357,8 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO - CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), + CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * @@ -375,7 +379,8 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * * Solve the system LU = Pb. * - CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), + CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * @@ -388,7 +393,8 @@ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ GPIND = J IF( GPIND.NE.J ) THEN DO 80 I = GPIND, J - 1 - ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), + ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, + $ I ), $ 1 ) CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1, $ WORK( INDRV1+1 ), 1 ) diff --git a/lapack-netlib/SRC/dstevr.c b/lapack-netlib/SRC/dstevr.c index 8b6b1b379f..80b0ffcbda 100644 --- a/lapack-netlib/SRC/dstevr.c +++ b/lapack-netlib/SRC/dstevr.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -244,7 +242,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSTEVR + dependencies */ /* > */ @@ -255,7 +252,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -525,9 +521,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup doubleOTHEReigen */ +/* > \ingroup stevr */ /* > \par Contributors: */ /* ================== */ @@ -549,11 +543,11 @@ f"> */ doublereal d__1, d__2; /* Local variables */ - integer imax; - doublereal rmin, rmax; + integer iscale, i__, j, jj; + doublereal eps, vll, vuu, tmp1, rmin, rmax; logical test; doublereal tnrm; - integer itmp1, i__, j; + integer itmp1; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -564,10 +558,9 @@ f"> */ *, doublereal *, integer *); integer lwmin; logical wantz; - integer jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; + integer ieeeok, indibl, indifl; logical valeig; doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, @@ -584,24 +577,22 @@ f"> */ extern /* Subroutine */ void dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, - integer *, doublereal *, integer *, integer *), - dstemr_(char *, char *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, integer *, - logical *, doublereal *, integer *, integer *, integer *, integer - *); + integer *, doublereal *, integer *, integer *); integer liwmin; + extern /* Subroutine */ void dstemr_(char *, char *, integer *, doublereal + *, doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + integer *, logical *, doublereal *, integer *, integer *, integer + *, integer *); logical tryrac; integer nsplit; doublereal smlnum; logical lquery; - doublereal eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -615,7 +606,7 @@ f"> */ --e; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -732,8 +723,12 @@ f"> */ iscale = 1; sigma = rmin / tnrm; } else if (tnrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / tnrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { dscal_(n, &sigma, &d__[1], &c__1); @@ -818,13 +813,8 @@ f"> */ L10: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dstevr.f b/lapack-netlib/SRC/dstevr.f index ce9383758d..87548af613 100644 --- a/lapack-netlib/SRC/dstevr.f +++ b/lapack-netlib/SRC/dstevr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSTEVR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -287,7 +285,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHEReigen +*> \ingroup stevr * *> \par Contributors: * ================== @@ -298,9 +296,11 @@ *> California at Berkeley, USA \n *> * ===================================================================== - SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, + SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ ABSTOL, $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -326,7 +326,7 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ, $ TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP, + INTEGER I, IEEEOK, INDIBL, INDIFL, INDISP, $ INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN, $ NSPLIT DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, @@ -339,7 +339,8 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, EXTERNAL LSAME, ILAENV, DLAMCH, DLANST * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, DSTERF, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, + $ DSTERF, $ DSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -449,8 +450,11 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / TNRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( N, SIGMA, D, 1 ) @@ -521,12 +525,14 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, ORDER = 'E' END IF - CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, + $ M, $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK, $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN - CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), + CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), + $ IWORK( INDISP ), $ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ), $ INFO ) END IF @@ -534,14 +540,8 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * If matrix was scaled, then rescale eigenvalues appropriately. * 10 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/dstevx.c b/lapack-netlib/SRC/dstevx.c index 8e0363c796..2d81d35667 100644 --- a/lapack-netlib/SRC/dstevx.c +++ b/lapack-netlib/SRC/dstevx.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -240,7 +238,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSTEVX + dependencies */ /* > */ @@ -251,7 +248,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -441,8 +437,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > DSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -453,9 +452,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup doubleOTHEReigen */ +/* > \ingroup stevx */ /* ===================================================================== */ /* Subroutine */ void dstevx_(char *jobz, char *range, integer *n, doublereal * @@ -469,25 +466,23 @@ f"> */ doublereal d__1, d__2; /* Local variables */ - integer imax; - doublereal rmin, rmax; + integer iscale, i__, j, jj; + doublereal eps, vll, vuu, tmp1, rmin, rmax; logical test; doublereal tnrm; - integer itmp1, i__, j; + integer itmp1; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; extern logical lsame_(char *, char *); + integer iinfo; char order[1]; extern /* Subroutine */ void dcopy_(integer *, doublereal *, integer *, doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *); logical wantz; - integer jj; extern doublereal dlamch_(char *); - logical alleig, indeig; - integer iscale, indibl; - logical valeig; + logical alleig, indeig, valeig; doublereal safmin; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); doublereal bignum; @@ -506,13 +501,12 @@ f"> */ extern /* Subroutine */ void dsteqr_(char *, integer *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, integer *); integer nsplit; - doublereal smlnum, eps, vll, vuu, tmp1; + doublereal smlnum; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -525,7 +519,7 @@ f"> */ --e; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -618,8 +612,12 @@ f"> */ iscale = 1; sigma = rmin / tnrm; } else if (tnrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / tnrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { dscal_(n, &sigma, &d__[1], &c__1); @@ -674,30 +672,33 @@ f"> */ *(unsigned char *)order = 'E'; } indwrk = 1; - indibl = 1; - indisp = indibl + *n; + indisp = *n + 1; indiwo = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & - nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], & - iwork[indiwo], info); + nsplit, &w[1], &iwork[1], &iwork[indisp], &work[indwrk], &iwork[ + indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L20; + } + } if (wantz) { - dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & - z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], - info); + dstein_(n, &d__[1], &e[1], m, &w[1], &iwork[1], &iwork[indisp], &z__[ + z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], & + iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } } /* If matrix was scaled, then rescale eigenvalues appropriately. */ L20: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -718,11 +719,11 @@ f"> */ } if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; + itmp1 = iwork[i__]; w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + iwork[i__] = iwork[j]; w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; + iwork[j] = itmp1; dswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); if (*info != 0) { diff --git a/lapack-netlib/SRC/dstevx.f b/lapack-netlib/SRC/dstevx.f index bec98530bb..e9ddbd8066 100644 --- a/lapack-netlib/SRC/dstevx.f +++ b/lapack-netlib/SRC/dstevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSTEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -222,11 +220,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleOTHEReigen +*> \ingroup stevx * * ===================================================================== - SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, + SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -251,7 +251,7 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDISP, INDIWO, INDWRK, + INTEGER I, IINFO, INDISP, INDIWO, INDWRK, $ ISCALE, ITMP1, J, JJ, NSPLIT DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TMP1, TNRM, VLL, VUU @@ -262,7 +262,8 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, EXTERNAL LSAME, DLAMCH, DLANST * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, + $ DSTERF, $ DSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -351,8 +352,11 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / TNRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL DSCAL( N, SIGMA, D, 1 ) @@ -380,7 +384,8 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, IF( .NOT.WANTZ ) THEN CALL DSTERF( N, W, WORK, INFO ) ELSE - CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO ) + CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), + $ INFO ) IF( INFO.EQ.0 ) THEN DO 10 I = 1, N IFAIL( I ) = 0 @@ -404,7 +409,8 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, INDWRK = 1 INDISP = 1 + N INDIWO = INDISP + N - CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, + CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, + $ M, $ NSPLIT, W, IWORK( 1 ), IWORK( INDISP ), $ WORK( INDWRK ), IWORK( INDIWO ), IINFO ) IF( IINFO.NE.0 ) THEN @@ -424,14 +430,8 @@ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/dsyevr.c b/lapack-netlib/SRC/dsyevr.c index 9c0040e2ae..955a2f914c 100644 --- a/lapack-netlib/SRC/dsyevr.c +++ b/lapack-netlib/SRC/dsyevr.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -245,7 +243,6 @@ rices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSYEVR + dependencies */ /* > */ @@ -256,7 +253,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -278,9 +274,16 @@ f"> */ /* > \verbatim */ /* > */ /* > DSYEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ -/* > selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ +/* > of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ +/* > selected by specifying either a range of values or a range of indices */ +/* > for the desired eigenvalues. Invocations with different choices for */ +/* > these parameters may result in the computation of slightly different */ +/* > eigenvalues and/or eigenvectors for the same matrix. The reason for */ +/* > this behavior is that there exists a variety of algorithms (each */ +/* > performing best for a particular set of options) with DSYEVR */ +/* > attempting to select the best based on the various parameters. In all */ +/* > cases, the computed values are accurate within the limits of finite */ +/* > precision arithmetic. */ /* > */ /* > DSYEVR first reduces the matrix A to tridiagonal form T with a call */ /* > to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute */ @@ -344,6 +347,9 @@ f"> */ /* > JOBZ is CHARACTER*1 */ /* > = 'N': Compute eigenvalues only; */ /* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] RANGE */ @@ -355,6 +361,9 @@ f"> */ /* > = 'I': the IL-th through IU-th eigenvalues will be found. */ /* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ /* > DSTEIN are called */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] UPLO */ @@ -510,7 +519,8 @@ f"> */ /* > \param[in] LWORK */ /* > \verbatim */ /* > LWORK is INTEGER */ -/* > The dimension of the array WORK. LWORK >= f2cmax(1,26*N). */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK >= 1, else LWORK >= 26*N. */ /* > For optimal efficiency, LWORK >= (NB+6)*N, */ /* > where NB is the f2cmax of the blocksize for DSYTRD and DORMTR */ /* > returned by ILAENV. */ @@ -524,13 +534,14 @@ f"> */ /* > \param[out] IWORK */ /* > \verbatim */ /* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ -/* > On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ /* > \endverbatim */ /* > */ /* > \param[in] LIWORK */ /* > \verbatim */ /* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK >= 1, else LIWORK >= 10*N. */ /* > */ /* > If LIWORK = -1, then a workspace query is assumed; the */ /* > routine only calculates the optimal size of the IWORK array, */ @@ -554,9 +565,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup doubleSYeigen */ +/* > \ingroup heevr */ /* > \par Contributors: */ /* ================== */ @@ -580,11 +589,11 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, nb, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; - integer i__, j, inddd, indee; + doublereal anrm, rmin, rmax; + integer inddd, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -597,10 +606,9 @@ f"> */ *, doublereal *, integer *); integer lwmin; logical lower, wantz; - integer nb, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; + integer ieeeok, indibl, indifl; logical valeig; doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, @@ -618,13 +626,13 @@ f"> */ extern /* Subroutine */ void dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, - integer *, doublereal *, integer *, integer *), - dstemr_(char *, char *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, integer *, - logical *, doublereal *, integer *, integer *, integer *, integer - *); + integer *, doublereal *, integer *, integer *); integer liwmin; + extern /* Subroutine */ void dstemr_(char *, char *, integer *, doublereal + *, doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + integer *, logical *, doublereal *, integer *, integer *, integer + *, integer *); logical tryrac; extern /* Subroutine */ void dormtr_(char *, char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, @@ -636,13 +644,11 @@ f"> */ integer *, integer *); integer lwkopt; logical lquery; - doublereal eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.1) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -652,11 +658,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -674,12 +680,13 @@ f"> */ lquery = *lwork == -1 || *liwork == -1; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 26; - lwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); + if (*n <= 1) { + lwmin = 1; + liwmin = 1; + } else { + lwmin = *n * 26; + liwmin = *n * 10; + } *info = 0; if (! (wantz || lsame_(jobz, "N"))) { @@ -706,7 +713,7 @@ f"> */ } } if (*info == 0) { - if (*ldz < 1 || (wantz && *ldz < *n)) { + if (*ldz < 1 || wantz && *ldz < *n) { *info = -15; } else if (*lwork < lwmin && ! lquery) { *info = -18; @@ -746,7 +753,7 @@ f"> */ } if (*n == 1) { - work[1] = 7.; + work[1] = 1.; if (alleig || indeig) { *m = 1; w[1] = a[a_dim1 + 1]; @@ -788,8 +795,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -856,7 +867,7 @@ f"> */ /* If all eigenvalues are desired */ /* then call DSTERF or DSTEMR and DORMTR. */ - if ((alleig || (indeig && *il == 1 && *iu == *n)) && ieeeok == 1) { + if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { if (! wantz) { dcopy_(n, &work[indd], &c__1, &w[1], &c__1); i__1 = *n - 1; @@ -930,13 +941,8 @@ f"> */ /* Jump here if DSTEMR/DSTEIN succeeded. */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dsyevr.f b/lapack-netlib/SRC/dsyevr.f index 8647b0162c..caa54cda31 100644 --- a/lapack-netlib/SRC/dsyevr.f +++ b/lapack-netlib/SRC/dsyevr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYEVR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -39,9 +37,16 @@ *> \verbatim *> *> DSYEVR computes selected eigenvalues and, optionally, eigenvectors -*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be -*> selected by specifying either a range of values or a range of -*> indices for the desired eigenvalues. +*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. Invocations with different choices for +*> these parameters may result in the computation of slightly different +*> eigenvalues and/or eigenvectors for the same matrix. The reason for +*> this behavior is that there exists a variety of algorithms (each +*> performing best for a particular set of options) with DSYEVR +*> attempting to select the best based on the various parameters. In all +*> cases, the computed values are accurate within the limits of finite +*> precision arithmetic. *> *> DSYEVR first reduces the matrix A to tridiagonal form T with a call *> to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute @@ -105,6 +110,9 @@ *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. +*> +*> This parameter influences the choice of the algorithm and +*> may alter the computed values. *> \endverbatim *> *> \param[in] RANGE @@ -116,6 +124,9 @@ *> = 'I': the IL-th through IU-th eigenvalues will be found. *> For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and *> DSTEIN are called +*> +*> This parameter influences the choice of the algorithm and +*> may alter the computed values. *> \endverbatim *> *> \param[in] UPLO @@ -330,9 +341,11 @@ *> California at Berkeley, USA \n *> * ===================================================================== - SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -358,7 +371,7 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, $ TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + INTEGER I, IEEEOK, IINFO, INDD, INDDD, INDE, $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT @@ -372,7 +385,8 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. - EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, + EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, + $ DSTEIN, $ DSTERF, DSWAP, DSYTRD, XERBLA * .. * .. Intrinsic Functions .. @@ -497,8 +511,11 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -632,7 +649,8 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * @@ -640,14 +658,8 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * * Jump here if DSTEMR/DSTEIN succeeded. 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. Note: We do not sort the IFAIL portion of IWORK. diff --git a/lapack-netlib/SRC/dsyevr_2stage.c b/lapack-netlib/SRC/dsyevr_2stage.c index e1018fd9b9..1d90cab838 100644 --- a/lapack-netlib/SRC/dsyevr_2stage.c +++ b/lapack-netlib/SRC/dsyevr_2stage.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -237,385 +235,6 @@ static integer c__3 = 3; static integer c__4 = 4; static integer c_n1 = -1; -/* > \brief DSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - SY matrices */ - -/* @precisions fortran d -> s */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download DSYEVR_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, */ -/* LWORK, IWORK, LIWORK, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N */ -/* DOUBLE PRECISION ABSTOL, VL, VU */ -/* INTEGER ISUPPZ( * ), IWORK( * ) */ -/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > DSYEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can be */ -/* > selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > */ -/* > DSYEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call */ -/* > to DSYTRD. Then, whenever possible, DSYEVR_2STAGE calls DSTEMR to compute */ -/* > the eigenspectrum using Relatively Robust Representations. DSTEMR */ -/* > computes eigenvalues by the dqds algorithm, while orthogonal */ -/* > eigenvectors are computed from various "good" L D L^T representations */ -/* > (also known as Relatively Robust Representations). Gram-Schmidt */ -/* > orthogonalization is avoided as far as possible. More specifically, */ -/* > the various steps of the algorithm are as follows. */ -/* > */ -/* > For each unreduced block (submatrix) of T, */ -/* > (a) Compute T - sigma I = L D L^T, so that L and D */ -/* > define all the wanted eigenvalues to high relative accuracy. */ -/* > This means that small relative changes in the entries of D and L */ -/* > cause only small relative changes in the eigenvalues and */ -/* > eigenvectors. The standard (unfactored) representation of the */ -/* > tridiagonal matrix T does not have this property in general. */ -/* > (b) Compute the eigenvalues to suitable accuracy. */ -/* > If the eigenvectors are desired, the algorithm attains full */ -/* > accuracy of the computed eigenvalues only right before */ -/* > the corresponding vectors have to be computed, see steps c) and d). */ -/* > (c) For each cluster of close eigenvalues, select a new */ -/* > shift close to the cluster, find a new factorization, and refine */ -/* > the shifted eigenvalues to suitable accuracy. */ -/* > (d) For each eigenvalue with a large enough relative separation compute */ -/* > the corresponding eigenvector by forming a rank revealing twisted */ -/* > factorization. Go back to (c) for any clusters that remain. */ -/* > */ -/* > The desired accuracy of the output can be specified by the input */ -/* > parameter ABSTOL. */ -/* > */ -/* > For more details, see DSTEMR's documentation and: */ -/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* > 2004. Also LAPACK Working Note 154. */ -/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* > tridiagonal eigenvalue/eigenvector problem", */ -/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* > UC Berkeley, May 1997. */ -/* > */ -/* > */ -/* > Note 1 : DSYEVR_2STAGE calls DSTEMR when the full spectrum is requested */ -/* > on machines which conform to the ieee-754 floating point standard. */ -/* > DSYEVR_2STAGE calls DSTEBZ and SSTEIN on non-ieee machines and */ -/* > when partial spectrum requests are made. */ -/* > */ -/* > Normal execution of DSTEMR may create NaNs and infinities and */ -/* > hence may abort due to a floating point exception in environments */ -/* > which do not handle NaNs and infinities in the ieee standard default */ -/* > manner. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ -/* > DSTEIN are called */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is DOUBLE PRECISION */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is DOUBLE PRECISION */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is 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 * f2cmax( |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. */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > */ -/* > If high relative accuracy is important, set ABSTOL to */ -/* > DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* > eigenvalues are computed to high relative accuracy when */ -/* > possible in future releases. The current code does not */ -/* > make any guarantees about high relative accuracy, but */ -/* > future releases will. See J. Barlow and J. Demmel, */ -/* > "Computing Accurate Eigensystems of Scaled Diagonally */ -/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* > of which matrices define their eigenvalues to high relative */ -/* > accuracy. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is DOUBLE PRECISION array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > Supplying N columns is always safe. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] ISUPPZ */ -/* > \verbatim */ -/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ -/* > The support of the eigenvectors in Z, i.e., the indices */ -/* > indicating the nonzero elements in Z. The i-th eigenvector */ -/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* > ISUPPZ( 2*i ). This is an output of DSTEMR (tridiagonal */ -/* > matrix). The support of the eigenvectors of A is typically */ -/* > 1:N because of the orthogonal transformations applied by DORMTR. */ -/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The dimension of the array WORK. */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 26*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 5*N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + 5*N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ -/* > On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LIWORK */ -/* > \verbatim */ -/* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ -/* > */ -/* > If LIWORK = -1, then a workspace query is assumed; the */ -/* > routine only calculates the optimal size of the IWORK array, */ -/* > returns this value as the first entry of the IWORK array, and */ -/* > no error message related to LIWORK is issued by XERBLA. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: Internal error */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup doubleSYeigen */ - -/* > \par Contributors: */ -/* ================== */ -/* > */ -/* > Inderjit Dhillon, IBM Almaden, USA \n */ -/* > Osni Marques, LBNL/NERSC, USA \n */ -/* > Ken Stanley, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > Jason Riedy, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > */ -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void dsyevr_2stage_(char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal * vu, integer *il, integer *iu, doublereal *abstol, integer *m, @@ -628,13 +247,13 @@ static integer c_n1 = -1; doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - doublereal anrm; - integer imax; - doublereal rmin, rmax; - integer i__, j, inddd, indee; + doublereal anrm, rmin, rmax; + integer inddd, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -652,10 +271,9 @@ static integer c_n1 = -1; logical lower; integer lwtrd; logical wantz; - integer ib, kd, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; + integer ieeeok, indibl, indifl; logical valeig; doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, @@ -673,13 +291,13 @@ static integer c_n1 = -1; extern /* Subroutine */ void dstebz_(char *, char *, integer *, doublereal *, doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, - integer *, doublereal *, integer *, integer *), - dstemr_(char *, char *, integer *, doublereal *, doublereal *, - doublereal *, doublereal *, integer *, integer *, integer *, - doublereal *, doublereal *, integer *, integer *, integer *, - logical *, doublereal *, integer *, integer *, integer *, integer - *); + integer *, doublereal *, integer *, integer *); integer liwmin; + extern /* Subroutine */ void dstemr_(char *, char *, integer *, doublereal + *, doublereal *, doublereal *, doublereal *, integer *, integer *, + integer *, doublereal *, doublereal *, integer *, integer *, + integer *, logical *, doublereal *, integer *, integer *, integer + *, integer *); logical tryrac; extern /* Subroutine */ void dormtr_(char *, char *, char *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, @@ -687,16 +305,13 @@ static integer c_n1 = -1; integer llwrkn, llwork, nsplit; doublereal smlnum; logical lquery; - doublereal eps, vll, vuu; integer indhous; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -706,11 +321,11 @@ static integer c_n1 = -1; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -732,12 +347,16 @@ static integer c_n1 = -1; ib = ilaenv2stage_(&c__2, "DSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); lhtrd = ilaenv2stage_(&c__3, "DSYTRD_2STAGE", jobz, n, &kd, &ib, &c_n1); lwtrd = ilaenv2stage_(&c__4, "DSYTRD_2STAGE", jobz, n, &kd, &ib, &c_n1); + + if (*n <= 1) { + lwmin = 1; + liwmin = 1; + } else { /* Computing MAX */ - i__1 = *n * 26, i__2 = *n * 5 + lhtrd + lwtrd; - lwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); + i__1 = *n * 26, i__2 = *n * 5 + lhtrd + lwtrd; + lwmin = f2cmax(i__1,i__2); + liwmin = *n * 10; + } *info = 0; if (! lsame_(jobz, "N")) { @@ -798,7 +417,7 @@ static integer c_n1 = -1; } if (*n == 1) { - work[1] = 7.; + work[1] = 1.; if (alleig || indeig) { *m = 1; w[1] = a[a_dim1 + 1]; @@ -840,8 +459,12 @@ static integer c_n1 = -1; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -912,7 +535,7 @@ static integer c_n1 = -1; /* If all eigenvalues are desired */ /* then call DSTERF or DSTEMR and DORMTR. */ - if ((alleig || (indeig && *il == 1 && *iu == *n)) && ieeeok == 1) { + if ((alleig || indeig && *il == 1 && *iu == *n) && ieeeok == 1) { if (! wantz) { dcopy_(n, &work[indd], &c__1, &w[1], &c__1); i__1 = *n - 1; @@ -986,13 +609,8 @@ static integer c_n1 = -1; /* Jump here if DSTEMR/DSTEIN succeeded. */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dsyevr_2stage.f b/lapack-netlib/SRC/dsyevr_2stage.f index 63d5e31598..f09a137b3e 100644 --- a/lapack-netlib/SRC/dsyevr_2stage.f +++ b/lapack-netlib/SRC/dsyevr_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYEVR_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -407,7 +405,7 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, $ TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + INTEGER I, IEEEOK, IINFO, INDD, INDDD, INDE, $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, $ LLWORK, LLWRKN, LWMIN, NSPLIT, @@ -419,10 +417,12 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL LSAME INTEGER ILAENV, ILAENV2STAGE DOUBLE PRECISION DLAMCH, DLANSY - EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV, ILAENV2STAGE + EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV, + $ ILAENV2STAGE * .. * .. External Subroutines .. - EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN, + EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, + $ DSTEIN, $ DSTERF, DSWAP, DSYTRD_2STAGE, XERBLA * .. * .. Intrinsic Functions .. @@ -442,10 +442,14 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) * - KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) - IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) - LHTRD = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) - LWTRD = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + KD = ILAENV2STAGE( 1, 'DSYTRD_2STAGE', JOBZ, N, -1, -1, + $ -1 ) + IB = ILAENV2STAGE( 2, 'DSYTRD_2STAGE', JOBZ, N, KD, -1, + $ -1 ) + LHTRD = ILAENV2STAGE( 3, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, + $ -1 ) + LWTRD = ILAENV2STAGE( 4, 'DSYTRD_2STAGE', JOBZ, N, KD, IB, + $ -1 ) * IF( N.LE.1 ) THEN LWMIN = 1 @@ -552,8 +556,11 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -692,7 +699,8 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * @@ -700,14 +708,8 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * * Jump here if DSTEMR/DSTEIN succeeded. 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. Note: We do not sort the IFAIL portion of IWORK. diff --git a/lapack-netlib/SRC/dsyevx.c b/lapack-netlib/SRC/dsyevx.c index 51ca3672ff..f9eeafd2f3 100644 --- a/lapack-netlib/SRC/dsyevx.c +++ b/lapack-netlib/SRC/dsyevx.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -241,7 +239,6 @@ rices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download DSYEVX + dependencies */ /* > */ @@ -252,7 +249,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -467,8 +463,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > DSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -479,9 +478,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup doubleSYeigen */ +/* > \ingroup heevx */ /* ===================================================================== */ /* Subroutine */ void dsyevx_(char *jobz, char *range, char *uplo, integer *n, @@ -495,12 +492,12 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, nb, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -511,10 +508,9 @@ f"> */ doublereal *, integer *), dswap_(integer *, doublereal *, integer *, doublereal *, integer *); logical lower, wantz; - integer nb, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; extern /* Subroutine */ void dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); @@ -549,13 +545,11 @@ f"> */ integer *, integer *); integer lwkopt; logical lquery; - doublereal eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -565,11 +559,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -616,7 +610,7 @@ f"> */ if (*info == 0) { if (*n <= 1) { lwkmin = 1; - work[1] = (doublereal) lwkmin; + lwkopt = 1; } else { lwkmin = *n << 3; nb = ilaenv_(&c__1, "DSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, ( @@ -628,8 +622,8 @@ f"> */ /* Computing MAX */ i__1 = lwkmin, i__2 = (nb + 3) * *n; lwkopt = f2cmax(i__1,i__2); - work[1] = (doublereal) lwkopt; } + work[1] = (doublereal) lwkopt; if (*lwork < lwkmin && ! lquery) { *info = -17; @@ -691,8 +685,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -780,12 +778,21 @@ f"> */ indiwo = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by DSTEIN. */ @@ -800,13 +807,8 @@ f"> */ L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dsyevx.f b/lapack-netlib/SRC/dsyevx.f index 6d924c47fd..ac3bf7d28f 100644 --- a/lapack-netlib/SRC/dsyevx.f +++ b/lapack-netlib/SRC/dsyevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -250,9 +248,11 @@ *> \ingroup heevx * * ===================================================================== - SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -278,7 +278,7 @@ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN, $ LWKOPT, NB, NSPLIT @@ -292,7 +292,8 @@ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, + EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, + $ DSTEBZ, $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA * .. * .. Intrinsic Functions .. @@ -345,7 +346,8 @@ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ELSE LWKMIN = 8*N NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) - NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) ) + NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, + $ -1 ) ) LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) END IF WORK( 1 ) = LWKOPT @@ -405,8 +407,11 @@ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -504,21 +509,16 @@ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/dsyevx_2stage.c b/lapack-netlib/SRC/dsyevx_2stage.c index f3b3651d1f..e04e54f5b0 100644 --- a/lapack-netlib/SRC/dsyevx_2stage.c +++ b/lapack-netlib/SRC/dsyevx_2stage.c @@ -226,8 +226,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -236,304 +234,6 @@ static integer c__2 = 2; static integer c__3 = 3; static integer c__4 = 4; -/* > \brief DSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - SY matrices */ - -/* @precisions fortran d -> s */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download DSYEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */ -/* LWORK, IWORK, IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N */ -/* DOUBLE PRECISION ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > DSYEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can be */ -/* > selected by specifying either a range of values or a range of indices */ -/* > for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is DOUBLE PRECISION */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is DOUBLE PRECISION */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is 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 * f2cmax( |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'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is DOUBLE PRECISION array, dimension (N) */ -/* > On normal exit, the first M elements contain the selected */ -/* > eigenvalues in ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is DOUBLE PRECISION array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 8*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 3*N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + 3*N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup doubleSYeigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void dsyevx_2stage_(char *jobz, char *range, char *uplo, integer *n, doublereal *a, integer *lda, doublereal *vl, doublereal * vu, integer *il, integer *iu, doublereal *abstol, integer *m, @@ -545,14 +245,14 @@ static integer c__4 = 4; doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -570,10 +270,9 @@ static integer c__4 = 4; logical lower; integer lwtrd; logical wantz; - integer ib, kd, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; extern /* Subroutine */ void dlacpy_(char *, integer *, integer *, doublereal *, integer *, doublereal *, integer *); @@ -602,16 +301,13 @@ static integer c__4 = 4; integer llwrkn, llwork, nsplit; doublereal smlnum; logical lquery; - doublereal eps, vll, vuu; integer indhous; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -621,11 +317,11 @@ static integer c__4 = 4; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -748,8 +444,12 @@ static integer c__4 = 4; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -840,12 +540,21 @@ static integer c__4 = 4; indiwo = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { dstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by DSTEIN. */ @@ -860,13 +569,8 @@ static integer c__4 = 4; L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/dsyevx_2stage.f b/lapack-netlib/SRC/dsyevx_2stage.f index 18cc883f7a..cdbb7e2c1e 100644 --- a/lapack-netlib/SRC/dsyevx_2stage.f +++ b/lapack-netlib/SRC/dsyevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download DSYEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -208,12 +206,12 @@ *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= 1, when N <= 1; -*> otherwise +*> otherwise *> If JOBZ = 'N' and N > 1, LWORK must be queried. *> LWORK = MAX(1, 8*N, dimension) where *> dimension = max(stage1,stage2) + (KD+1)*N + 3*N -*> = N*KD + N*max(KD+1,FACTOPTNB) -*> + max(2*KD*KD, KD*NTHREADS) +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) *> + (KD+1)*N + 3*N *> where KD is the blocking size of the reduction, *> FACTOPTNB is the blocking used by the QR or LQ @@ -262,7 +260,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup doubleSYeigen +*> \ingroup heevx_2stage * *> \par Further Details: * ===================== @@ -280,7 +278,7 @@ *> http://doi.acm.org/10.1145/2063384.2063394 *> *> A. Haidar, J. Kurzak, P. Luszczek, 2013. -*> An improved parallel singular value algorithm and its implementation +*> An improved parallel singular value algorithm and its implementation *> for multicore hardware, In Proceedings of 2013 International Conference *> for High Performance Computing, Networking, Storage and Analysis (SC '13). *> Denver, Colorado, USA, 2013. @@ -288,11 +286,11 @@ *> http://doi.acm.org/10.1145/2503210.2503292 *> *> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. -*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure *> calculations based on fine-grained memory aware tasks. *> International Journal of High Performance Computing Applications. *> Volume 28 Issue 2, Pages 196-209, May 2014. -*> http://hpc.sagepub.com/content/28/2/196 +*> http://hpc.sagepub.com/content/28/2/196 *> *> \endverbatim * @@ -327,7 +325,7 @@ SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LLWRKN, $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS @@ -341,7 +339,8 @@ SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV2STAGE * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ, + EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, + $ DSTEBZ, $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA, $ DSYTRD_2STAGE * .. @@ -460,8 +459,11 @@ SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -490,7 +492,7 @@ SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, INDWRK = INDHOUS + LHTRD LLWORK = LWORK - INDWRK + 1 * - CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), + CALL DSYTRD_2STAGE( JOBZ, UPLO, N, A, LDA, WORK( INDD ), $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), $ LHTRD, WORK( INDWRK ), LLWORK, IINFO ) * @@ -562,21 +564,16 @@ SUBROUTINE DSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/ssbevx.c b/lapack-netlib/SRC/ssbevx.c index 67d608985c..bf201e0582 100644 --- a/lapack-netlib/SRC/ssbevx.c +++ b/lapack-netlib/SRC/ssbevx.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SSBEVX + dependencies */ /* > */ @@ -498,7 +245,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -725,8 +471,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit. */ /* > < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > SSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -737,9 +486,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup realOTHEReigen */ +/* > \ingroup hbevx */ /* ===================================================================== */ /* Subroutine */ void ssbevx_(char *jobz, char *range, char *uplo, integer *n, @@ -754,12 +501,12 @@ f"> */ real r__1, r__2; /* Local variables */ + integer iscale, i__, j, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -771,10 +518,8 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer jj; - logical alleig, indeig; - integer iscale, indibl; + logical wantz, alleig, indeig; + integer indibl; logical valeig; extern real slamch_(char *); real safmin; @@ -801,13 +546,11 @@ f"> */ integer *, real *, integer *, integer *, real *, integer *, integer *), ssteqr_(char *, integer *, real *, real *, real *, integer *, real *, integer *); - real eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -817,14 +560,14 @@ f"> */ /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -932,8 +675,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1010,12 +757,21 @@ f"> */ indiwo = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by SSTEIN. */ @@ -1033,13 +789,8 @@ f"> */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/ssbevx.f b/lapack-netlib/SRC/ssbevx.f index 9961cdd425..c7080f906a 100644 --- a/lapack-netlib/SRC/ssbevx.f +++ b/lapack-netlib/SRC/ssbevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSBEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -259,12 +257,14 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHEReigen +*> \ingroup hbevx * * ===================================================================== - SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, + SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, + $ VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK, $ IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -290,7 +290,7 @@ SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, $ NSPLIT REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -302,7 +302,8 @@ SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, EXTERNAL LSAME, SLAMCH, SLANSB * .. * .. External Subroutines .. - EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SSBTRD, SSCAL, + EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SSBTRD, + $ SSCAL, $ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -405,14 +406,19 @@ SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -504,14 +510,8 @@ SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/ssbevx_2stage.c b/lapack-netlib/SRC/ssbevx_2stage.c index 7795967f82..318d4165d0 100644 --- a/lapack-netlib/SRC/ssbevx_2stage.c +++ b/lapack-netlib/SRC/ssbevx_2stage.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \brief SSBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - OTHER matrices */ - -/* @generated from dsbevx_2stage.f, fortran d -> s, Sat Nov 5 23:58:06 2016 */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download SSBEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, */ -/* LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, */ -/* LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK */ -/* REAL ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* REAL AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ), */ -/* $ Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > SSBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric band matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] KD */ -/* > \verbatim */ -/* > KD is INTEGER */ -/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] AB */ -/* > \verbatim */ -/* > AB is REAL array, dimension (LDAB, N) */ -/* > On entry, the upper or lower triangle of the symmetric 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 f2cmax(1,j-kd)<=i<=j; */ -/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDAB */ -/* > \verbatim */ -/* > LDAB is INTEGER */ -/* > The leading dimension of the array AB. LDAB >= KD + 1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Q */ -/* > \verbatim */ -/* > Q is REAL array, dimension (LDQ, N) */ -/* > If JOBZ = 'V', the N-by-N orthogonal matrix used in the */ -/* > reduction to tridiagonal form. */ -/* > If JOBZ = 'N', the array Q is not referenced. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDQ */ -/* > \verbatim */ -/* > LDQ is INTEGER */ -/* > The leading dimension of the array Q. If JOBZ = 'V', then */ -/* > LDQ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is REAL */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is REAL */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is REAL */ -/* > 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 * f2cmax( |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 AB to tridiagonal form. */ -/* > */ -/* > Eigenvalues will be computed most accurately when ABSTOL is */ -/* > set to twice the underflow threshold 2*SLAMCH('S'), not zero. */ -/* > If this routine returns with INFO>0, indicating that some */ -/* > eigenvectors did not converge, try setting ABSTOL to */ -/* > 2*SLAMCH('S'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is REAL array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is REAL array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is REAL array, dimension (LWORK) */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 7*N, dimension) where */ -/* > dimension = (2KD+1)*N + KD*NTHREADS + 2*N */ -/* > where KD is the size of the band. */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit. */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup realOTHEReigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void ssbevx_2stage_(char *jobz, char *range, char *uplo, integer *n, integer *kd, real *ab, integer *ldab, real *q, integer * ldq, real *vl, real *vu, integer *il, integer *iu, real *abstol, @@ -815,17 +243,17 @@ static real c_b45 = 0.f; real r__1, r__2; /* Local variables */ + integer iscale, i__, j, ib, jj; + real eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; extern /* Subroutine */ void ssytrd_sb2st_(char *, char *, char *, integer *, integer *, real *, integer *, real *, real *, real *, integer *, real *, integer *, integer *); - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -840,10 +268,8 @@ static real c_b45 = 0.f; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer ib, jj; - logical alleig, indeig; - integer iscale, indibl; + logical wantz, alleig, indeig; + integer indibl; logical valeig; extern real slamch_(char *); real safmin; @@ -870,16 +296,14 @@ static real c_b45 = 0.f; logical lquery; extern /* Subroutine */ void ssteqr_(char *, integer *, real *, real *, real *, integer *, real *, integer *); - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer indhous; - real tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -889,14 +313,14 @@ static real c_b45 = 0.f; /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -947,7 +371,7 @@ static real c_b45 = 0.f; if (*info == 0) { if (*n <= 1) { lwmin = 1; - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); } else { ib = ilaenv2stage_(&c__2, "SSYTRD_SB2ST", jobz, n, kd, &c_n1, & c_n1); @@ -956,7 +380,7 @@ static real c_b45 = 0.f; lwtrd = ilaenv2stage_(&c__4, "SSYTRD_SB2ST", jobz, n, kd, &ib, & c_n1); lwmin = (*n << 1) + lhtrd + lwtrd; - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); } if (*lwork < lwmin && ! lquery) { @@ -966,7 +390,7 @@ static real c_b45 = 0.f; if (*info != 0) { i__1 = -(*info); - xerbla_("SSBEVX_2STAGE ", &i__1, (ftnlen)13); + xerbla_("SSBEVX_2STAGE ", &i__1, (ftnlen)14); return; } else if (lquery) { return; @@ -1027,8 +451,12 @@ static real c_b45 = 0.f; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1109,12 +537,21 @@ static real c_b45 = 0.f; indiwo = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by SSTEIN. */ @@ -1132,13 +569,8 @@ static real c_b45 = 0.f; L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1178,7 +610,7 @@ static real c_b45 = 0.f; /* Set WORK(1) to optimal workspace size. */ - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); return; diff --git a/lapack-netlib/SRC/ssbevx_2stage.f b/lapack-netlib/SRC/ssbevx_2stage.f index 33c2e5cac3..d70644ca22 100644 --- a/lapack-netlib/SRC/ssbevx_2stage.f +++ b/lapack-netlib/SRC/ssbevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSBEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -319,7 +317,8 @@ *> \endverbatim * * ===================================================================== - SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, + SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, + $ Q, $ LDQ, VL, VU, IL, IU, ABSTOL, M, W, Z, $ LDZ, WORK, LWORK, IWORK, IFAIL, INFO ) * @@ -350,7 +349,7 @@ SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, $ LQUERY CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ, $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, $ NSPLIT @@ -365,7 +364,8 @@ SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SSCAL, + EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, + $ SSCAL, $ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA, $ SSYTRD_SB2ST * .. @@ -491,14 +491,19 @@ SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -516,7 +521,8 @@ SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, INDWRK = INDHOUS + LHTRD LLWORK = LWORK - INDWRK + 1 * - CALL SSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ), + CALL SSYTRD_SB2ST( "N", JOBZ, UPLO, N, KD, AB, LDAB, + $ WORK( INDD ), $ WORK( INDE ), WORK( INDHOUS ), LHTRD, $ WORK( INDWRK ), LLWORK, IINFO ) * @@ -594,14 +600,8 @@ SUBROUTINE SSBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/sspevx.c b/lapack-netlib/SRC/sspevx.c index 2a6cc694e5..3f9a018297 100644 --- a/lapack-netlib/SRC/sspevx.c +++ b/lapack-netlib/SRC/sspevx.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SSPEVX + dependencies */ /* > */ @@ -496,7 +243,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -692,8 +438,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > SSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -704,9 +453,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup realOTHEReigen */ +/* > \ingroup hpevx */ /* ===================================================================== */ /* Subroutine */ void sspevx_(char *jobz, char *range, char *uplo, integer *n, @@ -719,12 +466,12 @@ f"> */ real r__1, r__2; /* Local variables */ + integer iscale, i__, j, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -733,11 +480,7 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer jj; - logical alleig, indeig; - integer iscale, indibl; - logical valeig; + logical wantz, alleig, indeig, valeig; extern real slamch_(char *); real safmin; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); @@ -761,13 +504,11 @@ f"> */ real *, integer *), sopmtr_(char *, char *, char *, integer *, integer *, real *, real *, real *, integer *, real *, integer *); - real eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -779,7 +520,7 @@ f"> */ --ap; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -876,8 +617,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; @@ -945,17 +690,25 @@ f"> */ } else { *(unsigned char *)order = 'E'; } - indibl = 1; - indisp = indibl + *n; + indisp = *n + 1; indiwo = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ - inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + inde], m, &nsplit, &w[1], &iwork[1], &iwork[indisp], &work[indwrk] + , &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L20; + } + } if (wantz) { - sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ + sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[1], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by SSTEIN. */ @@ -968,13 +721,8 @@ f"> */ L20: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -995,11 +743,11 @@ f"> */ } if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; + itmp1 = iwork[i__]; w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + iwork[i__] = iwork[j]; w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; + iwork[j] = itmp1; sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); if (*info != 0) { diff --git a/lapack-netlib/SRC/sspevx.f b/lapack-netlib/SRC/sspevx.f index 4eba31870e..ca602d8c7d 100644 --- a/lapack-netlib/SRC/sspevx.f +++ b/lapack-netlib/SRC/sspevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSPEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -228,12 +226,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHEReigen +*> \ingroup hpevx * * ===================================================================== SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL, $ INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -258,7 +257,7 @@ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, + INTEGER I, IINFO, INDD, INDE, INDEE, $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1, $ J, JJ, NSPLIT REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -270,7 +269,8 @@ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, EXTERNAL LSAME, SLAMCH, SLANSP * .. * .. External Subroutines .. - EXTERNAL SCOPY, SOPGTR, SOPMTR, SSCAL, SSPTRD, SSTEBZ, + EXTERNAL SCOPY, SOPGTR, SOPMTR, SSCAL, SSPTRD, + $ SSTEBZ, $ SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -290,7 +290,8 @@ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. + $ LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -3 ELSE IF( N.LT.0 ) THEN @@ -363,8 +364,11 @@ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) @@ -449,21 +453,16 @@ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * Apply orthogonal matrix used in reduction to tridiagonal * form to eigenvectors returned by SSTEIN. * - CALL SOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, + CALL SOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, + $ LDZ, $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/sstein.c b/lapack-netlib/SRC/sstein.c index f52ed075f7..8c54b4a697 100644 --- a/lapack-netlib/SRC/sstein.c +++ b/lapack-netlib/SRC/sstein.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \htmlonly */ /* > Download SSTEIN + dependencies */ /* > */ @@ -497,7 +244,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -570,6 +316,8 @@ f"> */ /* > the first submatrix from the top, =2 if W(i) belongs to */ /* > the second submatrix, etc. ( The output array IBLOCK */ /* > from SSTEBZ is expected here. ) */ +/* > A negative entry, with which SSTEBZ flags an eigenvalue that */ +/* > did not converge, is treated as its absolute value. */ /* > \endverbatim */ /* > */ /* > \param[in] ISPLIT */ @@ -646,9 +394,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup realOTHERcomputational */ +/* > \ingroup stein */ /* ===================================================================== */ /* Subroutine */ void sstein_(integer *n, real *d__, real *e, integer *m, real @@ -660,22 +406,22 @@ f"> */ real r__1, r__2, r__3, r__4, r__5; /* Local variables */ + integer i__, j, b1, j1, bn; + real xj, scl, eps, ctr, sep, nrm, tol; + integer its; + real xjm, eps1; integer jblk, nblk, jmax; extern real sdot_(integer *, real *, integer *, real *, integer *), snrm2_(integer *, real *, integer *); - integer i__, j, iseed[4], gpind, iinfo; - extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); - integer b1, j1; - extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, - integer *); + integer iseed[4], gpind, iinfo; + extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *), + scopy_(integer *, real *, integer *, real *, integer *); real ortol; extern /* Subroutine */ void saxpy_(integer *, real *, real *, integer *, real *, integer *); - integer indrv1, indrv2, indrv3, indrv4, indrv5, bn; - real xj; + integer indrv1, indrv2, indrv3, indrv4, indrv5; extern real slamch_(char *); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void slagtf_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), slagtf_( integer *, real *, real *, real *, real *, real *, real *, integer *, integer *); integer nrmchk; @@ -686,15 +432,12 @@ f"> */ real onenrm, pertol; extern /* Subroutine */ void slarnv_(integer *, integer *, integer *, real *); - real stpcrt, scl, eps, ctr, sep, nrm, tol; - integer its; - real xjm, eps1; + real stpcrt; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -709,7 +452,7 @@ f"> */ --iblock; --isplit; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -732,11 +475,13 @@ f"> */ } else { i__1 = *m; for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) < (i__3 = iblock[j - 1], abs( + i__3))) { *info = -6; goto L30; } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) == (i__3 = iblock[j - 1], abs( + i__3)) && w[j] < w[j - 1]) { *info = -5; goto L30; } @@ -783,8 +528,8 @@ f"> */ /* Compute eigenvectors of matrix blocks. */ j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { + i__2 = (i__1 = iblock[*m], abs(i__1)); + for (nblk = 1; nblk <= i__2; ++nblk) { /* Find starting and ending indices of block nblk. */ @@ -807,8 +552,8 @@ f"> */ r__3 = onenrm, r__4 = (r__1 = d__[bn], abs(r__1)) + (r__2 = e[bn - 1], abs(r__2)); onenrm = f2cmax(r__3,r__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { + i__1 = bn - 1; + for (i__ = b1 + 1; i__ <= i__1; ++i__) { /* Computing MAX */ r__4 = onenrm, r__5 = (r__1 = d__[i__], abs(r__1)) + (r__2 = e[ i__ - 1], abs(r__2)) + (r__3 = e[i__], abs(r__3)); @@ -817,15 +562,15 @@ f"> */ } ortol = onenrm * .001f; - stpcrt = sqrt(.1f / blksiz); + stpcrt = sqrt(.1f / (real) blksiz); /* Loop through eigenvalues of block nblk. */ L60: jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { + i__1 = *m; + for (j = j1; j <= i__1; ++j) { + if ((i__3 = iblock[j], abs(i__3)) != nblk) { j1 = j; goto L160; } @@ -885,8 +630,8 @@ f"> */ jmax = isamax_(&blksiz, &work[indrv1 + 1], &c__1); /* Computing MAX */ r__3 = eps, r__4 = (r__1 = work[indrv4 + blksiz], abs(r__1)); - scl = blksiz * onenrm * f2cmax(r__3,r__4) / (r__2 = work[indrv1 + - jmax], abs(r__2)); + scl = (real) blksiz * onenrm * f2cmax(r__3,r__4) / (r__2 = work[ + indrv1 + jmax], abs(r__2)); sscal_(&blksiz, &scl, &work[indrv1 + 1], &c__1); /* Solve the system LU = Pb. */ diff --git a/lapack-netlib/SRC/sstein.f b/lapack-netlib/SRC/sstein.f index d944c0b112..72d5507309 100644 --- a/lapack-netlib/SRC/sstein.f +++ b/lapack-netlib/SRC/sstein.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSTEIN + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -90,6 +88,8 @@ *> the first submatrix from the top, =2 if W(i) belongs to *> the second submatrix, etc. ( The output array IBLOCK *> from SSTEBZ is expected here. ) +*> A negative entry, with which SSTEBZ flags an eigenvalue that +*> did not converge, is treated as its absolute value. *> \endverbatim *> *> \param[in] ISPLIT @@ -166,11 +166,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHERcomputational +*> \ingroup stein * * ===================================================================== SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -210,7 +211,8 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, EXTERNAL ISAMAX, SDOT, SLAMCH, SNRM2 * .. * .. External Subroutines .. - EXTERNAL SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL, + EXTERNAL SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, + $ SSCAL, $ XERBLA * .. * .. Intrinsic Functions .. @@ -233,11 +235,12 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, INFO = -9 ELSE DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN + IF( ABS( IBLOCK( J ) ).LT.ABS( IBLOCK( J-1 ) ) ) THEN INFO = -6 GO TO 30 END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) + IF( ABS( IBLOCK( J ) ).EQ.ABS( IBLOCK( J-1 ) ) .AND. + $ W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 @@ -281,7 +284,7 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute eigenvectors of matrix blocks. * J1 = 1 - DO 160 NBLK = 1, IBLOCK( M ) + DO 160 NBLK = 1, ABS( IBLOCK( M ) ) * * Find starting and ending indices of block nblk. * @@ -306,14 +309,14 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, 50 CONTINUE ORTOL = ODM3*ONENRM * - STPCRT = SQRT( ODM1 / BLKSIZ ) + STPCRT = SQRT( ODM1 / REAL( BLKSIZ ) ) * * Loop through eigenvalues of block nblk. * 60 CONTINUE JBLK = 0 DO 150 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN + IF( ABS( IBLOCK( J ) ).NE.NBLK ) THEN J1 = J GO TO 160 END IF @@ -354,7 +357,8 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO - CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), + CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * @@ -368,14 +372,15 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Normalize and scale the righthand side vector Pb. * JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 ) - SCL = BLKSIZ*ONENRM*MAX( EPS, + SCL = REAL( BLKSIZ )*ONENRM*MAX( EPS, $ ABS( WORK( INDRV4+BLKSIZ ) ) ) / $ ABS( WORK( INDRV1+JMAX ) ) CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 ) * * Solve the system LU = Pb. * - CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), + CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * @@ -388,7 +393,8 @@ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ GPIND = J IF( GPIND.NE.J ) THEN DO 80 I = GPIND, J - 1 - CTR = -SDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ), + CTR = -SDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, + $ I ), $ 1 ) CALL SAXPY( BLKSIZ, CTR, Z( B1, I ), 1, $ WORK( INDRV1+1 ), 1 ) diff --git a/lapack-netlib/SRC/sstevr.c b/lapack-netlib/SRC/sstevr.c index 0f8b50b586..05aae45095 100644 --- a/lapack-netlib/SRC/sstevr.c +++ b/lapack-netlib/SRC/sstevr.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SSTEVR + dependencies */ /* > */ @@ -500,7 +247,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -770,9 +516,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup realOTHEReigen */ +/* > \ingroup stevr */ /* > \par Contributors: */ /* ================== */ @@ -795,12 +539,10 @@ f"> */ real r__1, r__2; /* Local variables */ - integer imax; - real rmin, rmax; + integer iscale, i__, j, jj; + real eps, vll, vuu, tmp1, rmin, rmax; logical test; - real tnrm; - integer i__, j; - real sigma; + real tnrm, sigma; extern logical lsame_(char *, char *); extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); char order[1]; @@ -808,10 +550,8 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer jj; - logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; + logical wantz, alleig, indeig; + integer ieeeok, indibl, indifl; logical valeig; extern real slamch_(char *); real safmin; @@ -837,13 +577,12 @@ f"> */ real *, integer *, integer *, integer *, logical *, real *, integer *, integer *, integer *, integer *); logical lquery; - real eps, vll, vuu, tmp1; + extern real sroundup_lwork__(integer *); -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -857,7 +596,7 @@ f"> */ --e; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -908,7 +647,7 @@ f"> */ } if (*info == 0) { - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { @@ -974,8 +713,12 @@ f"> */ iscale = 1; sigma = rmin / tnrm; } else if (tnrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / tnrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { sscal_(n, &sigma, &d__[1], &c__1); @@ -1021,7 +764,7 @@ f"> */ ssterf_(n, &w[1], &work[1], info); } else { scopy_(n, &d__[1], &c__1, &work[*n + 1], &c__1); - if (*abstol <= *n * 2.f * eps) { + if (*abstol <= (real) (*n) * 2.f * eps) { tryrac = TRUE_; } else { tryrac = FALSE_; @@ -1060,13 +803,8 @@ f"> */ L10: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1100,7 +838,7 @@ f"> */ /* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002 */ - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); iwork[1] = liwmin; return; diff --git a/lapack-netlib/SRC/sstevr.f b/lapack-netlib/SRC/sstevr.f index 42f49b11b2..51dac1c905 100644 --- a/lapack-netlib/SRC/sstevr.f +++ b/lapack-netlib/SRC/sstevr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSTEVR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -300,9 +298,11 @@ *> California at Berkeley, USA \n *> * ===================================================================== - SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, + SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ ABSTOL, $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK, $ LIWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -328,7 +328,7 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ, $ TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP, + INTEGER I, IEEEOK, INDIBL, INDIFL, INDISP, $ INDIWO, ISCALE, J, JJ, LIWMIN, LWMIN, NSPLIT REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TMP1, TNRM, VLL, VUU @@ -337,10 +337,12 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANST, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, SLAMCH, SLANST, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SLAMCH, SLANST, + $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEMR, SSTEIN, SSTERF, + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEMR, SSTEIN, + $ SSTERF, $ SSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -450,8 +452,11 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / TNRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL SSCAL( N, SIGMA, D, 1 ) @@ -497,7 +502,7 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, CALL SSTERF( N, W, WORK, INFO ) ELSE CALL SCOPY( N, D, 1, WORK( N+1 ), 1 ) - IF (ABSTOL .LE. TWO*N*EPS) THEN + IF (ABSTOL .LE. TWO*REAL( N )*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. @@ -522,12 +527,14 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, ORDER = 'E' END IF - CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, + $ M, $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK, $ IWORK( INDIWO ), INFO ) * IF( WANTZ ) THEN - CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ), + CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), + $ IWORK( INDISP ), $ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ), $ INFO ) END IF @@ -535,14 +542,8 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * If matrix was scaled, then rescale eigenvalues appropriately. * 10 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/sstevx.c b/lapack-netlib/SRC/sstevx.c index 9efccc2952..312a771493 100644 --- a/lapack-netlib/SRC/sstevx.c +++ b/lapack-netlib/SRC/sstevx.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SSTEVX + dependencies */ /* > */ @@ -496,7 +243,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -686,8 +432,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > SSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -698,9 +447,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup realOTHEReigen */ +/* > \ingroup stevx */ /* ===================================================================== */ /* Subroutine */ void sstevx_(char *jobz, char *range, integer *n, real *d__, @@ -713,23 +460,20 @@ f"> */ real r__1, r__2; /* Local variables */ - integer imax; - real rmin, rmax; + integer iscale, i__, j, jj; + real eps, vll, vuu, tmp1, rmin, rmax; logical test; real tnrm; - integer itmp1, i__, j; + integer itmp1; real sigma; extern logical lsame_(char *, char *); + integer iinfo; extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *); char order[1]; extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer jj; - logical alleig, indeig; - integer iscale, indibl; - logical valeig; + logical wantz, alleig, indeig, valeig; extern real slamch_(char *); real safmin; extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); @@ -748,13 +492,11 @@ f"> */ real smlnum; extern /* Subroutine */ void ssteqr_(char *, integer *, real *, real *, real *, integer *, real *, integer *); - real eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -767,7 +509,7 @@ f"> */ --e; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -860,8 +602,12 @@ f"> */ iscale = 1; sigma = rmin / tnrm; } else if (tnrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / tnrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { sscal_(n, &sigma, &d__[1], &c__1); @@ -916,30 +662,33 @@ f"> */ *(unsigned char *)order = 'E'; } indwrk = 1; - indibl = 1; - indisp = indibl + *n; + indisp = *n + 1; indiwo = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, abstol, &d__[1], &e[1], m, & - nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[indwrk], & - iwork[indiwo], info); + nsplit, &w[1], &iwork[1], &iwork[indisp], &work[indwrk], &iwork[ + indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L20; + } + } if (wantz) { - sstein_(n, &d__[1], &e[1], m, &w[1], &iwork[indibl], &iwork[indisp], & - z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], - info); + sstein_(n, &d__[1], &e[1], m, &w[1], &iwork[1], &iwork[indisp], &z__[ + z_offset], ldz, &work[indwrk], &iwork[indiwo], &ifail[1], & + iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } } /* If matrix was scaled, then rescale eigenvalues appropriately. */ L20: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -960,11 +709,11 @@ f"> */ } if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; + itmp1 = iwork[i__]; w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + iwork[i__] = iwork[j]; w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; + iwork[j] = itmp1; sswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); if (*info != 0) { diff --git a/lapack-netlib/SRC/sstevx.f b/lapack-netlib/SRC/sstevx.f index ecadf486f1..51c563109b 100644 --- a/lapack-netlib/SRC/sstevx.f +++ b/lapack-netlib/SRC/sstevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSTEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -222,11 +220,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup realOTHEReigen +*> \ingroup stevx * * ===================================================================== - SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, + SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, + $ ABSTOL, $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -251,7 +251,7 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDISP, INDIWO, INDWRK, + INTEGER I, IINFO, INDISP, INDIWO, INDWRK, $ ISCALE, ITMP1, J, JJ, NSPLIT REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM, $ TMP1, TNRM, VLL, VUU @@ -262,7 +262,8 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, EXTERNAL LSAME, SLAMCH, SLANST * .. * .. External Subroutines .. - EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEIN, SSTEQR, SSTERF, + EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEIN, SSTEQR, + $ SSTERF, $ SSWAP, XERBLA * .. * .. Intrinsic Functions .. @@ -351,8 +352,11 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, ISCALE = 1 SIGMA = RMIN / TNRM ELSE IF( TNRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / TNRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL SSCAL( N, SIGMA, D, 1 ) @@ -380,7 +384,8 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, IF( .NOT.WANTZ ) THEN CALL SSTERF( N, W, WORK, INFO ) ELSE - CALL SSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO ) + CALL SSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), + $ INFO ) IF( INFO.EQ.0 ) THEN DO 10 I = 1, N IFAIL( I ) = 0 @@ -404,7 +409,8 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, INDWRK = 1 INDISP = 1 + N INDIWO = INDISP + N - CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M, + CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, + $ M, $ NSPLIT, W, IWORK( 1 ), IWORK( INDISP ), $ WORK( INDWRK ), IWORK( INDIWO ), IINFO ) IF( IINFO.NE.0 ) THEN @@ -424,14 +430,8 @@ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL, * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/ssyevr.c b/lapack-netlib/SRC/ssyevr.c index a48b36b9bc..ad73b00047 100644 --- a/lapack-netlib/SRC/ssyevr.c +++ b/lapack-netlib/SRC/ssyevr.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SSYEVR + dependencies */ /* > */ @@ -501,7 +248,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -523,9 +269,16 @@ f"> */ /* > \verbatim */ /* > */ /* > SSYEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ -/* > selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ +/* > of a real symmetric matrix A. Eigenvalues and eigenvectors can be */ +/* > selected by specifying either a range of values or a range of indices */ +/* > for the desired eigenvalues. Invocations with different choices for */ +/* > these parameters may result in the computation of slightly different */ +/* > eigenvalues and/or eigenvectors for the same matrix. The reason for */ +/* > this behavior is that there exists a variety of algorithms (each */ +/* > performing best for a particular set of options) with SSYEVR */ +/* > attempting to select the best based on the various parameters. In all */ +/* > cases, the computed values are accurate within the limits of finite */ +/* > precision arithmetic. */ /* > */ /* > SSYEVR first reduces the matrix A to tridiagonal form T with a call */ /* > to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute */ @@ -589,6 +342,9 @@ f"> */ /* > JOBZ is CHARACTER*1 */ /* > = 'N': Compute eigenvalues only; */ /* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] RANGE */ @@ -600,6 +356,9 @@ f"> */ /* > = 'I': the IL-th through IU-th eigenvalues will be found. */ /* > For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */ /* > SSTEIN are called */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] UPLO */ @@ -755,7 +514,8 @@ f"> */ /* > \param[in] LWORK */ /* > \verbatim */ /* > LWORK is INTEGER */ -/* > The dimension of the array WORK. LWORK >= f2cmax(1,26*N). */ +/* > The dimension of the array WORK. */ +/* > If N <= 1, LWORK >= 1, else LWORK >= 26*N. */ /* > For optimal efficiency, LWORK >= (NB+6)*N, */ /* > where NB is the f2cmax of the blocksize for SSYTRD and SORMTR */ /* > returned by ILAENV. */ @@ -776,7 +536,8 @@ f"> */ /* > \param[in] LIWORK */ /* > \verbatim */ /* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK >= 1, else LIWORK >= 10*N. */ /* > */ /* > If LIWORK = -1, then a workspace query is assumed; the */ /* > routine only calculates the optimal sizes of the WORK and */ @@ -801,9 +562,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup realSYeigen */ +/* > \ingroup heevr */ /* > \par Contributors: */ /* ================== */ @@ -827,12 +586,12 @@ f"> */ real r__1, r__2; /* Local variables */ + integer iscale, i__, j, nb, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer i__, j, inddd, indee; + integer inddd, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -843,10 +602,8 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer nb, jj; - logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; + logical wantz, alleig, indeig; + integer ieeeok, indibl, indifl; logical valeig; extern real slamch_(char *); real safmin; @@ -877,13 +634,12 @@ f"> */ integer *, integer *), ssytrd_(char *, integer *, real *, integer *, real *, real *, real *, real *, integer *, integer *); - real eps, vll, vuu, tmp1; + extern real sroundup_lwork__(integer *); -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -893,11 +649,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -915,12 +671,13 @@ f"> */ lquery = *lwork == -1 || *liwork == -1; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 26; - lwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); + if (*n <= 1) { + lwmin = 1; + liwmin = 1; + } else { + lwmin = *n * 26; + liwmin = *n * 10; + } *info = 0; if (! (wantz || lsame_(jobz, "N"))) { @@ -962,7 +719,7 @@ f"> */ /* Computing MAX */ i__1 = (nb + 1) * *n; lwkopt = f2cmax(i__1,lwmin); - work[1] = (real) lwkopt; + work[1] = sroundup_lwork__(&lwkopt); iwork[1] = liwmin; if (*lwork < lwmin && ! lquery) { @@ -1031,8 +788,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1116,7 +877,7 @@ f"> */ scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); scopy_(n, &work[indd], &c__1, &work[inddd], &c__1); - if (*abstol <= *n * 2.f * eps) { + if (*abstol <= (real) (*n) * 2.f * eps) { tryrac = TRUE_; } else { tryrac = FALSE_; @@ -1179,13 +940,8 @@ f"> */ /* Jump here if SSTEMR/SSTEIN succeeded. */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1219,7 +975,7 @@ f"> */ /* Set WORK(1) to optimal workspace size. */ - work[1] = (real) lwkopt; + work[1] = sroundup_lwork__(&lwkopt); iwork[1] = liwmin; return; diff --git a/lapack-netlib/SRC/ssyevr.f b/lapack-netlib/SRC/ssyevr.f index 870facd606..cbe3e71ae3 100644 --- a/lapack-netlib/SRC/ssyevr.f +++ b/lapack-netlib/SRC/ssyevr.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYEVR + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -39,9 +37,16 @@ *> \verbatim *> *> SSYEVR computes selected eigenvalues and, optionally, eigenvectors -*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be -*> selected by specifying either a range of values or a range of -*> indices for the desired eigenvalues. +*> of a real symmetric matrix A. Eigenvalues and eigenvectors can be +*> selected by specifying either a range of values or a range of indices +*> for the desired eigenvalues. Invocations with different choices for +*> these parameters may result in the computation of slightly different +*> eigenvalues and/or eigenvectors for the same matrix. The reason for +*> this behavior is that there exists a variety of algorithms (each +*> performing best for a particular set of options) with SSYEVR +*> attempting to select the best based on the various parameters. In all +*> cases, the computed values are accurate within the limits of finite +*> precision arithmetic. *> *> SSYEVR first reduces the matrix A to tridiagonal form T with a call *> to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute @@ -105,6 +110,9 @@ *> JOBZ is CHARACTER*1 *> = 'N': Compute eigenvalues only; *> = 'V': Compute eigenvalues and eigenvectors. +*> +*> This parameter influences the choice of the algorithm and +*> may alter the computed values. *> \endverbatim *> *> \param[in] RANGE @@ -116,6 +124,9 @@ *> = 'I': the IL-th through IU-th eigenvalues will be found. *> For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and *> SSTEIN are called +*> +*> This parameter influences the choice of the algorithm and +*> may alter the computed values. *> \endverbatim *> *> \param[in] UPLO @@ -332,9 +343,11 @@ *> California at Berkeley, USA \n *> * ===================================================================== - SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, $ IWORK, LIWORK, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -360,7 +373,7 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ, TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + INTEGER I, IEEEOK, IINFO, INDD, INDDD, INDE, $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT @@ -371,10 +384,12 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANSY, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SLAMCH, + $ SLANSY, SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, SSTEIN, + EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, + $ SSTEIN, $ SSTERF, SSWAP, SSYTRD, XERBLA * .. * .. Intrinsic Functions .. @@ -501,8 +516,11 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -582,7 +600,7 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) * - IF (ABSTOL .LE. TWO*N*EPS) THEN + IF (ABSTOL .LE. TWO*REAL( N )*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. @@ -641,7 +659,8 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * @@ -649,14 +668,8 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * * Jump here if SSTEMR/SSTEIN succeeded. 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. Note: We do not sort the IFAIL portion of IWORK. diff --git a/lapack-netlib/SRC/ssyevr_2stage.c b/lapack-netlib/SRC/ssyevr_2stage.c index 9ed63a0302..4bc2618af3 100644 --- a/lapack-netlib/SRC/ssyevr_2stage.c +++ b/lapack-netlib/SRC/ssyevr_2stage.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \brief SSYEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - SY matrices */ - -/* @generated from dsyevr_2stage.f, fortran d -> s, Sat Nov 5 23:50:10 2016 */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download SSYEVR_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, */ -/* LWORK, IWORK, LIWORK, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N */ -/* REAL ABSTOL, VL, VU */ -/* INTEGER ISUPPZ( * ), IWORK( * ) */ -/* REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > SSYEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can be */ -/* > selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > */ -/* > SSYEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call */ -/* > to SSYTRD. Then, whenever possible, SSYEVR_2STAGE calls SSTEMR to compute */ -/* > the eigenspectrum using Relatively Robust Representations. SSTEMR */ -/* > computes eigenvalues by the dqds algorithm, while orthogonal */ -/* > eigenvectors are computed from various "good" L D L^T representations */ -/* > (also known as Relatively Robust Representations). Gram-Schmidt */ -/* > orthogonalization is avoided as far as possible. More specifically, */ -/* > the various steps of the algorithm are as follows. */ -/* > */ -/* > For each unreduced block (submatrix) of T, */ -/* > (a) Compute T - sigma I = L D L^T, so that L and D */ -/* > define all the wanted eigenvalues to high relative accuracy. */ -/* > This means that small relative changes in the entries of D and L */ -/* > cause only small relative changes in the eigenvalues and */ -/* > eigenvectors. The standard (unfactored) representation of the */ -/* > tridiagonal matrix T does not have this property in general. */ -/* > (b) Compute the eigenvalues to suitable accuracy. */ -/* > If the eigenvectors are desired, the algorithm attains full */ -/* > accuracy of the computed eigenvalues only right before */ -/* > the corresponding vectors have to be computed, see steps c) and d). */ -/* > (c) For each cluster of close eigenvalues, select a new */ -/* > shift close to the cluster, find a new factorization, and refine */ -/* > the shifted eigenvalues to suitable accuracy. */ -/* > (d) For each eigenvalue with a large enough relative separation compute */ -/* > the corresponding eigenvector by forming a rank revealing twisted */ -/* > factorization. Go back to (c) for any clusters that remain. */ -/* > */ -/* > The desired accuracy of the output can be specified by the input */ -/* > parameter ABSTOL. */ -/* > */ -/* > For more details, see SSTEMR's documentation and: */ -/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* > 2004. Also LAPACK Working Note 154. */ -/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* > tridiagonal eigenvalue/eigenvector problem", */ -/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* > UC Berkeley, May 1997. */ -/* > */ -/* > */ -/* > Note 1 : SSYEVR_2STAGE calls SSTEMR when the full spectrum is requested */ -/* > on machines which conform to the ieee-754 floating point standard. */ -/* > SSYEVR_2STAGE calls SSTEBZ and SSTEIN on non-ieee machines and */ -/* > when partial spectrum requests are made. */ -/* > */ -/* > Normal execution of SSTEMR may create NaNs and infinities and */ -/* > hence may abort due to a floating point exception in environments */ -/* > which do not handle NaNs and infinities in the ieee standard default */ -/* > manner. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and */ -/* > SSTEIN are called */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is REAL 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is REAL */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is REAL */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is REAL */ -/* > 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 * f2cmax( |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. */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > */ -/* > If high relative accuracy is important, set ABSTOL to */ -/* > SLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* > eigenvalues are computed to high relative accuracy when */ -/* > possible in future releases. The current code does not */ -/* > make any guarantees about high relative accuracy, but */ -/* > future releases will. See J. Barlow and J. Demmel, */ -/* > "Computing Accurate Eigensystems of Scaled Diagonally */ -/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* > of which matrices define their eigenvalues to high relative */ -/* > accuracy. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is REAL array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is REAL array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > Supplying N columns is always safe. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] ISUPPZ */ -/* > \verbatim */ -/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ -/* > The support of the eigenvectors in Z, i.e., the indices */ -/* > indicating the nonzero elements in Z. The i-th eigenvector */ -/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* > ISUPPZ( 2*i ). This is an output of SSTEMR (tridiagonal */ -/* > matrix). The support of the eigenvectors of A is typically */ -/* > 1:N because of the orthogonal transformations applied by SORMTR. */ -/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The dimension of the array WORK. */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 26*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 5*N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + 5*N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ -/* > On exit, if INFO = 0, IWORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LIWORK */ -/* > \verbatim */ -/* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ -/* > */ -/* > If LIWORK = -1, then a workspace query is assumed; the */ -/* > routine only calculates the optimal size of the IWORK array, */ -/* > returns this value as the first entry of the IWORK array, and */ -/* > no error message related to LIWORK is issued by XERBLA. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: Internal error */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup realSYeigen */ - -/* > \par Contributors: */ -/* ================== */ -/* > */ -/* > Inderjit Dhillon, IBM Almaden, USA \n */ -/* > Osni Marques, LBNL/NERSC, USA \n */ -/* > Ken Stanley, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > Jason Riedy, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > */ -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void ssyevr_2stage_(char *jobz, char *range, char *uplo, integer *n, real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z__, integer * @@ -872,14 +241,14 @@ static integer c_n1 = -1; real r__1, r__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + real eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer i__, j, inddd, indee; + integer inddd, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -893,10 +262,8 @@ static integer c_n1 = -1; ), ssytrd_2stage_(char *, char *, integer *, real *, integer *, real *, real *, real *, real *, integer *, real *, integer *, integer *); - logical wantz; - integer ib, kd, jj; - logical alleig, indeig; - integer iscale, ieeeok, indibl, indifl; + logical wantz, alleig, indeig; + integer ieeeok, indibl, indifl; logical valeig; extern real slamch_(char *); real safmin; @@ -924,16 +291,14 @@ static integer c_n1 = -1; extern /* Subroutine */ void sormtr_(char *, char *, char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *); - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer indhous; - real tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -943,11 +308,11 @@ static integer c_n1 = -1; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -969,12 +334,16 @@ static integer c_n1 = -1; ib = ilaenv2stage_(&c__2, "SSYTRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); lhtrd = ilaenv2stage_(&c__3, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &c_n1); lwtrd = ilaenv2stage_(&c__4, "SSYTRD_2STAGE", jobz, n, &kd, &ib, &c_n1); + + if (*n <= 1) { + lwmin = 1; + liwmin = 1; + } else { /* Computing MAX */ - i__1 = *n * 26, i__2 = *n * 5 + lhtrd + lwtrd; - lwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); + i__1 = *n * 26, i__2 = *n * 5 + lhtrd + lwtrd; + lwmin = f2cmax(i__1,i__2); + liwmin = *n * 10; + } *info = 0; if (! lsame_(jobz, "N")) { @@ -1014,7 +383,7 @@ static integer c_n1 = -1; /* NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) */ /* NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) ) */ /* LWKOPT = MAX( ( NB+1 )*N, LWMIN ) */ - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); iwork[1] = liwmin; } @@ -1035,7 +404,7 @@ static integer c_n1 = -1; } if (*n == 1) { - work[1] = 26.f; + work[1] = 1.f; if (alleig || indeig) { *m = 1; w[1] = a[a_dim1 + 1]; @@ -1077,8 +446,12 @@ static integer c_n1 = -1; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1166,7 +539,7 @@ static integer c_n1 = -1; scopy_(&i__1, &work[inde], &c__1, &work[indee], &c__1); scopy_(n, &work[indd], &c__1, &work[inddd], &c__1); - if (*abstol <= *n * 2.f * eps) { + if (*abstol <= (real) (*n) * 2.f * eps) { tryrac = TRUE_; } else { tryrac = FALSE_; @@ -1229,13 +602,8 @@ static integer c_n1 = -1; /* Jump here if SSTEMR/SSTEIN succeeded. */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1269,7 +637,7 @@ static integer c_n1 = -1; /* Set WORK(1) to optimal workspace size. */ - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); iwork[1] = liwmin; return; diff --git a/lapack-netlib/SRC/ssyevr_2stage.f b/lapack-netlib/SRC/ssyevr_2stage.f index 471e259776..47d82f3084 100644 --- a/lapack-netlib/SRC/ssyevr_2stage.f +++ b/lapack-netlib/SRC/ssyevr_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYEVR_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -407,7 +405,7 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ, $ TRYRAC, TEST CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE, + INTEGER I, IEEEOK, IINFO, INDD, INDDD, INDE, $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU, $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN, $ LLWORK, LLWRKN, LWMIN, NSPLIT, @@ -419,11 +417,13 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL LSAME INTEGER ILAENV, ILAENV2STAGE REAL SLAMCH, SLANSY, SROUNDUP_LWORK - EXTERNAL LSAME, SLAMCH, SLANSY, SROUNDUP_LWORK, ILAENV, + EXTERNAL LSAME, SLAMCH, SLANSY, + $ SROUNDUP_LWORK, ILAENV, $ ILAENV2STAGE * .. * .. External Subroutines .. - EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, SSTEIN, + EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, + $ SSTEIN, $ SSTERF, SSWAP, SSYTRD_2STAGE, XERBLA * .. * .. Intrinsic Functions .. @@ -443,10 +443,14 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) ) * - KD = ILAENV2STAGE( 1, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, -1 ) - IB = ILAENV2STAGE( 2, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, -1 ) - LHTRD = ILAENV2STAGE( 3, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) - LWTRD = ILAENV2STAGE( 4, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, -1 ) + KD = ILAENV2STAGE( 1, 'SSYTRD_2STAGE', JOBZ, N, -1, -1, + $ -1 ) + IB = ILAENV2STAGE( 2, 'SSYTRD_2STAGE', JOBZ, N, KD, -1, + $ -1 ) + LHTRD = ILAENV2STAGE( 3, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, + $ -1 ) + LWTRD = ILAENV2STAGE( 4, 'SSYTRD_2STAGE', JOBZ, N, KD, IB, + $ -1 ) * IF( N.LE.1 ) THEN LWMIN = 1 @@ -553,8 +557,11 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -639,7 +646,7 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) * - IF (ABSTOL .LE. TWO*N*EPS) THEN + IF (ABSTOL .LE. TWO*REAL( N )*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. @@ -698,7 +705,8 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * @@ -706,14 +714,8 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * * Jump here if SSTEMR/SSTEIN succeeded. 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. Note: We do not sort the IFAIL portion of IWORK. diff --git a/lapack-netlib/SRC/ssyevx.c b/lapack-netlib/SRC/ssyevx.c index c4b931f53c..87b07df77b 100644 --- a/lapack-netlib/SRC/ssyevx.c +++ b/lapack-netlib/SRC/ssyevx.c @@ -220,259 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download SSYEVX + dependencies */ /* > */ @@ -498,7 +244,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -713,8 +458,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > SSTEIN; their indices are stored in IFAIL. */ +/* > > N: SSTEBZ returned INFO = INFO - N; */ +/* > see SSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -725,9 +473,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup realSYeigen */ +/* > \ingroup heevx */ /* ===================================================================== */ /* Subroutine */ void ssyevx_(char *jobz, char *range, char *uplo, integer *n, @@ -740,12 +486,12 @@ f"> */ real r__1, r__2; /* Local variables */ + integer iscale, i__, j, nb, jj; + real eps, vll, vuu, tmp1; integer indd, inde; - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -755,10 +501,8 @@ f"> */ extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, integer *), sswap_(integer *, real *, integer *, real *, integer * ); - logical wantz; - integer nb, jj; - logical alleig, indeig; - integer iscale, indibl; + logical wantz, alleig, indeig; + integer indibl; logical valeig; extern real slamch_(char *); real safmin; @@ -790,13 +534,12 @@ f"> */ integer *), ssytrd_(char *, integer *, real *, integer *, real *, real *, real *, real *, integer *, integer *); - real eps, vll, vuu, tmp1; + extern real sroundup_lwork__(integer *); -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -806,11 +549,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -857,7 +600,7 @@ f"> */ if (*info == 0) { if (*n <= 1) { lwkmin = 1; - work[1] = (real) lwkmin; + lwkopt = 1; } else { lwkmin = *n << 3; nb = ilaenv_(&c__1, "SSYTRD", uplo, n, &c_n1, &c_n1, &c_n1, ( @@ -869,8 +612,8 @@ f"> */ /* Computing MAX */ i__1 = lwkmin, i__2 = (nb + 3) * *n; lwkopt = f2cmax(i__1,i__2); - work[1] = (real) lwkopt; } + work[1] = sroundup_lwork__(&lwkopt); if (*lwork < lwkmin && ! lquery) { *info = -17; @@ -932,8 +675,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1021,12 +768,21 @@ f"> */ indiwo = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by SSTEIN. */ @@ -1041,13 +797,8 @@ f"> */ L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1087,7 +838,7 @@ f"> */ /* Set WORK(1) to optimal workspace size. */ - work[1] = (real) lwkopt; + work[1] = sroundup_lwork__(&lwkopt); return; diff --git a/lapack-netlib/SRC/ssyevx.f b/lapack-netlib/SRC/ssyevx.f index 4d5de0a88b..857e61da01 100644 --- a/lapack-netlib/SRC/ssyevx.f +++ b/lapack-netlib/SRC/ssyevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -250,9 +248,11 @@ *> \ingroup heevx * * ===================================================================== - SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK, $ IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -278,7 +278,7 @@ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN, $ LWKOPT, NB, NSPLIT @@ -289,10 +289,12 @@ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL LSAME INTEGER ILAENV REAL SLAMCH, SLANSY, SROUNDUP_LWORK - EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY, SROUNDUP_LWORK + EXTERNAL LSAME, ILAENV, SLAMCH, + $ SLANSY, SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, SSTEBZ, + EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, + $ SSTEBZ, $ SSTEIN, SSTEQR, SSTERF, SSWAP, SSYTRD, XERBLA * .. * .. Intrinsic Functions .. @@ -345,7 +347,8 @@ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ELSE LWKMIN = 8*N NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) - NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) ) + NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, + $ -1 ) ) LWKOPT = MAX( LWKMIN, ( NB + 3 )*N ) END IF WORK( 1 ) = SROUNDUP_LWORK( LWKOPT ) @@ -405,8 +408,11 @@ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -504,21 +510,16 @@ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/ssyevx_2stage.c b/lapack-netlib/SRC/ssyevx_2stage.c index 966170d0d3..60002c34d2 100644 --- a/lapack-netlib/SRC/ssyevx_2stage.c +++ b/lapack-netlib/SRC/ssyevx_2stage.c @@ -220,258 +220,6 @@ typedef struct Namelist Namelist; //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} -/* procedure parameter types for -A and -C++ */ - - -#ifdef __cplusplus -typedef logical (*L_fp)(...); -#else -typedef logical (*L_fp)(); -#endif -#if 0 -static float spow_ui(float x, integer n) { - float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static double dpow_ui(double x, integer n) { - double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#ifdef _MSC_VER -static _Fcomplex cpow_ui(complex x, integer n) { - complex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x.r = 1/x.r, x.i=1/x.i; - for(u = n; ; ) { - if(u & 01) pow.r *= x.r, pow.i *= x.i; - if(u >>= 1) x.r *= x.r, x.i *= x.i; - else break; - } - } - _Fcomplex p={pow.r, pow.i}; - return p; -} -#else -static _Complex float cpow_ui(_Complex float x, integer n) { - _Complex float pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -#ifdef _MSC_VER -static _Dcomplex zpow_ui(_Dcomplex x, integer n) { - _Dcomplex pow={1.0,0.0}; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x._Val[0] = 1/x._Val[0], x._Val[1] =1/x._Val[1]; - for(u = n; ; ) { - if(u & 01) pow._Val[0] *= x._Val[0], pow._Val[1] *= x._Val[1]; - if(u >>= 1) x._Val[0] *= x._Val[0], x._Val[1] *= x._Val[1]; - else break; - } - } - _Dcomplex p = {pow._Val[0], pow._Val[1]}; - return p; -} -#else -static _Complex double zpow_ui(_Complex double x, integer n) { - _Complex double pow=1.0; unsigned long int u; - if(n != 0) { - if(n < 0) n = -n, x = 1/x; - for(u = n; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -#endif -static integer pow_ii(integer x, integer n) { - integer pow; unsigned long int u; - if (n <= 0) { - if (n == 0 || x == 1) pow = 1; - else if (x != -1) pow = x == 0 ? 1/x : 0; - else n = -n; - } - if ((n > 0) || !(n == 0 || x == 1 || x != -1)) { - u = n; - for(pow = 1; ; ) { - if(u & 01) pow *= x; - if(u >>= 1) x *= x; - else break; - } - } - return pow; -} -static integer dmaxloc_(double *w, integer s, integer e, integer *n) -{ - double m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static integer smaxloc_(float *w, integer s, integer e, integer *n) -{ - float m; integer i, mi; - for(m=w[s-1], mi=s, i=s+1; i<=e; i++) - if (w[i-1]>m) mi=i ,m=w[i-1]; - return mi-s+1; -} -static inline void cdotc_(complex *z, integer *n_, complex *x, integer *incx_, complex *y, integer *incy_) { - integer n = *n_, incx = *incx_, incy = *incy_, i; -#ifdef _MSC_VER - _Fcomplex zdotc = {0.0, 0.0}; - if (incx == 1 && incy == 1) { - for (i=0;i \brief SSYEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - SY matrices */ - -/* @generated from dsyevx_2stage.f, fortran d -> s, Sat Nov 5 23:55:46 2016 */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download SSYEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */ -/* LWORK, IWORK, IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N */ -/* REAL ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > SSYEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a real symmetric matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can be */ -/* > selected by specifying either a range of values or a range of indices */ -/* > for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is REAL 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is REAL */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is REAL */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is REAL */ -/* > 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 * f2cmax( |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*SLAMCH('S'), not zero. */ -/* > If this routine returns with INFO>0, indicating that some */ -/* > eigenvectors did not converge, try setting ABSTOL to */ -/* > 2*SLAMCH('S'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is REAL array, dimension (N) */ -/* > On normal exit, the first M elements contain the selected */ -/* > eigenvalues in ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is REAL array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 8*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + 3*N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + 3*N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup realSYeigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void ssyevx_2stage_(char *jobz, char *range, char *uplo, integer *n, real *a, integer *lda, real *vl, real *vu, integer *il, integer *iu, real *abstol, integer *m, real *w, real *z__, integer * @@ -790,14 +240,14 @@ static integer c__4 = 4; real r__1, r__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + real eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - real anrm; - integer imax; - real rmin, rmax; + real anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; real sigma; extern logical lsame_(char *, char *); integer iinfo; @@ -811,10 +261,8 @@ static integer c__4 = 4; ), ssytrd_2stage_(char *, char *, integer *, real *, integer *, real *, real *, real *, real *, integer *, real *, integer *, integer *); - logical wantz; - integer ib, kd, jj; - logical alleig, indeig; - integer iscale, indibl; + logical wantz, alleig, indeig; + integer indibl; logical valeig; extern real slamch_(char *); real safmin; @@ -841,16 +289,14 @@ static integer c__4 = 4; real *, integer *, real *, integer *), sormtr_(char *, char *, char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *, integer *, integer *); - real eps, vll, vuu; + extern real sroundup_lwork__(integer *); integer indhous; - real tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -860,11 +306,11 @@ static integer c__4 = 4; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -911,7 +357,7 @@ static integer c__4 = 4; if (*info == 0) { if (*n <= 1) { lwmin = 1; - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); } else { kd = ilaenv2stage_(&c__1, "SSYTRD_2STAGE", jobz, n, &c_n1, &c_n1, &c_n1); @@ -987,8 +433,12 @@ static integer c__4 = 4; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.f) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1079,12 +529,21 @@ static integer c__4 = 4; indiwo = indisp + *n; sstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &work[indd], &work[ inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], &work[ - indwrk], &iwork[indiwo], info); + indwrk], &iwork[indiwo], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { sstein_(n, &work[indd], &work[inde], m, &w[1], &iwork[indibl], &iwork[ indisp], &z__[z_offset], ldz, &work[indwrk], &iwork[indiwo], & - ifail[1], info); + ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply orthogonal matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by SSTEIN. */ @@ -1099,13 +558,8 @@ static integer c__4 = 4; L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } r__1 = 1.f / sigma; - sscal_(&imax, &r__1, &w[1], &c__1); + sscal_(m, &r__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -1145,7 +599,7 @@ static integer c__4 = 4; /* Set WORK(1) to optimal workspace size. */ - work[1] = (real) lwmin; + work[1] = sroundup_lwork__(&lwmin); return; diff --git a/lapack-netlib/SRC/ssyevx_2stage.f b/lapack-netlib/SRC/ssyevx_2stage.f index 6ae126b2f3..a0338bac85 100644 --- a/lapack-netlib/SRC/ssyevx_2stage.f +++ b/lapack-netlib/SRC/ssyevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download SSYEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -327,7 +325,7 @@ SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LLWRKN, $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS @@ -342,7 +340,8 @@ SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ SROUNDUP_LWORK * .. * .. External Subroutines .. - EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, SSTEBZ, + EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, + $ SSTEBZ, $ SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA, $ SSYTRD_2STAGE * .. @@ -403,7 +402,7 @@ SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LWTRD = ILAENV2STAGE( 4, 'SSYTRD_2STAGE', JOBZ, $ N, KD, IB, -1 ) LWMIN = MAX( 8*N, 3*N + LHTRD + LWTRD ) - WORK( 1 ) = LWMIN + WORK( 1 ) = REAL( LWMIN ) END IF * IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) @@ -461,8 +460,11 @@ SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -563,21 +565,16 @@ SUBROUTINE SSYEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * INDWKN = INDE LLWRKN = LWORK - INDWKN + 1 - CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWKN ), LLWRKN, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL SSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL SSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zhbevx.c b/lapack-netlib/SRC/zhbevx.c index c29399328d..8167d2247c 100644 --- a/lapack-netlib/SRC/zhbevx.c +++ b/lapack-netlib/SRC/zhbevx.c @@ -250,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {0.,0.}; @@ -267,7 +265,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHBEVX + dependencies */ /* > */ @@ -278,7 +275,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -507,8 +503,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > ZSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -519,9 +518,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complex16OTHEReigen */ +/* > \ingroup hbevx */ /* ===================================================================== */ /* Subroutine */ void zhbevx_(char *jobz, char *range, char *uplo, integer *n, @@ -537,13 +534,13 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; doublecomplex ctmp1; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -560,10 +557,9 @@ f"> */ extern /* Subroutine */ void zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; doublereal safmin; extern doublereal zlanhb_(char *, char *, integer *, integer *, @@ -591,13 +587,11 @@ f"> */ integer *, doublereal *, integer *, integer *, integer *), zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *); - doublereal eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -607,14 +601,14 @@ f"> */ /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -727,8 +721,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -806,12 +804,21 @@ f"> */ indiwk = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by ZSTEIN. */ @@ -829,13 +836,8 @@ f"> */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/zhbevx.f b/lapack-netlib/SRC/zhbevx.f index 611b12aefd..9387893844 100644 --- a/lapack-netlib/SRC/zhbevx.f +++ b/lapack-netlib/SRC/zhbevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHBEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -261,12 +259,14 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16OTHEReigen +*> \ingroup hbevx * * ===================================================================== - SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, + SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, + $ VL, $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, RWORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -296,7 +296,7 @@ SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1, $ J, JJ, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -309,7 +309,8 @@ SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, EXTERNAL LSAME, DLAMCH, ZLANHB * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZCOPY, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, + $ ZCOPY, $ ZGEMV, ZHBTRD, ZLACPY, ZLASCL, ZSTEIN, ZSTEQR, $ ZSWAP * .. @@ -414,14 +415,19 @@ SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -514,14 +520,8 @@ SUBROUTINE ZHBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zhbevx_2stage.c b/lapack-netlib/SRC/zhbevx_2stage.c index 6f803f9dc1..63e325c13d 100644 --- a/lapack-netlib/SRC/zhbevx_2stage.c +++ b/lapack-netlib/SRC/zhbevx_2stage.c @@ -250,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static doublecomplex c_b1 = {0.,0.}; @@ -263,330 +261,6 @@ static integer c__4 = 4; static doublereal c_b26 = 1.; static integer c__1 = 1; -/* > \brief ZHBEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - OTHER matrices */ - -/* @precisions fortran z -> s d c */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download ZHBEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, */ -/* Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, */ -/* Z, LDZ, WORK, LWORK, RWORK, IWORK, */ -/* IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N, LWORK */ -/* DOUBLE PRECISION ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* DOUBLE PRECISION RWORK( * ), W( * ) */ -/* COMPLEX*16 AB( LDAB, * ), Q( LDQ, * ), WORK( * ), */ -/* $ Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > ZHBEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian band matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors */ -/* > can be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] KD */ -/* > \verbatim */ -/* > KD is INTEGER */ -/* > The number of superdiagonals of the matrix A if UPLO = 'U', */ -/* > or the number of subdiagonals if UPLO = 'L'. KD >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] AB */ -/* > \verbatim */ -/* > AB is COMPLEX*16 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 f2cmax(1,j-kd)<=i<=j; */ -/* > if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=f2cmin(n,j+kd). */ -/* > */ -/* > On exit, AB is overwritten by values generated during the */ -/* > reduction to tridiagonal form. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDAB */ -/* > \verbatim */ -/* > LDAB is INTEGER */ -/* > The leading dimension of the array AB. LDAB >= KD + 1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Q */ -/* > \verbatim */ -/* > Q is COMPLEX*16 array, dimension (LDQ, N) */ -/* > If JOBZ = 'V', the N-by-N unitary matrix used in the */ -/* > reduction to tridiagonal form. */ -/* > If JOBZ = 'N', the array Q is not referenced. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDQ */ -/* > \verbatim */ -/* > LDQ is INTEGER */ -/* > The leading dimension of the array Q. If JOBZ = 'V', then */ -/* > LDQ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is DOUBLE PRECISION */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is DOUBLE PRECISION */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is 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 * f2cmax( |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 AB 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'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is DOUBLE PRECISION array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is COMPLEX*16 array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is COMPLEX*16 array, dimension (LWORK) */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, dimension) where */ -/* > dimension = (2KD+1)*N + KD*NTHREADS */ -/* > where KD is the size of the band. */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available. */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] RWORK */ -/* > \verbatim */ -/* > RWORK is DOUBLE PRECISION array, dimension (7*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup complex16OTHEReigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void zhbevx_2stage_(char *jobz, char *range, char *uplo, integer *n, integer *kd, doublecomplex *ab, integer *ldab, doublecomplex *q, integer *ldq, doublereal *vl, doublereal *vu, @@ -601,11 +275,12 @@ static integer c__1 = 1; doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, ib, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); doublereal anrm; - integer imax; extern /* Subroutine */ void zhetrd_hb2st_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublecomplex *, @@ -613,7 +288,7 @@ static integer c__1 = 1; doublereal rmin, rmax; logical test; doublecomplex ctmp1; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -633,10 +308,9 @@ static integer c__1 = 1; extern /* Subroutine */ void zcopy_(integer *, doublecomplex *, integer *, doublecomplex *, integer *), zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer ib, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; doublereal safmin; extern doublereal zlanhb_(char *, char *, integer *, integer *, @@ -662,16 +336,13 @@ static integer c__1 = 1; logical lquery; extern /* Subroutine */ void zsteqr_(char *, integer *, doublereal *, doublereal *, doublecomplex *, integer *, doublereal *, integer *); - doublereal eps, vll, vuu; integer indhous; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -681,14 +352,14 @@ static integer c__1 = 1; /* Parameter adjustments */ ab_dim1 = *ldab; - ab_offset = 1 + ab_dim1 * 1; + ab_offset = 1 + ab_dim1; ab -= ab_offset; q_dim1 = *ldq; - q_offset = 1 + q_dim1 * 1; + q_offset = 1 + q_dim1; q -= q_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -824,8 +495,12 @@ static integer c__1 = 1; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -908,12 +583,21 @@ static integer c__1 = 1; indiwk = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L30; + } + } if (wantz) { zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by ZSTEIN. */ @@ -931,13 +615,8 @@ static integer c__1 = 1; L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/zhbevx_2stage.f b/lapack-netlib/SRC/zhbevx_2stage.f index 9519b0e569..bfc6e542a7 100644 --- a/lapack-netlib/SRC/zhbevx_2stage.f +++ b/lapack-netlib/SRC/zhbevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHBEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,14 +14,13 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, * Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, -* Z, LDZ, WORK, LWORK, RWORK, IWORK, +* Z, LDZ, WORK, LWORK, RWORK, IWORK, * IFAIL, INFO ) * * IMPLICIT NONE @@ -233,7 +231,7 @@ *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= 1, when N <= 1; -*> otherwise +*> otherwise *> If JOBZ = 'N' and N > 1, LWORK must be queried. *> LWORK = MAX(1, dimension) where *> dimension = (2KD+1)*N + KD*NTHREADS @@ -288,7 +286,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16OTHEReigen +*> \ingroup hbevx_2stage * *> \par Further Details: * ===================== @@ -306,7 +304,7 @@ *> http://doi.acm.org/10.1145/2063384.2063394 *> *> A. Haidar, J. Kurzak, P. Luszczek, 2013. -*> An improved parallel singular value algorithm and its implementation +*> An improved parallel singular value algorithm and its implementation *> for multicore hardware, In Proceedings of 2013 International Conference *> for High Performance Computing, Networking, Storage and Analysis (SC '13). *> Denver, Colorado, USA, 2013. @@ -314,18 +312,18 @@ *> http://doi.acm.org/10.1145/2503210.2503292 *> *> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. -*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure *> calculations based on fine-grained memory aware tasks. *> International Journal of High Performance Computing Applications. *> Volume 28 Issue 2, Pages 196-209, May 2014. -*> http://hpc.sagepub.com/content/28/2/196 +*> http://hpc.sagepub.com/content/28/2/196 *> *> \endverbatim * * ===================================================================== SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, $ Q, LDQ, VL, VU, IL, IU, ABSTOL, M, W, - $ Z, LDZ, WORK, LWORK, RWORK, IWORK, + $ Z, LDZ, WORK, LWORK, RWORK, IWORK, $ IFAIL, INFO ) * IMPLICIT NONE @@ -359,7 +357,7 @@ SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ, $ LQUERY CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDWRK, ISCALE, ITMP1, $ LLWORK, LWMIN, LHTRD, LWTRD, IB, INDHOUS, $ J, JJ, NSPLIT @@ -374,7 +372,8 @@ SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, EXTERNAL LSAME, DLAMCH, ZLANHB, ILAENV2STAGE * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZCOPY, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, + $ ZCOPY, $ ZGEMV, ZLACPY, ZLASCL, ZSTEIN, ZSTEQR, $ ZSWAP, ZHETRD_HB2ST * .. @@ -501,14 +500,19 @@ SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN - CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL ZLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) ELSE - CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO ) + CALL ZLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, + $ INFO ) END IF IF( ABSTOL.GT.0 ) $ ABSTLL = ABSTOL*SIGMA @@ -606,14 +610,8 @@ SUBROUTINE ZHBEVX_2STAGE( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zheevr.c b/lapack-netlib/SRC/zheevr.c index bbfc5fd99b..e2007787bd 100644 --- a/lapack-netlib/SRC/zheevr.c +++ b/lapack-netlib/SRC/zheevr.c @@ -250,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -269,7 +267,6 @@ rices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHEEVR + dependencies */ /* > */ @@ -280,7 +277,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -304,9 +300,16 @@ f"> */ /* > \verbatim */ /* > */ /* > ZHEEVR computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian matrix A. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ +/* > of a complex Hermitian matrix A. Eigenvalues and eigenvectors can be */ +/* > selected by specifying either a range of values or a range of indices */ +/* > for the desired eigenvalues. Invocations with different choices for */ +/* > these parameters may result in the computation of slightly different */ +/* > eigenvalues and/or eigenvectors for the same matrix. The reason for */ +/* > this behavior is that there exists a variety of algorithms (each */ +/* > performing best for a particular set of options) with ZHEEVR */ +/* > attempting to select the best based on the various parameters. In all */ +/* > cases, the computed values are accurate within the limits of finite */ +/* > precision arithmetic. */ /* > */ /* > ZHEEVR first reduces the matrix A to tridiagonal form T with a call */ /* > to ZHETRD. Then, whenever possible, ZHEEVR calls ZSTEMR to compute */ @@ -338,7 +341,7 @@ f"> */ /* > The desired accuracy of the output can be specified by the input */ /* > parameter ABSTOL. */ /* > */ -/* > For more details, see DSTEMR's documentation and: */ +/* > For more details, see ZSTEMR's documentation and: */ /* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ /* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ /* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ @@ -370,6 +373,9 @@ f"> */ /* > JOBZ is CHARACTER*1 */ /* > = 'N': Compute eigenvalues only; */ /* > = 'V': Compute eigenvalues and eigenvectors. */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] RANGE */ @@ -381,6 +387,9 @@ f"> */ /* > = 'I': the IL-th through IU-th eigenvalues will be found. */ /* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ /* > ZSTEIN are called */ +/* > */ +/* > This parameter influences the choice of the algorithm and */ +/* > may alter the computed values. */ /* > \endverbatim */ /* > */ /* > \param[in] UPLO */ @@ -505,6 +514,7 @@ f"> */ /* > Note: the user must ensure that at least f2cmax(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. */ +/* > Supplying N columns is always safe. */ /* > \endverbatim */ /* > */ /* > \param[in] LDZ */ @@ -535,7 +545,8 @@ f"> */ /* > \param[in] LWORK */ /* > \verbatim */ /* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= f2cmax(1,2*N). */ +/* > The length of the array WORK. */ +/* > If N <= 1, LWORK >= 1, else LWORK >= 2*N. */ /* > For optimal efficiency, LWORK >= (NB+1)*N, */ /* > where NB is the f2cmax of the blocksize for ZHETRD and for */ /* > ZUNMTR as returned by ILAENV. */ @@ -557,7 +568,8 @@ f"> */ /* > \param[in] LRWORK */ /* > \verbatim */ /* > LRWORK is INTEGER */ -/* > The length of the array RWORK. LRWORK >= f2cmax(1,24*N). */ +/* > The length of the array RWORK. */ +/* > If N <= 1, LRWORK >= 1, else LRWORK >= 24*N. */ /* > */ /* > If LRWORK = -1, then a workspace query is assumed; the */ /* > routine only calculates the optimal sizes of the WORK, RWORK */ @@ -576,7 +588,8 @@ f"> */ /* > \param[in] LIWORK */ /* > \verbatim */ /* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*N). */ +/* > The dimension of the array IWORK. */ +/* > If N <= 1, LIWORK >= 1, else LIWORK >= 10*N. */ /* > */ /* > If LIWORK = -1, then a workspace query is assumed; the */ /* > routine only calculates the optimal sizes of the WORK, RWORK */ @@ -601,9 +614,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complex16HEeigen */ +/* > \ingroup heevr */ /* > \par Contributors: */ /* ================== */ @@ -628,11 +639,10 @@ f"> */ doublereal d__1, d__2; /* Local variables */ - doublereal anrm; - integer imax; - doublereal rmin, rmax; + integer iscale, i__, j, nb, jj; + doublereal eps, vll, vuu, tmp1, anrm, rmin, rmax; logical test; - integer itmp1, i__, j; + integer itmp1; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); integer indrd, indre; @@ -647,16 +657,14 @@ f"> */ logical lower, wantz; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer nb, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, ieeeok, indibl, indrdd, indifl, indree; + integer ieeeok, indibl, indrdd, indifl, indree; logical valeig; doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal abstll, bignum; integer indtau, indisp; @@ -689,15 +697,12 @@ f"> */ integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * ); - doublereal eps, vll, vuu; integer llrwork; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -707,11 +712,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -730,15 +735,15 @@ f"> */ lquery = *lwork == -1 || *lrwork == -1 || *liwork == -1; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 24; - lrwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n << 1; - lwmin = f2cmax(i__1,i__2); + if (*n <= 1) { + lwmin = 1; + lrwmin = 1; + liwmin = 1; + } else { + lwmin = *n << 1; + lrwmin = *n * 24; + liwmin = *n * 10; + } *info = 0; if (! (wantz || lsame_(jobz, "N"))) { @@ -810,7 +815,7 @@ f"> */ } if (*n == 1) { - work[1].r = 2., work[1].i = 0.; + work[1].r = 1., work[1].i = 0.; if (alleig || indeig) { *m = 1; i__1 = a_dim1 + 1; @@ -857,8 +862,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1005,13 +1014,8 @@ f"> */ L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/zheevr.f b/lapack-netlib/SRC/zheevr.f index 038738ec8b..cf77d1c2b9 100644 --- a/lapack-netlib/SRC/zheevr.f +++ b/lapack-netlib/SRC/zheevr.f @@ -398,7 +398,7 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ, TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, + INTEGER I, IEEEOK, IINFO, INDIBL, INDIFL, INDISP, $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, @@ -548,8 +548,11 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -699,14 +702,8 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zheevr_2stage.c b/lapack-netlib/SRC/zheevr_2stage.c index 623c2562b9..cb927a4043 100644 --- a/lapack-netlib/SRC/zheevr_2stage.c +++ b/lapack-netlib/SRC/zheevr_2stage.c @@ -238,11 +238,11 @@ typedef struct Namelist Namelist; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) {ceil(w)} -#define myhuge_(w) {HUGE_VAL} +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} /* -- translated by f2c (version 20000121). You must link the resulting object file with the libraries: @@ -250,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__10 = 10; @@ -261,409 +259,6 @@ static integer c__3 = 3; static integer c__4 = 4; static integer c_n1 = -1; -/* > \brief ZHEEVR_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - HE matrices */ - -/* @precisions fortran z -> s d c */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download ZHEEVR_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, ISUPPZ, */ -/* WORK, LWORK, RWORK, LRWORK, IWORK, */ -/* LIWORK, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LRWORK, LWORK, */ -/* $ M, N */ -/* DOUBLE PRECISION ABSTOL, VL, VU */ -/* INTEGER ISUPPZ( * ), IWORK( * ) */ -/* DOUBLE PRECISION RWORK( * ), W( * ) */ -/* COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > ZHEEVR_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > */ -/* > ZHEEVR_2STAGE first reduces the matrix A to tridiagonal form T with a call */ -/* > to ZHETRD. Then, whenever possible, ZHEEVR_2STAGE calls ZSTEMR to compute */ -/* > eigenspectrum using Relatively Robust Representations. ZSTEMR */ -/* > computes eigenvalues by the dqds algorithm, while orthogonal */ -/* > eigenvectors are computed from various "good" L D L^T representations */ -/* > (also known as Relatively Robust Representations). Gram-Schmidt */ -/* > orthogonalization is avoided as far as possible. More specifically, */ -/* > the various steps of the algorithm are as follows. */ -/* > */ -/* > For each unreduced block (submatrix) of T, */ -/* > (a) Compute T - sigma I = L D L^T, so that L and D */ -/* > define all the wanted eigenvalues to high relative accuracy. */ -/* > This means that small relative changes in the entries of D and L */ -/* > cause only small relative changes in the eigenvalues and */ -/* > eigenvectors. The standard (unfactored) representation of the */ -/* > tridiagonal matrix T does not have this property in general. */ -/* > (b) Compute the eigenvalues to suitable accuracy. */ -/* > If the eigenvectors are desired, the algorithm attains full */ -/* > accuracy of the computed eigenvalues only right before */ -/* > the corresponding vectors have to be computed, see steps c) and d). */ -/* > (c) For each cluster of close eigenvalues, select a new */ -/* > shift close to the cluster, find a new factorization, and refine */ -/* > the shifted eigenvalues to suitable accuracy. */ -/* > (d) For each eigenvalue with a large enough relative separation compute */ -/* > the corresponding eigenvector by forming a rank revealing twisted */ -/* > factorization. Go back to (c) for any clusters that remain. */ -/* > */ -/* > The desired accuracy of the output can be specified by the input */ -/* > parameter ABSTOL. */ -/* > */ -/* > For more details, see DSTEMR's documentation and: */ -/* > - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations */ -/* > to compute orthogonal eigenvectors of symmetric tridiagonal matrices," */ -/* > Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004. */ -/* > - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and */ -/* > Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25, */ -/* > 2004. Also LAPACK Working Note 154. */ -/* > - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric */ -/* > tridiagonal eigenvalue/eigenvector problem", */ -/* > Computer Science Division Technical Report No. UCB/CSD-97-971, */ -/* > UC Berkeley, May 1997. */ -/* > */ -/* > */ -/* > Note 1 : ZHEEVR_2STAGE calls ZSTEMR when the full spectrum is requested */ -/* > on machines which conform to the ieee-754 floating point standard. */ -/* > ZHEEVR_2STAGE calls DSTEBZ and ZSTEIN on non-ieee machines and */ -/* > when partial spectrum requests are made. */ -/* > */ -/* > Normal execution of ZSTEMR may create NaNs and infinities and */ -/* > hence may abort due to a floating point exception in environments */ -/* > which do not handle NaNs and infinities in the ieee standard default */ -/* > manner. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and */ -/* > ZSTEIN are called */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is COMPLEX*16 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, the lower triangle (if UPLO='L') or the upper */ -/* > triangle (if UPLO='U') of A, including the diagonal, is */ -/* > destroyed. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is DOUBLE PRECISION */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is DOUBLE PRECISION */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is 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 * f2cmax( |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. */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > */ -/* > If high relative accuracy is important, set ABSTOL to */ -/* > DLAMCH( 'Safe minimum' ). Doing so will guarantee that */ -/* > eigenvalues are computed to high relative accuracy when */ -/* > possible in future releases. The current code does not */ -/* > make any guarantees about high relative accuracy, but */ -/* > future releases will. See J. Barlow and J. Demmel, */ -/* > "Computing Accurate Eigensystems of Scaled Diagonally */ -/* > Dominant Matrices", LAPACK Working Note #7, for a discussion */ -/* > of which matrices define their eigenvalues to high relative */ -/* > accuracy. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is DOUBLE PRECISION array, dimension (N) */ -/* > The first M elements contain the selected eigenvalues in */ -/* > ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is COMPLEX*16 array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] ISUPPZ */ -/* > \verbatim */ -/* > ISUPPZ is INTEGER array, dimension ( 2*f2cmax(1,M) ) */ -/* > The support of the eigenvectors in Z, i.e., the indices */ -/* > indicating the nonzero elements in Z. The i-th eigenvector */ -/* > is nonzero only in elements ISUPPZ( 2*i-1 ) through */ -/* > ISUPPZ( 2*i ). This is an output of ZSTEMR (tridiagonal */ -/* > matrix). The support of the eigenvectors of A is typically */ -/* > 1:N because of the unitary transformations applied by ZUNMTR. */ -/* > Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1 */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The dimension of the array WORK. */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 26*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] RWORK */ -/* > \verbatim */ -/* > RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK)) */ -/* > On exit, if INFO = 0, RWORK(1) returns the optimal */ -/* > (and minimal) LRWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LRWORK */ -/* > \verbatim */ -/* > LRWORK is INTEGER */ -/* > The length of the array RWORK. LRWORK >= f2cmax(1,24*N). */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ -/* > On exit, if INFO = 0, IWORK(1) returns the optimal */ -/* > (and minimal) LIWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LIWORK */ -/* > \verbatim */ -/* > LIWORK is INTEGER */ -/* > The dimension of the array IWORK. LIWORK >= f2cmax(1,10*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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: Internal error */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup complex16HEeigen */ - -/* > \par Contributors: */ -/* ================== */ -/* > */ -/* > Inderjit Dhillon, IBM Almaden, USA \n */ -/* > Osni Marques, LBNL/NERSC, USA \n */ -/* > Ken Stanley, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > Jason Riedy, Computer Science Division, University of */ -/* > California at Berkeley, USA \n */ -/* > */ -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void zheevr_2stage_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer @@ -676,13 +271,13 @@ static integer c_n1 = -1; doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + doublereal eps, vll, vuu, tmp1; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j; + integer itmp1; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); integer indrd, indre; @@ -703,16 +298,14 @@ static integer c_n1 = -1; logical wantz; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer ib, kd, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, ieeeok, indibl, indrdd, indifl, indree; + integer ieeeok, indibl, indrdd, indifl, indree; logical valeig; doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal abstll, bignum; integer indtau, indisp; @@ -741,16 +334,13 @@ static integer c_n1 = -1; integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer * ); - doublereal eps, vll, vuu; integer indhous, llrwork; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -760,11 +350,11 @@ static integer c_n1 = -1; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --isuppz; --work; @@ -787,13 +377,16 @@ static integer c_n1 = -1; ib = ilaenv2stage_(&c__2, "ZHETRD_2STAGE", jobz, n, &kd, &c_n1, &c_n1); lhtrd = ilaenv2stage_(&c__3, "ZHETRD_2STAGE", jobz, n, &kd, &ib, &c_n1); lwtrd = ilaenv2stage_(&c__4, "ZHETRD_2STAGE", jobz, n, &kd, &ib, &c_n1); - lwmin = *n + lhtrd + lwtrd; -/* Computing MAX */ - i__1 = 1, i__2 = *n * 24; - lrwmin = f2cmax(i__1,i__2); -/* Computing MAX */ - i__1 = 1, i__2 = *n * 10; - liwmin = f2cmax(i__1,i__2); + + if (*n <= 1) { + lwmin = 1; + lrwmin = 1; + liwmin = 1; + } else { + lwmin = *n + lhtrd + lwtrd; + lrwmin = *n * 24; + liwmin = *n * 10; + } *info = 0; if (! lsame_(jobz, "N")) { @@ -856,7 +449,7 @@ static integer c_n1 = -1; } if (*n == 1) { - work[1].r = 2., work[1].i = 0.; + work[1].r = 1., work[1].i = 0.; if (alleig || indeig) { *m = 1; i__1 = a_dim1 + 1; @@ -903,8 +496,12 @@ static integer c_n1 = -1; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -1053,13 +650,8 @@ static integer c_n1 = -1; L30: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/zheevr_2stage.f b/lapack-netlib/SRC/zheevr_2stage.f index 0ba5a29533..4553203a7e 100644 --- a/lapack-netlib/SRC/zheevr_2stage.f +++ b/lapack-netlib/SRC/zheevr_2stage.f @@ -433,7 +433,7 @@ SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ, TRYRAC CHARACTER ORDER - INTEGER I, IEEEOK, IINFO, IMAX, INDIBL, INDIFL, INDISP, + INTEGER I, IEEEOK, IINFO, INDIBL, INDIFL, INDISP, $ INDIWO, INDRD, INDRDD, INDRE, INDREE, INDRWK, $ INDTAU, INDWK, INDWKN, ISCALE, ITMP1, J, JJ, $ LIWMIN, LLWORK, LLRWORK, LLWRKN, LRWMIN, @@ -590,8 +590,11 @@ SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -744,14 +747,8 @@ SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * If matrix was scaled, then rescale eigenvalues appropriately. * 30 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zheevx.c b/lapack-netlib/SRC/zheevx.c index 0df1b07e82..beff97d347 100644 --- a/lapack-netlib/SRC/zheevx.c +++ b/lapack-netlib/SRC/zheevx.c @@ -250,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -265,7 +263,6 @@ rices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHEEVX + dependencies */ /* > */ @@ -276,7 +273,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -497,8 +493,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > ZSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -509,9 +508,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complex16HEeigen */ +/* > \ingroup heevx */ /* ===================================================================== */ /* Subroutine */ void zheevx_(char *jobz, char *range, char *uplo, integer *n, @@ -526,12 +523,12 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, nb, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -543,16 +540,14 @@ f"> */ logical lower, wantz; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer nb, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; doublereal safmin; extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *, ftnlen, ftnlen); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal abstll, bignum; extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, @@ -563,13 +558,12 @@ f"> */ doublereal *, integer *, integer *, doublereal *, doublereal *, doublereal *, integer *, integer *, doublereal *, integer *, integer *, doublereal *, integer *, integer *); - integer indrwk, indwrk; + integer indrwk, indwrk, lwkmin; extern /* Subroutine */ void zhetrd_(char *, integer *, doublecomplex *, integer *, doublereal *, doublereal *, doublecomplex *, - doublecomplex *, integer *, integer *); - integer lwkmin; - extern /* Subroutine */ void zlacpy_(char *, integer *, integer *, - doublecomplex *, integer *, doublecomplex *, integer *); + doublecomplex *, integer *, integer *), zlacpy_(char *, + integer *, integer *, doublecomplex *, integer *, doublecomplex *, + integer *); integer llwork, nsplit; doublereal smlnum; extern /* Subroutine */ void zstein_(integer *, doublereal *, doublereal *, @@ -583,13 +577,11 @@ f"> */ zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); - doublereal eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -599,11 +591,11 @@ f"> */ /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -731,8 +723,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -821,12 +817,21 @@ f"> */ indiwk = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by ZSTEIN. */ @@ -839,13 +844,8 @@ f"> */ L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/zheevx.f b/lapack-netlib/SRC/zheevx.f index cf14be9da5..29699b8fb3 100644 --- a/lapack-netlib/SRC/zheevx.f +++ b/lapack-netlib/SRC/zheevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHEEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -253,12 +251,14 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16HEeigen +*> \ingroup heevx * * ===================================================================== - SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, + SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, + $ IU, $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, RWORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -287,7 +287,7 @@ SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, $ ITMP1, J, JJ, LLWORK, LWKMIN, LWKOPT, NB, $ NSPLIT @@ -301,7 +301,8 @@ SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, EXTERNAL LSAME, ILAENV, DLAMCH, ZLANHE * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, + $ ZDSCAL, $ ZHETRD, ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, $ ZUNMTR * .. @@ -355,7 +356,8 @@ SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ELSE LWKMIN = 2*N NB = ILAENV( 1, 'ZHETRD', UPLO, N, -1, -1, -1 ) - NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, -1 ) ) + NB = MAX( NB, ILAENV( 1, 'ZUNMTR', UPLO, N, -1, -1, + $ -1 ) ) LWKOPT = MAX( 1, ( NB + 1 )*N ) WORK( 1 ) = LWKOPT END IF @@ -416,8 +418,11 @@ SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -514,21 +519,16 @@ SUBROUTINE ZHEEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, * Apply unitary matrix used in reduction to tridiagonal * form to eigenvectors returned by ZSTEIN. * - CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zheevx_2stage.c b/lapack-netlib/SRC/zheevx_2stage.c index 7eee67d698..90a596b9b2 100644 --- a/lapack-netlib/SRC/zheevx_2stage.c +++ b/lapack-netlib/SRC/zheevx_2stage.c @@ -39,14 +39,6 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -#ifdef _MSC_VER -static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} -static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} -#else -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#endif -#define pCd(z) (*_pCd(z)) typedef blasint logical; typedef char logical1; @@ -258,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -268,310 +258,6 @@ static integer c__2 = 2; static integer c__3 = 3; static integer c__4 = 4; -/* > \brief ZHEEVX_2STAGE computes the eigenvalues and, optionally, the left and/or right eigenvectors for - HE matrices */ - -/* @precisions fortran z -> s d c */ - -/* =========== DOCUMENTATION =========== */ - -/* Online html documentation available at */ -/* http://www.netlib.org/lapack/explore-html/ */ - -/* > \htmlonly */ -/* > Download ZHEEVX_2STAGE + dependencies */ -/* > */ -/* > [TGZ] */ -/* > */ -/* > [ZIP] */ -/* > */ -/* > [TXT] */ -/* > \endhtmlonly */ - -/* Definition: */ -/* =========== */ - -/* SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, */ -/* IL, IU, ABSTOL, M, W, Z, LDZ, WORK, */ -/* LWORK, RWORK, IWORK, IFAIL, INFO ) */ - -/* IMPLICIT NONE */ - -/* CHARACTER JOBZ, RANGE, UPLO */ -/* INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N */ -/* DOUBLE PRECISION ABSTOL, VL, VU */ -/* INTEGER IFAIL( * ), IWORK( * ) */ -/* DOUBLE PRECISION RWORK( * ), W( * ) */ -/* COMPLEX*16 A( LDA, * ), WORK( * ), Z( LDZ, * ) */ - - -/* > \par Purpose: */ -/* ============= */ -/* > */ -/* > \verbatim */ -/* > */ -/* > ZHEEVX_2STAGE computes selected eigenvalues and, optionally, eigenvectors */ -/* > of a complex Hermitian matrix A using the 2stage technique for */ -/* > the reduction to tridiagonal. Eigenvalues and eigenvectors can */ -/* > be selected by specifying either a range of values or a range of */ -/* > indices for the desired eigenvalues. */ -/* > \endverbatim */ - -/* Arguments: */ -/* ========== */ - -/* > \param[in] JOBZ */ -/* > \verbatim */ -/* > JOBZ is CHARACTER*1 */ -/* > = 'N': Compute eigenvalues only; */ -/* > = 'V': Compute eigenvalues and eigenvectors. */ -/* > Not available in this release. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] RANGE */ -/* > \verbatim */ -/* > RANGE is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] UPLO */ -/* > \verbatim */ -/* > UPLO is CHARACTER*1 */ -/* > = 'U': Upper triangle of A is stored; */ -/* > = 'L': Lower triangle of A is stored. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] N */ -/* > \verbatim */ -/* > N is INTEGER */ -/* > The order of the matrix A. N >= 0. */ -/* > \endverbatim */ -/* > */ -/* > \param[in,out] A */ -/* > \verbatim */ -/* > A is COMPLEX*16 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, the lower triangle (if UPLO='L') or the upper */ -/* > triangle (if UPLO='U') of A, including the diagonal, is */ -/* > destroyed. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDA */ -/* > \verbatim */ -/* > LDA is INTEGER */ -/* > The leading dimension of the array A. LDA >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VL */ -/* > \verbatim */ -/* > VL is DOUBLE PRECISION */ -/* > If RANGE='V', the lower bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] VU */ -/* > \verbatim */ -/* > VU is DOUBLE PRECISION */ -/* > If RANGE='V', the upper bound of the interval to */ -/* > be searched for eigenvalues. VL < VU. */ -/* > Not referenced if RANGE = 'A' or 'I'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IL */ -/* > \verbatim */ -/* > IL is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > smallest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] IU */ -/* > \verbatim */ -/* > IU is INTEGER */ -/* > If RANGE='I', the index of the */ -/* > largest eigenvalue 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'. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] ABSTOL */ -/* > \verbatim */ -/* > ABSTOL is 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 * f2cmax( |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'). */ -/* > */ -/* > See "Computing Small Singular Values of Bidiagonal Matrices */ -/* > with Guaranteed High Relative Accuracy," by Demmel and */ -/* > Kahan, LAPACK Working Note #3. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] M */ -/* > \verbatim */ -/* > M is INTEGER */ -/* > The total number of eigenvalues found. 0 <= M <= N. */ -/* > If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] W */ -/* > \verbatim */ -/* > W is DOUBLE PRECISION array, dimension (N) */ -/* > On normal exit, the first M elements contain the selected */ -/* > eigenvalues in ascending order. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] Z */ -/* > \verbatim */ -/* > Z is COMPLEX*16 array, dimension (LDZ, f2cmax(1,M)) */ -/* > 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). */ -/* > 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. */ -/* > If JOBZ = 'N', then Z is not referenced. */ -/* > Note: the user must ensure that at least f2cmax(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. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LDZ */ -/* > \verbatim */ -/* > LDZ is INTEGER */ -/* > The leading dimension of the array Z. LDZ >= 1, and if */ -/* > JOBZ = 'V', LDZ >= f2cmax(1,N). */ -/* > \endverbatim */ -/* > */ -/* > \param[out] WORK */ -/* > \verbatim */ -/* > WORK is COMPLEX*16 array, dimension (MAX(1,LWORK)) */ -/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ -/* > \endverbatim */ -/* > */ -/* > \param[in] LWORK */ -/* > \verbatim */ -/* > LWORK is INTEGER */ -/* > The length of the array WORK. LWORK >= 1, when N <= 1; */ -/* > otherwise */ -/* > If JOBZ = 'N' and N > 1, LWORK must be queried. */ -/* > LWORK = MAX(1, 8*N, dimension) where */ -/* > dimension = f2cmax(stage1,stage2) + (KD+1)*N + N */ -/* > = N*KD + N*f2cmax(KD+1,FACTOPTNB) */ -/* > + f2cmax(2*KD*KD, KD*NTHREADS) */ -/* > + (KD+1)*N + N */ -/* > where KD is the blocking size of the reduction, */ -/* > FACTOPTNB is the blocking used by the QR or LQ */ -/* > algorithm, usually FACTOPTNB=128 is a good choice */ -/* > NTHREADS is the number of threads used when */ -/* > openMP compilation is enabled, otherwise =1. */ -/* > If JOBZ = 'V' and N > 1, LWORK must be queried. Not yet available */ -/* > */ -/* > 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] RWORK */ -/* > \verbatim */ -/* > RWORK is DOUBLE PRECISION array, dimension (7*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IWORK */ -/* > \verbatim */ -/* > IWORK is INTEGER array, dimension (5*N) */ -/* > \endverbatim */ -/* > */ -/* > \param[out] IFAIL */ -/* > \verbatim */ -/* > IFAIL is 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. */ -/* > \endverbatim */ -/* > */ -/* > \param[out] INFO */ -/* > \verbatim */ -/* > INFO is INTEGER */ -/* > = 0: successful exit */ -/* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ -/* > \endverbatim */ - -/* Authors: */ -/* ======== */ - -/* > \author Univ. of Tennessee */ -/* > \author Univ. of California Berkeley */ -/* > \author Univ. of Colorado Denver */ -/* > \author NAG Ltd. */ - -/* > \date June 2016 */ - -/* > \ingroup complex16HEeigen */ - -/* > \par Further Details: */ -/* ===================== */ -/* > */ -/* > \verbatim */ -/* > */ -/* > All details about the 2stage techniques are available in: */ -/* > */ -/* > Azzam Haidar, Hatem Ltaief, and Jack Dongarra. */ -/* > Parallel reduction to condensed forms for symmetric eigenvalue problems */ -/* > using aggregated fine-grained and memory-aware kernels. In Proceedings */ -/* > of 2011 International Conference for High Performance Computing, */ -/* > Networking, Storage and Analysis (SC '11), New York, NY, USA, */ -/* > Article 8 , 11 pages. */ -/* > http://doi.acm.org/10.1145/2063384.2063394 */ -/* > */ -/* > A. Haidar, J. Kurzak, P. Luszczek, 2013. */ -/* > An improved parallel singular value algorithm and its implementation */ -/* > for multicore hardware, In Proceedings of 2013 International Conference */ -/* > for High Performance Computing, Networking, Storage and Analysis (SC '13). */ -/* > Denver, Colorado, USA, 2013. */ -/* > Article 90, 12 pages. */ -/* > http://doi.acm.org/10.1145/2503210.2503292 */ -/* > */ -/* > A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. */ -/* > A novel hybrid CPU-GPU generalized eigensolver for electronic structure */ -/* > calculations based on fine-grained memory aware tasks. */ -/* > International Journal of High Performance Computing Applications. */ -/* > Volume 28 Issue 2, Pages 196-209, May 2014. */ -/* > http://hpc.sagepub.com/content/28/2/196 */ -/* > */ -/* > \endverbatim */ - -/* ===================================================================== */ /* Subroutine */ void zheevx_2stage_(char *jobz, char *range, char *uplo, integer *n, doublecomplex *a, integer *lda, doublereal *vl, doublereal *vu, integer *il, integer *iu, doublereal *abstol, integer @@ -584,14 +270,14 @@ static integer c__4 = 4; doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, ib, kd, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; extern integer ilaenv2stage_(integer *, char *, char *, integer *, integer *, integer *, integer *); - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -611,14 +297,12 @@ static integer c__4 = 4; logical wantz; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer ib, kd, jj; extern doublereal dlamch_(char *); logical alleig, indeig; - integer iscale, indibl; + integer indibl; logical valeig; doublereal safmin; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal abstll, bignum; extern doublereal zlanhe_(char *, char *, integer *, doublecomplex *, @@ -644,16 +328,13 @@ static integer c__4 = 4; zunmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); - doublereal eps, vll, vuu; integer indhous; - doublereal tmp1; -/* -- LAPACK driver routine (version 3.8.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -663,11 +344,11 @@ static integer c__4 = 4; /* Parameter adjustments */ a_dim1 = *lda; - a_offset = 1 + a_dim1 * 1; + a_offset = 1 + a_dim1; a -= a_offset; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -794,8 +475,12 @@ static integer c__4 = 4; iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { if (lower) { @@ -887,12 +572,21 @@ static integer c__4 = 4; indiwk = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L40; + } + } if (wantz) { zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + indiwk], &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by ZSTEIN. */ @@ -905,13 +599,8 @@ static integer c__4 = 4; L40: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ diff --git a/lapack-netlib/SRC/zheevx_2stage.f b/lapack-netlib/SRC/zheevx_2stage.f index d74beab235..a9a7e59299 100644 --- a/lapack-netlib/SRC/zheevx_2stage.f +++ b/lapack-netlib/SRC/zheevx_2stage.f @@ -7,7 +7,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHEEVX_2STAGE + dependencies *> *> [TGZ] @@ -15,7 +14,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -209,12 +207,12 @@ *> \verbatim *> LWORK is INTEGER *> The length of the array WORK. LWORK >= 1, when N <= 1; -*> otherwise +*> otherwise *> If JOBZ = 'N' and N > 1, LWORK must be queried. *> LWORK = MAX(1, 8*N, dimension) where *> dimension = max(stage1,stage2) + (KD+1)*N + N -*> = N*KD + N*max(KD+1,FACTOPTNB) -*> + max(2*KD*KD, KD*NTHREADS) +*> = N*KD + N*max(KD+1,FACTOPTNB) +*> + max(2*KD*KD, KD*NTHREADS) *> + (KD+1)*N + N *> where KD is the blocking size of the reduction, *> FACTOPTNB is the blocking used by the QR or LQ @@ -268,7 +266,7 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16HEeigen +*> \ingroup heevx_2stage * *> \par Further Details: * ===================== @@ -286,7 +284,7 @@ *> http://doi.acm.org/10.1145/2063384.2063394 *> *> A. Haidar, J. Kurzak, P. Luszczek, 2013. -*> An improved parallel singular value algorithm and its implementation +*> An improved parallel singular value algorithm and its implementation *> for multicore hardware, In Proceedings of 2013 International Conference *> for High Performance Computing, Networking, Storage and Analysis (SC '13). *> Denver, Colorado, USA, 2013. @@ -294,11 +292,11 @@ *> http://doi.acm.org/10.1145/2503210.2503292 *> *> A. Haidar, R. Solca, S. Tomov, T. Schulthess and J. Dongarra. -*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure +*> A novel hybrid CPU-GPU generalized eigensolver for electronic structure *> calculations based on fine-grained memory aware tasks. *> International Journal of High Performance Computing Applications. *> Volume 28 Issue 2, Pages 196-209, May 2014. -*> http://hpc.sagepub.com/content/28/2/196 +*> http://hpc.sagepub.com/content/28/2/196 *> *> \endverbatim * @@ -336,9 +334,9 @@ SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG, $ WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL, + INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, - $ ITMP1, J, JJ, LLWORK, + $ ITMP1, J, JJ, LLWORK, $ NSPLIT, LWMIN, LHTRD, LWTRD, KD, IB, INDHOUS DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, $ SIGMA, SMLNUM, TMP1, VLL, VUU @@ -350,7 +348,8 @@ SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, EXTERNAL LSAME, DLAMCH, ZLANHE, ILAENV2STAGE * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, + $ ZDSCAL, $ ZLACPY, ZSTEIN, ZSTEQR, ZSWAP, ZUNGTR, ZUNMTR, $ ZHETRD_2STAGE * .. @@ -470,8 +469,11 @@ SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN IF( LOWER ) THEN @@ -502,7 +504,7 @@ SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, LLWORK = LWORK - INDWRK + 1 * CALL ZHETRD_2STAGE( JOBZ, UPLO, N, A, LDA, RWORK( INDD ), - $ RWORK( INDE ), WORK( INDTAU ), + $ RWORK( INDE ), WORK( INDTAU ), $ WORK( INDHOUS ), LHTRD, WORK( INDWRK ), $ LLWORK, IINFO ) * @@ -572,21 +574,16 @@ SUBROUTINE ZHEEVX_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, * Apply unitary matrix used in reduction to tridiagonal * form to eigenvectors returned by ZSTEIN. * - CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z, + CALL ZUNMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), + $ Z, $ LDZ, WORK( INDWRK ), LLWORK, IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 40 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zhpevx.c b/lapack-netlib/SRC/zhpevx.c index 42c1ce0834..4c6c6fe7c0 100644 --- a/lapack-netlib/SRC/zhpevx.c +++ b/lapack-netlib/SRC/zhpevx.c @@ -250,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__1 = 1; @@ -264,7 +262,6 @@ matrices */ /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZHPEVX + dependencies */ /* > */ @@ -275,7 +272,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -477,8 +473,11 @@ f"> */ /* > INFO is INTEGER */ /* > = 0: successful exit */ /* > < 0: if INFO = -i, the i-th argument had an illegal value */ -/* > > 0: if INFO = i, then i eigenvectors failed to converge. */ -/* > Their indices are stored in array IFAIL. */ +/* > > 0: if INFO = i, and i is: */ +/* > <= N: then i eigenvectors failed to converge in */ +/* > ZSTEIN; their indices are stored in IFAIL. */ +/* > > N: DSTEBZ returned INFO = INFO - N; */ +/* > see DSTEBZ for details. */ /* > \endverbatim */ /* Authors: */ @@ -489,9 +488,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date June 2016 */ - -/* > \ingroup complex16OTHEReigen */ +/* > \ingroup hpevx */ /* ===================================================================== */ /* Subroutine */ void zhpevx_(char *jobz, char *range, char *uplo, integer *n, @@ -505,12 +502,12 @@ f"> */ doublereal d__1, d__2; /* Local variables */ + integer iscale, i__, j, jj; + doublereal eps, vll, vuu, tmp1; integer indd, inde; - doublereal anrm; - integer imax; - doublereal rmin, rmax; + doublereal anrm, rmin, rmax; logical test; - integer itmp1, i__, j, indee; + integer itmp1, indee; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); doublereal sigma; @@ -522,14 +519,10 @@ f"> */ logical wantz; extern /* Subroutine */ void zswap_(integer *, doublecomplex *, integer *, doublecomplex *, integer *); - integer jj; extern doublereal dlamch_(char *); - logical alleig, indeig; - integer iscale, indibl; - logical valeig; + logical alleig, indeig, valeig; doublereal safmin; - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void zdscal_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), zdscal_( integer *, doublereal *, doublecomplex *, integer *); doublereal abstll, bignum; integer indiwk, indisp, indtau; @@ -553,13 +546,11 @@ f"> */ doublecomplex *, integer *), zupmtr_(char *, char *, char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *); - doublereal eps, vll, vuu, tmp1; -/* -- LAPACK driver routine (version 3.7.0) -- */ +/* -- LAPACK driver routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* June 2016 */ /* ===================================================================== */ @@ -571,7 +562,7 @@ f"> */ --ap; --w; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --rwork; @@ -670,8 +661,12 @@ f"> */ iscale = 1; sigma = rmin / anrm; } else if (anrm > rmax) { - iscale = 1; +/* An infinite norm gives SIGMA = 0; leave such a matrix */ +/* unscaled so that VL and VU remain a valid interval. */ sigma = rmax / anrm; + if (sigma > 0.) { + iscale = 1; + } } if (iscale == 1) { i__1 = *n * (*n + 1) / 2; @@ -741,17 +736,25 @@ f"> */ } else { *(unsigned char *)order = 'E'; } - indibl = 1; - indisp = indibl + *n; + indisp = *n + 1; indiwk = indisp + *n; dstebz_(range, order, n, &vll, &vuu, il, iu, &abstll, &rwork[indd], & - rwork[inde], m, &nsplit, &w[1], &iwork[indibl], &iwork[indisp], & - rwork[indrwk], &iwork[indiwk], info); + rwork[inde], m, &nsplit, &w[1], &iwork[1], &iwork[indisp], &rwork[ + indrwk], &iwork[indiwk], &iinfo); + if (iinfo != 0) { + *info = *n + iinfo; + if (iinfo != 1) { + goto L20; + } + } if (wantz) { - zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[indibl], & - iwork[indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[ - indiwk], &ifail[1], info); + zstein_(n, &rwork[indd], &rwork[inde], m, &w[1], &iwork[1], &iwork[ + indisp], &z__[z_offset], ldz, &rwork[indrwk], &iwork[indiwk], + &ifail[1], &iinfo); + if (iinfo != 0 && *info == 0) { + *info = iinfo; + } /* Apply unitary matrix used in reduction to tridiagonal */ /* form to eigenvectors returned by ZSTEIN. */ @@ -765,13 +768,8 @@ f"> */ L20: if (iscale == 1) { - if (*info == 0) { - imax = *m; - } else { - imax = *info - 1; - } d__1 = 1. / sigma; - dscal_(&imax, &d__1, &w[1], &c__1); + dscal_(m, &d__1, &w[1], &c__1); } /* If eigenvalues are not in order, then sort them, along with */ @@ -792,11 +790,11 @@ f"> */ } if (i__ != 0) { - itmp1 = iwork[indibl + i__ - 1]; + itmp1 = iwork[i__]; w[i__] = w[j]; - iwork[indibl + i__ - 1] = iwork[indibl + j - 1]; + iwork[i__] = iwork[j]; w[j] = tmp1; - iwork[indibl + j - 1] = itmp1; + iwork[j] = itmp1; zswap_(n, &z__[i__ * z_dim1 + 1], &c__1, &z__[j * z_dim1 + 1], &c__1); if (*info != 0) { diff --git a/lapack-netlib/SRC/zhpevx.f b/lapack-netlib/SRC/zhpevx.f index 0acb505f64..a3a5bcfe9a 100644 --- a/lapack-netlib/SRC/zhpevx.f +++ b/lapack-netlib/SRC/zhpevx.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZHPEVX + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -234,12 +232,13 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16OTHEReigen +*> \ingroup hpevx * * ===================================================================== SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, $ ABSTOL, M, W, Z, LDZ, WORK, RWORK, IWORK, $ IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK driver routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -267,7 +266,7 @@ SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * .. Local Scalars .. LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ CHARACTER ORDER - INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, + INTEGER I, IINFO, INDD, INDE, INDEE, $ INDISP, INDIWK, INDRWK, INDTAU, INDWRK, ISCALE, $ ITMP1, J, JJ, NSPLIT DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, @@ -279,7 +278,8 @@ SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, EXTERNAL LSAME, DLAMCH, ZLANHP * .. * .. External Subroutines .. - EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, ZDSCAL, + EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTERF, XERBLA, + $ ZDSCAL, $ ZHPTRD, ZSTEIN, ZSTEQR, ZSWAP, ZUPGTR, ZUPMTR * .. * .. Intrinsic Functions .. @@ -299,7 +299,8 @@ SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, INFO = -1 ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN INFO = -2 - ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) ) + ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. + $ LSAME( UPLO, 'U' ) ) ) $ THEN INFO = -3 ELSE IF( N.LT.0 ) THEN @@ -372,8 +373,11 @@ SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ISCALE = 1 SIGMA = RMIN / ANRM ELSE IF( ANRM.GT.RMAX ) THEN - ISCALE = 1 +* An infinite norm gives SIGMA = 0; leave such a matrix +* unscaled so that VL and VU remain a valid interval. SIGMA = RMAX / ANRM + IF( SIGMA.GT.ZERO ) + $ ISCALE = 1 END IF IF( ISCALE.EQ.1 ) THEN CALL ZDSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 ) @@ -460,21 +464,16 @@ SUBROUTINE ZHPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, * form to eigenvectors returned by ZSTEIN. * INDWRK = INDTAU + N - CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ, + CALL ZUPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, + $ LDZ, $ WORK( INDWRK ), IINFO ) END IF * * If matrix was scaled, then rescale eigenvalues appropriately. * 20 CONTINUE - IF( ISCALE.EQ.1 ) THEN - IF( INFO.EQ.0 ) THEN - IMAX = M - ELSE - IMAX = INFO - 1 - END IF - CALL DSCAL( IMAX, ONE / SIGMA, W, 1 ) - END IF + IF( ISCALE.EQ.1 ) + $ CALL DSCAL( M, ONE / SIGMA, W, 1 ) * * If eigenvalues are not in order, then sort them, along with * eigenvectors. diff --git a/lapack-netlib/SRC/zstein.c b/lapack-netlib/SRC/zstein.c index 0a5b358a18..fce006ad70 100644 --- a/lapack-netlib/SRC/zstein.c +++ b/lapack-netlib/SRC/zstein.c @@ -39,14 +39,6 @@ typedef float real; typedef double doublereal; typedef struct { real r, i; } complex; typedef struct { doublereal r, i; } doublecomplex; -#ifdef _MSC_VER -static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;} -static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;} -#else -static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;} -static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;} -#endif -#define pCd(z) (*_pCd(z)) typedef blasint logical; typedef char logical1; @@ -246,11 +238,11 @@ typedef struct Namelist Namelist; #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));} #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));} #define myexit_() break; -#define mycycle_() continue; -#define myceiling_(w) {ceil(w)} -#define myhuge_(w) {HUGE_VAL} +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} -#define mymaxloc_(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} /* -- translated by f2c (version 20000121). You must link the resulting object file with the libraries: @@ -258,8 +250,6 @@ typedef struct Namelist Namelist; */ - - /* Table of constant values */ static integer c__2 = 2; @@ -273,7 +263,6 @@ static integer c_n1 = -1; /* Online html documentation available at */ /* http://www.netlib.org/lapack/explore-html/ */ -/* > \htmlonly */ /* > Download ZSTEIN + dependencies */ /* > */ @@ -284,7 +273,6 @@ f"> */ /* > */ /* > [TXT] */ -/* > \endhtmlonly */ /* Definition: */ /* =========== */ @@ -364,6 +352,8 @@ f"> */ /* > the first submatrix from the top, =2 if W(i) belongs to */ /* > the second submatrix, etc. ( The output array IBLOCK */ /* > from DSTEBZ is expected here. ) */ +/* > A negative entry, with which DSTEBZ flags an eigenvalue that */ +/* > did not converge, is treated as its absolute value. */ /* > \endverbatim */ /* > */ /* > \param[in] ISPLIT */ @@ -441,9 +431,7 @@ f"> */ /* > \author Univ. of Colorado Denver */ /* > \author NAG Ltd. */ -/* > \date December 2016 */ - -/* > \ingroup complex16OTHERcomputational */ +/* > \ingroup stein */ /* ===================================================================== */ /* Subroutine */ void zstein_(integer *n, doublereal *d__, doublereal *e, @@ -457,41 +445,37 @@ f"> */ doublecomplex z__1; /* Local variables */ + integer i__, j, b1, j1, bn, jr; + doublereal xj, scl, eps, sep, nrm, tol; + integer its; + doublereal xjm, ztr, eps1; integer jblk, nblk, jmax; extern doublereal dnrm2_(integer *, doublereal *, integer *); - integer i__, j; extern /* Subroutine */ void dscal_(integer *, doublereal *, doublereal *, integer *); integer iseed[4], gpind, iinfo; extern /* Subroutine */ void dcopy_(integer *, doublereal *, integer *, doublereal *, integer *); - integer b1, j1; doublereal ortol; - integer indrv1, indrv2, indrv3, indrv4, indrv5, bn; + integer indrv1, indrv2, indrv3, indrv4, indrv5; extern doublereal dlamch_(char *); - integer jr; extern /* Subroutine */ void dlagtf_(integer *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, doublereal *, integer * , integer *); - doublereal xj; extern integer idamax_(integer *, doublereal *, integer *); - extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); - extern void dlagts_( + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), dlagts_( integer *, integer *, doublereal *, doublereal *, doublereal *, doublereal *, integer *, doublereal *, doublereal *, integer *); integer nrmchk; extern /* Subroutine */ void dlarnv_(integer *, integer *, integer *, doublereal *); integer blksiz; - doublereal onenrm, dtpcrt, pertol, scl, eps, sep, nrm, tol; - integer its; - doublereal xjm, ztr, eps1; + doublereal dtpcrt, onenrm, pertol; -/* -- LAPACK computational routine (version 3.7.0) -- */ +/* -- LAPACK computational routine -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ -/* December 2016 */ /* ===================================================================== */ @@ -506,7 +490,7 @@ f"> */ --iblock; --isplit; z_dim1 = *ldz; - z_offset = 1 + z_dim1 * 1; + z_offset = 1 + z_dim1; z__ -= z_offset; --work; --iwork; @@ -529,11 +513,13 @@ f"> */ } else { i__1 = *m; for (j = 2; j <= i__1; ++j) { - if (iblock[j] < iblock[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) < (i__3 = iblock[j - 1], abs( + i__3))) { *info = -6; goto L30; } - if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) { + if ((i__2 = iblock[j], abs(i__2)) == (i__3 = iblock[j - 1], abs( + i__3)) && w[j] < w[j - 1]) { *info = -5; goto L30; } @@ -581,8 +567,8 @@ f"> */ /* Compute eigenvectors of matrix blocks. */ j1 = 1; - i__1 = iblock[*m]; - for (nblk = 1; nblk <= i__1; ++nblk) { + i__2 = (i__1 = iblock[*m], abs(i__1)); + for (nblk = 1; nblk <= i__2; ++nblk) { /* Find starting and ending indices of block nblk. */ @@ -605,8 +591,8 @@ f"> */ d__3 = onenrm, d__4 = (d__1 = d__[bn], abs(d__1)) + (d__2 = e[bn - 1], abs(d__2)); onenrm = f2cmax(d__3,d__4); - i__2 = bn - 1; - for (i__ = b1 + 1; i__ <= i__2; ++i__) { + i__1 = bn - 1; + for (i__ = b1 + 1; i__ <= i__1; ++i__) { /* Computing MAX */ d__4 = onenrm, d__5 = (d__1 = d__[i__], abs(d__1)) + (d__2 = e[ i__ - 1], abs(d__2)) + (d__3 = e[i__], abs(d__3)); @@ -621,9 +607,9 @@ f"> */ L60: jblk = 0; - i__2 = *m; - for (j = j1; j <= i__2; ++j) { - if (iblock[j] != nblk) { + i__1 = *m; + for (j = j1; j <= i__1; ++j) { + if ((i__3 = iblock[j], abs(i__3)) != nblk) { j1 = j; goto L180; } diff --git a/lapack-netlib/SRC/zstein.f b/lapack-netlib/SRC/zstein.f index 9be9d981c1..a00c088c1b 100644 --- a/lapack-netlib/SRC/zstein.f +++ b/lapack-netlib/SRC/zstein.f @@ -5,7 +5,6 @@ * Online html documentation available at * http://www.netlib.org/lapack/explore-html/ * -*> \htmlonly *> Download ZSTEIN + dependencies *> *> [TGZ] @@ -13,7 +12,6 @@ *> [ZIP] *> *> [TXT] -*> \endhtmlonly * * Definition: * =========== @@ -97,6 +95,8 @@ *> the first submatrix from the top, =2 if W(i) belongs to *> the second submatrix, etc. ( The output array IBLOCK *> from DSTEBZ is expected here. ) +*> A negative entry, with which DSTEBZ flags an eigenvalue that +*> did not converge, is treated as its absolute value. *> \endverbatim *> *> \param[in] ISPLIT @@ -174,11 +174,12 @@ *> \author Univ. of Colorado Denver *> \author NAG Ltd. * -*> \ingroup complex16OTHERcomputational +*> \ingroup stein * * ===================================================================== SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, $ IWORK, IFAIL, INFO ) + IMPLICIT NONE * * -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -222,7 +223,8 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, EXTERNAL IDAMAX, DLAMCH, DNRM2 * .. * .. External Subroutines .. - EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, XERBLA + EXTERNAL DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL, + $ XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, DCMPLX, MAX, SQRT @@ -244,11 +246,12 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, INFO = -9 ELSE DO 20 J = 2, M - IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN + IF( ABS( IBLOCK( J ) ).LT.ABS( IBLOCK( J-1 ) ) ) THEN INFO = -6 GO TO 30 END IF - IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) ) + IF( ABS( IBLOCK( J ) ).EQ.ABS( IBLOCK( J-1 ) ) .AND. + $ W( J ).LT.W( J-1 ) ) $ THEN INFO = -5 GO TO 30 @@ -292,7 +295,7 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute eigenvectors of matrix blocks. * J1 = 1 - DO 180 NBLK = 1, IBLOCK( M ) + DO 180 NBLK = 1, ABS( IBLOCK( M ) ) * * Find starting and ending indices of block nblk. * @@ -324,7 +327,7 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, 60 CONTINUE JBLK = 0 DO 170 J = J1, M - IF( IBLOCK( J ).NE.NBLK ) THEN + IF( ABS( IBLOCK( J ) ).NE.NBLK ) THEN J1 = J GO TO 180 END IF @@ -365,7 +368,8 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * Compute LU factors with partial pivoting ( PT = LU ) * TOL = ZERO - CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ), + CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK, $ IINFO ) * @@ -386,7 +390,8 @@ SUBROUTINE ZSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK, * * Solve the system LU = Pb. * - CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ), + CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), + $ WORK( INDRV2+2 ), $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK, $ WORK( INDRV1+1 ), TOL, IINFO ) * From 6878681268f4970ebfe2a87a6d53e2ce78188b83 Mon Sep 17 00:00:00 2001 From: Martin Kroeker Date: Tue, 27 Oct 2026 08:37:46 +0100 Subject: [PATCH 2/2] Fix rescaling after partial failure in the ?STEBZ-based drivers (Reference-LAPACK PR 1384( --- lapack-netlib/TESTING/EIG/derrst.f | 47 ++++++++++++++++++++++++++++++ lapack-netlib/TESTING/EIG/serrst.f | 47 ++++++++++++++++++++++++++++++ 2 files changed, 94 insertions(+) diff --git a/lapack-netlib/TESTING/EIG/derrst.f b/lapack-netlib/TESTING/EIG/derrst.f index 7d111e2e0d..3662873a94 100644 --- a/lapack-netlib/TESTING/EIG/derrst.f +++ b/lapack-netlib/TESTING/EIG/derrst.f @@ -58,6 +58,7 @@ * * ===================================================================== SUBROUTINE DERRST( PATH, NUNIT ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -85,6 +86,7 @@ SUBROUTINE DERRST( PATH, NUNIT ) $ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ), $ TAU( NMAX ), W( LW ), X( NMAX ), $ Z( NMAX, NMAX ) + DOUBLE PRECISION RINF, RZERO * .. * .. External Functions .. LOGICAL LSAMEN @@ -438,6 +440,49 @@ SUBROUTINE DERRST( PATH, NUNIT ) CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* A matrix that holds an infinity must come back from the +* drivers that scale it, instead of reaching XERBLA with a +* scale factor of zero. +* + RZERO = 0.0D0 + RINF = 1.0D0 / RZERO + DO 50 J = 1, NMAX + D( J ) = DBLE( J ) + E( J ) = 1.0D0 / DBLE( J+1 ) + DO 40 I = 1, NMAX + A( I, J ) = RZERO + 40 CONTINUE + A( J, J ) = D( J ) + 50 CONTINUE + D( 1 ) = RINF + A( 1, 1 ) = RINF + E( NMAX ) = RZERO + A( 1, 2 ) = E( 1 ) + A( 2, 3 ) = E( 2 ) + SRNAMT = 'DSTEVX' + INFOT = 0 + LERR = .FALSE. + CALL DSTEVX( 'V', 'V', NMAX, D, E, RZERO, 1.0D0, 1, NMAX, + $ RZERO, M, X, Z, NMAX, W, IW, I3, INFO ) + IF( LERR ) THEN + WRITE( NOUT, FMT = 9997 )'DSTEVX' + OK = .FALSE. + END IF + D( 1 ) = RINF + E( 1 ) = 1.0D0 / DBLE( 2 ) + E( 2 ) = 1.0D0 / DBLE( 3 ) + E( NMAX ) = RZERO + SRNAMT = 'DSYEVX' + INFOT = 0 + LERR = .FALSE. + CALL DSYEVX( 'V', 'V', 'U', NMAX, A, NMAX, RZERO, 1.0D0, 1, + $ NMAX, RZERO, M, X, Z, NMAX, W, LW, IW, I3, INFO ) + IF( LERR ) THEN + WRITE( NOUT, FMT = 9997 )'DSYEVX' + OK = .FALSE. + END IF + NT = NT + 2 +* * DSTEQR * SRNAMT = 'DSTEQR' @@ -1426,6 +1471,8 @@ SUBROUTINE DERRST( PATH, NUNIT ) $ ' (', I3, ' tests done)' ) 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ', $ 'exits ***' ) + 9997 FORMAT( ' *** ', A6, ' called XERBLA for a matrix with an ', + $ 'infinity ***' ) * RETURN * diff --git a/lapack-netlib/TESTING/EIG/serrst.f b/lapack-netlib/TESTING/EIG/serrst.f index 4083463829..642a0648cb 100644 --- a/lapack-netlib/TESTING/EIG/serrst.f +++ b/lapack-netlib/TESTING/EIG/serrst.f @@ -58,6 +58,7 @@ * * ===================================================================== SUBROUTINE SERRST( PATH, NUNIT ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -85,6 +86,7 @@ SUBROUTINE SERRST( PATH, NUNIT ) $ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ), $ TAU( NMAX ), W( LW ), X( NMAX ), $ Z( NMAX, NMAX ) + REAL RINF, RZERO * .. * .. External Functions .. LOGICAL LSAMEN @@ -438,6 +440,49 @@ SUBROUTINE SERRST( PATH, NUNIT ) CALL CHKXER( 'SSTEIN', INFOT, NOUT, LERR, OK ) NT = NT + 4 * +* A matrix that holds an infinity must come back from the +* drivers that scale it, instead of reaching XERBLA with a +* scale factor of zero. +* + RZERO = 0.0E0 + RINF = 1.0E0 / RZERO + DO 50 J = 1, NMAX + D( J ) = REAL( J ) + E( J ) = 1.0E0 / REAL( J+1 ) + DO 40 I = 1, NMAX + A( I, J ) = RZERO + 40 CONTINUE + A( J, J ) = D( J ) + 50 CONTINUE + D( 1 ) = RINF + A( 1, 1 ) = RINF + E( NMAX ) = RZERO + A( 1, 2 ) = E( 1 ) + A( 2, 3 ) = E( 2 ) + SRNAMT = 'SSTEVX' + INFOT = 0 + LERR = .FALSE. + CALL SSTEVX( 'V', 'V', NMAX, D, E, RZERO, 1.0E0, 1, NMAX, + $ RZERO, M, X, Z, NMAX, W, IW, I3, INFO ) + IF( LERR ) THEN + WRITE( NOUT, FMT = 9997 )'SSTEVX' + OK = .FALSE. + END IF + D( 1 ) = RINF + E( 1 ) = 1.0E0 / REAL( 2 ) + E( 2 ) = 1.0E0 / REAL( 3 ) + E( NMAX ) = RZERO + SRNAMT = 'SSYEVX' + INFOT = 0 + LERR = .FALSE. + CALL SSYEVX( 'V', 'V', 'U', NMAX, A, NMAX, RZERO, 1.0E0, 1, + $ NMAX, RZERO, M, X, Z, NMAX, W, LW, IW, I3, INFO ) + IF( LERR ) THEN + WRITE( NOUT, FMT = 9997 )'SSYEVX' + OK = .FALSE. + END IF + NT = NT + 2 +* * SSTEQR * SRNAMT = 'SSTEQR' @@ -1424,6 +1469,8 @@ SUBROUTINE SERRST( PATH, NUNIT ) $ ' (', I3, ' tests done)' ) 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ', $ 'exits ***' ) + 9997 FORMAT( ' *** ', A6, ' called XERBLA for a matrix with an ', + $ 'infinity ***' ) * RETURN *