lib
/
LAPACK-3.11.0
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
Cloned library LAPACK-3.11.0 with extra build files for internal package management.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
3 Commits
1 Branch
0 Tags
5.8 MiB
Tag: Branch: Tree: 67a4b69a9f
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from '67a4b69a9f'
${ noResults }
LAPACK-3.11.0/TESTING/EIG/sget24.f

993 lines
32 KiB
Raw Normal View History Unescape

Initial commit
2 years ago
*> \brief \b SGET24
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE SGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
* H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
* LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
* RESULT, WORK, LWORK, IWORK, BWORK, INFO )
*
* .. Scalar Arguments ..
* LOGICAL COMP
* INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
* REAL RCDEIN, RCDVIN, THRESH
* ..
* .. Array Arguments ..
* LOGICAL BWORK( * )
* INTEGER ISEED( 4 ), ISLCT( * ), IWORK( * )
* REAL A( LDA, * ), H( LDA, * ), HT( LDA, * ),
* $ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
* $ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
* $ WR( * ), WRT( * ), WRTMP( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> SGET24 checks the nonsymmetric eigenvalue (Schur form) problem
*> expert driver SGEESX.
*>
*> If COMP = .FALSE., the first 13 of the following tests will be
*> be performed on the input matrix A, and also tests 14 and 15
*> if LWORK is sufficiently large.
*> If COMP = .TRUE., all 17 test will be performed.
*>
*> (1) 0 if T is in Schur form, 1/ulp otherwise
*> (no sorting of eigenvalues)
*>
*> (2) | A - VS T VS' | / ( n |A| ulp )
*>
*> Here VS is the matrix of Schur eigenvectors, and T is in Schur
*> form (no sorting of eigenvalues).
*>
*> (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
*>
*> (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
*> 1/ulp otherwise
*> (no sorting of eigenvalues)
*>
*> (5) 0 if T(with VS) = T(without VS),
*> 1/ulp otherwise
*> (no sorting of eigenvalues)
*>
*> (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
*> 1/ulp otherwise
*> (no sorting of eigenvalues)
*>
*> (7) 0 if T is in Schur form, 1/ulp otherwise
*> (with sorting of eigenvalues)
*>
*> (8) | A - VS T VS' | / ( n |A| ulp )
*>
*> Here VS is the matrix of Schur eigenvectors, and T is in Schur
*> form (with sorting of eigenvalues).
*>
*> (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
*>
*> (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
*> 1/ulp otherwise
*> If workspace sufficient, also compare WR, WI with and
*> without reciprocal condition numbers
*> (with sorting of eigenvalues)
*>
*> (11) 0 if T(with VS) = T(without VS),
*> 1/ulp otherwise
*> If workspace sufficient, also compare T with and without
*> reciprocal condition numbers
*> (with sorting of eigenvalues)
*>
*> (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
*> 1/ulp otherwise
*> If workspace sufficient, also compare VS with and without
*> reciprocal condition numbers
*> (with sorting of eigenvalues)
*>
*> (13) if sorting worked and SDIM is the number of
*> eigenvalues which were SELECTed
*> If workspace sufficient, also compare SDIM with and
*> without reciprocal condition numbers
*>
*> (14) if RCONDE the same no matter if VS and/or RCONDV computed
*>
*> (15) if RCONDV the same no matter if VS and/or RCONDE computed
*>
*> (16) |RCONDE - RCDEIN| / cond(RCONDE)
*>
*> RCONDE is the reciprocal average eigenvalue condition number
*> computed by SGEESX and RCDEIN (the precomputed true value)
*> is supplied as input. cond(RCONDE) is the condition number
*> of RCONDE, and takes errors in computing RCONDE into account,
*> so that the resulting quantity should be O(ULP). cond(RCONDE)
*> is essentially given by norm(A)/RCONDV.
*>
*> (17) |RCONDV - RCDVIN| / cond(RCONDV)
*>
*> RCONDV is the reciprocal right invariant subspace condition
*> number computed by SGEESX and RCDVIN (the precomputed true
*> value) is supplied as input. cond(RCONDV) is the condition
*> number of RCONDV, and takes errors in computing RCONDV into
*> account, so that the resulting quantity should be O(ULP).
*> cond(RCONDV) is essentially given by norm(A)/RCONDE.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] COMP
*> \verbatim
*> COMP is LOGICAL
*> COMP describes which input tests to perform:
*> = .FALSE. if the computed condition numbers are not to
*> be tested against RCDVIN and RCDEIN
*> = .TRUE. if they are to be compared
*> \endverbatim
*>
*> \param[in] JTYPE
*> \verbatim
*> JTYPE is INTEGER
*> Type of input matrix. Used to label output if error occurs.
*> \endverbatim
*>
*> \param[in] ISEED
*> \verbatim
*> ISEED is INTEGER array, dimension (4)
*> If COMP = .FALSE., the random number generator seed
*> used to produce matrix.
*> If COMP = .TRUE., ISEED(1) = the number of the example.
*> Used to label output if error occurs.
*> \endverbatim
*>
*> \param[in] THRESH
*> \verbatim
*> THRESH is REAL
*> A test will count as "failed" if the "error", computed as
*> described above, exceeds THRESH. Note that the error
*> is scaled to be O(1), so THRESH should be a reasonably
*> small multiple of 1, e.g., 10 or 100. In particular,
*> it should not depend on the precision (single vs. double)
*> or the size of the matrix. It must be at least zero.
*> \endverbatim
*>
*> \param[in] NOUNIT
*> \verbatim
*> NOUNIT is INTEGER
*> The FORTRAN unit number for printing out error messages
*> (e.g., if a routine returns INFO not equal to 0.)
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The dimension of A. N must be at least 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is REAL array, dimension (LDA, N)
*> Used to hold the matrix whose eigenvalues are to be
*> computed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of A, and H. LDA must be at
*> least 1 and at least N.
*> \endverbatim
*>
*> \param[out] H
*> \verbatim
*> H is REAL array, dimension (LDA, N)
*> Another copy of the test matrix A, modified by SGEESX.
*> \endverbatim
*>
*> \param[out] HT
*> \verbatim
*> HT is REAL array, dimension (LDA, N)
*> Yet another copy of the test matrix A, modified by SGEESX.
*> \endverbatim
*>
*> \param[out] WR
*> \verbatim
*> WR is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WI
*> \verbatim
*> WI is REAL array, dimension (N)
*>
*> The real and imaginary parts of the eigenvalues of A.
*> On exit, WR + WI*i are the eigenvalues of the matrix in A.
*> \endverbatim
*>
*> \param[out] WRT
*> \verbatim
*> WRT is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WIT
*> \verbatim
*> WIT is REAL array, dimension (N)
*>
*> Like WR, WI, these arrays contain the eigenvalues of A,
*> but those computed when SGEESX only computes a partial
*> eigendecomposition, i.e. not Schur vectors
*> \endverbatim
*>
*> \param[out] WRTMP
*> \verbatim
*> WRTMP is REAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] WITMP
*> \verbatim
*> WITMP is REAL array, dimension (N)
*>
*> Like WR, WI, these arrays contain the eigenvalues of A,
*> but sorted by increasing real part.
*> \endverbatim
*>
*> \param[out] VS
*> \verbatim
*> VS is REAL array, dimension (LDVS, N)
*> VS holds the computed Schur vectors.
*> \endverbatim
*>
*> \param[in] LDVS
*> \verbatim
*> LDVS is INTEGER
*> Leading dimension of VS. Must be at least max(1, N).
*> \endverbatim
*>
*> \param[out] VS1
*> \verbatim
*> VS1 is REAL array, dimension (LDVS, N)
*> VS1 holds another copy of the computed Schur vectors.
*> \endverbatim
*>
*> \param[in] RCDEIN
*> \verbatim
*> RCDEIN is REAL
*> When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
*> condition number for the average of selected eigenvalues.
*> \endverbatim
*>
*> \param[in] RCDVIN
*> \verbatim
*> RCDVIN is REAL
*> When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
*> condition number for the selected right invariant subspace.
*> \endverbatim
*>
*> \param[in] NSLCT
*> \verbatim
*> NSLCT is INTEGER
*> When COMP = .TRUE. the number of selected eigenvalues
*> corresponding to the precomputed values RCDEIN and RCDVIN.
*> \endverbatim
*>
*> \param[in] ISLCT
*> \verbatim
*> ISLCT is INTEGER array, dimension (NSLCT)
*> When COMP = .TRUE. ISLCT selects the eigenvalues of the
*> input matrix corresponding to the precomputed values RCDEIN
*> and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
*> eigenvalue with the J-th largest real part is selected.
*> Not referenced if COMP = .FALSE.
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*> RESULT is REAL array, dimension (17)
*> The values computed by the 17 tests described above.
*> The values are currently limited to 1/ulp, to avoid
*> overflow.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is REAL array, dimension (LWORK)
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The number of entries in WORK to be passed to SGEESX. This
*> must be at least 3*N, and N+N**2 if tests 14--16 are to
*> be performed.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (N*N)
*> \endverbatim
*>
*> \param[out] BWORK
*> \verbatim
*> BWORK is LOGICAL array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> If 0, successful exit.
*> If <0, input parameter -INFO had an incorrect value.
*> If >0, SGEESX returned an error code, the absolute
*> value of which is returned.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup single_eig
*
* =====================================================================
SUBROUTINE SGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
$ H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
$ LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
$ RESULT, WORK, LWORK, IWORK, BWORK, INFO )
*
* -- LAPACK test routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL COMP
INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
REAL RCDEIN, RCDVIN, THRESH
* ..
* .. Array Arguments ..
LOGICAL BWORK( * )
INTEGER ISEED( 4 ), ISLCT( * ), IWORK( * )
REAL A( LDA, * ), H( LDA, * ), HT( LDA, * ),
$ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
$ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
$ WR( * ), WRT( * ), WRTMP( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
REAL EPSIN
PARAMETER ( EPSIN = 5.9605E-8 )
* ..
* .. Local Scalars ..
CHARACTER SORT
INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, LIWORK,
$ RSUB, SDIM, SDIM1
REAL ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
$ SMLNUM, TMP, TOL, TOLIN, ULP, ULPINV, V, VIMIN,
$ VRMIN, WNORM
* ..
* .. Local Arrays ..
INTEGER IPNT( 20 )
* ..
* .. Arrays in Common ..
LOGICAL SELVAL( 20 )
REAL SELWI( 20 ), SELWR( 20 )
* ..
* .. Scalars in Common ..
INTEGER SELDIM, SELOPT
* ..
* .. Common blocks ..
COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
* ..
* .. External Functions ..
LOGICAL SSLECT
REAL SLAMCH, SLANGE
EXTERNAL SSLECT, SLAMCH, SLANGE
* ..
* .. External Subroutines ..
EXTERNAL SCOPY, SGEESX, SGEMM, SLACPY, SORT01, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
IF( THRESH.LT.ZERO ) THEN
INFO = -3
ELSE IF( NOUNIT.LE.0 ) THEN
INFO = -5
ELSE IF( N.LT.0 ) THEN
INFO = -6
ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
INFO = -8
ELSE IF( LDVS.LT.1 .OR. LDVS.LT.N ) THEN
INFO = -18
ELSE IF( LWORK.LT.3*N ) THEN
INFO = -26
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGET24', -INFO )
RETURN
END IF
*
* Quick return if nothing to do
*
DO 10 I = 1, 17
RESULT( I ) = -ONE
10 CONTINUE
*
IF( N.EQ.0 )
$ RETURN
*
* Important constants
*
SMLNUM = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Precision' )
ULPINV = ONE / ULP
*
* Perform tests (1)-(13)
*
SELOPT = 0
LIWORK = N*N
DO 120 ISORT = 0, 1
IF( ISORT.EQ.0 ) THEN
SORT = 'N'
RSUB = 0
ELSE
SORT = 'S'
RSUB = 6
END IF
*
* Compute Schur form and Schur vectors, and test them
*
CALL SLACPY( 'F', N, N, A, LDA, H, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'N', N, H, LDA, SDIM, WR, WI,
$ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 1+RSUB ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX1', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX1', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
RETURN
END IF
IF( ISORT.EQ.0 ) THEN
CALL SCOPY( N, WR, 1, WRTMP, 1 )
CALL SCOPY( N, WI, 1, WITMP, 1 )
END IF
*
* Do Test (1) or Test (7)
*
RESULT( 1+RSUB ) = ZERO
DO 30 J = 1, N - 2
DO 20 I = J + 2, N
IF( H( I, J ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
20 CONTINUE
30 CONTINUE
DO 40 I = 1, N - 2
IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.ZERO )
$ RESULT( 1+RSUB ) = ULPINV
40 CONTINUE
DO 50 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
IF( H( I, I ).NE.H( I+1, I+1 ) .OR. H( I, I+1 ).EQ.
$ ZERO .OR. SIGN( ONE, H( I+1, I ) ).EQ.
$ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB ) = ULPINV
END IF
50 CONTINUE
*
* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
*
* Copy A to VS1, used as workspace
*
CALL SLACPY( ' ', N, N, A, LDA, VS1, LDVS )
*
* Compute Q*H and store in HT.
*
CALL SGEMM( 'No transpose', 'No transpose', N, N, N, ONE, VS,
$ LDVS, H, LDA, ZERO, HT, LDA )
*
* Compute A - Q*H*Q'
*
CALL SGEMM( 'No transpose', 'Transpose', N, N, N, -ONE, HT,
$ LDA, VS, LDVS, ONE, VS1, LDVS )
*
ANORM = MAX( SLANGE( '1', N, N, A, LDA, WORK ), SMLNUM )
WNORM = SLANGE( '1', N, N, VS1, LDVS, WORK )
*
IF( ANORM.GT.WNORM ) THEN
RESULT( 2+RSUB ) = ( WNORM / ANORM ) / ( N*ULP )
ELSE
IF( ANORM.LT.ONE ) THEN
RESULT( 2+RSUB ) = ( MIN( WNORM, N*ANORM ) / ANORM ) /
$ ( N*ULP )
ELSE
RESULT( 2+RSUB ) = MIN( WNORM / ANORM, REAL( N ) ) /
$ ( N*ULP )
END IF
END IF
*
* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP )
*
CALL SORT01( 'Columns', N, N, VS, LDVS, WORK, LWORK,
$ RESULT( 3+RSUB ) )
*
* Do Test (4) or Test (10)
*
RESULT( 4+RSUB ) = ZERO
DO 60 I = 1, N
IF( H( I, I ).NE.WR( I ) )
$ RESULT( 4+RSUB ) = ULPINV
60 CONTINUE
IF( N.GT.1 ) THEN
IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
$ RESULT( 4+RSUB ) = ULPINV
END IF
DO 70 I = 1, N - 1
IF( H( I+1, I ).NE.ZERO ) THEN
TMP = SQRT( ABS( H( I+1, I ) ) )*
$ SQRT( ABS( H( I, I+1 ) ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I )-TMP ) /
$ MAX( ULP*TMP, SMLNUM ) )
RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
$ ABS( WI( I+1 )+TMP ) /
$ MAX( ULP*TMP, SMLNUM ) )
ELSE IF( I.GT.1 ) THEN
IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.ZERO .AND.
$ WI( I ).NE.ZERO )RESULT( 4+RSUB ) = ULPINV
END IF
70 CONTINUE
*
* Do Test (5) or Test (11)
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'N', N, HT, LDA, SDIM, WRT,
$ WIT, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
$ LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 5+RSUB ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX2', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX2', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
RESULT( 5+RSUB ) = ZERO
DO 90 J = 1, N
DO 80 I = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 5+RSUB ) = ULPINV
80 CONTINUE
90 CONTINUE
*
* Do Test (6) or Test (12)
*
RESULT( 6+RSUB ) = ZERO
DO 100 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 6+RSUB ) = ULPINV
100 CONTINUE
*
* Do Test (13)
*
IF( ISORT.EQ.1 ) THEN
RESULT( 13 ) = ZERO
KNTEIG = 0
DO 110 I = 1, N
IF( SSLECT( WR( I ), WI( I ) ) .OR.
$ SSLECT( WR( I ), -WI( I ) ) )KNTEIG = KNTEIG + 1
IF( I.LT.N ) THEN
IF( ( SSLECT( WR( I+1 ), WI( I+1 ) ) .OR.
$ SSLECT( WR( I+1 ), -WI( I+1 ) ) ) .AND.
$ ( .NOT.( SSLECT( WR( I ),
$ WI( I ) ) .OR. SSLECT( WR( I ),
$ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )RESULT( 13 )
$ = ULPINV
END IF
110 CONTINUE
IF( SDIM.NE.KNTEIG )
$ RESULT( 13 ) = ULPINV
END IF
*
120 CONTINUE
*
* If there is enough workspace, perform tests (14) and (15)
* as well as (10) through (13)
*
IF( LWORK.GE.N+( N*N ) / 2 ) THEN
*
* Compute both RCONDE and RCONDV with VS
*
SORT = 'S'
RESULT( 14 ) = ZERO
RESULT( 15 ) = ZERO
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX3', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX3', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform tests (10), (11), (12), and (13)
*
DO 140 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 130 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
130 CONTINUE
140 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute both RCONDE and RCONDV without VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX4', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX4', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform tests (14) and (15)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 160 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 150 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
150 CONTINUE
160 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDE with VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'E', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX5', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX5', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (14)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 180 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 170 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
170 CONTINUE
180 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDE without VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'E', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 14 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX6', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX6', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (14)
*
IF( RCNDE1.NE.RCONDE )
$ RESULT( 14 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 200 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 190 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
190 CONTINUE
200 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDV with VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'V', SORT, SSLECT, 'V', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX7', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX7', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (15)
*
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 220 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 210 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
210 CONTINUE
220 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
* Compute RCONDV without VS, and compare
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', SORT, SSLECT, 'V', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 15 ) = ULPINV
IF( JTYPE.NE.22 ) THEN
WRITE( NOUNIT, FMT = 9998 )'SGEESX8', IINFO, N, JTYPE,
$ ISEED
ELSE
WRITE( NOUNIT, FMT = 9999 )'SGEESX8', IINFO, N,
$ ISEED( 1 )
END IF
INFO = ABS( IINFO )
GO TO 250
END IF
*
* Perform test (15)
*
IF( RCNDV1.NE.RCONDV )
$ RESULT( 15 ) = ULPINV
*
* Perform tests (10), (11), (12), and (13)
*
DO 240 I = 1, N
IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
$ RESULT( 10 ) = ULPINV
DO 230 J = 1, N
IF( H( I, J ).NE.HT( I, J ) )
$ RESULT( 11 ) = ULPINV
IF( VS( I, J ).NE.VS1( I, J ) )
$ RESULT( 12 ) = ULPINV
230 CONTINUE
240 CONTINUE
IF( SDIM.NE.SDIM1 )
$ RESULT( 13 ) = ULPINV
*
END IF
*
250 CONTINUE
*
* If there are precomputed reciprocal condition numbers, compare
* computed values with them.
*
IF( COMP ) THEN
*
* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that
* the logical function SSLECT selects the eigenvalues specified
* by NSLCT and ISLCT.
*
SELDIM = N
SELOPT = 1
EPS = MAX( ULP, EPSIN )
DO 260 I = 1, N
IPNT( I ) = I
SELVAL( I ) = .FALSE.
SELWR( I ) = WRTMP( I )
SELWI( I ) = WITMP( I )
260 CONTINUE
DO 280 I = 1, N - 1
KMIN = I
VRMIN = WRTMP( I )
VIMIN = WITMP( I )
DO 270 J = I + 1, N
IF( WRTMP( J ).LT.VRMIN ) THEN
KMIN = J
VRMIN = WRTMP( J )
VIMIN = WITMP( J )
END IF
270 CONTINUE
WRTMP( KMIN ) = WRTMP( I )
WITMP( KMIN ) = WITMP( I )
WRTMP( I ) = VRMIN
WITMP( I ) = VIMIN
ITMP = IPNT( I )
IPNT( I ) = IPNT( KMIN )
IPNT( KMIN ) = ITMP
280 CONTINUE
DO 290 I = 1, NSLCT
SELVAL( IPNT( ISLCT( I ) ) ) = .TRUE.
290 CONTINUE
*
* Compute condition numbers
*
CALL SLACPY( 'F', N, N, A, LDA, HT, LDA )
CALL SGEESX( 'N', 'S', SSLECT, 'B', N, HT, LDA, SDIM1, WRT,
$ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
$ IWORK, LIWORK, BWORK, IINFO )
IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
RESULT( 16 ) = ULPINV
RESULT( 17 ) = ULPINV
WRITE( NOUNIT, FMT = 9999 )'SGEESX9', IINFO, N, ISEED( 1 )
INFO = ABS( IINFO )
GO TO 300
END IF
*
* Compare condition number for average of selected eigenvalues
* taking its condition number into account
*
ANORM = SLANGE( '1', N, N, A, LDA, WORK )
V = MAX( REAL( N )*EPS*ANORM, SMLNUM )
IF( ANORM.EQ.ZERO )
$ V = ONE
IF( V.GT.RCONDV ) THEN
TOL = ONE
ELSE
TOL = V / RCONDV
END IF
IF( V.GT.RCDVIN ) THEN
TOLIN = ONE
ELSE
TOLIN = V / RCDVIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDEIN-TOLIN ).GT.RCONDE+TOL ) THEN
RESULT( 16 ) = ULPINV
ELSE IF( RCDEIN-TOLIN.GT.RCONDE+TOL ) THEN
RESULT( 16 ) = ( RCDEIN-TOLIN ) / ( RCONDE+TOL )
ELSE IF( RCDEIN+TOLIN.LT.EPS*( RCONDE-TOL ) ) THEN
RESULT( 16 ) = ULPINV
ELSE IF( RCDEIN+TOLIN.LT.RCONDE-TOL ) THEN
RESULT( 16 ) = ( RCONDE-TOL ) / ( RCDEIN+TOLIN )
ELSE
RESULT( 16 ) = ONE
END IF
*
* Compare condition numbers for right invariant subspace
* taking its condition number into account
*
IF( V.GT.RCONDV*RCONDE ) THEN
TOL = RCONDV
ELSE
TOL = V / RCONDE
END IF
IF( V.GT.RCDVIN*RCDEIN ) THEN
TOLIN = RCDVIN
ELSE
TOLIN = V / RCDEIN
END IF
TOL = MAX( TOL, SMLNUM / EPS )
TOLIN = MAX( TOLIN, SMLNUM / EPS )
IF( EPS*( RCDVIN-TOLIN ).GT.RCONDV+TOL ) THEN
RESULT( 17 ) = ULPINV
ELSE IF( RCDVIN-TOLIN.GT.RCONDV+TOL ) THEN
RESULT( 17 ) = ( RCDVIN-TOLIN ) / ( RCONDV+TOL )
ELSE IF( RCDVIN+TOLIN.LT.EPS*( RCONDV-TOL ) ) THEN
RESULT( 17 ) = ULPINV
ELSE IF( RCDVIN+TOLIN.LT.RCONDV-TOL ) THEN
RESULT( 17 ) = ( RCONDV-TOL ) / ( RCDVIN+TOLIN )
ELSE
RESULT( 17 ) = ONE
END IF
*
300 CONTINUE
*
END IF
*
9999 FORMAT( ' SGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
9998 FORMAT( ' SGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
*
RETURN
*
* End of SGET24
*
END