ddrvsg.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,273 行 · 第 1/4 页
F
1,273 行
*
* Generate random well-conditioned positive definite
* matrix B, of bandwidth not greater than that of A.
*
CALL DLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE,
$ KB, KB, UPLO, B, LDB, WORK( N+1 ),
$ IINFO )
*
* Test DSYGV
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
$ WORK, NWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGV(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSYGVD
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
$ WORK, NWORK, IWORK, LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSYGVX
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,A' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
* since we do not know the exact eigenvalues of this
* eigenpair, we just set VL and VU as constants.
* It is quite possible that there are no eigenvalues
* in this interval.
*
VL = ZERO
VU = ANORM
CALL DSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
*
CALL DSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB,
$ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
$ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
$ IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,I,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 100
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
100 CONTINUE
*
* Test DSPGV
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 120 J = 1, N
DO 110 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
110 CONTINUE
120 CONTINUE
ELSE
IJ = 1
DO 140 J = 1, N
DO 130 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
130 CONTINUE
140 CONTINUE
END IF
*
CALL DSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
$ WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGV(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSPGVD
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 160 J = 1, N
DO 150 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
150 CONTINUE
160 CONTINUE
ELSE
IJ = 1
DO 180 J = 1, N
DO 170 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
170 CONTINUE
180 CONTINUE
END IF
*
CALL DSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
$ WORK, NWORK, IWORK, LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVD(V,' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSPGVX
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 200 J = 1, N
DO 190 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
190 CONTINUE
200 CONTINUE
ELSE
IJ = 1
DO 220 J = 1, N
DO 210 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
210 CONTINUE
220 CONTINUE
END IF
*
CALL DSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,A' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 310
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
NTEST = NTEST + 1
*
* Copy the matrices into packed storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
IJ = 1
DO 240 J = 1, N
DO 230 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
230 CONTINUE
240 CONTINUE
ELSE
IJ = 1
DO 260 J = 1, N
DO 250 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
250 CONTINUE
260 CONTINUE
END IF
*
VL = ZERO
VU = ANORM
CALL DSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL,
$ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, INFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,V' // UPLO //
$ ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?