schkgg.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,081 行 · 第 1/3 页
F
1,081 行
* RESULT (output) REAL array, dimension (15)
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid
* overflow.
*
* INFO (output) INTEGER
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
* > 0: A routine returned an error code. INFO is the
* absolute value of the INFO value returned.
*
* =====================================================================
*
* .. Parameters ..
REAL ZERO, ONE
PARAMETER ( ZERO = 0.0, ONE = 1.0 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN
INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
$ LWKOPT, MTYPES, N, N1, NERRS, NMATS, NMAX,
$ NTEST, NTESTT
REAL ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
$ ULP, ULPINV
* ..
* .. Local Arrays ..
INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
$ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
$ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
$ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
$ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
$ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
REAL DUMMA( 4 ), RMAGN( 0: 3 )
* ..
* .. External Functions ..
REAL SLAMCH, SLANGE, SLARND
EXTERNAL SLAMCH, SLANGE, SLARND
* ..
* .. External Subroutines ..
EXTERNAL SGEQR2, SGET51, SGET52, SGGHRD, SHGEQZ, SLABAD,
$ SLACPY, SLARFG, SLASET, SLASUM, SLATM4, SORM2R,
$ STGEVC, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SIGN
* ..
* .. Data statements ..
DATA KCLASS / 15*1, 10*2, 1*3 /
DATA KZ1 / 0, 1, 2, 1, 3, 3 /
DATA KZ2 / 0, 0, 1, 2, 1, 1 /
DATA KADD / 0, 0, 0, 0, 3, 2 /
DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
$ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
$ 1, 1, -4, 2, -4, 8*8, 0 /
DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
$ 4*5, 4*3, 1 /
DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
$ 4*6, 4*4, 1 /
DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
$ 2, 1 /
DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
$ 2, 1 /
DATA KTRIAN / 16*0, 10*1 /
DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
$ 5*2, 0 /
DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
* ..
* .. Executable Statements ..
*
* Check for errors
*
INFO = 0
*
BADNN = .FALSE.
NMAX = 1
DO 10 J = 1, NSIZES
NMAX = MAX( NMAX, NN( J ) )
IF( NN( J ).LT.0 )
$ BADNN = .TRUE.
10 CONTINUE
*
* Maximum blocksize and shift -- we assume that blocksize and number
* of shifts are monotone increasing functions of N.
*
LWKOPT = MAX( 6*NMAX, 2*NMAX*NMAX, 1 )
*
* Check for errors
*
IF( NSIZES.LT.0 ) THEN
INFO = -1
ELSE IF( BADNN ) THEN
INFO = -2
ELSE IF( NTYPES.LT.0 ) THEN
INFO = -3
ELSE IF( THRESH.LT.ZERO ) THEN
INFO = -6
ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
INFO = -10
ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
INFO = -19
ELSE IF( LWKOPT.GT.LWORK ) THEN
INFO = -30
END IF
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SCHKGG', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
$ RETURN
*
SAFMIN = SLAMCH( 'Safe minimum' )
ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
SAFMIN = SAFMIN / ULP
SAFMAX = ONE / SAFMIN
CALL SLABAD( SAFMIN, SAFMAX )
ULPINV = ONE / ULP
*
* The values RMAGN(2:3) depend on N, see below.
*
RMAGN( 0 ) = ZERO
RMAGN( 1 ) = ONE
*
* Loop over sizes, types
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 240 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*N1
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
DO 230 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 230
NMATS = NMATS + 1
NTEST = 0
*
* Save ISEED in case of an error.
*
DO 20 J = 1, 4
IOLDSD( J ) = ISEED( J )
20 CONTINUE
*
* Initialize RESULT
*
DO 30 J = 1, 15
RESULT( J ) = ZERO
30 CONTINUE
*
* Compute A and B
*
* Description of control parameters:
*
* KCLASS: =1 means w/o rotation, =2 means w/ rotation,
* =3 means random.
* KATYPE: the "type" to be passed to SLATM4 for computing A.
* KAZERO: the pattern of zeros on the diagonal for A:
* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
* non-zero entries.)
* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
* =2: large, =3: small.
* IASIGN: 1 if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number, =2 if
* randomly chosen diagonal blocks are to be rotated
* to form 2x2 blocks.
* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
* KTRIAN: =0: don't fill in the upper triangle, =1: do.
* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
* RMAGN: used to implement KAMAGN and KBMAGN.
*
IF( MTYPES.GT.MAXTYP )
$ GO TO 110
IINFO = 0
IF( KCLASS( JTYPE ).LT.3 ) THEN
*
* Generate A (w/o rotation)
*
IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
$ ISEED, A, LDA )
IADD = KADD( KAZERO( JTYPE ) )
IF( IADD.GT.0 .AND. IADD.LE.N )
$ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) )
*
* Generate B (w/o rotation)
*
IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
IN = 2*( ( N-1 ) / 2 ) + 1
IF( IN.NE.N )
$ CALL SLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
ELSE
IN = N
END IF
CALL SLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 .AND. IADD.LE.N )
$ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) )
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate U, V as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
U( JR, JC ) = SLARND( 3, ISEED )
V( JR, JC ) = SLARND( 3, ISEED )
40 CONTINUE
CALL SLARFG( N+1-JC, U( JC, JC ), U( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, U( JC, JC ) )
U( JC, JC ) = ONE
CALL SLARFG( N+1-JC, V( JC, JC ), V( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, V( JC, JC ) )
V( JC, JC ) = ONE
50 CONTINUE
U( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
V( N, N ) = ONE
WORK( 2*N ) = ZERO
WORK( 4*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL SORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
$ B, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
END IF
ELSE
*
* Random matrices
*
DO 90 JC = 1, N
DO 80 JR = 1, N
A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ SLARND( 2, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
ANORM = SLANGE( '1', N, N, A, LDA, WORK )
BNORM = SLANGE( '1', N, N, B, LDA, WORK )
*
100 CONTINUE
*
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
RETURN
END IF
*
110 CONTINUE
*
* Call SGEQR2, SORM2R, and SGGHRD to compute H, T, U, and V
*
CALL SLACPY( ' ', N, N, A, LDA, H, LDA )
CALL SLACPY( ' ', N, N, B, LDA, T, LDA )
NTEST = 1
RESULT( 1 ) = ULPINV
*
CALL SGEQR2( N, N, T, LDA, WORK, WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGEQR2', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SORM2R( 'L', 'T', N, N, N, T, LDA, WORK, H, LDA,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SLASET( 'Full', N, N, ZERO, ONE, U, LDU )
CALL SORM2R( 'R', 'N', N, N, N, T, LDA, WORK, U, LDU,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SORM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL SGGHRD( 'V', 'I', N, 1, N, H, LDA, T, LDA, U, LDU, V,
$ LDU, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'SGGHRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
NTEST = 4
*
* Do tests 1--4
*
CALL SGET51( 1, N, A, LDA, H, LDA, U, LDU, V, LDU, WORK,
$ RESULT( 1 ) )
CALL SGET51( 1, N, B, LDA, T, LDA, U, LDU, V, LDU, WORK,
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?