139 CHARACTER DIAG, TRANS, UPLO
140 INTEGER IMAT, INFO, LDA, N
144 REAL A( LDA, * ), B( * ), WORK( * )
151 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
157 INTEGER I, IY, J, JCOUNT, KL, KU, MODE
158 REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
159 $ PLUS2, RA, RB, REXP, S, SFAC, SMLNUM, STAR1,
160 $ TEXP, TLEFT, TSCAL, ULP, UNFL, X, Y, Z
173 INTRINSIC abs, max, real, sign, sqrt
177 path( 1: 1 ) =
'Single precision'
179 unfl =
slamch(
'Safe minimum' )
182 bignum = ( one-ulp ) / smlnum
183 CALL slabad( smlnum, bignum )
184 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 )
THEN
198 upper =
lsame( uplo,
'U' )
200 CALL slatb4( path, imat, n, n,
TYPE, KL, KU, ANORM, MODE,
203 CALL slatb4( path, -imat, n, n,
TYPE, KL, KU, ANORM, MODE,
210 CALL slatms( n, n, dist, iseed,
TYPE, B, MODE, CNDNUM, ANORM,
211 $ KL, KU,
'No packing', A, LDA, WORK, INFO )
218 ELSE IF( imat.EQ.7 )
THEN
241 ELSE IF( imat.LE.10 )
THEN
320 plus2 = star1 / plus1
326 plus1 = star1 / plus2
328 star1 = star1*( sfac**rexp )
329 IF( rexp.LT.zero )
THEN
330 star1 = -sfac**( one-rexp )
332 star1 = sfac**( one+rexp )
337 x = sqrt( cndnum ) - 1 / sqrt( cndnum )
339 y = sqrt( 2. / ( n-2 ) )*x
347 CALL scopy( n-3, work, 1, a( 2, 3 ), lda+1 )
349 $
CALL scopy( n-4, work( n+1 ), 1, a( 2, 4 ), lda+1 )
358 CALL scopy( n-3, work, 1, a( 3, 2 ), lda+1 )
360 $
CALL scopy( n-4, work( n+1 ), 1, a( 4, 2 ), lda+1 )
375 CALL srotg( ra, rb, c, s )
380 $
CALL srot( n-j-1, a( j, j+2 ), lda, a( j+1, j+2 ),
386 $
CALL srot( j-1, a( 1, j+1 ), 1, a( 1, j ), 1, -c, -s )
390 a( j, j+1 ) = -a( j, j+1 )
396 CALL srotg( ra, rb, c, s )
401 $
CALL srot( n-j-1, a( j+2, j+1 ), 1, a( j+2, j ), 1, c,
407 $
CALL srot( j-1, a( j, 1 ), lda, a( j+1, 1 ), lda, -c,
412 a( j+1, j ) = -a( j+1, j )
420 ELSE IF( imat.EQ.11 )
THEN
428 CALL slarnv( 2, iseed, j, a( 1, j ) )
429 a( j, j ) = sign( two, a( j, j ) )
433 CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
434 a( j, j ) = sign( two, a( j, j ) )
440 CALL slarnv( 2, iseed, n, b )
442 bnorm = abs( b( iy ) )
443 bscal = bignum / max( one, bnorm )
444 CALL sscal( n, bscal, b, 1 )
446 ELSE IF( imat.EQ.12 )
THEN
452 CALL slarnv( 2, iseed, n, b )
453 tscal = one / max( one, real( n-1 ) )
456 CALL slarnv( 2, iseed, j, a( 1, j ) )
457 CALL sscal( j-1, tscal, a( 1, j ), 1 )
458 a( j, j ) = sign( one, a( j, j ) )
460 a( n, n ) = smlnum*a( n, n )
463 CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
465 $
CALL sscal( n-j, tscal, a( j+1, j ), 1 )
466 a( j, j ) = sign( one, a( j, j ) )
468 a( 1, 1 ) = smlnum*a( 1, 1 )
471 ELSE IF( imat.EQ.13 )
THEN
477 CALL slarnv( 2, iseed, n, b )
480 CALL slarnv( 2, iseed, j, a( 1, j ) )
481 a( j, j ) = sign( one, a( j, j ) )
483 a( n, n ) = smlnum*a( n, n )
486 CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
487 a( j, j ) = sign( one, a( j, j ) )
489 a( 1, 1 ) = smlnum*a( 1, 1 )
492 ELSE IF( imat.EQ.14 )
THEN
504 IF( jcount.LE.2 )
THEN
519 IF( jcount.LE.2 )
THEN
540 DO 250 i = 1, n - 1, 2
546 ELSE IF( imat.EQ.15 )
THEN
552 texp = one / max( one, real( n-1 ) )
554 CALL slarnv( 2, iseed, n, b )
577 ELSE IF( imat.EQ.16 )
THEN
584 CALL slarnv( 2, iseed, j, a( 1, j ) )
586 a( j, j ) = sign( two, a( j, j ) )
593 CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
595 a( j, j ) = sign( two, a( j, j ) )
601 CALL slarnv( 2, iseed, n, b )
602 CALL sscal( n, two, b, 1 )
604 ELSE IF( imat.EQ.17 )
THEN
612 tscal = ( one-ulp ) / tscal
621 a( 1, j ) = -tscal / real( n+1 )
623 b( j ) = texp*( one-ulp )
624 a( 1, j-1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
626 b( j-1 ) = texp*real( n*n+n-1 )
629 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
631 DO 350 j = 1, n - 1, 2
632 a( n, j ) = -tscal / real( n+1 )
634 b( j ) = texp*( one-ulp )
635 a( n, j+1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
637 b( j+1 ) = texp*real( n*n+n-1 )
640 b( n ) = ( real( n+1 ) / real( n+2 ) )*tscal
643 ELSE IF( imat.EQ.18 )
THEN
651 CALL slarnv( 2, iseed, j-1, a( 1, j ) )
657 $
CALL slarnv( 2, iseed, n-j, a( j+1, j ) )
664 CALL slarnv( 2, iseed, n, b )
666 bnorm = abs( b( iy ) )
667 bscal = bignum / max( one, bnorm )
668 CALL sscal( n, bscal, b, 1 )
670 ELSE IF( imat.EQ.19 )
THEN
677 tleft = bignum / max( one, real( n-1 ) )
678 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
681 CALL slarnv( 2, iseed, j, a( 1, j ) )
683 a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
688 CALL slarnv( 2, iseed, n-j+1, a( j, j ) )
690 a( i, j ) = sign( tleft, a( i, j ) ) + tscal*a( i, j )
694 CALL slarnv( 2, iseed, n, b )
695 CALL sscal( n, two, b, 1 )
700 IF( .NOT.
lsame( trans,
'N' ) )
THEN
703 CALL sswap( n-2*j+1, a( j, j ), lda, a( j+1, n-j+1 ),
708 CALL sswap( n-2*j+1, a( j, j ), 1, a( n-j+1, j+1 ),
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
integer function isamax(N, SX, INCX)
ISAMAX
logical function lsame(CA, CB)
LSAME
real function slarnd(IDIST, ISEED)
SLARND
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine srotg(a, b, c, s)
SROTG
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
real function slamch(CMACH)
SLAMCH