399 SUBROUTINE zherfsx( 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,
413 DOUBLE PRECISION rcond
417 COMPLEX*16 a( lda, * ), af( ldaf, * ),
b( ldb, * ),
418 $
x( ldx, * ), work( * )
419 DOUBLE PRECISION s( * ), params( * ), berr( * ), rwork( * ),
420 $ err_bnds_norm( nrhs, * ),
421 $ err_bnds_comp( nrhs, * )
426 DOUBLE PRECISION zero, one
427 parameter( zero = 0.0d+0, one = 1.0d+0 )
428 DOUBLE PRECISION itref_default, ithresh_default
429 DOUBLE PRECISION componentwise_default, rthresh_default
430 DOUBLE PRECISION dzthresh_default
431 parameter( itref_default = 1.0d+0 )
432 parameter( ithresh_default = 10.0d+0 )
433 parameter( componentwise_default = 1.0d+0 )
434 parameter( rthresh_default = 0.5d+0 )
435 parameter( dzthresh_default = 0.25d+0 )
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 DOUBLE PRECISION anorm, rcond_tmp
452 DOUBLE PRECISION illrcond_thresh, err_lbnd, cwise_wrong
455 DOUBLE PRECISION rthresh, unstable_thresh
461 INTRINSIC max, sqrt, transfer
468 INTEGER blas_fpinfo_x
476 ref_type = int( itref_default )
477 IF ( nparams .GE. la_linrx_itref_i )
THEN
478 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
479 params( la_linrx_itref_i ) = itref_default
481 ref_type = params( la_linrx_itref_i )
487 illrcond_thresh = dble( n ) *
dlamch(
'Epsilon' )
488 ithresh = int( ithresh_default )
489 rthresh = rthresh_default
490 unstable_thresh = dzthresh_default
491 ignore_cwise = componentwise_default .EQ. 0.0d+0
493 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
494 IF ( params( la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
495 params( la_linrx_ithresh_i ) = ithresh
497 ithresh = int( params( la_linrx_ithresh_i ) )
500 IF ( nparams.GE.la_linrx_cwise_i )
THEN
501 IF ( params(la_linrx_cwise_i ).LT.0.0d+0 )
THEN
502 IF ( ignore_cwise )
THEN
503 params( la_linrx_cwise_i ) = 0.0d+0
505 params( la_linrx_cwise_i ) = 1.0d+0
508 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
511 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
513 ELSE IF ( ignore_cwise )
THEN
519 rcequ =
lsame( equed,
'Y' )
523 IF (.NOT.
lsame( uplo,
'U' ) .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
525 ELSE IF( .NOT.rcequ .AND. .NOT.
lsame( equed,
'N' ) )
THEN
527 ELSE IF( n.LT.0 )
THEN
529 ELSE IF( nrhs.LT.0 )
THEN
531 ELSE IF( lda.LT.max( 1, n ) )
THEN
533 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
535 ELSE IF( ldb.LT.max( 1, n ) )
THEN
537 ELSE IF( ldx.LT.max( 1, n ) )
THEN
541 CALL
xerbla(
'ZHERFSX', -info )
547 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
551 IF ( n_err_bnds .GE. 1 )
THEN
552 err_bnds_norm(
j, la_linrx_trust_i ) = 1.0d+0
553 err_bnds_comp(
j, la_linrx_trust_i ) = 1.0d+0
555 IF ( n_err_bnds .GE. 2 )
THEN
556 err_bnds_norm(
j, la_linrx_err_i ) = 0.0d+0
557 err_bnds_comp(
j, la_linrx_err_i ) = 0.0d+0
559 IF ( n_err_bnds .GE. 3 )
THEN
560 err_bnds_norm(
j, la_linrx_rcond_i ) = 1.0d+0
561 err_bnds_comp(
j, la_linrx_rcond_i ) = 1.0d+0
572 IF ( n_err_bnds .GE. 1 )
THEN
573 err_bnds_norm(
j, la_linrx_trust_i ) = 1.0d+0
574 err_bnds_comp(
j, la_linrx_trust_i ) = 1.0d+0
576 IF ( n_err_bnds .GE. 2 )
THEN
577 err_bnds_norm(
j, la_linrx_err_i ) = 1.0d+0
578 err_bnds_comp(
j, la_linrx_err_i ) = 1.0d+0
580 IF ( n_err_bnds .GE. 3 )
THEN
581 err_bnds_norm(
j, la_linrx_rcond_i ) = 0.0d+0
582 err_bnds_comp(
j, la_linrx_rcond_i ) = 0.0d+0
590 anorm =
zlanhe( norm, uplo, n, a, lda, rwork )
591 CALL
zhecon( uplo, n, af, ldaf, ipiv, anorm, rcond, work,
596 IF ( ref_type .NE. 0 )
THEN
601 $ nrhs, a, lda, af, ldaf, ipiv, rcequ, s,
b,
602 $ ldb,
x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
603 $ work, rwork, work(n+1),
604 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n), rcond,
605 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
609 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) *
dlamch(
'Epsilon' )
610 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
616 $ s, .true., info, work, rwork )
619 $ s, .false., info, work, rwork )
625 IF ( n_err_bnds .GE. la_linrx_err_i
626 $ .AND. err_bnds_norm(
j, la_linrx_err_i ) .GT. 1.0d+0 )
627 $ err_bnds_norm(
j, la_linrx_err_i ) = 1.0d+0
631 IF (rcond_tmp .LT. illrcond_thresh)
THEN
632 err_bnds_norm(
j, la_linrx_err_i ) = 1.0d+0
633 err_bnds_norm(
j, la_linrx_trust_i ) = 0.0d+0
634 IF ( info .LE. n ) info = n +
j
635 ELSE IF ( err_bnds_norm(
j, la_linrx_err_i ) .LT. err_lbnd )
637 err_bnds_norm(
j, la_linrx_err_i ) = err_lbnd
638 err_bnds_norm(
j, la_linrx_trust_i ) = 1.0d+0
643 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
644 err_bnds_norm(
j, la_linrx_rcond_i ) = rcond_tmp
649 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
659 cwise_wrong = sqrt(
dlamch(
'Epsilon' ) )
661 IF ( err_bnds_comp(
j, la_linrx_err_i ) .LT. cwise_wrong )
664 $ ipiv,
x( 1,
j ), info, work, rwork )
671 IF ( n_err_bnds .GE. la_linrx_err_i
672 $ .AND. err_bnds_comp(
j, la_linrx_err_i ) .GT. 1.0d+0 )
673 $ err_bnds_comp(
j, la_linrx_err_i ) = 1.0d+0
677 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
678 err_bnds_comp(
j, la_linrx_err_i ) = 1.0d+0
679 err_bnds_comp(
j, la_linrx_trust_i ) = 0.0d+0
680 IF ( .NOT. ignore_cwise
681 $ .AND. info.LT.n +
j ) info = n +
j
682 ELSE IF ( err_bnds_comp(
j, la_linrx_err_i )
683 $ .LT. err_lbnd )
THEN
684 err_bnds_comp(
j, la_linrx_err_i ) = err_lbnd
685 err_bnds_comp(
j, la_linrx_trust_i ) = 1.0d+0
690 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
691 err_bnds_comp(
j, la_linrx_rcond_i ) = rcond_tmp
subroutine zhecon(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
ZHECON
LOGICAL function lsame(CA, CB)
LSAME
subroutine zherfsx(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)
ZHERFSX
DOUBLE PRECISION function zla_hercond_c(UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK)
ZLA_HERCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian indefin...
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zla_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)
ZLA_HERFSX_EXTENDED improves the computed solution to a system of linear equations for Hermitian inde...
DOUBLE PRECISION function zla_hercond_x(UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK)
ZLA_HERCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian indefinite m...
DOUBLE PRECISION function zlanhe(NORM, UPLO, N, A, LDA, WORK)
ZLANHE 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.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
INTEGER function ilatrans(TRANS)
ILATRANS
INTEGER function ilaprec(PREC)
ILAPREC