ddrvst.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,693 行 · 第 1/5 页
F
1,693 行
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*
$ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
DO 390 I = 1, N
D1( I ) = DBLE( A( I, I ) )
390 CONTINUE
DO 400 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
400 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 13 ) = ULPINV
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
GO TO 440
END IF
END IF
*
IF( M2.EQ.0 .AND. N.GT.0 ) THEN
RESULT( 13 ) = ULPINV
RESULT( 14 ) = ULPINV
RESULT( 15 ) = ULPINV
GO TO 440
END IF
*
* Do tests 13 and 14.
*
DO 410 I = 1, N
D3( I ) = DBLE( A( I, I ) )
410 CONTINUE
DO 420 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
420 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 13 ) )
*
NTEST = 15
DO 430 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
430 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, WORK, IWORK,
$ IWORK( 5*N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 15 ) = ULPINV
GO TO 440
END IF
END IF
*
* Do test 15.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
440 CONTINUE
*
NTEST = 16
DO 450 I = 1, N
D1( I ) = DBLE( A( I, I ) )
450 CONTINUE
DO 460 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
460 CONTINUE
SRNAMT = 'DSTEVD'
CALL DSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVD(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 16 ) = ULPINV
RESULT( 17 ) = ULPINV
RESULT( 18 ) = ULPINV
GO TO 510
END IF
END IF
*
* Do tests 16 and 17.
*
DO 470 I = 1, N
D3( I ) = DBLE( A( I, I ) )
470 CONTINUE
DO 480 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
480 CONTINUE
CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
$ RESULT( 16 ) )
*
NTEST = 18
DO 490 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
490 CONTINUE
SRNAMT = 'DSTEVD'
CALL DSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK,
$ LIWEDC, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVD(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 18 ) = ULPINV
GO TO 510
END IF
END IF
*
* Do test 18.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 500 J = 1, N
TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ),
$ ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) )
500 CONTINUE
RESULT( 18 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
510 CONTINUE
*
NTEST = 19
DO 520 I = 1, N
D1( I ) = DBLE( A( I, I ) )
520 CONTINUE
DO 530 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
530 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 19 ) = ULPINV
RESULT( 20 ) = ULPINV
RESULT( 21 ) = ULPINV
GO TO 570
END IF
END IF
*
* DO tests 19 and 20.
*
DO 540 I = 1, N
D3( I ) = DBLE( A( I, I ) )
540 CONTINUE
DO 550 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
550 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 19 ) )
*
*
NTEST = 21
DO 560 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
560 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 21 ) = ULPINV
GO TO 570
END IF
END IF
*
* Do test 21.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
*
570 CONTINUE
*
NTEST = 21
IF( N.GT.0 ) THEN
IF( IL.NE.1 ) THEN
VL = WA1( IL ) - MAX( HALF*
$ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
IF( IU.NE.N ) THEN
VU = WA1( IU ) + MAX( HALF*
$ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
$ TEN*RTUNFL )
ELSE
VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
$ TEN*ULP*TEMP3, TEN*RTUNFL )
END IF
ELSE
VL = ZERO
VU = ONE
END IF
*
DO 580 I = 1, N
D1( I ) = DBLE( A( I, I ) )
580 CONTINUE
DO 590 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
590 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 22 ) = ULPINV
RESULT( 23 ) = ULPINV
RESULT( 24 ) = ULPINV
GO TO 630
END IF
END IF
*
IF( M2.EQ.0 .AND. N.GT.0 ) THEN
RESULT( 22 ) = ULPINV
RESULT( 23 ) = ULPINV
RESULT( 24 ) = ULPINV
GO TO 630
END IF
*
* Do tests 22 and 23.
*
DO 600 I = 1, N
D3( I ) = DBLE( A( I, I ) )
600 CONTINUE
DO 610 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
610 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 22 ) )
*
NTEST = 24
DO 620 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
620 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
$ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 24 ) = ULPINV
GO TO 630
END IF
END IF
*
* Do test 24.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
*
630 CONTINUE
*
*
*
ELSE
*
DO 640 I = 1, 24
RESULT( I ) = ZERO
640 CONTINUE
NTEST = 24
END IF
*
* Perform remaining tests storing upper or lower triangular
* part of matrix.
*
DO 1720 IUPLO = 0, 1
IF( IUPLO.EQ.0 ) THEN
UPLO = 'L'
ELSE
UPLO = 'U'
END IF
*
* 4) Call DSYEV and DSYEVX.
*
CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
*
NTEST = NTEST + 1
SRNAMT = 'DSYEV'
CALL DSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK,
$ IINFO )
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?