ddrvsg.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,273 行 · 第 1/4 页
F
1,273 行
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 280 J = 1, N
DO 270 I = 1, J
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
270 CONTINUE
280 CONTINUE
ELSE
IJ = 1
DO 300 J = 1, N
DO 290 I = J, N
AP( IJ ) = A( I, J )
BP( IJ ) = B( I, J )
IJ = IJ + 1
290 CONTINUE
300 CONTINUE
END IF
*
CALL DSPGVX( IBTYPE, 'V', 'I', 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,I' // 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 ) )
*
310 CONTINUE
*
IF( IBTYPE.EQ.1 ) THEN
*
* TEST DSBGV
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 340 J = 1, N
DO 320 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
320 CONTINUE
DO 330 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
330 CONTINUE
340 CONTINUE
ELSE
DO 370 J = 1, N
DO 350 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
350 CONTINUE
DO 360 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
360 CONTINUE
370 CONTINUE
END IF
*
CALL DSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB,
$ D, Z, LDZ, WORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGV(V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* TEST DSBGVD
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 400 J = 1, N
DO 380 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
380 CONTINUE
DO 390 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
390 CONTINUE
400 CONTINUE
ELSE
DO 430 J = 1, N
DO 410 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
410 CONTINUE
DO 420 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
420 CONTINUE
430 CONTINUE
END IF
*
CALL DSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB,
$ LDB, D, Z, LDZ, WORK, NWORK, IWORK,
$ LIWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVD(V,' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
* Test DSBGVX
*
NTEST = NTEST + 1
*
* Copy the matrices into band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 460 J = 1, N
DO 440 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
440 CONTINUE
DO 450 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
450 CONTINUE
460 CONTINUE
ELSE
DO 490 J = 1, N
DO 470 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
470 CONTINUE
DO 480 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
480 CONTINUE
490 CONTINUE
END IF
*
CALL DSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,A' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
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 band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 520 J = 1, N
DO 500 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
500 CONTINUE
DO 510 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
510 CONTINUE
520 CONTINUE
ELSE
DO 550 J = 1, N
DO 530 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
530 CONTINUE
DO 540 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
540 CONTINUE
550 CONTINUE
END IF
*
VL = ZERO
VU = ANORM
CALL DSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,V' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
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 band storage.
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 580 J = 1, N
DO 560 I = MAX( 1, J-KA ), J
AB( KA+1+I-J, J ) = A( I, J )
560 CONTINUE
DO 570 I = MAX( 1, J-KB ), J
BB( KB+1+I-J, J ) = B( I, J )
570 CONTINUE
580 CONTINUE
ELSE
DO 610 J = 1, N
DO 590 I = J, MIN( N, J+KA )
AB( 1+I-J, J ) = A( I, J )
590 CONTINUE
DO 600 I = J, MIN( N, J+KB )
BB( 1+I-J, J ) = B( I, J )
600 CONTINUE
610 CONTINUE
END IF
*
CALL DSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA,
$ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
$ IU, ABSTOL, M, D, Z, LDZ, WORK,
$ IWORK( N+1 ), IWORK, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,I' //
$ UPLO // ')', IINFO, N, JTYPE, IOLDSD
INFO = ABS( IINFO )
IF( IINFO.LT.0 ) THEN
RETURN
ELSE
RESULT( NTEST ) = ULPINV
GO TO 620
END IF
END IF
*
* Do Test
*
CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
$ LDZ, D, WORK, RESULT( NTEST ) )
*
END IF
*
620 CONTINUE
630 CONTINUE
*
* End of Loop -- Check for RESULT(j) > THRESH
*
NTESTT = NTESTT + NTEST
CALL DLAFTS( 'DSG', N, N, JTYPE, NTEST, RESULT, IOLDSD,
$ THRESH, NOUNIT, NERRS )
640 CONTINUE
650 CONTINUE
*
* Summary
*
CALL DLASUM( 'DSG', NOUNIT, NERRS, NTESTT )
*
RETURN
*
* End of DDRVSG
*
9999 FORMAT( ' DDRVSG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
$ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
END
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?