133 SUBROUTINE slattr( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B,
142 CHARACTER DIAG, TRANS, UPLO
143 INTEGER IMAT, INFO, LDA, N
147 REAL A( lda, * ), B( * ), WORK( * )
154 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
160 INTEGER I, IY, J, JCOUNT, KL, KU, MODE
161 REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
162 $ plus2, ra, rb, rexp, s, sfac, smlnum, star1,
163 $ texp, tleft, tscal, ulp, unfl, x, y, z
169 EXTERNAL lsame, isamax, slamch, slarnd
176 INTRINSIC abs, max,
REAL, SIGN, SQRT
180 path( 1: 1 ) =
'Single precision'
182 unfl = slamch(
'Safe minimum' )
183 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
185 bignum = ( one-ulp ) / smlnum
186 CALL
slabad( smlnum, bignum )
187 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 )
THEN
201 upper = lsame( uplo,
'U' )
203 CALL
slatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
206 CALL
slatb4( path, -imat, n, n,
TYPE, KL, KU, ANORM, MODE,
213 CALL
slatms( n, n, dist, iseed,
TYPE, B, MODE, CNDNUM, ANORM,
214 $ kl, ku,
'No packing', a, lda, work, info )
221 ELSE IF( imat.EQ.7 )
THEN
244 ELSE IF( imat.LE.10 )
THEN
323 plus2 = star1 / plus1
329 plus1 = star1 / plus2
330 rexp = slarnd( 2, iseed )
331 star1 = star1*( sfac**rexp )
332 IF( rexp.LT.zero )
THEN
333 star1 = -sfac**( one-rexp )
335 star1 = sfac**( one+rexp )
340 x = sqrt( cndnum ) - 1 / sqrt( cndnum )
342 y = sqrt( 2. / ( n-2 ) )*x
350 CALL
scopy( n-3, work, 1, a( 2, 3 ), lda+1 )
352 $ CALL
scopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
361 CALL
scopy( n-3, work, 1, a( 3, 2 ), lda+1 )
363 $ CALL
scopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
378 CALL
srotg( ra, rb, c, s )
383 $ CALL
srot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
389 $ CALL
srot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
393 a( j, j+1 ) = -a( j, j+1 )
399 CALL
srotg( ra, rb, c, s )
404 $ CALL
srot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
410 $ CALL
srot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
415 a( j+1, j ) = -a( j+1, j )
423 ELSE IF( imat.EQ.11 )
THEN
431 CALL
slarnv( 2, iseed, j, a( 1, j ) )
432 a( j, j ) = sign( two, a( j, j ) )
436 CALL
slarnv( 2, iseed, n-j+1, a( j, j ) )
437 a( j, j ) = sign( two, a( j, j ) )
443 CALL
slarnv( 2, iseed, n, b )
444 iy = isamax( n, b, 1 )
445 bnorm = abs( b( iy ) )
446 bscal = bignum / max( one, bnorm )
447 CALL
sscal( n, bscal, b, 1 )
449 ELSE IF( imat.EQ.12 )
THEN
455 CALL
slarnv( 2, iseed, n, b )
456 tscal = one / max( one,
REAL( N-1 ) )
459 CALL
slarnv( 2, iseed, j, a( 1, j ) )
460 CALL
sscal( j-1, tscal, a( 1, j ), 1 )
461 a( j, j ) = sign( one, a( j, j ) )
463 a( n, n ) = smlnum*a( n, n )
466 CALL
slarnv( 2, iseed, n-j+1, a( j, j ) )
468 $ CALL
sscal( n-j, tscal, a( j+1, j ), 1 )
469 a( j, j ) = sign( one, a( j, j ) )
471 a( 1, 1 ) = smlnum*a( 1, 1 )
474 ELSE IF( imat.EQ.13 )
THEN
480 CALL
slarnv( 2, iseed, n, b )
483 CALL
slarnv( 2, iseed, j, a( 1, j ) )
484 a( j, j ) = sign( one, a( j, j ) )
486 a( n, n ) = smlnum*a( n, n )
489 CALL
slarnv( 2, iseed, n-j+1, a( j, j ) )
490 a( j, j ) = sign( one, a( j, j ) )
492 a( 1, 1 ) = smlnum*a( 1, 1 )
495 ELSE IF( imat.EQ.14 )
THEN
507 IF( jcount.LE.2 )
THEN
522 IF( jcount.LE.2 )
THEN
543 DO 250 i = 1, n - 1, 2
549 ELSE IF( imat.EQ.15 )
THEN
555 texp = one / max( one,
REAL( N-1 ) )
557 CALL
slarnv( 2, iseed, n, b )
580 ELSE IF( imat.EQ.16 )
THEN
587 CALL
slarnv( 2, iseed, j, a( 1, j ) )
589 a( j, j ) = sign( two, a( j, j ) )
596 CALL
slarnv( 2, iseed, n-j+1, a( j, j ) )
598 a( j, j ) = sign( two, a( j, j ) )
604 CALL
slarnv( 2, iseed, n, b )
605 CALL
sscal( n, two, b, 1 )
607 ELSE IF( imat.EQ.17 )
THEN
615 tscal = ( one-ulp ) / tscal
624 a( 1, j ) = -tscal /
REAL( n+1 )
626 b( j ) = texp*( one-ulp )
627 a( 1, j-1 ) = -( tscal /
REAL( N+1 ) ) /
REAL( N+2 )
629 b( j-1 ) = texp*
REAL( n*n+n-1 )
632 b( 1 ) = (
REAL( N+1 ) /
REAL( N+2 ) )*tscal
634 DO 350 j = 1, n - 1, 2
635 a( n, j ) = -tscal /
REAL( n+1 )
637 b( j ) = texp*( one-ulp )
638 a( n, j+1 ) = -( tscal /
REAL( N+1 ) ) /
REAL( N+2 )
640 b( j+1 ) = texp*
REAL( n*n+n-1 )
643 b( n ) = (
REAL( N+1 ) /
REAL( N+2 ) )*tscal
646 ELSE IF( imat.EQ.18 )
THEN
654 CALL
slarnv( 2, iseed, j-1, a( 1, j ) )
660 $ CALL
slarnv( 2, iseed, n-j, a( j+1, j ) )
667 CALL
slarnv( 2, iseed, n, b )
668 iy = isamax( n, b, 1 )
669 bnorm = abs( b( iy ) )
670 bscal = bignum / max( one, bnorm )
671 CALL
sscal( n, bscal, b, 1 )
673 ELSE IF( imat.EQ.19 )
THEN
680 tleft = bignum / max( one,
REAL( N-1 ) )
681 tscal = bignum*(
REAL( N-1 ) / MAX( one,
REAL( N ) ) )
684 CALL
slarnv( 2, iseed, j, a( 1, j ) )
686 a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
691 CALL
slarnv( 2, iseed, n-j+1, a( j, j ) )
693 a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
697 CALL
slarnv( 2, iseed, n, b )
698 CALL
sscal( n, two, b, 1 )
703 IF( .NOT.lsame( trans,
'N' ) )
THEN
706 CALL
sswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
711 CALL
sswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine slattr(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, LDA, B, WORK, INFO)
SLATTR
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine srotg(SA, SB, C, S)
SROTG
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT