437 SUBROUTINE dgbrfsx( 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, iwork,
449 CHARACTER TRANS, EQUED
450 INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
451 $ nparams, n_err_bnds
452 DOUBLE PRECISION RCOND
455 INTEGER IPIV( * ), IWORK( * )
456 DOUBLE PRECISION AB( ldab, * ), AFB( ldafb, * ), B( ldb, * ),
457 $ x( ldx , * ),work( * )
458 DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
459 $ err_bnds_norm( nrhs, * ),
460 $ err_bnds_comp( nrhs, * )
466 DOUBLE PRECISION ZERO, ONE
467 parameter( zero = 0.0d+0, one = 1.0d+0 )
468 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
469 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
470 DOUBLE PRECISION DZTHRESH_DEFAULT
471 parameter( itref_default = 1.0d+0 )
472 parameter( ithresh_default = 10.0d+0 )
473 parameter( componentwise_default = 1.0d+0 )
474 parameter( rthresh_default = 0.5d+0 )
475 parameter( dzthresh_default = 0.25d+0 )
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
489 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE
491 DOUBLE PRECISION ANORM, RCOND_TMP
492 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
495 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
507 DOUBLE PRECISION DLAMCH, DLANGB, DLA_GBRCOND
509 INTEGER BLAS_FPINFO_X
510 INTEGER ILATRANS, ILAPREC
517 trans_type = ilatrans( trans )
518 ref_type = int( itref_default )
519 IF ( nparams .GE. la_linrx_itref_i )
THEN
520 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
521 params( la_linrx_itref_i ) = itref_default
523 ref_type = params( la_linrx_itref_i )
529 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
530 ithresh = int( ithresh_default )
531 rthresh = rthresh_default
532 unstable_thresh = dzthresh_default
533 ignore_cwise = componentwise_default .EQ. 0.0d+0
535 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
536 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
537 params( la_linrx_ithresh_i ) = ithresh
539 ithresh = int( params( la_linrx_ithresh_i ) )
542 IF ( nparams.GE.la_linrx_cwise_i )
THEN
543 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 )
THEN
544 IF ( ignore_cwise )
THEN
545 params( la_linrx_cwise_i ) = 0.0d+0
547 params( la_linrx_cwise_i ) = 1.0d+0
550 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
553 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
555 ELSE IF ( ignore_cwise )
THEN
561 notran = lsame( trans,
'N' )
562 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
563 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
567 IF( trans_type.EQ.-1 )
THEN
569 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
570 $ .NOT.lsame( equed,
'N' ) )
THEN
572 ELSE IF( n.LT.0 )
THEN
574 ELSE IF( kl.LT.0 )
THEN
576 ELSE IF( ku.LT.0 )
THEN
578 ELSE IF( nrhs.LT.0 )
THEN
580 ELSE IF( ldab.LT.kl+ku+1 )
THEN
582 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
584 ELSE IF( ldb.LT.max( 1, n ) )
THEN
586 ELSE IF( ldx.LT.max( 1, n ) )
THEN
590 CALL xerbla(
'DGBRFSX', -info )
596 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
600 IF ( n_err_bnds .GE. 1 )
THEN
601 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
602 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
604 IF ( n_err_bnds .GE. 2 )
THEN
605 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
606 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
608 IF ( n_err_bnds .GE. 3 )
THEN
609 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
610 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
621 IF ( n_err_bnds .GE. 1 )
THEN
622 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
623 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
625 IF ( n_err_bnds .GE. 2 )
THEN
626 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
627 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
629 IF ( n_err_bnds .GE. 3 )
THEN
630 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
631 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
643 anorm = dlangb( norm, n, kl, ku, ab, ldab, work )
644 CALL dgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,
645 $ work, iwork, info )
649 IF (ref_type .NE. 0)
THEN
651 prec_type = ilaprec(
'E' )
655 $ nrhs, ab, ldab, afb, ldafb, ipiv, colequ, c, b,
656 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
657 $ err_bnds_comp, work( n+1 ), work( 1 ), work( 2*n+1 ),
658 $ work( 1 ), rcond, ithresh, rthresh, unstable_thresh,
659 $ ignore_cwise, info )
662 $ nrhs, ab, ldab, afb, ldafb, ipiv, rowequ, r, b,
663 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
664 $ err_bnds_comp, work( n+1 ), work( 1 ), work( 2*n+1 ),
665 $ work( 1 ), rcond, ithresh, rthresh, unstable_thresh,
666 $ ignore_cwise, info )
670 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
671 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
675 IF ( colequ .AND. notran )
THEN
676 rcond_tmp = dla_gbrcond( trans, n, kl, ku, ab, ldab, afb,
677 $ ldafb, ipiv, -1, c, info, work, iwork )
678 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
679 rcond_tmp = dla_gbrcond( trans, n, kl, ku, ab, ldab, afb,
680 $ ldafb, ipiv, -1, r, info, work, iwork )
682 rcond_tmp = dla_gbrcond( trans, n, kl, ku, ab, ldab, afb,
683 $ ldafb, ipiv, 0, r, info, work, iwork )
689 IF ( n_err_bnds .GE. la_linrx_err_i
690 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0 )
691 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
695 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
696 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
697 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
698 IF ( info .LE. n ) info = n + j
699 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
701 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
702 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
707 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
708 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
714 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 2)
THEN
724 cwise_wrong = sqrt( dlamch(
'Epsilon' ) )
726 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
728 rcond_tmp = dla_gbrcond( trans, n, kl, ku, ab, ldab, afb,
729 $ ldafb, ipiv, 1, x( 1, j ), info, work, iwork )
736 IF ( n_err_bnds .GE. la_linrx_err_i
737 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0d+0 )
738 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
742 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
743 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
744 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
745 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+0
746 $ .AND. info.LT.n + j ) info = n + j
747 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
748 $ .LT. err_lbnd )
THEN
749 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
750 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
755 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
756 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
integer function ilatrans(TRANS)
ILATRANS
subroutine dla_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)
DLA_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general banded...
subroutine xerbla(SRNAME, INFO)
XERBLA
double precision function dlangb(NORM, N, KL, KU, AB, LDAB, WORK)
DLANGB returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
logical function lsame(CA, CB)
LSAME
integer function ilaprec(PREC)
ILAPREC
subroutine dgbcon(NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND, WORK, IWORK, INFO)
DGBCON
double precision function dlamch(CMACH)
DLAMCH
double precision function dla_gbrcond(TRANS, N, KL, KU, AB, LDAB, AFB, LDAFB, IPIV, CMODE, C, INFO, WORK, IWORK)
DLA_GBRCOND estimates the Skeel condition number for a general banded matrix.
subroutine dgbrfsx(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, IWORK, INFO)
DGBRFSX