cchkgg.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 1,086 行 · 第 1/3 页
F
1,086 行
*
* 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.0E+0, ONE = 1.0E+0 )
COMPLEX CZERO, CONE
PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ),
$ CONE = ( 1.0E+0, 0.0E+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
COMPLEX CTEMP
* ..
* .. Local Arrays ..
LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP )
INTEGER 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 )
COMPLEX CDUMMA( 4 )
* ..
* .. External Functions ..
REAL CLANGE, SLAMCH
COMPLEX CLARND
EXTERNAL CLANGE, SLAMCH, CLARND
* ..
* .. External Subroutines ..
EXTERNAL CGEQR2, CGET51, CGET52, CGGHRD, CHGEQZ, CLACPY,
$ CLARFG, CLASET, CLATM4, CTGEVC, CUNM2R, SLABAD,
$ SLASUM, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, CONJG, 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 LASIGN / 6*.FALSE., .TRUE., .FALSE., 2*.TRUE.,
$ 2*.FALSE., 3*.TRUE., .FALSE., .TRUE.,
$ 3*.FALSE., 5*.TRUE., .FALSE. /
DATA LBSIGN / 7*.FALSE., .TRUE., 2*.FALSE.,
$ 2*.TRUE., 2*.FALSE., .TRUE., .FALSE., .TRUE.,
$ 9*.FALSE. /
* ..
* .. 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
*
LWKOPT = MAX( 2*NMAX*NMAX, 4*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( 'CCHKGG', -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 CLATM4 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.
* LASIGN: .TRUE. if the diagonal elements of A are to be
* multiplied by a random magnitude 1 number.
* KBTYPE, KBZERO, KBMAGN, LBSIGN: 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 CLASET( 'Full', N, N, CZERO, CZERO, A, LDA )
ELSE
IN = N
END IF
CALL CLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
$ KZ2( KAZERO( JTYPE ) ), LASIGN( JTYPE ),
$ RMAGN( KAMAGN( JTYPE ) ), ULP,
$ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 4,
$ 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 CLASET( 'Full', N, N, CZERO, CZERO, B, LDA )
ELSE
IN = N
END IF
CALL CLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
$ KZ2( KBZERO( JTYPE ) ), LBSIGN( JTYPE ),
$ RMAGN( KBMAGN( JTYPE ) ), ONE,
$ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 4,
$ ISEED, B, LDA )
IADD = KADD( KBZERO( JTYPE ) )
IF( IADD.NE.0 )
$ 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. (Note that CLARFG makes U(j,j) and
* V(j,j) real.)
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
U( JR, JC ) = CLARND( 3, ISEED )
V( JR, JC ) = CLARND( 3, ISEED )
40 CONTINUE
CALL CLARFG( N+1-JC, U( JC, JC ), U( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, REAL( U( JC, JC ) ) )
U( JC, JC ) = CONE
CALL CLARFG( N+1-JC, V( JC, JC ), V( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, REAL( V( JC, JC ) ) )
V( JC, JC ) = CONE
50 CONTINUE
CTEMP = CLARND( 3, ISEED )
U( N, N ) = CONE
WORK( N ) = CZERO
WORK( 3*N ) = CTEMP / ABS( CTEMP )
CTEMP = CLARND( 3, ISEED )
V( N, N ) = CONE
WORK( 2*N ) = CZERO
WORK( 4*N ) = CTEMP / ABS( CTEMP )
*
* Apply the diagonal matrices
*
DO 70 JC = 1, N
DO 60 JR = 1, N
A( JR, JC ) = WORK( 2*N+JR )*
$ CONJG( WORK( 3*N+JC ) )*
$ A( JR, JC )
B( JR, JC ) = WORK( 2*N+JR )*
$ CONJG( WORK( 3*N+JC ) )*
$ B( JR, JC )
60 CONTINUE
70 CONTINUE
CALL CUNM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL CUNM2R( 'R', 'C', N, N, N-1, V, LDU, WORK( N+1 ),
$ A, LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL CUNM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL CUNM2R( 'R', 'C', 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 ) )*
$ CLARND( 4, ISEED )
B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
$ CLARND( 4, ISEED )
80 CONTINUE
90 CONTINUE
END IF
*
ANORM = CLANGE( '1', N, N, A, LDA, RWORK )
BNORM = CLANGE( '1', N, N, B, LDA, RWORK )
*
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 CGEQR2, CUNM2R, and CGGHRD to compute H, T, U, and V
*
CALL CLACPY( ' ', N, N, A, LDA, H, LDA )
CALL CLACPY( ' ', N, N, B, LDA, T, LDA )
NTEST = 1
RESULT( 1 ) = ULPINV
*
CALL CGEQR2( N, N, T, LDA, WORK, WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'CGEQR2', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL CUNM2R( 'L', 'C', N, N, N, T, LDA, WORK, H, LDA,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'CUNM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL CLASET( 'Full', N, N, CZERO, CONE, U, LDU )
CALL CUNM2R( 'R', 'N', N, N, N, T, LDA, WORK, U, LDU,
$ WORK( N+1 ), IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'CUNM2R', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
*
CALL CGGHRD( 'V', 'I', N, 1, N, H, LDA, T, LDA, U, LDU, V,
$ LDU, IINFO )
IF( IINFO.NE.0 ) THEN
WRITE( NOUNIT, FMT = 9999 )'CGGHRD', IINFO, N, JTYPE,
$ IOLDSD
INFO = ABS( IINFO )
GO TO 210
END IF
NTEST = 4
*
* Do tests 1--4
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?