399 SUBROUTINE cherfsx( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV,
400 $ s, b, ldb, x, ldx, rcond, berr, n_err_bnds,
401 $ err_bnds_norm, err_bnds_comp, nparams, params,
402 $ work, rwork, info )
410 CHARACTER UPLO, EQUED
411 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
417 COMPLEX A( lda, * ), AF( ldaf, * ), B( ldb, * ),
418 $ x( ldx, * ), work( * )
419 REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ),
420 $ err_bnds_norm( nrhs, * ),
421 $ err_bnds_comp( nrhs, * )
427 parameter ( zero = 0.0e+0, one = 1.0e+0 )
428 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
429 $ componentwise_default
430 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
431 parameter ( itref_default = 1.0 )
432 parameter ( ithresh_default = 10.0 )
433 parameter ( componentwise_default = 1.0 )
434 parameter ( rthresh_default = 0.5 )
435 parameter ( dzthresh_default = 0.25 )
436 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
438 parameter ( la_linrx_itref_i = 1,
439 $ la_linrx_ithresh_i = 2 )
440 parameter ( la_linrx_cwise_i = 3 )
441 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
443 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
444 parameter ( la_linrx_rcond_i = 3 )
449 INTEGER J, PREC_TYPE, REF_TYPE
451 REAL ANORM, RCOND_TMP
452 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
455 REAL RTHRESH, UNSTABLE_THRESH
461 INTRINSIC max, sqrt, transfer
466 REAL SLAMCH, CLANHE, CLA_HERCOND_X, CLA_HERCOND_C
475 ref_type = int( itref_default )
476 IF ( nparams .GE. la_linrx_itref_i )
THEN
477 IF ( params( la_linrx_itref_i ) .LT. 0.0 )
THEN
478 params( la_linrx_itref_i ) = itref_default
480 ref_type = params( la_linrx_itref_i )
486 illrcond_thresh =
REAL( N ) * SLAMCH(
'Epsilon' )
487 ithresh = int( ithresh_default )
488 rthresh = rthresh_default
489 unstable_thresh = dzthresh_default
490 ignore_cwise = componentwise_default .EQ. 0.0
492 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
493 IF ( params( la_linrx_ithresh_i ).LT.0.0 )
THEN
494 params( la_linrx_ithresh_i ) = ithresh
496 ithresh = int( params( la_linrx_ithresh_i ) )
499 IF ( nparams.GE.la_linrx_cwise_i )
THEN
500 IF ( params(la_linrx_cwise_i ).LT.0.0 )
THEN
501 IF ( ignore_cwise )
THEN
502 params( la_linrx_cwise_i ) = 0.0
504 params( la_linrx_cwise_i ) = 1.0
507 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
510 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
512 ELSE IF ( ignore_cwise )
THEN
518 rcequ = lsame( equed,
'Y' )
522 IF (.NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
524 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed,
'N' ) )
THEN
526 ELSE IF( n.LT.0 )
THEN
528 ELSE IF( nrhs.LT.0 )
THEN
530 ELSE IF( lda.LT.max( 1, n ) )
THEN
532 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
534 ELSE IF( ldb.LT.max( 1, n ) )
THEN
536 ELSE IF( ldx.LT.max( 1, n ) )
THEN
540 CALL xerbla(
'CHERFSX', -info )
546 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
550 IF ( n_err_bnds .GE. 1 )
THEN
551 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
552 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
554 IF ( n_err_bnds .GE. 2 )
THEN
555 err_bnds_norm( j, la_linrx_err_i ) = 0.0
556 err_bnds_comp( j, la_linrx_err_i ) = 0.0
558 IF ( n_err_bnds .GE. 3 )
THEN
559 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
560 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
571 IF ( n_err_bnds .GE. 1 )
THEN
572 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
573 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
575 IF ( n_err_bnds .GE. 2 )
THEN
576 err_bnds_norm( j, la_linrx_err_i ) = 1.0
577 err_bnds_comp( j, la_linrx_err_i ) = 1.0
579 IF ( n_err_bnds .GE. 3 )
THEN
580 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
581 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
589 anorm = clanhe( norm, uplo, n, a, lda, rwork )
590 CALL checon( uplo, n, af, ldaf, ipiv, anorm, rcond, work,
595 IF ( ref_type .NE. 0 )
THEN
597 prec_type = ilaprec(
'D' )
600 $ nrhs, a, lda, af, ldaf, ipiv, rcequ, s, b,
601 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
602 $ work, rwork, work(n+1),
603 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n), rcond,
604 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
608 err_lbnd = max( 10.0, sqrt(
REAL( N ) ) ) * slamch(
'Epsilon' )
609 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
614 rcond_tmp = cla_hercond_c( uplo, n, a, lda, af, ldaf, ipiv,
615 $ s, .true., info, work, rwork )
617 rcond_tmp = cla_hercond_c( uplo, n, a, lda, af, ldaf, ipiv,
618 $ s, .false., info, work, rwork )
624 IF ( n_err_bnds .GE. la_linrx_err_i
625 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
626 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
630 IF (rcond_tmp .LT. illrcond_thresh)
THEN
631 err_bnds_norm( j, la_linrx_err_i ) = 1.0
632 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
633 IF ( info .LE. n ) info = n + j
634 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
636 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
637 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
642 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
643 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
648 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
658 cwise_wrong = sqrt( slamch(
'Epsilon' ) )
660 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
662 rcond_tmp = cla_hercond_x( uplo, n, a, lda, af, ldaf,
663 $ ipiv, x( 1, j ), info, work, rwork )
670 IF ( n_err_bnds .GE. la_linrx_err_i
671 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
672 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
676 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
677 err_bnds_comp( j, la_linrx_err_i ) = 1.0
678 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
679 IF ( .NOT. ignore_cwise
680 $ .AND. info.LT.n + j ) info = n + j
681 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
682 $ .LT. err_lbnd )
THEN
683 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
684 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
689 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
690 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
real function cla_hercond_c(UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK)
CLA_HERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian indefin...
real function cla_hercond_x(UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK)
CLA_HERCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian indefinite m...
subroutine cla_herfsx_extended(PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, 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)
CLA_HERFSX_EXTENDED improves the computed solution to a system of linear equations for Hermitian inde...
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
subroutine cherfsx(UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV, S, B, LDB, X, LDX, RCOND, BERR, N_ERR_BNDS, ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS, WORK, RWORK, INFO)
CHERFSX
real function clanhe(NORM, UPLO, N, A, LDA, WORK)
CLANHE returns the value of the 1-norm, or the Frobenius norm, or the infinity norm, or the element of largest absolute value of a complex Hermitian matrix.
subroutine checon(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
CHECON