435 SUBROUTINE zgbrfsx( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB,
436 $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND,
437 $ BERR, N_ERR_BNDS, ERR_BNDS_NORM,
438 $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK,
446 CHARACTER TRANS, EQUED
447 INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
448 $ NPARAMS, N_ERR_BNDS
449 DOUBLE PRECISION RCOND
453 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
454 $ X( LDX , * ),WORK( * )
455 DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
456 $ err_bnds_norm( nrhs, * ),
457 $ err_bnds_comp( nrhs, * ), rwork( * )
463 DOUBLE PRECISION ZERO, ONE
464 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
465 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
466 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
467 DOUBLE PRECISION DZTHRESH_DEFAULT
468 parameter( itref_default = 1.0d+0 )
469 parameter( ithresh_default = 10.0d+0 )
470 parameter( componentwise_default = 1.0d+0 )
471 parameter( rthresh_default = 0.5d+0 )
472 parameter( dzthresh_default = 0.25d+0 )
473 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
475 parameter( la_linrx_itref_i = 1,
476 $ la_linrx_ithresh_i = 2 )
477 parameter( la_linrx_cwise_i = 3 )
478 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
480 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
481 parameter( la_linrx_rcond_i = 3 )
485 LOGICAL ROWEQU, COLEQU, NOTRAN, IGNORE_CWISE
486 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE, N_NORMS,
488 DOUBLE PRECISION ANORM, RCOND_TMP, ILLRCOND_THRESH, ERR_LBND,
489 $ cwise_wrong, rthresh, unstable_thresh
495 INTRINSIC max, sqrt, transfer
500 DOUBLE PRECISION DLAMCH, ZLANGB, ZLA_GBRCOND_X, ZLA_GBRCOND_C
502 INTEGER ILATRANS, ILAPREC
509 trans_type = ilatrans( trans )
510 ref_type = int( itref_default )
511 IF ( nparams .GE. la_linrx_itref_i )
THEN
512 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
513 params( la_linrx_itref_i ) = itref_default
515 ref_type = params( la_linrx_itref_i )
521 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
522 ithresh = int( ithresh_default )
523 rthresh = rthresh_default
524 unstable_thresh = dzthresh_default
525 ignore_cwise = componentwise_default .EQ. 0.0d+0
527 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
528 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
529 params( la_linrx_ithresh_i ) = ithresh
531 ithresh = int( params( la_linrx_ithresh_i ) )
534 IF ( nparams.GE.la_linrx_cwise_i )
THEN
535 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 )
THEN
536 IF ( ignore_cwise )
THEN
537 params( la_linrx_cwise_i ) = 0.0d+0
539 params( la_linrx_cwise_i ) = 1.0d+0
542 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
545 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
547 ELSE IF ( ignore_cwise )
THEN
553 notran = lsame( trans,
'N' )
554 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
555 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
559 IF( trans_type.EQ.-1 )
THEN
561 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
562 $ .NOT.lsame( equed,
'N' ) )
THEN
564 ELSE IF( n.LT.0 )
THEN
566 ELSE IF( kl.LT.0 )
THEN
568 ELSE IF( ku.LT.0 )
THEN
570 ELSE IF( nrhs.LT.0 )
THEN
572 ELSE IF( ldab.LT.kl+ku+1 )
THEN
574 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
576 ELSE IF( ldb.LT.max( 1, n ) )
THEN
578 ELSE IF( ldx.LT.max( 1, n ) )
THEN
582 CALL xerbla(
'ZGBRFSX', -info )
588 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
592 IF ( n_err_bnds .GE. 1 )
THEN
593 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
594 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
596 IF ( n_err_bnds .GE. 2 )
THEN
597 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
598 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
600 IF ( n_err_bnds .GE. 3 )
THEN
601 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
602 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
613 IF ( n_err_bnds .GE. 1 )
THEN
614 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
615 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
617 IF ( n_err_bnds .GE. 2 )
THEN
618 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
619 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
621 IF ( n_err_bnds .GE. 3 )
THEN
622 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
623 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
635 anorm = zlangb( norm, n, kl, ku, ab, ldab, rwork )
636 CALL zgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,
637 $ work, rwork, info )
641 IF ( ref_type .NE. 0 .AND. info .EQ. 0 )
THEN
643 prec_type = ilaprec(
'E' )
647 $ nrhs, ab, ldab, afb, ldafb, ipiv, colequ, c, b,
648 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
649 $ err_bnds_comp, work, rwork, work(n+1),
650 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
651 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
655 $ nrhs, ab, ldab, afb, ldafb, ipiv, rowequ, r, b,
656 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
657 $ err_bnds_comp, work, rwork, work(n+1),
658 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
659 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
664 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
665 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 1)
THEN
669 IF ( colequ .AND. notran )
THEN
670 rcond_tmp = zla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,
671 $ ldafb, ipiv, c, .true., info, work, rwork )
672 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
673 rcond_tmp = zla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,
674 $ ldafb, ipiv, r, .true., info, work, rwork )
676 rcond_tmp = zla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,
677 $ ldafb, ipiv, c, .false., info, work, rwork )
683 IF ( n_err_bnds .GE. la_linrx_err_i
684 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0)
685 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
689 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
690 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
691 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
692 IF ( info .LE. n ) info = n + j
693 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
695 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
696 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
701 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
702 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
708 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 2)
THEN
718 cwise_wrong = sqrt( dlamch(
'Epsilon' ) )
720 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
722 rcond_tmp = zla_gbrcond_x( trans, n, kl, ku, ab, ldab,
723 $ afb, ldafb, ipiv, x( 1, j ), info, work, rwork )
730 IF ( n_err_bnds .GE. la_linrx_err_i
731 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0d+0 )
732 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
736 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
737 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
738 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
739 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+0
740 $ .AND. info.LT.n + j ) info = n + j
741 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
742 $ .LT. err_lbnd )
THEN
743 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
744 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
749 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
750 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
subroutine xerbla(srname, info)
subroutine zgbcon(norm, n, kl, ku, ab, ldab, ipiv, anorm, rcond, work, rwork, info)
ZGBCON
subroutine zgbrfsx(trans, equed, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, r, c, b, ldb, x, ldx, rcond, berr, n_err_bnds, err_bnds_norm, err_bnds_comp, nparams, params, work, rwork, info)
ZGBRFSX
integer function ilaprec(prec)
ILAPREC
double precision function zla_gbrcond_x(trans, n, kl, ku, ab, ldab, afb, ldafb, ipiv, x, info, work, rwork)
ZLA_GBRCOND_X computes the infinity norm condition number of op(A)*diag(x) for general banded matrice...
double precision function zla_gbrcond_c(trans, n, kl, ku, ab, ldab, afb, ldafb, ipiv, c, capply, info, work, rwork)
ZLA_GBRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general banded ma...
subroutine zla_gbrfsx_extended(prec_type, trans_type, n, kl, ku, nrhs, ab, ldab, afb, ldafb, ipiv, colequ, c, b, ldb, y, ldy, berr_out, n_norms, err_bnds_norm, err_bnds_comp, res, ayb, dy, y_tail, rcond, ithresh, rthresh, dz_ub, ignore_cwise, info)
ZLA_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general banded...
double precision function dlamch(cmach)
DLAMCH
double precision function zlangb(norm, n, kl, ku, ab, ldab, work)
ZLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
logical function lsame(ca, cb)
LSAME