📄 zchkst.f
字号:
* ask for all eigenvalues with high relative accuracy.
*
VL = ZERO
VU = ZERO
IL = 0
IU = 0
IF( JTYPE.EQ.21 ) THEN
NTEST = 17
ABSTOL = UNFL + UNFL
CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ),
$ RWORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 17 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do test 17
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
$ ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 190 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
$ ( ABSTOL+ABS( D4( J ) ) ) )
190 CONTINUE
*
RESULT( 17 ) = TEMP1 / TEMP2
ELSE
RESULT( 17 ) = ZERO
END IF
*
* Now ask for all eigenvalues with high absolute accuracy.
*
NTEST = 18
ABSTOL = UNFL + UNFL
CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
$ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK,
$ IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do test 18
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 200 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) )
200 CONTINUE
*
RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Choose random values for IL and IU, and ask for the
* IL-th through IU-th eigenvalues.
*
NTEST = 19
IF( N.LE.1 ) THEN
IL = 1
IU = N
ELSE
IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
END IF
*
CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ),
$ RWORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
GO TO 280
END IF
END IF
*
* Determine the values VL and VU of the IL-th and IU-th
* eigenvalues and ask for all eigenvalues in this range.
*
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ),
$ ULP*ANORM, TWO*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ ULP*ANORM, TWO*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
$ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ),
$ RWORK, IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
GO TO 280
END IF
END IF
*
IF( M3.EQ.0 .AND. N.NE.0 ) THEN
RESULT( 19 ) = ULPINV
GO TO 280
END IF
*
* Do test 19
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) )
ELSE
TEMP3 = ZERO
END IF
*
RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
* Call ZSTEIN to compute eigenvectors corresponding to
* eigenvalues in WA1. (First call DSTEBZ again, to make sure
* it returns these eigenvalues in the correct order.)
*
NTEST = 21
CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
$ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), RWORK,
$ IWORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 280
END IF
END IF
*
CALL ZSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z,
$ LDU, RWORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'ZSTEIN', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do tests 20 and 21
*
CALL ZSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK, RWORK,
$ RESULT( 20 ) )
*
* Call ZSTEDC(I) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
INDE = 1
INDRWK = INDE + N
CALL DCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 )
CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU )
*
NTEST = 22
CALL ZSTEDC( 'I', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC,
$ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(I)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 22 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 22 and 23
*
CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK,
$ RESULT( 22 ) )
*
* Call ZSTEDC(V) to compute D1 and Z, do tests.
*
* Compute D1 and Z
*
CALL DCOPY( N, SD, 1, D1, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 )
CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU )
*
NTEST = 24
CALL ZSTEDC( 'V', N, D1, RWORK( INDE ), Z, LDU, WORK, LWEDC,
$ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(V)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 24 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Tests 24 and 25
*
CALL ZSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, RWORK,
$ RESULT( 24 ) )
*
* Call ZSTEDC(N) to compute D2, do tests.
*
* Compute D2
*
CALL DCOPY( N, SD, 1, D2, 1 )
IF( N.GT.0 )
$ CALL DCOPY( N-1, SE, 1, RWORK( INDE ), 1 )
CALL ZLASET( 'Full', N, N, CZERO, CONE, Z, LDU )
*
NTEST = 26
CALL ZSTEDC( 'N', N, D2, RWORK( INDE ), Z, LDU, WORK, LWEDC,
$ RWORK( INDRWK ), LRWEDC, IWORK, LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'ZSTEDC(N)', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 26 ) = ULPINV
GO TO 280
END IF
END IF
*
* Do Test 26
*
TEMP1 = ZERO
TEMP2 = ZERO
*
DO 210 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
210 CONTINUE
*
RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
*
* Only test ZSTEMR if IEEE compliant
*
IF( ILAENV( 10, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
$ ILAENV( 11, 'ZSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
*
* Call ZSTEMR, do test 27 (relative eigenvalue accuracy)
*
* If S is positive definite and diagonally dominant,
* ask for all eigenvalues with high relative accuracy.
*
VL = ZERO
VU = ZERO
IL = 0
IU = 0
IF( JTYPE.EQ.21 .AND. CREL ) THEN
NTEST = 27
ABSTOL = UNFL + UNFL
CALL ZSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU,
$ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ RWORK, LRWORK, IWORK( 2*N+1 ), LWORK-2*N,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,A,rel)',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 27 ) = ULPINV
GO TO 270
END IF
END IF
*
* Do test 27
*
TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
$ ( ONE-HALF )**4
*
TEMP1 = ZERO
DO 220 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
$ ( ABSTOL+ABS( D4( J ) ) ) )
220 CONTINUE
*
RESULT( 27 ) = TEMP1 / TEMP2
*
IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
IF( IU.LT.IL ) THEN
ITEMP = IU
IU = IL
IL = ITEMP
END IF
*
IF( CRANGE ) THEN
NTEST = 28
ABSTOL = UNFL + UNFL
CALL ZSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU,
$ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
$ RWORK, LRWORK, IWORK( 2*N+1 ),
$ LWORK-2*N, IINFO )
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'ZSTEMR(V,I,rel)',
$ IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -