sdrges.f
来自「famous linear algebra library (LAPACK) p」· F 代码 · 共 880 行 · 第 1/3 页
F
880 行
* The values computed by the tests described above.
* The values are currently limited to 1/ulp, to avoid overflow.
*
* BWORK (workspace) LOGICAL array, dimension (N)
*
* 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 )
INTEGER MAXTYP
PARAMETER ( MAXTYP = 26 )
* ..
* .. Local Scalars ..
LOGICAL BADNN, ILABAD
CHARACTER SORT
INTEGER I, I1, IADD, IERR, IINFO, IN, ISORT, J, JC, JR,
$ JSIZE, JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES,
$ N, N1, NB, NERRS, NMATS, NMAX, NTEST, NTESTT,
$ RSUB, SDIM
REAL 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 RMAGN( 0: 3 )
* ..
* .. External Functions ..
LOGICAL SLCTES
INTEGER ILAENV
REAL SLAMCH, SLARND
EXTERNAL SLCTES, ILAENV, SLAMCH, SLARND
* ..
* .. External Subroutines ..
EXTERNAL ALASVM, SGET51, SGET53, SGET54, SGGES, SLABAD,
$ SLACPY, SLARFG, SLASET, SLATM4, SORM2R, 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
*
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 = -9
ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
INFO = -14
END IF
*
* Compute workspace
* (Note: Comments in the code beginning "Workspace:" describe the
* minimal amount of workspace needed at that point in the code,
* as well as the preferred amount for good performance.
* NB refers to the optimal block size for the immediately
* following subroutine, as returned by ILAENV.
*
MINWRK = 1
IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
MINWRK = MAX( 10*( NMAX+1 ), 3*NMAX*NMAX )
NB = MAX( 1, ILAENV( 1, 'SGEQRF', ' ', NMAX, NMAX, -1, -1 ),
$ ILAENV( 1, 'SORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
$ ILAENV( 1, 'SORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
MAXWRK = MAX( 10*( NMAX+1 ), 2*NMAX+NMAX*NB, 3*NMAX*NMAX )
WORK( 1 ) = MAXWRK
END IF
*
IF( LWORK.LT.MINWRK )
$ INFO = -20
*
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SDRGES', -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 matrix sizes
*
NTESTT = 0
NERRS = 0
NMATS = 0
*
DO 190 JSIZE = 1, NSIZES
N = NN( JSIZE )
N1 = MAX( 1, N )
RMAGN( 2 ) = SAFMAX*ULP / REAL( N1 )
RMAGN( 3 ) = SAFMIN*ULPINV*REAL( N1 )
*
IF( NSIZES.NE.1 ) THEN
MTYPES = MIN( MAXTYP, NTYPES )
ELSE
MTYPES = MIN( MAXTYP+1, NTYPES )
END IF
*
* Loop over matrix types
*
DO 180 JTYPE = 1, MTYPES
IF( .NOT.DOTYPE( JTYPE ) )
$ GO TO 180
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, 13
RESULT( J ) = ZERO
30 CONTINUE
*
* Generate test matrices 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 ) = ONE
*
* 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 ) = ONE
*
IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
*
* Include rotations
*
* Generate Q, Z as Householder transformations times
* a diagonal matrix.
*
DO 50 JC = 1, N - 1
DO 40 JR = JC, N
Q( JR, JC ) = SLARND( 3, ISEED )
Z( JR, JC ) = SLARND( 3, ISEED )
40 CONTINUE
CALL SLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
$ WORK( JC ) )
WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
Q( JC, JC ) = ONE
CALL SLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
$ WORK( N+JC ) )
WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
Z( JC, JC ) = ONE
50 CONTINUE
Q( N, N ) = ONE
WORK( N ) = ZERO
WORK( 3*N ) = SIGN( ONE, SLARND( 2, ISEED ) )
Z( 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, Q, LDQ, WORK, A,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
CALL SORM2R( 'R', 'T', N, N, N-1, Z, LDQ, 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, Q, LDQ, WORK, B,
$ LDA, WORK( 2*N+1 ), IINFO )
IF( IINFO.NE.0 )
$ GO TO 100
⌨️ 快捷键说明
复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?