144 CHARACTER diag, trans, uplo
145 INTEGER imat, info, kd, ldab, n
149 REAL ab( ldab, * ), b( * ), work( * )
156 parameter ( one = 1.0e+0, two = 2.0e+0, zero = 0.0e+0 )
160 CHARACTER dist, packit, type
162 INTEGER i, ioff, iy, j, jcount, kl, ku, lenj, mode
163 REAL anorm, bignum, bnorm, bscal, cndnum, plus1,
164 $ plus2, rexp, sfac, smlnum, star1, texp, tleft,
165 $ tnorm, tscal, ulp, unfl
178 INTRINSIC abs, max, min,
REAL, sign, sqrt
182 path( 1: 1 ) =
'Single precision'
184 unfl =
slamch(
'Safe minimum' )
187 bignum = ( one-ulp ) / smlnum
188 CALL slabad( smlnum, bignum )
189 IF( ( imat.GE.6 .AND. imat.LE.9 ) .OR. imat.EQ.17 )
THEN
203 upper =
lsame( uplo,
'U' )
205 CALL slatb4( path, imat, n, n,
TYPE, kl, ku, anorm, mode,
208 ioff = 1 + max( 0, kd-n+1 )
212 CALL slatb4( path, -imat, n, n,
TYPE, kl, ku, anorm, mode,
223 CALL slatms( n, n, dist, iseed,
TYPE, b, mode, cndnum, anorm,
224 $ kl, ku, packit, ab( ioff, 1 ), ldab, work, info )
231 ELSE IF( imat.EQ.6 )
THEN
234 DO 10 i = max( 1, kd+2-j ), kd
242 DO 30 i = 2, min( kd+1, n-j+1 )
253 ELSE IF( imat.LE.9 )
THEN
254 tnorm = sqrt( cndnum )
260 DO 50 i = max( 1, kd+2-j ), kd
263 ab( kd+1, j ) =
REAL( j )
267 DO 70 i = 2, min( kd+1, n-j+1 )
270 ab( 1, j ) =
REAL( j )
279 ab( 1, 2 ) = sign( tnorm,
slarnd( 2, iseed ) )
281 CALL slarnv( 2, iseed, lenj, work )
283 ab( 1, 2*( j+1 ) ) = tnorm*work( j )
286 ab( 2, 1 ) = sign( tnorm,
slarnd( 2, iseed ) )
288 CALL slarnv( 2, iseed, lenj, work )
290 ab( 2, 2*j+1 ) = tnorm*work( j )
293 ELSE IF( kd.GT.1 )
THEN
311 star1 = sign( tnorm,
slarnd( 2, iseed ) )
313 plus1 = sign( sfac,
slarnd( 2, iseed ) )
315 plus2 = star1 / plus1
321 plus1 = star1 / plus2
327 IF( rexp.LT.zero )
THEN
328 star1 = -sfac**( one-rexp )
330 star1 = sfac**( one+rexp )
338 CALL scopy( n-1, work, 1, ab( kd, 2 ), ldab )
339 CALL scopy( n-2, work( n+1 ), 1, ab( kd-1, 3 ), ldab )
341 CALL scopy( n-1, work, 1, ab( 2, 1 ), ldab )
342 CALL scopy( n-2, work( n+1 ), 1, ab( 3, 1 ), ldab )
350 ELSE IF( imat.EQ.10 )
THEN
358 lenj = min( j, kd+1 )
359 CALL slarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
360 ab( kd+1, j ) = sign( two, ab( kd+1, j ) )
364 lenj = min( n-j+1, kd+1 )
366 $
CALL slarnv( 2, iseed, lenj, ab( 1, j ) )
367 ab( 1, j ) = sign( two, ab( 1, j ) )
373 CALL slarnv( 2, iseed, n, b )
375 bnorm = abs( b( iy ) )
376 bscal = bignum / max( one, bnorm )
377 CALL sscal( n, bscal, b, 1 )
379 ELSE IF( imat.EQ.11 )
THEN
385 CALL slarnv( 2, iseed, n, b )
386 tscal = one /
REAL( kd+1 )
389 lenj = min( j, kd+1 )
390 CALL slarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
391 CALL sscal( lenj-1, tscal, ab( kd+2-lenj, j ), 1 )
392 ab( kd+1, j ) = sign( one, ab( kd+1, j ) )
394 ab( kd+1, n ) = smlnum*ab( kd+1, n )
397 lenj = min( n-j+1, kd+1 )
398 CALL slarnv( 2, iseed, lenj, ab( 1, j ) )
400 $
CALL sscal( lenj-1, tscal, ab( 2, j ), 1 )
401 ab( 1, j ) = sign( one, ab( 1, j ) )
403 ab( 1, 1 ) = smlnum*ab( 1, 1 )
406 ELSE IF( imat.EQ.12 )
THEN
412 CALL slarnv( 2, iseed, n, b )
415 lenj = min( j, kd+1 )
416 CALL slarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
417 ab( kd+1, j ) = sign( one, ab( kd+1, j ) )
419 ab( kd+1, n ) = smlnum*ab( kd+1, n )
422 lenj = min( n-j+1, kd+1 )
423 CALL slarnv( 2, iseed, lenj, ab( 1, j ) )
424 ab( 1, j ) = sign( one, ab( 1, j ) )
426 ab( 1, 1 ) = smlnum*ab( 1, 1 )
429 ELSE IF( imat.EQ.13 )
THEN
438 DO 180 i = max( 1, kd+1-( j-1 ) ), kd
441 IF( jcount.LE.2 )
THEN
442 ab( kd+1, j ) = smlnum
453 DO 200 i = 2, min( n-j+1, kd+1 )
456 IF( jcount.LE.2 )
THEN
477 DO 230 i = 1, n - 1, 2
483 ELSE IF( imat.EQ.14 )
THEN
489 texp = one /
REAL( kd+1 )
491 CALL slarnv( 2, iseed, n, b )
494 DO 240 i = max( 1, kd+2-j ), kd
497 IF( j.GT.1 .AND. kd.GT.0 )
499 ab( kd+1, j ) = tscal
504 DO 260 i = 3, min( n-j+1, kd+1 )
507 IF( j.LT.n .AND. kd.GT.0 )
514 ELSE IF( imat.EQ.15 )
THEN
521 lenj = min( j, kd+1 )
522 CALL slarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
524 ab( kd+1, j ) = sign( two, ab( kd+1, j ) )
531 lenj = min( n-j+1, kd+1 )
532 CALL slarnv( 2, iseed, lenj, ab( 1, j ) )
534 ab( 1, j ) = sign( two, ab( 1, j ) )
540 CALL slarnv( 2, iseed, n, b )
541 CALL sscal( n, two, b, 1 )
543 ELSE IF( imat.EQ.16 )
THEN
551 tscal = ( one-ulp ) / tscal
561 DO 320 i = j, max( 1, j-kd+1 ), -2
562 ab( 1+( j-i ), i ) = -tscal /
REAL( kd+2 )
564 b( i ) = texp*( one-ulp )
565 IF( i.GT.max( 1, j-kd+1 ) )
THEN
566 ab( 2+( j-i ), i-1 ) = -( tscal /
REAL( KD+2 ) )
568 ab( kd+1, i-1 ) = one
569 b( i-1 ) = texp*
REAL( ( kd+1 )*( kd+1 )+kd )
573 b( max( 1, j-kd+1 ) ) = (
REAL( KD+2 ) /
574 $
REAL( KD+3 ) )*tscal
579 lenj = min( kd+1, n-j+1 )
580 DO 340 i = j, min( n, j+kd-1 ), 2
581 ab( lenj-( i-j ), j ) = -tscal /
REAL( kd+2 )
583 b( j ) = texp*( one-ulp )
584 IF( i.LT.min( n, j+kd-1 ) )
THEN
585 ab( lenj-( i-j+1 ), i+1 ) = -( tscal /
586 $
REAL( KD+2 ) ) /
REAL( kd+3 )
588 b( i+1 ) = texp*
REAL( ( kd+1 )*( kd+1 )+kd )
592 b( min( n, j+kd-1 ) ) = (
REAL( KD+2 ) /
593 $
REAL( KD+3 ) )*tscal
603 ELSE IF( imat.EQ.17 )
THEN
611 lenj = min( j-1, kd )
612 CALL slarnv( 2, iseed, lenj, ab( kd+1-lenj, j ) )
613 ab( kd+1, j ) =
REAL( j )
617 lenj = min( n-j, kd )
619 $
CALL slarnv( 2, iseed, lenj, ab( 2, j ) )
620 ab( 1, j ) =
REAL( j )
626 CALL slarnv( 2, iseed, n, b )
628 bnorm = abs( b( iy ) )
629 bscal = bignum / max( one, bnorm )
630 CALL sscal( n, bscal, b, 1 )
632 ELSE IF( imat.EQ.18 )
THEN
638 tleft = bignum / max( one,
REAL( KD ) )
639 tscal = bignum*(
REAL( KD ) /
REAL( KD+1 ) )
642 lenj = min( j, kd+1 )
643 CALL slarnv( 2, iseed, lenj, ab( kd+2-lenj, j ) )
644 DO 390 i = kd + 2 - lenj, kd + 1
645 ab( i, j ) = sign( tleft, ab( i, j ) ) +
651 lenj = min( n-j+1, kd+1 )
652 CALL slarnv( 2, iseed, lenj, ab( 1, j ) )
654 ab( i, j ) = sign( tleft, ab( i, j ) ) +
659 CALL slarnv( 2, iseed, n, b )
660 CALL sscal( n, two, b, 1 )
665 IF( .NOT.
lsame( trans,
'N' ) )
THEN
668 lenj = min( n-2*j+1, kd+1 )
669 CALL sswap( lenj, ab( kd+1, j ), ldab-1,
670 $ ab( kd+2-lenj, n-j+1 ), -1 )
674 lenj = min( n-2*j+1, kd+1 )
675 CALL sswap( lenj, ab( 1, j ), 1, ab( lenj, n-j+2-lenj ),
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
integer function isamax(N, SX, INCX)
ISAMAX
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
real function slarnd(IDIST, ISEED)
SLARND
subroutine sscal(N, SA, SX, INCX)
SSCAL
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
real function slamch(CMACH)
SLAMCH
logical function lsame(CA, CB)
LSAME
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY