From 390567a6fdce17ffb7784e9169217586c019d9ad Mon Sep 17 00:00:00 2001 From: Julien Schueller Date: Sat, 13 Jun 2026 12:10:56 +0200 Subject: [PATCH] *evr, *stevr: use fast CSTEMR path for partial eigenvalue ranges on IEEE machines The *evr and *stevr routines now call CSTEMR/DSTEMR/SSTEMR with the user-specified RANGE argument on IEEE-754 compliant machines, instead of only using the fast path when the full spectrum is requested (ALLEIG or IL=1, IU=N). Partial eigenvalue ranges with eigenvectors now also benefit from the faster algorithm. Fix a bug where WANTZ=.FALSE. with a partial range on IEEE machines would incorrectly set M=N and skip the DSTEBZ fallback, because INFO remained 0 from initialization when SSTERF was skipped (it can only compute all eigenvalues). The IF(INFO.EQ.0) success check is now moved inside each computational branch so it only triggers when SSTERF or CSTEMR was actually called and succeeded. Closes #1277 --- SRC/cheevr.f | 46 +++++++++++++++++++-------------------- SRC/cheevr_2stage.f | 46 +++++++++++++++++++-------------------- SRC/dstevr.f | 44 ++++++++++++++++++------------------- SRC/dsyevr.f | 48 ++++++++++++++++++++-------------------- SRC/dsyevr_2stage.f | 48 ++++++++++++++++++++-------------------- SRC/sstevr.f | 44 ++++++++++++++++++------------------- SRC/ssyevr.f | 53 ++++++++++++++++++++------------------------- SRC/ssyevr_2stage.f | 53 ++++++++++++++++++++------------------------- SRC/zheevr.f | 46 +++++++++++++++++++-------------------- SRC/zheevr_2stage.f | 46 +++++++++++++++++++-------------------- 10 files changed, 228 insertions(+), 246 deletions(-) diff --git a/SRC/cheevr.f b/SRC/cheevr.f index bab9353f8a..e4ef7450c4 100644 --- a/SRC/cheevr.f +++ b/SRC/cheevr.f @@ -93,10 +93,9 @@ *> UC Berkeley, May 1997. *> *> -*> Note 1 : CHEEVR calls CSTEMR when the full spectrum is requested -*> on machines which conform to the ieee-754 floating point standard. -*> CHEEVR calls SSTEBZ and CSTEIN on non-ieee machines and -*> when partial spectrum requests are made. +*> Note 1 : CHEEVR calls CSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). CHEEVR +*> calls SSTEBZ and CSTEIN on non-ieee machines. *> *> Normal execution of CSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -618,20 +617,22 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, CALL CHETRD( UPLO, N, A, LDA, RWORK( INDRD ), RWORK( INDRE ), $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call SSTERF or CSTEMR and CUNMTR. +* On IEEE-754 compliant machines, call SSTERF or CSTEMR and CUNMTR. * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL SCOPY( N, RWORK( INDRD ), 1, W, 1 ) - CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) - CALL SSTERF( N, W, RWORK( INDREE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL SCOPY( N, RWORK( INDRD ), 1, W, 1 ) + CALL SCOPY( N-1, RWORK( INDRE ), 1, + $ RWORK( INDREE ), 1 ) + CALL SSTERF( N, W, RWORK( INDREE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) CALL SCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) @@ -641,7 +642,7 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, ELSE TRYRAC = .FALSE. END IF - CALL CSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), + CALL CSTEMR( JOBZ, RANGE, N, RWORK( INDRDD ), $ RWORK( INDREE ), VL, VU, IL, IU, M, W, $ Z, LDZ, N, ISUPPZ, TRYRAC, $ RWORK( INDRWK ), LLRWORK, @@ -657,14 +658,11 @@ SUBROUTINE CHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. diff --git a/SRC/cheevr_2stage.f b/SRC/cheevr_2stage.f index 5bd16f449c..cfc51588e8 100644 --- a/SRC/cheevr_2stage.f +++ b/SRC/cheevr_2stage.f @@ -92,10 +92,9 @@ *> 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. +*> Note 1 : CHEEVR_2STAGE calls CSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). CHEEVR_2STAGE +*> calls SSTEBZ and CSTEIN on non-ieee machines. *> *> Normal execution of CSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -662,20 +661,22 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDHOUS ), LHTRD, $ WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call SSTERF or CSTEMR and CUNMTR. +* On IEEE-754 compliant machines, call SSTERF or CSTEMR and CUNMTR. * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL SCOPY( N, RWORK( INDRD ), 1, W, 1 ) - CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) - CALL SSTERF( N, W, RWORK( INDREE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL SCOPY( N, RWORK( INDRD ), 1, W, 1 ) + CALL SCOPY( N-1, RWORK( INDRE ), 1, + $ RWORK( INDREE ), 1 ) + CALL SSTERF( N, W, RWORK( INDREE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL SCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) CALL SCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) @@ -685,7 +686,7 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ELSE TRYRAC = .FALSE. END IF - CALL CSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), + CALL CSTEMR( JOBZ, RANGE, N, RWORK( INDRDD ), $ RWORK( INDREE ), VL, VU, IL, IU, M, W, $ Z, LDZ, N, ISUPPZ, TRYRAC, $ RWORK( INDRWK ), LLRWORK, @@ -701,14 +702,11 @@ SUBROUTINE CHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call SSTEBZ and, if eigenvectors are desired, CSTEIN. diff --git a/SRC/dstevr.f b/SRC/dstevr.f index d75afcb375..07f2d4dbdc 100644 --- a/SRC/dstevr.f +++ b/SRC/dstevr.f @@ -67,10 +67,9 @@ *> UC Berkeley, May 1997. *> *> -*> Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested -*> on machines which conform to the ieee-754 floating point standard. -*> DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and -*> when partial spectrum requests are made. +*> Note 1 : DSTEVR calls DSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). DSTEVR +*> calls DSTEBZ and DSTEIN on non-ieee machines. *> *> Normal execution of DSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -484,34 +483,35 @@ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * try DSTEBZ. * * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN - CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL DCOPY( N, D, 1, W, 1 ) - CALL DSTERF( N, W, WORK, INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) + CALL DCOPY( N, D, 1, W, 1 ) + CALL DSTERF( N, W, WORK, INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 10 + END IF + INFO = 0 + END IF ELSE + CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) CALL DCOPY( N, D, 1, WORK( N+1 ), 1 ) IF (ABSTOL .LE. TWO*N*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. END IF - CALL DSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL, - $ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC, + CALL DSTEMR( JOBZ, RANGE, N, WORK( N+1 ), WORK, VL, VU, + $ IL, IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC, $ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO ) -* - END IF - IF( INFO.EQ.0 ) THEN - M = N - GO TO 10 + IF( INFO.EQ.0 ) THEN + GO TO 10 + END IF + INFO = 0 END IF - INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. diff --git a/SRC/dsyevr.f b/SRC/dsyevr.f index 92166fa1bd..8fc1a4a9e8 100644 --- a/SRC/dsyevr.f +++ b/SRC/dsyevr.f @@ -91,10 +91,9 @@ *> UC Berkeley, May 1997. *> *> -*> Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested -*> on machines which conform to the ieee-754 floating point standard. -*> DSYEVR calls DSTEBZ and DSTEIN on non-ieee machines and -*> when partial spectrum requests are made. +*> Note 1 : DSYEVR calls DSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). DSYEVR +*> calls DSTEBZ and DSTEIN on non-ieee machines. *> *> Normal execution of DSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -574,15 +573,21 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call DSTERF or DSTEMR and DORMTR. +* On IEEE-754 compliant machines, call DSTERF or DSTEMR and DORMTR. * - IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. - $ IEEEOK.EQ.1 ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL DSTERF( N, W, WORK( INDEE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) @@ -592,10 +597,10 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, ELSE TRYRAC = .FALSE. END IF - CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), - $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, - $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, - $ INFO ) + CALL DSTEMR( JOBZ, RANGE, N, WORK( INDDD ), + $ WORK( INDEE ), VL, VU, IL, IU, M, W, Z, LDZ, + $ N, ISUPPZ, TRYRAC, WORK( INDWK ), LWORK, + $ IWORK, LIWORK, INFO ) * * * @@ -609,16 +614,11 @@ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN -* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are -* undefined. - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. diff --git a/SRC/dsyevr_2stage.f b/SRC/dsyevr_2stage.f index 180800e265..f75379c363 100644 --- a/SRC/dsyevr_2stage.f +++ b/SRC/dsyevr_2stage.f @@ -89,10 +89,9 @@ *> 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. +*> Note 1 : DSYEVR_2STAGE calls DSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). DSYEVR_2STAGE +*> calls DSTEBZ and SSTEIN on non-ieee machines. *> *> Normal execution of DSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -624,15 +623,21 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), $ LHTRD, WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call DSTERF or DSTEMR and DORMTR. +* On IEEE-754 compliant machines, call DSTERF or DSTEMR and DORMTR. * - IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND. - $ IEEEOK.EQ.1 ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) - CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL DSTERF( N, W, WORK( INDEE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL DCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL DSTERF( N, W, WORK( INDEE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) @@ -642,10 +647,10 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ELSE TRYRAC = .FALSE. END IF - CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), - $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, - $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, - $ INFO ) + CALL DSTEMR( JOBZ, RANGE, N, WORK( INDDD ), + $ WORK( INDEE ), VL, VU, IL, IU, M, W, Z, LDZ, + $ N, ISUPPZ, TRYRAC, WORK( INDWK ), LWORK, + $ IWORK, LIWORK, INFO ) * * * @@ -659,16 +664,11 @@ SUBROUTINE DSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN -* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are -* undefined. - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN. diff --git a/SRC/sstevr.f b/SRC/sstevr.f index 0b72c2f0e5..6dbda93124 100644 --- a/SRC/sstevr.f +++ b/SRC/sstevr.f @@ -67,10 +67,9 @@ *> UC Berkeley, May 1997. *> *> -*> Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested -*> on machines which conform to the ieee-754 floating point standard. -*> SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and -*> when partial spectrum requests are made. +*> Note 1 : SSTEVR calls SSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). SSTEVR +*> calls SSTEBZ and SSTEIN on non-ieee machines. *> *> Normal execution of SSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -486,34 +485,35 @@ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, * try SSTEBZ. * * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN - CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL SCOPY( N, D, 1, W, 1 ) - CALL SSTERF( N, W, WORK, INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) + CALL SCOPY( N, D, 1, W, 1 ) + CALL SSTERF( N, W, WORK, INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 10 + END IF + INFO = 0 + END IF ELSE + CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 ) CALL SCOPY( N, D, 1, WORK( N+1 ), 1 ) IF (ABSTOL .LE. TWO*REAL( N )*EPS) THEN TRYRAC = .TRUE. ELSE TRYRAC = .FALSE. END IF - CALL SSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL, - $ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC, + CALL SSTEMR( JOBZ, RANGE, N, WORK( N+1 ), WORK, VL, VU, + $ IL, IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC, $ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO ) -* - END IF - IF( INFO.EQ.0 ) THEN - M = N - GO TO 10 + IF( INFO.EQ.0 ) THEN + GO TO 10 + END IF + INFO = 0 END IF - INFO = 0 END IF * * Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. diff --git a/SRC/ssyevr.f b/SRC/ssyevr.f index 6a848bb1cb..59c10a257f 100644 --- a/SRC/ssyevr.f +++ b/SRC/ssyevr.f @@ -91,10 +91,9 @@ *> UC Berkeley, May 1997. *> *> -*> Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested -*> on machines which conform to the ieee-754 floating point standard. -*> SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and -*> when partial spectrum requests are made. +*> Note 1 : SSYEVR calls SSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). SSYEVR +*> calls SSTEBZ and SSTEIN on non-ieee machines. *> *> Normal execution of SSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -579,20 +578,21 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ), $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call SSTERF or SSTEMR and SORMTR. +* On IEEE-754 compliant machines, call SSTERF or SSTEMR and SORMTR. * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) - CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL SSTERF( N, W, WORK( INDEE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTERF( N, W, WORK( INDEE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) @@ -602,10 +602,10 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, ELSE TRYRAC = .FALSE. END IF - CALL SSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), - $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, - $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, - $ INFO ) + CALL SSTEMR( JOBZ, RANGE, N, WORK( INDDD ), + $ WORK( INDEE ), VL, VU, IL, IU, M, W, Z, LDZ, + $ N, ISUPPZ, TRYRAC, WORK( INDWK ), LWORK, + $ IWORK, LIWORK, INFO ) * * * @@ -619,16 +619,11 @@ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN -* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are -* undefined. - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. diff --git a/SRC/ssyevr_2stage.f b/SRC/ssyevr_2stage.f index 63f0023886..e0117c265d 100644 --- a/SRC/ssyevr_2stage.f +++ b/SRC/ssyevr_2stage.f @@ -89,10 +89,9 @@ *> 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. +*> Note 1 : SSYEVR_2STAGE calls SSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). SSYEVR_2STAGE +*> calls SSTEBZ and SSTEIN on non-ieee machines. *> *> Normal execution of SSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -625,20 +624,21 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDE ), WORK( INDTAU ), WORK( INDHOUS ), $ LHTRD, WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call SSTERF or SSTEMR and SORMTR. +* On IEEE-754 compliant machines, call SSTERF or SSTEMR and SORMTR. * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) - CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) - CALL SSTERF( N, W, WORK( INDEE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL SCOPY( N, WORK( INDD ), 1, W, 1 ) + CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) + CALL SSTERF( N, W, WORK( INDEE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 ) CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 ) @@ -648,10 +648,10 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ELSE TRYRAC = .FALSE. END IF - CALL SSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ), - $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ, - $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK, - $ INFO ) + CALL SSTEMR( JOBZ, RANGE, N, WORK( INDDD ), + $ WORK( INDEE ), VL, VU, IL, IU, M, W, Z, LDZ, + $ N, ISUPPZ, TRYRAC, WORK( INDWK ), LWORK, + $ IWORK, LIWORK, INFO ) * * * @@ -665,16 +665,11 @@ SUBROUTINE SSYEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN -* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are -* undefined. - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN. diff --git a/SRC/zheevr.f b/SRC/zheevr.f index 038738ec8b..36e433cc8d 100644 --- a/SRC/zheevr.f +++ b/SRC/zheevr.f @@ -93,10 +93,9 @@ *> UC Berkeley, May 1997. *> *> -*> Note 1 : ZHEEVR calls ZSTEMR when the full spectrum is requested -*> on machines which conform to the ieee-754 floating point standard. -*> ZHEEVR calls DSTEBZ and ZSTEIN on non-ieee machines and -*> when partial spectrum requests are made. +*> Note 1 : ZHEEVR calls ZSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). ZHEEVR +*> calls DSTEBZ and ZSTEIN on non-ieee machines. *> *> Normal execution of ZSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -617,20 +616,22 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, CALL ZHETRD( UPLO, N, A, LDA, RWORK( INDRD ), RWORK( INDRE ), $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call DSTERF or ZSTEMR and ZUNMTR. +* On IEEE-754 compliant machines, call DSTERF or ZSTEMR and ZUNMTR. * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) - CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) - CALL DSTERF( N, W, RWORK( INDREE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) + CALL DCOPY( N-1, RWORK( INDRE ), 1, + $ RWORK( INDREE ), 1 ) + CALL DSTERF( N, W, RWORK( INDREE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) @@ -640,7 +641,7 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, ELSE TRYRAC = .FALSE. END IF - CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), + CALL ZSTEMR( JOBZ, RANGE, N, RWORK( INDRDD ), $ RWORK( INDREE ), VL, VU, IL, IU, M, W, $ Z, LDZ, N, ISUPPZ, TRYRAC, $ RWORK( INDRWK ), LLRWORK, @@ -656,14 +657,11 @@ SUBROUTINE ZHEEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN. diff --git a/SRC/zheevr_2stage.f b/SRC/zheevr_2stage.f index 0ba5a29533..4ac804dfa5 100644 --- a/SRC/zheevr_2stage.f +++ b/SRC/zheevr_2stage.f @@ -92,10 +92,9 @@ *> 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. +*> Note 1 : ZHEEVR_2STAGE calls ZSTEMR when possible (i.e., on machines +*> which conform to the ieee-754 floating point standard). ZHEEVR_2STAGE +*> calls DSTEBZ and ZSTEIN on non-ieee machines. *> *> Normal execution of ZSTEMR may create NaNs and infinities and *> hence may abort due to a floating point exception in environments @@ -662,20 +661,22 @@ SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDHOUS ), LHTRD, $ WORK( INDWK ), LLWORK, IINFO ) * -* If all eigenvalues are desired -* then call DSTERF or ZSTEMR and ZUNMTR. +* On IEEE-754 compliant machines, call DSTERF or ZSTEMR and ZUNMTR. * - TEST = .FALSE. - IF( INDEIG ) THEN - IF( IL.EQ.1 .AND. IU.EQ.N ) THEN - TEST = .TRUE. - END IF - END IF - IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN + IF( IEEEOK.EQ.1 ) THEN IF( .NOT.WANTZ ) THEN - CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) - CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) - CALL DSTERF( N, W, RWORK( INDREE ), INFO ) + IF( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) + $ THEN + CALL DCOPY( N, RWORK( INDRD ), 1, W, 1 ) + CALL DCOPY( N-1, RWORK( INDRE ), 1, + $ RWORK( INDREE ), 1 ) + CALL DSTERF( N, W, RWORK( INDREE ), INFO ) + IF( INFO.EQ.0 ) THEN + M = N + GO TO 30 + END IF + INFO = 0 + END IF ELSE CALL DCOPY( N-1, RWORK( INDRE ), 1, RWORK( INDREE ), 1 ) CALL DCOPY( N, RWORK( INDRD ), 1, RWORK( INDRDD ), 1 ) @@ -685,7 +686,7 @@ SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, ELSE TRYRAC = .FALSE. END IF - CALL ZSTEMR( JOBZ, 'A', N, RWORK( INDRDD ), + CALL ZSTEMR( JOBZ, RANGE, N, RWORK( INDRDD ), $ RWORK( INDREE ), VL, VU, IL, IU, M, W, $ Z, LDZ, N, ISUPPZ, TRYRAC, $ RWORK( INDRWK ), LLRWORK, @@ -701,14 +702,11 @@ SUBROUTINE ZHEEVR_2STAGE( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ), $ LLWRKN, IINFO ) END IF + IF( INFO.EQ.0 ) THEN + GO TO 30 + END IF + INFO = 0 END IF -* -* - IF( INFO.EQ.0 ) THEN - M = N - GO TO 30 - END IF - INFO = 0 END IF * * Otherwise, call DSTEBZ and, if eigenvectors are desired, ZSTEIN.