serrgg.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 954 行 · 第 1/3 页
F
954 行
SUBROUTINE SERRGG( 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
* =======
*
* SERRGG tests the error exits for SGGES, SGGESX, SGGEV, SGGEVX,
* SGGGLM, SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP, SHGEQZ,
* STGEVC, STGEXC, STGSEN, STGSJA, STGSNA, and STGSYL.
*
* 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 )
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* ..
* .. Local Scalars ..
CHARACTER*2 C2
INTEGER DUMMYK, DUMMYL, I, IFST, ILST, INFO, J, M,
$ NCYCLE, NT, SDIM
REAL ANRM, BNRM, DIF, SCALE, TOLA, TOLB
* ..
* .. Local Arrays ..
LOGICAL BW( NMAX ), SEL( NMAX )
INTEGER IW( NMAX )
REAL 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 LSAMEN, SLCTES, SLCTSX
EXTERNAL LSAMEN, SLCTES, SLCTSX
* ..
* .. External Subroutines ..
EXTERNAL CHKXER, SGGES, SGGESX, SGGEV, SGGEVX, SGGGLM,
$ SGGHRD, SGGLSE, SGGQRF, SGGRQF, SGGSVD, SGGSVP,
$ SHGEQZ, STGEVC, STGEXC, STGSEN, STGSJA, STGSNA,
$ STGSYL
* ..
* .. 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.0E0
TOLB = 1.0E0
IFST = 1
ILST = 1
NT = 0
*
* Test error exits for the GG path.
*
IF( LSAMEN( 2, C2, 'GG' ) ) THEN
*
* SGGHRD
*
SRNAMT = 'SGGHRD'
INFOT = 1
CALL SGGHRD( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGHRD( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGHRD( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGHRD( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGHRD( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 7
CALL SGGHRD( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 9
CALL SGGHRD( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 11
CALL SGGHRD( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL SGGHRD( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
CALL CHKXER( 'SGGHRD', INFOT, NOUT, LERR, OK )
NT = NT + 9
*
* SHGEQZ
*
SRNAMT = 'SHGEQZ'
INFOT = 1
CALL SHGEQZ( '/', 'N', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SHGEQZ( 'E', '/', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SHGEQZ( 'E', 'N', '/', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SHGEQZ( 'E', 'N', 'N', -1, 0, 0, A, 1, B, 1, R1, R2, R3,
$ Q, 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SHGEQZ( 'E', 'N', 'N', 0, 0, 0, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SHGEQZ( 'E', 'N', 'N', 0, 1, 1, A, 1, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 1, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 2, B, 1, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 15
CALL SHGEQZ( 'E', 'V', 'N', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
INFOT = 17
CALL SHGEQZ( 'E', 'N', 'V', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
$ 1, Z, 1, W, LW, INFO )
CALL CHKXER( 'SHGEQZ', INFOT, NOUT, LERR, OK )
NT = NT + 10
*
* STGEVC
*
SRNAMT = 'STGEVC'
INFOT = 1
CALL STGEVC( '/', 'A', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL STGEVC( 'R', '/', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL STGEVC( 'R', 'A', SEL, -1, A, 1, B, 1, Q, 1, Z, 1, 0, M,
$ W, INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL STGEVC( 'R', 'A', SEL, 2, A, 1, B, 2, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL STGEVC( 'R', 'A', SEL, 2, A, 2, B, 1, Q, 1, Z, 2, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL STGEVC( 'L', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL STGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
INFOT = 13
CALL STGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 2, 1, M, W,
$ INFO )
CALL CHKXER( 'STGEVC', INFOT, NOUT, LERR, OK )
NT = NT + 8
*
* Test error exits for the GSV path.
*
ELSE IF( LSAMEN( 3, PATH, 'GSV' ) ) THEN
*
* SGGSVD
*
SRNAMT = 'SGGSVD'
INFOT = 1
CALL SGGSVD( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGSVD( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGSVD( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
$ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
CALL CHKXER( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 12
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
INFOT = 20
CALL SGGSVD( '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( 'SGGSVD', INFOT, NOUT, LERR, OK )
NT = NT + 11
*
* SGGSVP
*
SRNAMT = 'SGGSVP'
INFOT = 1
CALL SGGSVP( '/', '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 2
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 3
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 4
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 5
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 6
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 8
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 10
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 16
CALL SGGSVP( '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( 'SGGSVP', INFOT, NOUT, LERR, OK )
INFOT = 18
CALL SGGSVP( '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 + -
显示快捷键?