365 SUBROUTINE zgbsvx( FACT, TRANS, N, KL, KU, NRHS, AB, LDAB, AFB,
366 $ LDAFB, IPIV, EQUED, R, C, B, LDB, X, LDX,
367 $ RCOND, FERR, BERR, WORK, RWORK, INFO )
374 CHARACTER EQUED, FACT, TRANS
375 INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
376 DOUBLE PRECISION RCOND
380 DOUBLE PRECISION BERR( * ), C( * ), FERR( * ), R( * ),
382 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
383 $ WORK( * ), X( LDX, * )
392 DOUBLE PRECISION ZERO, ONE
393 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
396 LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
398 INTEGER I, INFEQU, J, J1, J2
399 DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
400 $ rowcnd, rpvgrw, smlnum
404 DOUBLE PRECISION DLAMCH, ZLANGB, ZLANTB
405 EXTERNAL lsame, dlamch, zlangb, zlantb
413 INTRINSIC abs, max, min
418 nofact = lsame( fact,
'N' )
419 equil = lsame( fact,
'E' )
420 notran = lsame( trans,
'N' )
421 IF( nofact .OR. equil )
THEN
426 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
427 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
428 smlnum = dlamch(
'Safe minimum' )
429 bignum = one / smlnum
434 IF( .NOT.nofact .AND.
436 $ .NOT.lsame( fact,
'F' ) )
439 ELSE IF( .NOT.notran .AND. .NOT.lsame( trans,
'T' ) .AND. .NOT.
440 $ lsame( trans,
'C' ) )
THEN
442 ELSE IF( n.LT.0 )
THEN
444 ELSE IF( kl.LT.0 )
THEN
446 ELSE IF( ku.LT.0 )
THEN
448 ELSE IF( nrhs.LT.0 )
THEN
450 ELSE IF( ldab.LT.kl+ku+1 )
THEN
452 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
454 ELSE IF( lsame( fact,
'F' ) .AND. .NOT.
455 $ ( rowequ .OR. colequ .OR. lsame( equed,
'N' ) ) )
THEN
462 rcmin = min( rcmin, r( j ) )
463 rcmax = max( rcmax, r( j ) )
465 IF( rcmin.LE.zero )
THEN
467 ELSE IF( n.GT.0 )
THEN
468 rowcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
473 IF( colequ .AND. info.EQ.0 )
THEN
477 rcmin = min( rcmin, c( j ) )
478 rcmax = max( rcmax, c( j ) )
480 IF( rcmin.LE.zero )
THEN
482 ELSE IF( n.GT.0 )
THEN
483 colcnd = max( rcmin, smlnum ) / min( rcmax, bignum )
489 IF( ldb.LT.max( 1, n ) )
THEN
491 ELSE IF( ldx.LT.max( 1, n ) )
THEN
498 CALL xerbla(
'ZGBSVX', -info )
506 CALL zgbequ( n, n, kl, ku, ab, ldab, r, c, rowcnd, colcnd,
508 IF( infequ.EQ.0 )
THEN
512 CALL zlaqgb( n, n, kl, ku, ab, ldab, r, c, rowcnd,
515 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
516 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
526 b( i, j ) = r( i )*b( i, j )
530 ELSE IF( colequ )
THEN
533 b( i, j ) = c( i )*b( i, j )
538 IF( nofact .OR. equil )
THEN
545 CALL zcopy( j2-j1+1, ab( ku+1-j+j1, j ), 1,
546 $ afb( kl+ku+1-j+j1, j ), 1 )
549 CALL zgbtrf( n, n, kl, ku, afb, ldafb, ipiv, info )
560 DO 80 i = max( ku+2-j, 1 ), min( n+ku+1-j, kl+ku+1 )
561 anorm = max( anorm, abs( ab( i, j ) ) )
564 rpvgrw = zlantb(
'M',
'U',
'N', info, min( info-1,
566 $ afb( max( 1, kl+ku+2-info ), 1 ), ldafb,
568 IF( rpvgrw.EQ.zero )
THEN
571 rpvgrw = anorm / rpvgrw
587 anorm = zlangb( norm, n, kl, ku, ab, ldab, rwork )
588 rpvgrw = zlantb(
'M',
'U',
'N', n, kl+ku, afb, ldafb, rwork )
589 IF( rpvgrw.EQ.zero )
THEN
592 rpvgrw = zlangb(
'M', n, kl, ku, ab, ldab, rwork ) / rpvgrw
597 CALL zgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,
598 $ work, rwork, info )
602 CALL zlacpy(
'Full', n, nrhs, b, ldb, x, ldx )
603 CALL zgbtrs( trans, n, kl, ku, nrhs, afb, ldafb, ipiv, x, ldx,
609 CALL zgbrfs( trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb,
611 $ b, ldb, x, ldx, ferr, berr, work, rwork, info )
620 x( i, j ) = c( i )*x( i, j )
624 ferr( j ) = ferr( j ) / colcnd
627 ELSE IF( rowequ )
THEN
630 x( i, j ) = r( i )*x( i, j )
634 ferr( j ) = ferr( j ) / rowcnd
640 IF( rcond.LT.dlamch(
'Epsilon' ) )
subroutine zgbsvx(fact, trans, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, equed, r, c, b, ldb, x, ldx, rcond, ferr, berr, work, rwork, info)
ZGBSVX computes the solution to system of linear equations A * X = B for GB matrices