433 SUBROUTINE zgbrfsx( TRANS, EQUED, N, KL, KU, NRHS, AB, LDAB,
435 $ LDAFB, IPIV, R, C, B, LDB, X, LDX, RCOND,
436 $ BERR, N_ERR_BNDS, ERR_BNDS_NORM,
437 $ ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK,
445 CHARACTER TRANS, EQUED
446 INTEGER INFO, LDAB, LDAFB, LDB, LDX, N, KL, KU, NRHS,
447 $ NPARAMS, N_ERR_BNDS
448 DOUBLE PRECISION RCOND
452 COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
453 $ x( ldx , * ),work( * )
454 DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
455 $ ERR_BNDS_NORM( NRHS, * ),
456 $ err_bnds_comp( nrhs, * ), rwork( * )
462 DOUBLE PRECISION ZERO, ONE
463 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
464 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
465 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
466 DOUBLE PRECISION DZTHRESH_DEFAULT
467 parameter( itref_default = 1.0d+0 )
468 parameter( ithresh_default = 10.0d+0 )
469 parameter( componentwise_default = 1.0d+0 )
470 parameter( rthresh_default = 0.5d+0 )
471 parameter( dzthresh_default = 0.25d+0 )
472 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
474 parameter( la_linrx_itref_i = 1,
475 $ la_linrx_ithresh_i = 2 )
476 parameter( la_linrx_cwise_i = 3 )
477 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
479 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
480 parameter( la_linrx_rcond_i = 3 )
484 LOGICAL ROWEQU, COLEQU, NOTRAN, IGNORE_CWISE
485 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE, N_NORMS,
487 DOUBLE PRECISION ANORM, RCOND_TMP, ILLRCOND_THRESH, ERR_LBND,
488 $ cwise_wrong, rthresh, unstable_thresh
494 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' )
648 $ nrhs, ab, ldab, afb, ldafb, ipiv, colequ, c, b,
649 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
650 $ err_bnds_comp, work, rwork, work(n+1),
651 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
652 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
657 $ nrhs, ab, ldab, afb, ldafb, ipiv, rowequ, r, b,
658 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
659 $ err_bnds_comp, work, rwork, work(n+1),
660 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n),
661 $ rcond, ithresh, rthresh, unstable_thresh, ignore_cwise,
666 err_lbnd = max( 10.0d+0,
667 $ sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
668 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 1)
THEN
672 IF ( colequ .AND. notran )
THEN
673 rcond_tmp = zla_gbrcond_c( trans, n, kl, ku, ab, ldab,
675 $ ldafb, ipiv, c, .true., info, work, rwork )
676 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
677 rcond_tmp = zla_gbrcond_c( trans, n, kl, ku, ab, ldab,
679 $ ldafb, ipiv, r, .true., info, work, rwork )
681 rcond_tmp = zla_gbrcond_c( trans, n, kl, ku, ab, ldab,
683 $ ldafb, ipiv, c, .false., info, work, rwork )
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 = zla_gbrcond_x( trans, n, kl, ku, ab, ldab,
729 $ afb, ldafb, ipiv, x( 1, j ), info, work, rwork )
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