412 SUBROUTINE dgerfsx( 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,
426 DOUBLE PRECISION RCOND
429 INTEGER IPIV( * ), IWORK( * )
430 DOUBLE PRECISION A( lda, * ), AF( ldaf, * ), B( ldb, * ),
431 $ x( ldx , * ), work( * )
432 DOUBLE PRECISION R( * ), C( * ), PARAMS( * ), BERR( * ),
433 $ err_bnds_norm( nrhs, * ),
434 $ err_bnds_comp( nrhs, * )
440 DOUBLE PRECISION ZERO, ONE
441 parameter ( zero = 0.0d+0, one = 1.0d+0 )
442 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
443 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
444 DOUBLE PRECISION DZTHRESH_DEFAULT
445 parameter ( itref_default = 1.0d+0 )
446 parameter ( ithresh_default = 10.0d+0 )
447 parameter ( componentwise_default = 1.0d+0 )
448 parameter ( rthresh_default = 0.5d+0 )
449 parameter ( dzthresh_default = 0.25d+0 )
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 DOUBLE PRECISION ANORM, RCOND_TMP
466 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
469 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
480 DOUBLE PRECISION DLAMCH, DLANGE, DLA_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.0d+0 )
THEN
493 params( la_linrx_itref_i ) = itref_default
495 ref_type = params( la_linrx_itref_i )
501 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
502 ithresh = int( ithresh_default )
503 rthresh = rthresh_default
504 unstable_thresh = dzthresh_default
505 ignore_cwise = componentwise_default .EQ. 0.0d+0
507 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
508 IF ( params( la_linrx_ithresh_i ).LT.0.0d+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.0d+0 )
THEN
516 IF ( ignore_cwise )
THEN
517 params( la_linrx_cwise_i ) = 0.0d+0
519 params( la_linrx_cwise_i ) = 1.0d+0
522 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+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(
'DGERFSX', -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.0d+0
570 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
572 IF ( n_err_bnds .GE. 2 )
THEN
573 err_bnds_norm( j, la_linrx_err_i) = 0.0d+0
574 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
576 IF ( n_err_bnds .GE. 3 )
THEN
577 err_bnds_norm( j, la_linrx_rcond_i) = 1.0d+0
578 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
589 IF ( n_err_bnds .GE. 1 )
THEN
590 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
591 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
593 IF ( n_err_bnds .GE. 2 )
THEN
594 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
595 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
597 IF ( n_err_bnds .GE. 3 )
THEN
598 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
599 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
611 anorm = dlange( norm, n, n, a, lda, work )
612 CALL dgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info )
616 IF ( ref_type .NE. 0 )
THEN
618 prec_type = ilaprec(
'E' )
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.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
638 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
642 IF ( colequ .AND. notran )
THEN
643 rcond_tmp = dla_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 = dla_gercond( trans, n, a, lda, af, ldaf, ipiv,
647 $ -1, r, info, work, iwork )
649 rcond_tmp = dla_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.0d+0 )
658 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
662 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
663 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
664 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+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.0d+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( dlamch(
'Epsilon' ) )
692 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
694 rcond_tmp = dla_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.0d+0 )
704 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
708 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
709 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
710 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
711 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+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.0d+0
721 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
722 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
double precision function dlamch(CMACH)
DLAMCH
double precision function dla_gercond(TRANS, N, A, LDA, AF, LDAF, IPIV, CMODE, C, INFO, WORK, IWORK)
DLA_GERCOND estimates the Skeel condition number for a general matrix.
subroutine dla_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)
DLA_GERFSX_EXTENDED improves the computed solution to a system of linear equations for general matric...
double precision function dlange(NORM, M, N, A, LDA, WORK)
DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
integer function ilatrans(TRANS)
ILATRANS
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine dgecon(NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
DGECON
subroutine dgerfsx(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)
DGERFSX