phynexis-deps/lapack
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

*evr, *stevr: use fast CSTEMR path for partial eigenvalue ranges on IEEE machines

Browse Source 
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
This commit is contained in:
Julien Schueller
2026-06-13 12:47:29 +02:00
parent fbd4146ce5
commit 390567a6fd
10 changed files with 228 additions and 246 deletions
Download Patch File Download Diff File Expand all files Collapse all files
SRC/cheevr.f
+22 -24
View File
@@ -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 @@
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 @@
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 @@
$ 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.
SRC/cheevr_2stage.f
+22 -24
View File
@@ -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 @@
$ 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 @@
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 @@
$ 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.
SRC/dstevr.f
+22 -22
View File
@@ -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 @@
* 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 )
*
IF( INFO.EQ.0 ) THEN
GO TO 10
END IF
INFO = 0
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 10
END IF
INFO = 0
END IF
*
* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
SRC/dsyevr.f
+24 -24
View File
@@ -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 @@
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 @@
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 @@
$ 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.
SRC/dsyevr_2stage.f
+24 -24
View File
@@ -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 @@
$ 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 @@
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 @@
$ 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.
SRC/sstevr.f
+22 -22
View File
@@ -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 @@
* 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 )
*
IF( INFO.EQ.0 ) THEN
GO TO 10
END IF
INFO = 0
END IF
IF( INFO.EQ.0 ) THEN
M = N
GO TO 10
END IF
INFO = 0
END IF
*
* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
SRC/ssyevr.f
+24 -29
View File
@@ -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 @@
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 @@
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 @@
$ 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.
SRC/ssyevr_2stage.f
+24 -29
View File
@@ -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 @@
$ 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 @@
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 @@
$ 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.
SRC/zheevr.f
+22 -24
View File
@@ -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 @@
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 @@
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 @@
$ 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.
SRC/zheevr_2stage.f
+22 -24
View File
@@ -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 @@
$ 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 @@
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 @@
$ 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.