437 SUBROUTINE cgbrfsx( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB, AFB,
438 $ ldafb, ipiv, r, c, b, ldb, x, ldx, rcond,
439 $ berr, n_err_bnds, err_bnds_norm,
440 $ err_bnds_comp, nparams, params, work, rwork,
449 CHARACTER TRANS, EQUED
450 INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
451 $ nparams, n_err_bnds
456 COMPLEX AB( ldab, * ), AFB( ldafb, * ), B( ldb, * ),
457 $ x( ldx , * ),work( * )
458 REAL R( * ), C( * ), PARAMS( * ), BERR( * ),
459 $ err_bnds_norm( nrhs, * ),
460 $ err_bnds_comp( nrhs, * ), rwork( * )
467 parameter ( zero = 0.0e+0, one = 1.0e+0 )
468 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
469 $ componentwise_default
470 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
471 parameter ( itref_default = 1.0 )
472 parameter ( ithresh_default = 10.0 )
473 parameter ( componentwise_default = 1.0 )
474 parameter ( rthresh_default = 0.5 )
475 parameter ( dzthresh_default = 0.25 )
476 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
478 parameter ( la_linrx_itref_i = 1,
479 $ la_linrx_ithresh_i = 2 )
480 parameter ( la_linrx_cwise_i = 3 )
481 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
483 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
484 parameter ( la_linrx_rcond_i = 3 )
488 LOGICAL ROWEQU, COLEQU, NOTRAN, IGNORE_CWISE
489 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE, N_NORMS,
491 REAL ANORM, RCOND_TMP, ILLRCOND_THRESH, ERR_LBND,
492 $ cwise_wrong, rthresh, unstable_thresh
498 INTRINSIC max, sqrt, transfer
503 REAL SLAMCH, CLANGB, CLA_GBRCOND_X, CLA_GBRCOND_C
505 INTEGER ILATRANS, ILAPREC
512 trans_type = ilatrans( trans )
513 ref_type = int( itref_default )
514 IF ( nparams .GE. la_linrx_itref_i )
THEN
515 IF ( params( la_linrx_itref_i ) .LT. 0.0 )
THEN
516 params( la_linrx_itref_i ) = itref_default
518 ref_type = params( la_linrx_itref_i )
524 illrcond_thresh =
REAL( N ) * SLAMCH(
'Epsilon' )
525 ithresh = int( ithresh_default )
526 rthresh = rthresh_default
527 unstable_thresh = dzthresh_default
528 ignore_cwise = componentwise_default .EQ. 0.0
530 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
531 IF ( params( la_linrx_ithresh_i ).LT.0.0 )
THEN
532 params( la_linrx_ithresh_i ) = ithresh
534 ithresh = int( params( la_linrx_ithresh_i ) )
537 IF ( nparams.GE.la_linrx_cwise_i )
THEN
538 IF ( params( la_linrx_cwise_i ).LT.0.0 )
THEN
539 IF ( ignore_cwise )
THEN
540 params( la_linrx_cwise_i ) = 0.0
542 params( la_linrx_cwise_i ) = 1.0
545 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
548 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
550 ELSE IF ( ignore_cwise )
THEN
556 notran = lsame( trans,
'N' )
557 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
558 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
562 IF( trans_type.EQ.-1 )
THEN
564 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
565 $ .NOT.lsame( equed,
'N' ) )
THEN
567 ELSE IF( n.LT.0 )
THEN
569 ELSE IF( kl.LT.0 )
THEN
571 ELSE IF( ku.LT.0 )
THEN
573 ELSE IF( nrhs.LT.0 )
THEN
575 ELSE IF( ldab.LT.kl+ku+1 )
THEN
577 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
579 ELSE IF( ldb.LT.max( 1, n ) )
THEN
581 ELSE IF( ldx.LT.max( 1, n ) )
THEN
585 CALL xerbla(
'CGBRFSX', -info )
591 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
595 IF ( n_err_bnds .GE. 1 )
THEN
596 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
597 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
599 IF ( n_err_bnds .GE. 2 )
THEN
600 err_bnds_norm( j, la_linrx_err_i ) = 0.0
601 err_bnds_comp( j, la_linrx_err_i ) = 0.0
603 IF ( n_err_bnds .GE. 3 )
THEN
604 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
605 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
616 IF ( n_err_bnds .GE. 1 )
THEN
617 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
618 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
620 IF ( n_err_bnds .GE. 2 )
THEN
621 err_bnds_norm( j, la_linrx_err_i ) = 1.0
622 err_bnds_comp( j, la_linrx_err_i ) = 1.0
624 IF ( n_err_bnds .GE. 3 )
THEN
625 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
626 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
638 anorm = clangb( norm, n, kl, ku, ab, ldab, rwork )
639 CALL cgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,
640 $ work, rwork, info )
644 IF ( ref_type .NE. 0 .AND. info .EQ. 0 )
THEN
646 prec_type = ilaprec(
'D' )
650 $ nrhs, ab, ldab, afb, ldafb, ipiv, colequ, c, b,
651 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
652 $ err_bnds_comp, work, rwork, work(n+1),
653 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
654 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
658 $ nrhs, ab, ldab, afb, ldafb, ipiv, rowequ, r, b,
659 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
660 $ err_bnds_comp, work, rwork, work(n+1),
661 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
662 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
667 err_lbnd = max( 10.0, sqrt(
REAL( N ) ) ) * slamch(
'Epsilon' )
668 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 1)
THEN
672 IF ( colequ .AND. notran )
THEN
673 rcond_tmp = cla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,
674 $ ldafb, ipiv, c, .true., info, work, rwork )
675 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
676 rcond_tmp = cla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,
677 $ ldafb, ipiv, r, .true., info, work, rwork )
679 rcond_tmp = cla_gbrcond_c( trans, n, kl, ku, ab, ldab, afb,
680 $ ldafb, ipiv, c, .false., info, work, rwork )
686 IF ( n_err_bnds .GE. la_linrx_err_i
687 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0)
688 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
692 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
693 err_bnds_norm( j, la_linrx_err_i ) = 1.0
694 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
695 IF ( info .LE. n ) info = n + j
696 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
698 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
699 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
704 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
705 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
711 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 2)
THEN
721 cwise_wrong = sqrt( slamch(
'Epsilon' ) )
723 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
725 rcond_tmp = cla_gbrcond_x( trans, n, kl, ku, ab, ldab,
726 $ afb, ldafb, ipiv, x( 1, j ), info, work, rwork )
733 IF ( n_err_bnds .GE. la_linrx_err_i
734 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
735 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
739 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
740 err_bnds_comp( j, la_linrx_err_i ) = 1.0
741 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
742 IF ( params( la_linrx_cwise_i ) .EQ. 1.0
743 $ .AND. info.LT.n + j ) info = n + j
744 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
745 $ .LT. err_lbnd )
THEN
746 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
747 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
752 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
753 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
subroutine cla_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)
CLA_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general banded...
subroutine cgbrfsx(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)
CGBRFSX
integer function ilatrans(TRANS)
ILATRANS
real function cla_gbrcond_x(TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, X, INFO, WORK, RWORK)
CLA_GBRCOND_X computes the infinity norm condition number of op(A)*diag(x) for general banded matrice...
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine cgbcon(NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, RWORK, INFO)
CGBCON
real function slamch(CMACH)
SLAMCH
real function clangb(NORM, N, KL, KU, AB, LDAB, WORK)
CLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
real function cla_gbrcond_c(TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, C, CAPPLY, INFO, WORK, RWORK)
CLA_GBRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for general banded ma...