ddrvst.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,693 行 · 第 1/5 页
F
1,693 行
*
* Symmetric banded, eigenvalues specified
*
IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) )
CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
$ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ),
$ IINFO )
*
* Store as dense matrix for most routines.
*
CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
DO 100 IDIAG = -IHBW, IHBW
IROW = IHBW - IDIAG + 1
J1 = MAX( 1, IDIAG+1 )
J2 = MIN( N, N+IDIAG )
DO 90 J = J1, J2
I = J - IDIAG
A( I, J ) = U( IROW, J )
90 CONTINUE
100 CONTINUE
ELSE
IINFO = 1
END IF
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
ABSTOL = UNFL + UNFL
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( IL.GT.IU ) THEN
ITEMP = IL
IL = IU
IU = ITEMP
END IF
END IF
*
* 3) If matrix is tridiagonal, call DSTEV and DSTEVX.
*
IF( JTYPE.LE.7 ) THEN
NTEST = 1
DO 120 I = 1, N
D1( I ) = DBLE( A( I, I ) )
120 CONTINUE
DO 130 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
130 CONTINUE
SRNAMT = 'DSTEV'
CALL DSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEV(V)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 1 ) = ULPINV
RESULT( 2 ) = ULPINV
RESULT( 3 ) = ULPINV
GO TO 180
END IF
END IF
*
* Do tests 1 and 2.
*
DO 140 I = 1, N
D3( I ) = DBLE( A( I, I ) )
140 CONTINUE
DO 150 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
150 CONTINUE
CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
$ RESULT( 1 ) )
*
NTEST = 3
DO 160 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
160 CONTINUE
SRNAMT = 'DSTEV'
CALL DSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEV(N)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 3 ) = ULPINV
GO TO 180
END IF
END IF
*
* Do test 3.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 170 J = 1, N
TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
170 CONTINUE
RESULT( 3 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
180 CONTINUE
*
NTEST = 4
DO 190 I = 1, N
EVEIGS( I ) = D3( I )
D1( I ) = DBLE( A( I, I ) )
190 CONTINUE
DO 200 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
200 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ),
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 4 ) = ULPINV
RESULT( 5 ) = ULPINV
RESULT( 6 ) = ULPINV
GO TO 250
END IF
END IF
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
*
* Do tests 4 and 5.
*
DO 210 I = 1, N
D3( I ) = DBLE( A( I, I ) )
210 CONTINUE
DO 220 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
220 CONTINUE
CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
$ RESULT( 4 ) )
*
NTEST = 6
DO 230 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
230 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'N', 'A', N, D3, D4, 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(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 6 ) = ULPINV
GO TO 250
END IF
END IF
*
* Do test 6.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 240 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
$ ABS( EVEIGS( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
240 CONTINUE
RESULT( 6 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
250 CONTINUE
*
NTEST = 7
DO 260 I = 1, N
D1( I ) = DBLE( A( I, I ) )
260 CONTINUE
DO 270 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
270 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
$ M, WA1, Z, LDU, IWORK, WORK, LWORK,
$ IWORK(2*N+1), LIWORK-2*N, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 7 ) = ULPINV
RESULT( 8 ) = ULPINV
GO TO 320
END IF
END IF
IF( N.GT.0 ) THEN
TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
ELSE
TEMP3 = ZERO
END IF
*
* Do tests 7 and 8.
*
DO 280 I = 1, N
D3( I ) = DBLE( A( I, I ) )
280 CONTINUE
DO 290 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
290 CONTINUE
CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
$ RESULT( 7 ) )
*
NTEST = 9
DO 300 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
300 CONTINUE
SRNAMT = 'DSTEVR'
CALL DSTEVR( 'N', 'A', N, D3, D4, 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(N,A)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 9 ) = ULPINV
GO TO 320
END IF
END IF
*
* Do test 9.
*
TEMP1 = ZERO
TEMP2 = ZERO
DO 310 J = 1, N
TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
$ ABS( EVEIGS( J ) ) )
TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
310 CONTINUE
RESULT( 9 ) = TEMP2 / MAX( UNFL,
$ ULP*MAX( TEMP1, TEMP2 ) )
*
320 CONTINUE
*
*
NTEST = 10
DO 330 I = 1, N
D1( I ) = DBLE( A( I, I ) )
330 CONTINUE
DO 340 I = 1, N - 1
D2( I ) = DBLE( A( I+1, I ) )
340 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'V', 'I', 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,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 10 ) = ULPINV
RESULT( 11 ) = ULPINV
RESULT( 12 ) = ULPINV
GO TO 380
END IF
END IF
*
* Do tests 10 and 11.
*
DO 350 I = 1, N
D3( I ) = DBLE( A( I, I ) )
350 CONTINUE
DO 360 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
360 CONTINUE
CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
$ MAX( 1, M2 ), RESULT( 10 ) )
*
*
NTEST = 12
DO 370 I = 1, N - 1
D4( I ) = DBLE( A( I+1, I ) )
370 CONTINUE
SRNAMT = 'DSTEVX'
CALL DSTEVX( 'N', 'I', 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,I)', IINFO, N,
$ JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( 12 ) = ULPINV
GO TO 380
END IF
END IF
*
* Do test 12.
*
TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
*
380 CONTINUE
*
NTEST = 12
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 ) ),
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?