135 SUBROUTINE slattb( IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB,
136 $ ldab,
b, work, info )
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 ) )
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
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
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 )
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 ) )
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 )
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 ) ) +
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 ),
LOGICAL function lsame(CA, CB)
LSAME
INTEGER function isamax(N, SX, INCX)
ISAMAX
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
REAL function slamch(CMACH)
SLAMCH
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
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine slattb(IMAT, UPLO, TRANS, DIAG, ISEED, N, KD, AB, LDAB, B, WORK, INFO)
SLATTB
subroutine slabad(SMALL, LARGE)
SLABAD
subroutine slatb4(PATH, IMAT, M, N, TYPE, KL, KU, ANORM, MODE, CNDNUM, DIST)
SLATB4
subroutine sscal(N, SA, SX, INCX)
SSCAL