389 SUBROUTINE zporfsx( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B,
390 $ LDB, X, LDX, RCOND, BERR, N_ERR_BNDS,
391 $ ERR_BNDS_NORM, ERR_BNDS_COMP, NPARAMS, PARAMS,
392 $ WORK, RWORK, INFO )
399 CHARACTER UPLO, EQUED
400 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
402 DOUBLE PRECISION RCOND
405 COMPLEX*16 A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
406 $ X( LDX, * ), WORK( * )
407 DOUBLE PRECISION RWORK( * ), S( * ), PARAMS(*), BERR( * ),
408 $ err_bnds_norm( nrhs, * ),
409 $ err_bnds_comp( nrhs, * )
415 DOUBLE PRECISION ZERO, ONE
416 PARAMETER ( ZERO = 0.0d+0, one = 1.0d+0 )
417 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
418 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
419 DOUBLE PRECISION DZTHRESH_DEFAULT
420 parameter( itref_default = 1.0d+0 )
421 parameter( ithresh_default = 10.0d+0 )
422 parameter( componentwise_default = 1.0d+0 )
423 parameter( rthresh_default = 0.5d+0 )
424 parameter( dzthresh_default = 0.25d+0 )
425 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
427 parameter( la_linrx_itref_i = 1,
428 $ la_linrx_ithresh_i = 2 )
429 parameter( la_linrx_cwise_i = 3 )
430 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
432 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
433 parameter( la_linrx_rcond_i = 3 )
438 INTEGER J, PREC_TYPE, REF_TYPE
440 DOUBLE PRECISION ANORM, RCOND_TMP
441 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
444 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
450 INTRINSIC max, sqrt, transfer
455 DOUBLE PRECISION DLAMCH, ZLANHE, ZLA_PORCOND_X, ZLA_PORCOND_C
464 ref_type = int( itref_default )
465 IF ( nparams .GE. la_linrx_itref_i )
THEN
466 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
467 params( la_linrx_itref_i ) = itref_default
469 ref_type = params( la_linrx_itref_i )
475 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
476 ithresh = int( ithresh_default )
477 rthresh = rthresh_default
478 unstable_thresh = dzthresh_default
479 ignore_cwise = componentwise_default .EQ. 0.0d+0
481 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
482 IF ( params(la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
483 params( la_linrx_ithresh_i ) = ithresh
485 ithresh = int( params( la_linrx_ithresh_i ) )
488 IF ( nparams.GE.la_linrx_cwise_i )
THEN
489 IF ( params(la_linrx_cwise_i ).LT.0.0d+0 )
THEN
490 IF ( ignore_cwise )
THEN
491 params( la_linrx_cwise_i ) = 0.0d+0
493 params( la_linrx_cwise_i ) = 1.0d+0
496 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
499 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
501 ELSE IF ( ignore_cwise )
THEN
507 rcequ = lsame( equed,
'Y' )
511 IF (.NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
513 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed,
'N' ) )
THEN
515 ELSE IF( n.LT.0 )
THEN
517 ELSE IF( nrhs.LT.0 )
THEN
519 ELSE IF( lda.LT.max( 1, n ) )
THEN
521 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
523 ELSE IF( ldb.LT.max( 1, n ) )
THEN
525 ELSE IF( ldx.LT.max( 1, n ) )
THEN
529 CALL xerbla(
'ZPORFSX', -info )
535 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
539 IF ( n_err_bnds .GE. 1 )
THEN
540 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
541 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
543 IF ( n_err_bnds .GE. 2 )
THEN
544 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
545 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
547 IF ( n_err_bnds .GE. 3 )
THEN
548 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
549 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
560 IF ( n_err_bnds .GE. 1 )
THEN
561 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
562 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
564 IF ( n_err_bnds .GE. 2 )
THEN
565 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
566 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
568 IF ( n_err_bnds .GE. 3 )
THEN
569 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
570 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
578 anorm = zlanhe( norm, uplo, n, a, lda, rwork )
579 CALL zpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork,
584 IF ( ref_type .NE. 0 )
THEN
586 prec_type = ilaprec(
'E' )
589 $ nrhs, a, lda, af, ldaf, rcequ, s, b,
590 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
591 $ work, rwork, work(n+1),
592 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n), rcond,
593 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
597 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
598 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
603 rcond_tmp = zla_porcond_c( uplo, n, a, lda, af, ldaf,
604 $ s, .true., info, work, rwork )
606 rcond_tmp = zla_porcond_c( uplo, n, a, lda, af, ldaf,
607 $ s, .false., info, work, rwork )
613 IF ( n_err_bnds .GE. la_linrx_err_i
614 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0 )
615 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
619 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
620 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
621 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
622 IF ( info .LE. n ) info = n + j
623 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
625 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
626 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
631 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
632 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
638 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 2)
THEN
648 cwise_wrong = sqrt( dlamch(
'Epsilon' ) )
650 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
652 rcond_tmp = zla_porcond_x( uplo, n, a, lda, af, ldaf,
653 $ x(1,j), info, work, rwork )
660 IF ( n_err_bnds .GE. la_linrx_err_i
661 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0d+0 )
662 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
666 IF (rcond_tmp .LT. illrcond_thresh)
THEN
667 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
668 err_bnds_comp( j, la_linrx_trust_i ) = 0.0d+0
669 IF ( params( la_linrx_cwise_i ) .EQ. 1.0d+0
670 $ .AND. info.LT.n + j ) info = n + j
671 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
672 $ .LT. err_lbnd )
THEN
673 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
674 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
679 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
680 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
subroutine xerbla(srname, info)
integer function ilaprec(prec)
ILAPREC
double precision function zla_porcond_c(uplo, n, a, lda, af, ldaf, c, capply, info, work, rwork)
ZLA_PORCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian positiv...
double precision function zla_porcond_x(uplo, n, a, lda, af, ldaf, x, info, work, rwork)
ZLA_PORCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian positive-def...
subroutine zla_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)
ZLA_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric or H...
double precision function dlamch(cmach)
DLAMCH
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,...
logical function lsame(ca, cb)
LSAME
subroutine zpocon(uplo, n, a, lda, anorm, rcond, work, rwork, info)
ZPOCON
subroutine zporfsx(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, rwork, info)
ZPORFSX