412 SUBROUTINE sgerfsx( TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV,
413 $ r, c, b, ldb, x, ldx, rcond, berr, n_err_bnds,
414 $ err_bnds_norm, err_bnds_comp, nparams, params,
415 $ work, iwork, info )
423 CHARACTER TRANS, EQUED
424 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
429 INTEGER IPIV( * ), IWORK( * )
430 REAL A( lda, * ), AF( ldaf, * ), B( ldb, * ),
431 $ x( ldx , * ), work( * )
432 REAL R( * ), C( * ), PARAMS( * ), BERR( * ),
433 $ err_bnds_norm( nrhs, * ),
434 $ err_bnds_comp( nrhs, * )
441 parameter ( zero = 0.0e+0, one = 1.0e+0 )
442 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
443 $ componentwise_default
444 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
445 parameter ( itref_default = 1.0 )
446 parameter ( ithresh_default = 10.0 )
447 parameter ( componentwise_default = 1.0 )
448 parameter ( rthresh_default = 0.5 )
449 parameter ( dzthresh_default = 0.25 )
450 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
452 parameter ( la_linrx_itref_i = 1,
453 $ la_linrx_ithresh_i = 2 )
454 parameter ( la_linrx_cwise_i = 3 )
455 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
457 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
458 parameter ( la_linrx_rcond_i = 3 )
462 LOGICAL ROWEQU, COLEQU, NOTRAN
463 INTEGER J, TRANS_TYPE, PREC_TYPE, REF_TYPE
465 REAL ANORM, RCOND_TMP
466 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
469 REAL RTHRESH, UNSTABLE_THRESH
480 REAL SLAMCH, SLANGE, SLA_GERCOND
482 INTEGER ILATRANS, ILAPREC
489 trans_type = ilatrans( trans )
490 ref_type = int( itref_default )
491 IF ( nparams .GE. la_linrx_itref_i )
THEN
492 IF ( params( la_linrx_itref_i ) .LT. 0.0 )
THEN
493 params( la_linrx_itref_i ) = itref_default
495 ref_type = params( la_linrx_itref_i )
501 illrcond_thresh =
REAL( N ) * SLAMCH(
'Epsilon' )
502 ithresh = int( ithresh_default )
503 rthresh = rthresh_default
504 unstable_thresh = dzthresh_default
505 ignore_cwise = componentwise_default .EQ. 0.0
507 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
508 IF ( params( la_linrx_ithresh_i ).LT.0.0 )
THEN
509 params( la_linrx_ithresh_i ) = ithresh
511 ithresh = int( params( la_linrx_ithresh_i ) )
514 IF ( nparams.GE.la_linrx_cwise_i )
THEN
515 IF ( params( la_linrx_cwise_i ).LT.0.0 )
THEN
516 IF ( ignore_cwise )
THEN
517 params( la_linrx_cwise_i ) = 0.0
519 params( la_linrx_cwise_i ) = 1.0
522 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
525 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
527 ELSE IF ( ignore_cwise )
THEN
533 notran = lsame( trans,
'N' )
534 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
535 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
539 IF( trans_type.EQ.-1 )
THEN
541 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
542 $ .NOT.lsame( equed,
'N' ) )
THEN
544 ELSE IF( n.LT.0 )
THEN
546 ELSE IF( nrhs.LT.0 )
THEN
548 ELSE IF( lda.LT.max( 1, n ) )
THEN
550 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
552 ELSE IF( ldb.LT.max( 1, n ) )
THEN
554 ELSE IF( ldx.LT.max( 1, n ) )
THEN
558 CALL xerbla(
'SGERFSX', -info )
564 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
568 IF ( n_err_bnds .GE. 1 )
THEN
569 err_bnds_norm( j, la_linrx_trust_i) = 1.0
570 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
572 IF ( n_err_bnds .GE. 2 )
THEN
573 err_bnds_norm( j, la_linrx_err_i) = 0.0
574 err_bnds_comp( j, la_linrx_err_i ) = 0.0
576 IF ( n_err_bnds .GE. 3 )
THEN
577 err_bnds_norm( j, la_linrx_rcond_i) = 1.0
578 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
589 IF ( n_err_bnds .GE. 1 )
THEN
590 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
591 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
593 IF ( n_err_bnds .GE. 2 )
THEN
594 err_bnds_norm( j, la_linrx_err_i ) = 1.0
595 err_bnds_comp( j, la_linrx_err_i ) = 1.0
597 IF ( n_err_bnds .GE. 3 )
THEN
598 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
599 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
611 anorm = slange( norm, n, n, a, lda, work )
612 CALL sgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info )
616 IF ( ref_type .NE. 0 )
THEN
618 prec_type = ilaprec(
'D' )
622 $ nrhs, a, lda, af, ldaf, ipiv, colequ, c, b,
623 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
624 $ err_bnds_comp, work(n+1), work(1), work(2*n+1),
625 $ work(1), rcond, ithresh, rthresh, unstable_thresh,
626 $ ignore_cwise, info )
629 $ nrhs, a, lda, af, ldaf, ipiv, rowequ, r, b,
630 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
631 $ err_bnds_comp, work(n+1), work(1), work(2*n+1),
632 $ work(1), rcond, ithresh, rthresh, unstable_thresh,
633 $ ignore_cwise, info )
637 err_lbnd = max( 10.0, sqrt(
REAL( N ) ) ) * slamch(
'Epsilon' )
638 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
642 IF ( colequ .AND. notran )
THEN
643 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf, ipiv,
644 $ -1, c, info, work, iwork )
645 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
646 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf, ipiv,
647 $ -1, r, info, work, iwork )
649 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf, ipiv,
650 $ 0, r, info, work, iwork )
656 IF ( n_err_bnds .GE. la_linrx_err_i
657 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
658 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
662 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
663 err_bnds_norm( j, la_linrx_err_i ) = 1.0
664 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
665 IF ( info .LE. n ) info = n + j
666 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
668 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
669 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
674 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
675 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
680 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
690 cwise_wrong = sqrt( slamch(
'Epsilon' ) )
692 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
694 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf,
695 $ ipiv, 1, x(1,j), info, work, iwork )
702 IF ( n_err_bnds .GE. la_linrx_err_i
703 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
704 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
708 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
709 err_bnds_comp( j, la_linrx_err_i ) = 1.0
710 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
711 IF ( params( la_linrx_cwise_i ) .EQ. 1.0
712 $ .AND. info.LT.n + j ) info = n + j
713 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
714 $ .LT. err_lbnd )
THEN
715 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
716 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
721 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
722 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
subroutine sgecon(NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
SGECON
real function sla_gercond(TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK)
SLA_GERCOND estimates the Skeel condition number for a general matrix.
integer function ilatrans(TRANS)
ILATRANS
real function slange(NORM, M, N, A, LDA, WORK)
SLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
subroutine sla_gerfsx_extended(PREC_TYPE, TRANS_TYPE, N, NRHS, A, LDA, AF, LDAF, IPIV, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERRS_N, ERRS_C, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO)
SLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matric...
subroutine sgerfsx(TRANS, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, R, C, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
SGERFSX