341 SUBROUTINE zpbsvx( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
342 $ equed, s,
b, ldb,
x, ldx, rcond, ferr, berr,
343 $ work, rwork, info )
351 CHARACTER equed, fact, uplo
352 INTEGER info, kd, ldab, ldafb, ldb, ldx, n, nrhs
353 DOUBLE PRECISION rcond
356 DOUBLE PRECISION berr( * ), ferr( * ), rwork( * ), s( * )
357 COMPLEX*16 ab( ldab, * ), afb( ldafb, * ),
b( ldb, * ),
358 $ work( * ),
x( ldx, * )
364 DOUBLE PRECISION zero, one
365 parameter( zero = 0.0d+0, one = 1.0d+0 )
368 LOGICAL equil, nofact, rcequ, upper
369 INTEGER i, infequ,
j, j1, j2
370 DOUBLE PRECISION amax, anorm, bignum, scond, smax, smin, smlnum
387 nofact =
lsame( fact,
'N' )
388 equil =
lsame( fact,
'E' )
389 upper =
lsame( uplo,
'U' )
390 IF( nofact .OR. equil )
THEN
394 rcequ =
lsame( equed,
'Y' )
395 smlnum =
dlamch(
'Safe minimum' )
396 bignum = one / smlnum
401 IF( .NOT.nofact .AND. .NOT.equil .AND. .NOT.
lsame( fact,
'F' ) )
404 ELSE IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
406 ELSE IF( n.LT.0 )
THEN
408 ELSE IF( kd.LT.0 )
THEN
410 ELSE IF( nrhs.LT.0 )
THEN
412 ELSE IF( ldab.LT.kd+1 )
THEN
414 ELSE IF( ldafb.LT.kd+1 )
THEN
416 ELSE IF(
lsame( fact,
'F' ) .AND. .NOT.
417 $ ( rcequ .OR.
lsame( equed,
'N' ) ) )
THEN
424 smin = min( smin, s(
j ) )
425 smax = max( smax, s(
j ) )
427 IF( smin.LE.zero )
THEN
429 ELSE IF( n.GT.0 )
THEN
430 scond = max( smin, smlnum ) / min( smax, bignum )
436 IF( ldb.LT.max( 1, n ) )
THEN
438 ELSE IF( ldx.LT.max( 1, n ) )
THEN
445 CALL
xerbla(
'ZPBSVX', -info )
453 CALL
zpbequ( uplo, n, kd, ab, ldab, s, scond, amax, infequ )
454 IF( infequ.EQ.0 )
THEN
458 CALL
zlaqhb( uplo, n, kd, ab, ldab, s, scond, amax, equed )
459 rcequ =
lsame( equed,
'Y' )
468 b( i,
j ) = s( i )*
b( i,
j )
473 IF( nofact .OR. equil )
THEN
480 CALL
zcopy(
j-j1+1, ab( kd+1-
j+j1,
j ), 1,
481 $ afb( kd+1-
j+j1,
j ), 1 )
486 CALL
zcopy( j2-
j+1, ab( 1,
j ), 1, afb( 1,
j ), 1 )
490 CALL
zpbtrf( uplo, n, kd, afb, ldafb, info )
502 anorm =
zlanhb(
'1', uplo, n, kd, ab, ldab, rwork )
506 CALL
zpbcon( uplo, n, kd, afb, ldafb, anorm, rcond, work, rwork,
511 CALL
zlacpy(
'Full', n, nrhs,
b, ldb,
x, ldx )
512 CALL
zpbtrs( uplo, n, kd, nrhs, afb, ldafb,
x, ldx, info )
517 CALL
zpbrfs( uplo, n, kd, nrhs, ab, ldab, afb, ldafb,
b, ldb,
x,
518 $ ldx, ferr, berr, work, rwork, info )
526 x( i,
j ) = s( i )*
x( i,
j )
530 ferr(
j ) = ferr(
j ) / scond
536 IF( rcond.LT.
dlamch(
'Epsilon' ) )
LOGICAL function lsame(CA, CB)
LSAME
subroutine zpbrfs(UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPBRFS
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zpbcon(UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK, RWORK, INFO)
ZPBCON
subroutine zpbtrf(UPLO, N, KD, AB, LDAB, INFO)
ZPBTRF
DOUBLE PRECISION function zlanhb(NORM, UPLO, N, K, AB, LDAB, WORK)
ZLANHB returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a Hermitian band matrix.
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
subroutine zpbequ(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO)
ZPBEQU
subroutine zpbsvx(FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK, RWORK, INFO)
ZPBSVX computes the solution to system of linear equations A * X = B for OTHER matrices ...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine zpbtrs(UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO)
ZPBTRS
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
subroutine zlaqhb(UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED)
ZLAQHB scales a Hermitian band matrix, using scaling factors computed by cpbequ.