363 SUBROUTINE sgbsvx( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
364 $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
365 $ RCOND, FERR, BERR, WORK, IWORK, INFO )
372 CHARACTER EQUED, FACT, TRANS
373 INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
377 INTEGER IPIV( * ), IWORK( * )
378 REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
379 $ berr( * ), c( * ), ferr( * ), r( * ),
380 $ work( * ), x( ldx, * )
390 PARAMETER ( ZERO = 0.0e+0, one = 1.0e+0 )
393 LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
395 INTEGER I, INFEQU, J, J1, J2
396 REAL AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
397 $ rowcnd, rpvgrw, smlnum
401 REAL SLAMCH, SLANGB, SLANTB
402 EXTERNAL lsame, slamch, slangb, slantb
410 INTRINSIC abs, max, min
415 nofact = lsame( fact,
'N' )
416 equil = lsame( fact,
'E' )
417 notran = lsame( trans,
'N' )
418 IF( nofact .OR. equil )
THEN
423 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
424 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
425 smlnum = slamch(
'Safe minimum' )
426 bignum = one / smlnum
431 IF( .NOT.nofact .AND.
433 $ .NOT.lsame( fact,
'F' ) )
436 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
437 $ lsame( trans,
'C' ) )
THEN
439 ELSE IF( n.LT.0 )
THEN
441 ELSE IF( kl.LT.0 )
THEN
443 ELSE IF( ku.LT.0 )
THEN
445 ELSE IF( nrhs.LT.0 )
THEN
447 ELSE IF( ldab.LT.kl+ku+1 )
THEN
449 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
451 ELSE IF( lsame( fact,
'F' ) .AND. .NOT.
452 $ ( rowequ .OR. colequ .OR. lsame( equed,
'N' ) ) )
THEN
459 rcmin = min( rcmin, r( j ) )
460 rcmax = max( rcmax, r( j ) )
462 IF( rcmin.LE.zero )
THEN
464 ELSE IF( n.GT.0 )
THEN
465 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
470 IF( colequ .AND. info.EQ.0 )
THEN
474 rcmin = min( rcmin, c( j ) )
475 rcmax = max( rcmax, c( j ) )
477 IF( rcmin.LE.zero )
THEN
479 ELSE IF( n.GT.0 )
THEN
480 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
486 IF( ldb.LT.max( 1, n ) )
THEN
488 ELSE IF( ldx.LT.max( 1, n ) )
THEN
495 CALL xerbla(
'SGBSVX', -info )
503 CALL sgbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,
505 IF( infequ.EQ.0 )
THEN
509 CALL slaqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd,
512 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
513 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
523 b( i, j ) = r( i )*b( i, j )
527 ELSE IF( colequ )
THEN
530 b( i, j ) = c( i )*b( i, j )
535 IF( nofact .OR. equil )
THEN
542 CALL scopy( j2-j1+1, ab( ku+1-j+j1, j ), 1,
543 $ afb( kl+ku+1-j+j1, j ), 1 )
546 CALL sgbtrf( n, n, kl, ku, afb, ldafb, ipiv, info )
557 DO 80 i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
558 anorm = max( anorm, abs( ab( i, j ) ) )
561 rpvgrw = slantb(
'M',
'U',
'N', info, min( info-1,
563 $ afb( max( 1, kl+ku+2-info ), 1 ), ldafb,
565 IF( rpvgrw.EQ.zero )
THEN
568 rpvgrw = anorm / rpvgrw
584 anorm = slangb( norm, n, kl, ku, ab, ldab, work )
585 rpvgrw = slantb(
'M',
'U',
'N', n, kl+ku, afb, ldafb, work )
586 IF( rpvgrw.EQ.zero )
THEN
589 rpvgrw = slangb(
'M', n, kl, ku, ab, ldab, work ) / rpvgrw
594 CALL sgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,
595 $ work, iwork, info )
599 CALL slacpy(
'Full', n, nrhs, b, ldb, x, ldx )
600 CALL sgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,
606 CALL sgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,
608 $ b, ldb, x, ldx, ferr, berr, work, iwork, info )
617 x( i, j ) = c( i )*x( i, j )
621 ferr( j ) = ferr( j ) / colcnd
624 ELSE IF( rowequ )
THEN
627 x( i, j ) = r( i )*x( i, j )
631 ferr( j ) = ferr( j ) / rowcnd
637 IF( rcond.LT.slamch(
'Epsilon' ) )
subroutine sgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, iwork, info)
SGBSVX computes the solution to system of linear equations A * X = B for GB matrices