342 SUBROUTINE dpbsvx( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
343 $ equed, s,
b, ldb,
x, ldx, rcond, ferr, berr,
344 $ work, iwork, info )
352 CHARACTER equed, fact, uplo
353 INTEGER info, kd, ldab, ldafb, ldb, ldx, n, nrhs
354 DOUBLE PRECISION rcond
358 DOUBLE PRECISION ab( ldab, * ), afb( ldafb, * ),
b( ldb, * ),
359 $ berr( * ), ferr( * ), s( * ), work( * ),
366 DOUBLE PRECISION zero, one
367 parameter( zero = 0.0d+0, one = 1.0d+0 )
370 LOGICAL equil, nofact, rcequ, upper
371 INTEGER i, infequ,
j, j1, j2
372 DOUBLE PRECISION amax, anorm, bignum, scond, smax, smin, smlnum
389 nofact =
lsame( fact,
'N' )
390 equil =
lsame( fact,
'E' )
391 upper =
lsame( uplo,
'U' )
392 IF( nofact .OR. equil )
THEN
396 rcequ =
lsame( equed,
'Y' )
397 smlnum =
dlamch(
'Safe minimum' )
398 bignum = one / smlnum
403 IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.
lsame( fact,
'F' ) )
406 ELSE IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
408 ELSE IF( n.LT.0 )
THEN
410 ELSE IF( kd.LT.0 )
THEN
412 ELSE IF( nrhs.LT.0 )
THEN
414 ELSE IF( ldab.LT.kd+1 )
THEN
416 ELSE IF( ldafb.LT.kd+1 )
THEN
418 ELSE IF(
lsame( fact,
'F' ) .AND. .NOT.
419 $ ( rcequ .OR.
lsame( equed,
'N' ) ) )
THEN
426 smin = min( smin, s(
j ) )
427 smax = max( smax, s(
j ) )
429 IF( smin.LE.zero )
THEN
431 ELSE IF( n.GT.0 )
THEN
432 scond = max( smin, smlnum ) / min( smax, bignum )
438 IF( ldb.LT.max( 1, n ) )
THEN
440 ELSE IF( ldx.LT.max( 1, n ) )
THEN
447 CALL
xerbla(
'DPBSVX', -info )
455 CALL
dpbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ )
456 IF( infequ.EQ.0 )
THEN
460 CALL
dlaqsb( uplo, n, kd, ab, ldab, s, scond, amax, equed )
461 rcequ =
lsame( equed,
'Y' )
470 b( i,
j ) = s( i )*
b( i,
j )
475 IF( nofact .OR. equil )
THEN
482 CALL
dcopy(
j-j1+1, ab( kd+1-
j+j1,
j ), 1,
483 $ afb( kd+1-
j+j1,
j ), 1 )
488 CALL
dcopy( j2-
j+1, ab( 1,
j ), 1, afb( 1,
j ), 1 )
492 CALL
dpbtrf( uplo, n, kd, afb, ldafb, info )
504 anorm =
dlansb(
'1', uplo, n, kd, ab, ldab, work )
508 CALL
dpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, iwork,
513 CALL
dlacpy(
'Full', n, nrhs,
b, ldb,
x, ldx )
514 CALL
dpbtrs( uplo, n, kd, nrhs, afb, ldafb,
x, ldx, info )
519 CALL
dpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb,
b, ldb,
x,
520 $ ldx, ferr, berr, work, iwork, info )
528 x( i,
j ) = s( i )*
x( i,
j )
532 ferr(
j ) = ferr(
j ) / scond
538 IF( rcond.LT.
dlamch(
'Epsilon' ) )
LOGICAL function lsame(CA, CB)
LSAME
subroutine dpbsvx(FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO)
DPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
subroutine dlaqsb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
DLAQSB scales a symmetric/Hermitian band matrix, using scaling factors computed by spbequ...
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dpbtrf(UPLO, N, KD, AB, LDAB, INFO)
DPBTRF
subroutine dpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, IWORK, INFO)
DPBCON
DOUBLE PRECISION function dlansb(NORM, UPLO, N, K, AB, LDAB, WORK)
DLANSB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a symmetric band matrix.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine dlacpy(UPLO, M, N, A, LDA, B, LDB)
DLACPY copies all or part of one two-dimensional array to another.
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine dpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO)
DPBRFS
subroutine dpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
DPBTRS
subroutine dpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
DPBEQU