437 SUBROUTINE zgbrfsx( 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
452 DOUBLE PRECISION rcond
456 COMPLEX*16 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, * ), rwork( * )
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, ignore_cwise
489 INTEGER j, trans_type, prec_type, ref_type, n_norms,
491 DOUBLE PRECISION anorm, rcond_tmp, illrcond_thresh, err_lbnd,
492 $ cwise_wrong, rthresh, unstable_thresh
498 INTRINSIC max, sqrt, transfer
505 INTEGER blas_fpinfo_x
514 ref_type = int( itref_default )
515 IF ( nparams .GE. la_linrx_itref_i )
THEN
516 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
517 params( la_linrx_itref_i ) = itref_default
519 ref_type = params( la_linrx_itref_i )
525 illrcond_thresh = dble( n ) *
dlamch(
'Epsilon' )
526 ithresh = int( ithresh_default )
527 rthresh = rthresh_default
528 unstable_thresh = dzthresh_default
529 ignore_cwise = componentwise_default .EQ. 0.0d+0
531 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
532 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
533 params( la_linrx_ithresh_i ) = ithresh
535 ithresh = int( params( la_linrx_ithresh_i ) )
538 IF ( nparams.GE.la_linrx_cwise_i )
THEN
539 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 )
THEN
540 IF ( ignore_cwise )
THEN
541 params( la_linrx_cwise_i ) = 0.0d+0
543 params( la_linrx_cwise_i ) = 1.0d+0
546 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
549 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
551 ELSE IF ( ignore_cwise )
THEN
557 notran =
lsame( trans,
'N' )
558 rowequ =
lsame( equed,
'R' ) .OR.
lsame( equed,
'B' )
559 colequ =
lsame( equed,
'C' ) .OR.
lsame( equed,
'B' )
563 IF( trans_type.EQ.-1 )
THEN
565 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
566 $ .NOT.
lsame( equed,
'N' ) )
THEN
568 ELSE IF( n.LT.0 )
THEN
570 ELSE IF( kl.LT.0 )
THEN
572 ELSE IF( ku.LT.0 )
THEN
574 ELSE IF( nrhs.LT.0 )
THEN
576 ELSE IF( ldab.LT.kl+ku+1 )
THEN
578 ELSE IF( ldafb.LT.2*kl+ku+1 )
THEN
580 ELSE IF( ldb.LT.max( 1, n ) )
THEN
582 ELSE IF( ldx.LT.max( 1, n ) )
THEN
586 CALL
xerbla(
'ZGBRFSX', -info )
592 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
596 IF ( n_err_bnds .GE. 1 )
THEN
597 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
598 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
600 IF ( n_err_bnds .GE. 2 )
THEN
601 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
602 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
604 IF ( n_err_bnds .GE. 3 )
THEN
605 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
606 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
617 IF ( n_err_bnds .GE. 1 )
THEN
618 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
619 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
621 IF ( n_err_bnds .GE. 2 )
THEN
622 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
623 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
625 IF ( n_err_bnds .GE. 3 )
THEN
626 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
627 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
639 anorm =
zlangb( norm, n, kl, ku, ab, ldab, rwork )
640 CALL
zgbcon( norm, n, kl, ku, afb, ldafb, ipiv, anorm, rcond,
641 $ work, rwork, info )
645 IF ( ref_type .NE. 0 )
THEN
651 $ nrhs, ab, ldab, afb, ldafb, ipiv, colequ, c, b,
652 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
653 $ err_bnds_comp, work, rwork, work(n+1),
654 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
655 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
659 $ nrhs, ab, ldab, afb, ldafb, ipiv, rowequ, r, b,
660 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
661 $ err_bnds_comp, work, rwork, work(n+1),
662 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
663 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
668 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) *
dlamch(
'Epsilon' )
669 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 1)
THEN
673 IF ( colequ .AND. notran )
THEN
675 $ ldafb, ipiv, c, .true., info, work, rwork )
676 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
678 $ ldafb, ipiv, r, .true., info, work, rwork )
681 $ ldafb, ipiv, c, .false., info, work, rwork )
687 IF ( n_err_bnds .GE. la_linrx_err_i
688 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0)
689 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
693 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
694 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
695 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
696 IF ( info .LE. n ) info = n + j
697 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
699 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
700 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
705 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
706 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
712 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 2)
THEN
722 cwise_wrong = sqrt(
dlamch(
'Epsilon' ) )
724 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
727 $ afb, ldafb, ipiv, x( 1, j ), info, work, rwork )
734 IF ( n_err_bnds .GE. la_linrx_err_i
735 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0d+0 )
736 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
740 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
741 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
742 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
743 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+0
744 $ .AND. info.LT.n + j ) info = n + j
745 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
746 $ .LT. err_lbnd )
THEN
747 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
748 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
753 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
754 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp