derrgg.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 954 行 · 第 1/3 页
F
954 行
SUBROUTINE DERRGG( PATH, NUNIT )
*
* -- LAPACK test routine (version 3.1) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2006
*
* .. Scalar Arguments ..
CHARACTER*3 PATH
INTEGER NUNIT
* ..
*
* Purpose
* =======
*
* DERRGG tests the error exits for DGGES, DGGESX, DGGEV, DGGEVX,
* DGGGLM, DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP, DHGEQZ,
* DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA, and DTGSYL.
*
* Arguments
* =========
*
* PATH (input) CHARACTER*3
* The LAPACK path name for the routines to be tested.
*
* NUNIT (input) INTEGER
* The unit number for output.
*
* =====================================================================
*
* .. Parameters ..
INTEGER NMAX, LW
PARAMETER ( NMAX = 3, LW = 6*NMAX )
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER DUMMYK, DUMMYL, I, IFST, ILST, INFO, J, M,
$ NCYCLE, NT, SDIM
DOUBLE PRECISION ANRM, BNRM, DIF, SCALE, TOLA, TOLB
* ..
* .. Local Arrays ..
LOGICAL BW( NMAX ), SEL( NMAX )
INTEGER IW( NMAX )
DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ), LS( NMAX ),
$ Q( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
$ R3( NMAX ), RCE( 2 ), RCV( 2 ), RS( NMAX ),
$ TAU( NMAX ), U( NMAX, NMAX ), V( NMAX, NMAX ),
$ W( LW ), Z( NMAX, NMAX )
* ..
* .. External Functions ..
LOGICAL DLCTES, DLCTSX, LSAMEN
EXTERNAL DLCTES, DLCTSX, LSAMEN
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, DGGES, DGGESX, DGGEV, DGGEVX, DGGGLM,
$ DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP,
$ DHGEQZ, DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA,
$ DTGSYL
* ..
* .. Scalars in Common ..
LOGICAL LERR, OK
CHARACTER*6 SRNAMT
INTEGER INFOT, NOUT
* ..
* .. Common blocks ..
COMMON / INFOC / INFOT, NOUT, OK, LERR
COMMON / SRNAMC / SRNAMT
* ..
* .. Executable Statements ..
*
NOUT = NUNIT
WRITE( NOUT, FMT = * )
C2 = PATH( 2: 3 )
*
* Set the variables to innocuous values.
*
DO 20 J = 1, NMAX
SEL( J ) = .TRUE.
DO 10 I = 1, NMAX
A( I, J ) = ZERO
B( I, J ) = ZERO
10 CONTINUE
20 CONTINUE
DO 30 I = 1, NMAX
A( I, I ) = ONE
B( I, I ) = ONE
30 CONTINUE
OK = .TRUE.
TOLA = 1.0D0
TOLB = 1.0D0
IFST = 1
ILST = 1
NT = 0
*
* Test error exits for the GG path.
*
IF( LSAMEN( 2, C2, 'GG' ) ) THEN
*
* DGGHRD
*
SRNAMT = 'DGGHRD'
INFOT = 1
CALL DGGHRD( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGHRD( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGHRD( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGHRD( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGHRD( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL DGGHRD( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL DGGHRD( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL DGGHRD( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DGGHRD( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* DHGEQZ
*
SRNAMT = 'DHGEQZ'
INFOT = 1
CALL DHGEQZ( '/', 'N', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DHGEQZ( 'E', '/', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DHGEQZ( 'E', 'N', '/', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DHGEQZ( 'E', 'N', 'N', -1, 0, 0, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DHGEQZ( 'E', 'N', 'N', 0, 0, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DHGEQZ( 'E', 'N', 'N', 0, 1, 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 1, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 2, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL DHGEQZ( 'E', 'V', 'N', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL DHGEQZ( 'E', 'N', 'V', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* DTGEVC
*
SRNAMT = 'DTGEVC'
INFOT = 1
CALL DTGEVC( '/', 'A', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DTGEVC( 'R', '/', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DTGEVC( 'R', 'A', SEL, -1, A, 1, B, 1, Q, 1, Z, 1, 0, M,
$ W, INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DTGEVC( 'R', 'A', SEL, 2, A, 1, B, 2, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 1, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DTGEVC( 'L', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 2, 1, M, W,
$ INFO )
CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the GSV path.
*
ELSE IF( LSAMEN( 3, PATH, 'GSV' ) ) THEN
*
* DGGSVD
*
SRNAMT = 'DGGSVD'
INFOT = 1
CALL DGGSVD( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGSVD( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGSVD( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGSVD( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGSVD( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGGSVD( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL DGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B,
$ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGGSVD( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
$ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL DGGSVD( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* DGGSVP
*
SRNAMT = 'DGGSVP'
INFOT = 1
CALL DGGSVP( '/', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL DGGSVP( 'N', '/', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL DGGSVP( 'N', 'N', '/', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL DGGSVP( 'N', 'N', 'N', -1, 0, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL DGGSVP( 'N', 'N', 'N', 0, -1, 0, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL DGGSVP( 'N', 'N', 'N', 0, 0, -1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL DGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL DGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL DGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL DGGSVP( 'N', 'V', 'N', 1, 2, 1, A, 1, B, 2, TOLA, TOLB,
$ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
$ INFO )
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?