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 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.0d+0 )
THEN
494 params( la_linrx_itref_i ) = itref_default
496 ref_type = params( la_linrx_itref_i )
502 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
503 ithresh = int( ithresh_default )
504 rthresh = rthresh_default
505 unstable_thresh = dzthresh_default
506 ignore_cwise = componentwise_default .EQ. 0.0d+0
508 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
509 IF ( params( la_linrx_ithresh_i ).LT.0.0d+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.0d+0 )
THEN
517 IF ( ignore_cwise )
THEN
518 params( la_linrx_cwise_i ) = 0.0d+0
520 params( la_linrx_cwise_i ) = 1.0d+0
523 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+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(
'DGERFSX', -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.0d+0
571 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
573 IF ( n_err_bnds .GE. 2 )
THEN
574 err_bnds_norm( j, la_linrx_err_i) = 0.0d+0
575 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
577 IF ( n_err_bnds .GE. 3 )
THEN
578 err_bnds_norm( j, la_linrx_rcond_i) = 1.0d+0
579 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
590 IF ( n_err_bnds .GE. 1 )
THEN
591 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
592 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
594 IF ( n_err_bnds .GE. 2 )
THEN
595 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
596 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
598 IF ( n_err_bnds .GE. 3 )
THEN
599 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
600 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
612 anorm = dlange( norm, n, n, a, lda, work )
613 CALL dgecon( norm, n, af, ldaf, anorm, rcond, work, iwork, info )
617 IF ( ref_type .NE. 0 )
THEN
619 prec_type = ilaprec(
'E' )
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.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
639 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
643 IF ( colequ .AND. notran )
THEN
644 rcond_tmp = dla_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 = dla_gercond( trans, n, a, lda, af, ldaf, ipiv,
648 $ -1, r, info, work, iwork )
650 rcond_tmp = dla_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.0d+0 )
659 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
663 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
664 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
665 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+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.0d+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( dlamch(
'Epsilon' ) )
693 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
695 rcond_tmp = dla_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.0d+0 )
705 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
709 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
710 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
711 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
712 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+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.0d+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
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.
double precision function dlamch(CMACH)
DLAMCH
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...
subroutine xerbla(SRNAME, INFO)
XERBLA
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 ilaprec(PREC)
ILAPREC
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
logical function lsame(CA, CB)
LSAME