391 SUBROUTINE zporfsx( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B,
392 $ ldb, x, ldx, rcond, berr, n_err_bnds,
393 $ err_bnds_norm, err_bnds_comp, nparams, params,
394 $ work, rwork, info )
402 CHARACTER UPLO, EQUED
403 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
405 DOUBLE PRECISION RCOND
408 COMPLEX*16 A( lda, * ), AF( ldaf, * ), B( ldb, * ),
409 $ x( ldx, * ), work( * )
410 DOUBLE PRECISION RWORK( * ), S( * ), PARAMS(*), BERR( * ),
411 $ err_bnds_norm( nrhs, * ),
412 $ err_bnds_comp( nrhs, * )
418 DOUBLE PRECISION ZERO, ONE
419 parameter ( zero = 0.0d+0, one = 1.0d+0 )
420 DOUBLE PRECISION ITREF_DEFAULT, ITHRESH_DEFAULT
421 DOUBLE PRECISION COMPONENTWISE_DEFAULT, RTHRESH_DEFAULT
422 DOUBLE PRECISION DZTHRESH_DEFAULT
423 parameter ( itref_default = 1.0d+0 )
424 parameter ( ithresh_default = 10.0d+0 )
425 parameter ( componentwise_default = 1.0d+0 )
426 parameter ( rthresh_default = 0.5d+0 )
427 parameter ( dzthresh_default = 0.25d+0 )
428 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
430 parameter ( la_linrx_itref_i = 1,
431 $ la_linrx_ithresh_i = 2 )
432 parameter ( la_linrx_cwise_i = 3 )
433 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
435 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
436 parameter ( la_linrx_rcond_i = 3 )
441 INTEGER J, PREC_TYPE, REF_TYPE
443 DOUBLE PRECISION ANORM, RCOND_TMP
444 DOUBLE PRECISION ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
447 DOUBLE PRECISION RTHRESH, UNSTABLE_THRESH
453 INTRINSIC max, sqrt, transfer
458 DOUBLE PRECISION DLAMCH, ZLANHE, ZLA_PORCOND_X, ZLA_PORCOND_C
467 ref_type = int( itref_default )
468 IF ( nparams .GE. la_linrx_itref_i )
THEN
469 IF ( params( la_linrx_itref_i ) .LT. 0.0d+0 )
THEN
470 params( la_linrx_itref_i ) = itref_default
472 ref_type = params( la_linrx_itref_i )
478 illrcond_thresh = dble( n ) * dlamch(
'Epsilon' )
479 ithresh = int( ithresh_default )
480 rthresh = rthresh_default
481 unstable_thresh = dzthresh_default
482 ignore_cwise = componentwise_default .EQ. 0.0d+0
484 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
485 IF ( params(la_linrx_ithresh_i ).LT.0.0d+0 )
THEN
486 params( la_linrx_ithresh_i ) = ithresh
488 ithresh = int( params( la_linrx_ithresh_i ) )
491 IF ( nparams.GE.la_linrx_cwise_i )
THEN
492 IF ( params(la_linrx_cwise_i ).LT.0.0d+0 )
THEN
493 IF ( ignore_cwise )
THEN
494 params( la_linrx_cwise_i ) = 0.0d+0
496 params( la_linrx_cwise_i ) = 1.0d+0
499 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0d+0
502 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
504 ELSE IF ( ignore_cwise )
THEN
510 rcequ = lsame( equed,
'Y' )
514 IF (.NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
516 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed,
'N' ) )
THEN
518 ELSE IF( n.LT.0 )
THEN
520 ELSE IF( nrhs.LT.0 )
THEN
522 ELSE IF( lda.LT.max( 1, n ) )
THEN
524 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
526 ELSE IF( ldb.LT.max( 1, n ) )
THEN
528 ELSE IF( ldx.LT.max( 1, n ) )
THEN
532 CALL xerbla(
'ZPORFSX', -info )
538 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
542 IF ( n_err_bnds .GE. 1 )
THEN
543 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
544 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
546 IF ( n_err_bnds .GE. 2 )
THEN
547 err_bnds_norm( j, la_linrx_err_i ) = 0.0d+0
548 err_bnds_comp( j, la_linrx_err_i ) = 0.0d+0
550 IF ( n_err_bnds .GE. 3 )
THEN
551 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0d+0
552 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0d+0
563 IF ( n_err_bnds .GE. 1 )
THEN
564 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
565 err_bnds_comp( j, la_linrx_trust_i ) = 1.0d+0
567 IF ( n_err_bnds .GE. 2 )
THEN
568 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
569 err_bnds_comp( j, la_linrx_err_i ) = 1.0d+0
571 IF ( n_err_bnds .GE. 3 )
THEN
572 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0d+0
573 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0d+0
581 anorm = zlanhe( norm, uplo, n, a, lda, rwork )
582 CALL zpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork,
587 IF ( ref_type .NE. 0 )
THEN
589 prec_type = ilaprec(
'E' )
592 $ nrhs, a, lda, af, ldaf, rcequ, s, b,
593 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
594 $ work, rwork, work(n+1),
595 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n), rcond,
596 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
600 err_lbnd = max( 10.0d+0, sqrt( dble( n ) ) ) * dlamch(
'Epsilon' )
601 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
606 rcond_tmp = zla_porcond_c( uplo, n, a, lda, af, ldaf,
607 $ s, .true., info, work, rwork )
609 rcond_tmp = zla_porcond_c( uplo, n, a, lda, af, ldaf,
610 $ s, .false., info, work, rwork )
616 IF ( n_err_bnds .GE. la_linrx_err_i
617 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0d+0 )
618 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
622 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
623 err_bnds_norm( j, la_linrx_err_i ) = 1.0d+0
624 err_bnds_norm( j, la_linrx_trust_i ) = 0.0d+0
625 IF ( info .LE. n ) info = n + j
626 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
628 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
629 err_bnds_norm( j, la_linrx_trust_i ) = 1.0d+0
634 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
635 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 = zla_porcond_x( uplo, n, a, lda, af, ldaf,
656 $ x(1,j), info, work, rwork )
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 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.
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
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...
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...
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
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 zpocon(UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO)
ZPOCON