367 SUBROUTINE sgbsvx( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
368 $ ldafb, ipiv, equed, r, c,
b, ldb, x, ldx,
369 $ rcond, ferr, berr, work, iwork, info )
377 CHARACTER equed, fact, trans
378 INTEGER info, kl, ku, ldab, ldafb, ldb, ldx, n, nrhs
382 INTEGER ipiv( * ), iwork( * )
383 REAL ab( ldab, * ), afb( ldafb, * ),
b( ldb, * ),
384 $ berr( * ), c( * ), ferr( * ), r( * ),
385 $ work( * ), x( ldx, * )
395 parameter( zero = 0.0e+0, one = 1.0e+0 )
398 LOGICAL colequ, equil, nofact, notran, rowequ
400 INTEGER i, infequ,
j, j1, j2
401 REAL amax, anorm, bignum, colcnd, rcmax, rcmin,
402 $ rowcnd, rpvgrw, smlnum
414 INTRINSIC abs, max, min
419 nofact =
lsame( fact,
'N' )
420 equil =
lsame( fact,
'E' )
421 notran =
lsame( trans,
'N' )
422 IF( nofact .OR. equil )
THEN
427 rowequ =
lsame( equed,
'R' ) .OR.
lsame( equed,
'B' )
428 colequ =
lsame( equed,
'C' ) .OR.
lsame( equed,
'B' )
429 smlnum =
slamch(
'Safe minimum' )
430 bignum = one / smlnum
435 IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.
lsame( fact,
'F' ) )
438 ELSE IF( .NOT.notran .AND. .NOT.
lsame( trans,
'T' ) .AND. .NOT.
439 $
lsame( trans,
'C' ) )
THEN
441 ELSE IF( n.LT.0 )
THEN
443 ELSE IF( kl.LT.0 )
THEN
445 ELSE IF( ku.LT.0 )
THEN
447 ELSE IF( nrhs.LT.0 )
THEN
449 ELSE IF( ldab.LT.kl+ku+1 )
THEN
451 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
453 ELSE IF(
lsame( fact,
'F' ) .AND. .NOT.
454 $ ( rowequ .OR. colequ .OR.
lsame( equed,
'N' ) ) )
THEN
461 rcmin = min( rcmin, r(
j ) )
462 rcmax = max( rcmax, r(
j ) )
464 IF( rcmin.LE.zero )
THEN
466 ELSE IF( n.GT.0 )
THEN
467 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
472 IF( colequ .AND. info.EQ.0 )
THEN
476 rcmin = min( rcmin, c(
j ) )
477 rcmax = max( rcmax, c(
j ) )
479 IF( rcmin.LE.zero )
THEN
481 ELSE IF( n.GT.0 )
THEN
482 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
488 IF( ldb.LT.max( 1, n ) )
THEN
490 ELSE IF( ldx.LT.max( 1, n ) )
THEN
497 CALL
xerbla(
'SGBSVX', -info )
505 CALL
sgbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,
507 IF( infequ.EQ.0 )
THEN
511 CALL
slaqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,
513 rowequ =
lsame( equed,
'R' ) .OR.
lsame( equed,
'B' )
514 colequ =
lsame( equed,
'C' ) .OR.
lsame( equed,
'B' )
524 b( i,
j ) = r( i )*
b( i,
j )
528 ELSE IF( colequ )
THEN
531 b( i,
j ) = c( i )*
b( i,
j )
536 IF( nofact .OR. equil )
THEN
543 CALL
scopy( j2-j1+1, ab( ku+1-
j+j1,
j ), 1,
544 $ afb( kl+ku+1-
j+j1,
j ), 1 )
547 CALL
sgbtrf( n, n, kl, ku, afb, ldafb, ipiv, info )
558 DO 80 i = max( ku+2-
j, 1 ), min( n+ku+1-
j, kl+ku+1 )
559 anorm = max( anorm, abs( ab( i,
j ) ) )
562 rpvgrw =
slantb(
'M',
'U',
'N', info, min( info-1, kl+ku ),
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, ipiv,
607 $
b, ldb, x, ldx, ferr, berr, work, iwork, info )
616 x( i,
j ) = c( i )*x( i,
j )
620 ferr(
j ) = ferr(
j ) / colcnd
623 ELSE IF( rowequ )
THEN
626 x( i,
j ) = r( i )*x( i,
j )
630 ferr(
j ) = ferr(
j ) / rowcnd
636 IF( rcond.LT.
slamch(
'Epsilon' ) )
real function slantb(NORM, UPLO, DIAG, N, K, AB, LDAB, WORK)
SLANTB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a triangular band matrix.
subroutine sgbequ(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, INFO)
SGBEQU
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 ...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sgbtrf(M, N, KL, KU, AB, LDAB, IPIV, INFO)
SGBTRF
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine slaqgb(M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND, AMAX, EQUED)
SLAQGB scales a general band matrix, using row and column scaling factors computed by sgbequ...
subroutine scopy(N, SX, INCX, SY, INCY)
SCOPY
logical function lsame(CA, CB)
LSAME
real function slangb(NORM, N, KL, KU, AB, LDAB, WORK)
SLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine sgbcon(NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
SGBCON
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
real function slamch(CMACH)
SLAMCH
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine sgbrfs(TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
SGBRFS
subroutine sgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
SGBTRS