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 BLAS_FPINFO_X
483 INTEGER ILATRANS, ILAPREC
490 trans_type = ilatrans( trans )
491 ref_type = int( itref_default )
492 IF ( nparams .GE. la_linrx_itref_i )
THEN
493 IF ( params( la_linrx_itref_i ) .LT. 0.0 )
THEN
494 params( la_linrx_itref_i ) = itref_default
496 ref_type = params( la_linrx_itref_i )
502 illrcond_thresh =
REAL( N ) * SLAMCH(
'Epsilon' )
503 ithresh = int( ithresh_default )
504 rthresh = rthresh_default
505 unstable_thresh = dzthresh_default
506 ignore_cwise = componentwise_default .EQ. 0.0
508 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
509 IF ( params( la_linrx_ithresh_i ).LT.0.0 )
THEN
510 params( la_linrx_ithresh_i ) = ithresh
512 ithresh = int( params( la_linrx_ithresh_i ) )
515 IF ( nparams.GE.la_linrx_cwise_i )
THEN
516 IF ( params( la_linrx_cwise_i ).LT.0.0 )
THEN
517 IF ( ignore_cwise )
THEN
518 params( la_linrx_cwise_i ) = 0.0
520 params( la_linrx_cwise_i ) = 1.0
523 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
526 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
528 ELSE IF ( ignore_cwise )
THEN
534 notran = lsame( trans,
'N' )
535 rowequ = lsame( equed,
'R' ) .OR. lsame( equed,
'B' )
536 colequ = lsame( equed,
'C' ) .OR. lsame( equed,
'B' )
540 IF( trans_type.EQ.-1 )
THEN
542 ELSE IF( .NOT.rowequ .AND. .NOT.colequ .AND.
543 $ .NOT.lsame( equed,
'N' ) )
THEN
545 ELSE IF( n.LT.0 )
THEN
547 ELSE IF( nrhs.LT.0 )
THEN
549 ELSE IF( lda.LT.max( 1, n ) )
THEN
551 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
553 ELSE IF( ldb.LT.max( 1, n ) )
THEN
555 ELSE IF( ldx.LT.max( 1, n ) )
THEN
559 CALL xerbla(
'SGERFSX', -info )
565 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
569 IF ( n_err_bnds .GE. 1 )
THEN
570 err_bnds_norm( j, la_linrx_trust_i) = 1.0
571 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
573 IF ( n_err_bnds .GE. 2 )
THEN
574 err_bnds_norm( j, la_linrx_err_i) = 0.0
575 err_bnds_comp( j, la_linrx_err_i ) = 0.0
577 IF ( n_err_bnds .GE. 3 )
THEN
578 err_bnds_norm( j, la_linrx_rcond_i) = 1.0
579 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
590 IF ( n_err_bnds .GE. 1 )
THEN
591 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
592 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
594 IF ( n_err_bnds .GE. 2 )
THEN
595 err_bnds_norm( j, la_linrx_err_i ) = 1.0
596 err_bnds_comp( j, la_linrx_err_i ) = 1.0
598 IF ( n_err_bnds .GE. 3 )
THEN
599 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
600 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
612 anorm = slange( norm, n, n, a, lda, work )
613 CALL sgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info )
617 IF ( ref_type .NE. 0 )
THEN
619 prec_type = ilaprec(
'D' )
623 $ nrhs, a, lda, af, ldaf, ipiv, colequ, c, b,
624 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
625 $ err_bnds_comp, work(n+1), work(1), work(2*n+1),
626 $ work(1), rcond, ithresh, rthresh, unstable_thresh,
627 $ ignore_cwise, info )
630 $ nrhs, a, lda, af, ldaf, ipiv, rowequ, r, b,
631 $ ldb, x, ldx, berr, n_norms, err_bnds_norm,
632 $ err_bnds_comp, work(n+1), work(1), work(2*n+1),
633 $ work(1), rcond, ithresh, rthresh, unstable_thresh,
634 $ ignore_cwise, info )
638 err_lbnd = max( 10.0, sqrt(
REAL( N ) ) ) * slamch(
'Epsilon' )
639 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
643 IF ( colequ .AND. notran )
THEN
644 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf, ipiv,
645 $ -1, c, info, work, iwork )
646 ELSE IF ( rowequ .AND. .NOT. notran )
THEN
647 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf, ipiv,
648 $ -1, r, info, work, iwork )
650 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf, ipiv,
651 $ 0, r, info, work, iwork )
657 IF ( n_err_bnds .GE. la_linrx_err_i
658 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
659 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
663 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
664 err_bnds_norm( j, la_linrx_err_i ) = 1.0
665 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
666 IF ( info .LE. n ) info = n + j
667 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
669 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
670 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
675 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
676 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
681 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
691 cwise_wrong = sqrt( slamch(
'Epsilon' ) )
693 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
695 rcond_tmp = sla_gercond( trans, n, a, lda, af, ldaf,
696 $ ipiv, 1, x(1,j), info, work, iwork )
703 IF ( n_err_bnds .GE. la_linrx_err_i
704 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
705 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
709 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
710 err_bnds_comp( j, la_linrx_err_i ) = 1.0
711 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
712 IF ( params( la_linrx_cwise_i ) .EQ. 1.0
713 $ .AND. info.LT.n + j ) info = n + j
714 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
715 $ .LT. err_lbnd )
THEN
716 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
717 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
722 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
723 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
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 ...
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.
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
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
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...
integer function ilaprec(PREC)
ILAPREC
real function slamch(CMACH)
SLAMCH
subroutine sgecon(NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
SGECON