123 SUBROUTINE slattp( IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK,
131 CHARACTER DIAG, TRANS, UPLO
132 INTEGER IMAT, INFO, N
136 REAL A( * ), B( * ), WORK( * )
143 parameter( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
147 CHARACTER DIST, PACKIT, TYPE
149 INTEGER I, IY, J, JC, JCNEXT, JCOUNT, JJ, JL, JR, JX,
151 REAL ANORM, BIGNUM, BNORM, BSCAL, C, CNDNUM, PLUS1,
152 $ plus2, ra, rb, rexp, s, sfac, smlnum, star1,
153 $ stemp, t, texp, tleft, tscal, ulp, unfl, x, y,
160 EXTERNAL lsame, isamax, slamch, slarnd
167 INTRINSIC abs, max, real, sign, sqrt
171 path( 1: 1 ) =
'Single precision'
173 unfl = slamch(
'Safe minimum' )
174 ulp = slamch(
'Epsilon' )*slamch(
'Base' )
176 bignum = ( one-ulp ) / smlnum
177 CALL slabad( smlnum, bignum )
178 IF( ( imat.GE.7 .AND. imat.LE.10 ) .OR. imat.EQ.18 )
THEN
192 upper = lsame( uplo,
'U' )
194 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
198 CALL slatb4( path, -imat, n, n,
TYPE, kl, ku, anorm, mode,
206 CALL slatms( n, n, dist, iseed,
TYPE, b, mode, cndnum, anorm,
207 $ kl, ku, packit, a, n, work, info )
214 ELSE IF( imat.EQ.7 )
THEN
241 ELSE IF( imat.LE.10 )
THEN
324 plus2 = star1 / plus1
330 plus1 = star1 / plus2
331 rexp = slarnd( 2, iseed )
332 star1 = star1*( sfac**rexp )
333 IF( rexp.LT.zero )
THEN
334 star1 = -sfac**( one-rexp )
336 star1 = sfac**( one+rexp )
341 x = sqrt( cndnum ) - one / sqrt( cndnum )
343 y = sqrt( two / real( n-2 ) )*x
358 $ a( jc+j-1 ) = work( j-2 )
360 $ a( jc+j-2 ) = work( n+j-3 )
379 a( jc+1 ) = work( j-1 )
381 $ a( jc+2 ) = work( n+j-1 )
395 CALL srotg( ra, rb, c, s )
402 stemp = c*a( jx+j ) + s*a( jx+j+1 )
403 a( jx+j+1 ) = -s*a( jx+j ) + c*a( jx+j+1 )
412 $
CALL srot( j-1, a( jcnext ), 1, a( jc ), 1, -c, -s )
416 a( jcnext+j-1 ) = -a( jcnext+j-1 )
422 jcnext = jc + n - j + 1
425 CALL srotg( ra, rb, c, s )
430 $
CALL srot( n-j-1, a( jcnext+1 ), 1, a( jc+2 ), 1, c,
438 stemp = -c*a( jx+j-i ) + s*a( jx+j-i+1 )
439 a( jx+j-i+1 ) = -s*a( jx+j-i ) - c*a( jx+j-i+1 )
447 a( jc+1 ) = -a( jc+1 )
456 ELSE IF( imat.EQ.11 )
THEN
465 CALL slarnv( 2, iseed, j, a( jc ) )
466 a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
472 CALL slarnv( 2, iseed, n-j+1, a( jc ) )
473 a( jc ) = sign( two, a( jc ) )
480 CALL slarnv( 2, iseed, n, b )
481 iy = isamax( n, b, 1 )
482 bnorm = abs( b( iy ) )
483 bscal = bignum / max( one, bnorm )
484 CALL sscal( n, bscal, b, 1 )
486 ELSE IF( imat.EQ.12 )
THEN
492 CALL slarnv( 2, iseed, n, b )
493 tscal = one / max( one, real( n-1 ) )
497 CALL slarnv( 2, iseed, j-1, a( jc ) )
498 CALL sscal( j-1, tscal, a( jc ), 1 )
499 a( jc+j-1 ) = sign( one, slarnd( 2, iseed ) )
502 a( n*( n+1 ) / 2 ) = smlnum
506 CALL slarnv( 2, iseed, n-j, a( jc+1 ) )
507 CALL sscal( n-j, tscal, a( jc+1 ), 1 )
508 a( jc ) = sign( one, slarnd( 2, iseed ) )
514 ELSE IF( imat.EQ.13 )
THEN
520 CALL slarnv( 2, iseed, n, b )
524 CALL slarnv( 2, iseed, j-1, a( jc ) )
525 a( jc+j-1 ) = sign( one, slarnd( 2, iseed ) )
528 a( n*( n+1 ) / 2 ) = smlnum
532 CALL slarnv( 2, iseed, n-j, a( jc+1 ) )
533 a( jc ) = sign( one, slarnd( 2, iseed ) )
539 ELSE IF( imat.EQ.14 )
THEN
547 jc = ( n-1 )*n / 2 + 1
552 IF( jcount.LE.2 )
THEN
569 IF( jcount.LE.2 )
THEN
591 DO 290 i = 1, n - 1, 2
597 ELSE IF( imat.EQ.15 )
THEN
603 texp = one / max( one, real( n-1 ) )
605 CALL slarnv( 2, iseed, n, b )
632 ELSE IF( imat.EQ.16 )
THEN
640 CALL slarnv( 2, iseed, j, a( jc ) )
642 a( jc+j-1 ) = sign( two, a( jc+j-1 ) )
651 CALL slarnv( 2, iseed, n-j+1, a( jc ) )
653 a( jc ) = sign( two, a( jc ) )
660 CALL slarnv( 2, iseed, n, b )
661 CALL sscal( n, two, b, 1 )
663 ELSE IF( imat.EQ.17 )
THEN
671 tscal = ( one-ulp ) / tscal
672 DO 360 j = 1, n*( n+1 ) / 2
677 jc = ( n-1 )*n / 2 + 1
679 a( jc ) = -tscal / real( n+1 )
681 b( j ) = texp*( one-ulp )
683 a( jc ) = -( tscal / real( n+1 ) ) / real( n+2 )
685 b( j-1 ) = texp*real( n*n+n-1 )
689 b( 1 ) = ( real( n+1 ) / real( n+2 ) )*tscal
692 DO 380 j = 1, n - 1, 2
693 a( jc+n-j ) = -tscal / real( n+1 )
695 b( j ) = texp*( one-ulp )
697 a( jc+n-j-1 ) = -( tscal / real( n+1 ) ) / real( n+2 )
699 b( j+1 ) = texp*real( n*n+n-1 )
703 b( n ) = ( real( n+1 ) / real( n+2 ) )*tscal
706 ELSE IF( imat.EQ.18 )
THEN
715 CALL slarnv( 2, iseed, j-1, a( jc ) )
723 $
CALL slarnv( 2, iseed, n-j, a( jc+1 ) )
731 CALL slarnv( 2, iseed, n, b )
732 iy = isamax( n, b, 1 )
733 bnorm = abs( b( iy ) )
734 bscal = bignum / max( one, bnorm )
735 CALL sscal( n, bscal, b, 1 )
737 ELSE IF( imat.EQ.19 )
THEN
743 tleft = bignum / max( one, real( n-1 ) )
744 tscal = bignum*( real( n-1 ) / max( one, real( n ) ) )
748 CALL slarnv( 2, iseed, j, a( jc ) )
750 a( jc+i-1 ) = sign( tleft, a( jc+i-1 ) ) +
758 CALL slarnv( 2, iseed, n-j+1, a( jc ) )
760 a( jc+i-j ) = sign( tleft, a( jc+i-j ) ) +
766 CALL slarnv( 2, iseed, n, b )
767 CALL sscal( n, two, b, 1 )
773 IF( .NOT.lsame( trans,
'N' ) )
THEN
781 a( jr-i+j ) = a( jl )
795 a( jl+i-j ) = a( jr )
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slarnv(IDIST, ISEED, N, X)
SLARNV returns a vector of random numbers from a uniform or normal distribution.
subroutine slatms(M, N, DIST, ISEED, SYM, D, MODE, COND, DMAX, KL, KU, PACK, A, LDA, WORK, INFO)
SLATMS
subroutine srot(N, SX, INCX, SY, INCY, C, S)
SROT
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
subroutine slattp(IMAT, UPLO, TRANS, DIAG, ISEED, N, A, B, WORK, INFO)
SLATTP