392 SUBROUTINE dporfsx( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B,
393 $ ldb, x, ldx, rcond, berr, n_err_bnds,
394 $ err_bnds_norm, err_bnds_comp, nparams, params,
395 $ work, iwork, info )
403 CHARACTER UPLO, EQUED
404 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
406 DOUBLE PRECISION RCOND
410 DOUBLE PRECISION A( lda, * ), AF( ldaf, * ), B( ldb, * ),
411 $ x( ldx, * ), work( * )
412 DOUBLE PRECISION S( * ), PARAMS( * ), BERR( * ),
413 $ err_bnds_norm( nrhs, * ),
414 $ err_bnds_comp( nrhs, * )
420 DOUBLE PRECISION ZERO, ONE
421 parameter ( zero = 0.0d+0, one = 1.0d+0 )
422 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
423 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
424 DOUBLE PRECISION DZTHRESH_DEFAULT
425 parameter ( itref_default = 1.0d+0 )
426 parameter ( ithresh_default = 10.0d+0 )
427 parameter ( componentwise_default = 1.0d+0 )
428 parameter ( rthresh_default = 0.5d+0 )
429 parameter ( dzthresh_default = 0.25d+0 )
430 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
432 parameter ( la_linrx_itref_i = 1,
433 $ la_linrx_ithresh_i = 2 )
434 parameter ( la_linrx_cwise_i = 3 )
435 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
437 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
438 parameter ( la_linrx_rcond_i = 3 )
443 INTEGER J, PREC_TYPE, REF_TYPE
445 DOUBLE PRECISION ANORM, RCOND_TMP
446 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
449 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
460 DOUBLE PRECISION DLAMCH, DLANSY, DLA_PORCOND
469 ref_type = int( itref_default )
470 IF ( nparams .GE. la_linrx_itref_i )
THEN
471 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
472 params( la_linrx_itref_i ) = itref_default
474 ref_type = params( la_linrx_itref_i )
480 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
481 ithresh = int( ithresh_default )
482 rthresh = rthresh_default
483 unstable_thresh = dzthresh_default
484 ignore_cwise = componentwise_default .EQ. 0.0d+0
486 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
487 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
488 params( la_linrx_ithresh_i ) = ithresh
490 ithresh = int( params( la_linrx_ithresh_i ) )
493 IF ( nparams.GE.la_linrx_cwise_i )
THEN
494 IF ( params( la_linrx_cwise_i ).LT.0.0d+0 )
THEN
495 IF ( ignore_cwise )
THEN
496 params( la_linrx_cwise_i ) = 0.0d+0
498 params( la_linrx_cwise_i ) = 1.0d+0
501 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
504 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
506 ELSE IF ( ignore_cwise )
THEN
512 rcequ = lsame( equed,
'Y' )
516 IF (.NOT.lsame(uplo,
'U') .AND. .NOT.lsame(uplo,
'L'))
THEN
518 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed,
'N' ) )
THEN
520 ELSE IF( n.LT.0 )
THEN
522 ELSE IF( nrhs.LT.0 )
THEN
524 ELSE IF( lda.LT.max( 1, n ) )
THEN
526 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
528 ELSE IF( ldb.LT.max( 1, n ) )
THEN
530 ELSE IF( ldx.LT.max( 1, n ) )
THEN
534 CALL xerbla(
'DPORFSX', -info )
540 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
544 IF ( n_err_bnds .GE. 1 )
THEN
545 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
546 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
548 IF ( n_err_bnds .GE. 2 )
THEN
549 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
550 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
552 IF ( n_err_bnds .GE. 3 )
THEN
553 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
554 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
565 IF ( n_err_bnds .GE. 1 )
THEN
566 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
567 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
569 IF ( n_err_bnds .GE. 2 )
THEN
570 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
571 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
573 IF ( n_err_bnds .GE. 3 )
THEN
574 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
575 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
583 anorm = dlansy( norm, uplo, n, a, lda, work )
584 CALL dpocon( uplo, n, af, ldaf, anorm, rcond, work,
589 IF ( ref_type .NE. 0 )
THEN
591 prec_type = ilaprec(
'E' )
594 $ nrhs, a, lda, af, ldaf, rcequ, s, b,
595 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
596 $ work( n+1 ), work( 1 ), work( 2*n+1 ), work( 1 ), rcond,
597 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
601 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
602 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
607 rcond_tmp = dla_porcond( uplo, n, a, lda, af, ldaf,
608 $ -1, s, info, work, iwork )
610 rcond_tmp = dla_porcond( uplo, n, a, lda, af, ldaf,
611 $ 0, s, info, work, iwork )
617 IF ( n_err_bnds .GE. la_linrx_err_i
618 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0 )
619 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
623 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
624 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
625 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
626 IF ( info .LE. n ) info = n + j
627 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
629 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
630 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
635 IF (n_err_bnds .GE. la_linrx_rcond_i)
THEN
636 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
641 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
651 cwise_wrong = sqrt( dlamch(
'Epsilon' ) )
653 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
655 rcond_tmp = dla_porcond( uplo, n, a, lda, af, ldaf, 1,
656 $ x( 1, j ), info, work, iwork )
663 IF ( n_err_bnds .GE. la_linrx_err_i
664 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0d+0 )
665 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
669 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
670 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
671 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
672 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+0
673 $ .AND. info.LT.n + j ) info = n + j
674 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
675 $ .LT. err_lbnd )
THEN
676 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
677 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
682 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
683 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
double precision function dlamch(CMACH)
DLAMCH
double precision function dla_porcond(UPLO, N, A, LDA, AF, LDAF, CMODE, C, INFO, WORK, IWORK)
DLA_PORCOND estimates the Skeel condition number for a symmetric positive-definite matrix...
double precision function dlansy(NORM, UPLO, N, A, LDA, WORK)
DLANSY returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a real symmetric matrix.
subroutine dla_porfsx_extended(PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, COLEQU, C, B, LDB, Y, LDY, BERR_OUT, N_NORMS, ERR_BNDS_NORM, ERR_BNDS_COMP, RES, AYB, DY, Y_TAIL, RCOND, ITHRESH, RTHRESH, DZ_UB, IGNORE_CWISE, INFO)
DLA_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric or H...
subroutine dpocon(UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK, INFO)
DPOCON
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
subroutine dporfsx(UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, IWORK, INFO)
DPORFSX