391 SUBROUTINE cporfsx( 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,
408 COMPLEX A( lda, * ), AF( ldaf, * ), B( ldb, * ),
409 $ x( ldx, * ), work( * )
410 REAL RWORK( * ), S( * ), PARAMS(*), BERR( * ),
411 $ err_bnds_norm( nrhs, * ),
412 $ err_bnds_comp( nrhs, * )
419 parameter ( zero = 0.0e+0, one = 1.0e+0 )
420 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
421 $ componentwise_default
422 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
423 parameter ( itref_default = 1.0 )
424 parameter ( ithresh_default = 10.0 )
425 parameter ( componentwise_default = 1.0 )
426 parameter ( rthresh_default = 0.5 )
427 parameter ( dzthresh_default = 0.25 )
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 REAL ANORM, RCOND_TMP
444 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
447 REAL RTHRESH, UNSTABLE_THRESH
453 INTRINSIC max, sqrt, transfer
458 REAL SLAMCH, CLANHE, CLA_PORCOND_X, CLA_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.0 )
THEN
470 params( la_linrx_itref_i ) = itref_default
472 ref_type = params( la_linrx_itref_i )
478 illrcond_thresh =
REAL( N ) * SLAMCH(
'Epsilon' )
479 ithresh = int( ithresh_default )
480 rthresh = rthresh_default
481 unstable_thresh = dzthresh_default
482 ignore_cwise = componentwise_default .EQ. 0.0
484 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
485 IF ( params(la_linrx_ithresh_i ).LT.0.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.0 )
THEN
493 IF ( ignore_cwise )
THEN
494 params( la_linrx_cwise_i ) = 0.0
496 params( la_linrx_cwise_i ) = 1.0
499 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.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(
'CPORFSX', -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.0
544 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
546 IF ( n_err_bnds .GE. 2 )
THEN
547 err_bnds_norm( j, la_linrx_err_i ) = 0.0
548 err_bnds_comp( j, la_linrx_err_i ) = 0.0
550 IF ( n_err_bnds .GE. 3 )
THEN
551 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
552 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
563 IF ( n_err_bnds .GE. 1 )
THEN
564 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
565 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
567 IF ( n_err_bnds .GE. 2 )
THEN
568 err_bnds_norm( j, la_linrx_err_i ) = 1.0
569 err_bnds_comp( j, la_linrx_err_i ) = 1.0
571 IF ( n_err_bnds .GE. 3 )
THEN
572 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
573 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
581 anorm = clanhe( norm, uplo, n, a, lda, rwork )
582 CALL cpocon( uplo, n, af, ldaf, anorm, rcond, work, rwork,
587 IF ( ref_type .NE. 0 )
THEN
589 prec_type = ilaprec(
'D' )
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.0, sqrt(
REAL( N ) ) ) * slamch(
'Epsilon' )
601 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
606 rcond_tmp = cla_porcond_c( uplo, n, a, lda, af, ldaf,
607 $ s, .true., info, work, rwork )
609 rcond_tmp = cla_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.0 )
618 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
622 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
623 err_bnds_norm( j, la_linrx_err_i ) = 1.0
624 err_bnds_norm( j, la_linrx_trust_i ) = 0.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.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( slamch(
'Epsilon' ) )
653 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
655 rcond_tmp = cla_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.0 )
665 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
669 IF (rcond_tmp .LT. illrcond_thresh)
THEN
670 err_bnds_comp( j, la_linrx_err_i ) = 1.0
671 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
672 IF ( params( la_linrx_cwise_i ) .EQ. 1.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.0
682 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
683 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
subroutine cla_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)
CLA_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric or H...
subroutine cpocon(UPLO, N, A, LDA, ANORM, RCOND, WORK, RWORK, INFO)
CPOCON
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
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.
real function cla_porcond_x(UPLO, N, A, LDA, AF, LDAF, X, INFO, WORK, RWORK)
CLA_PORCOND_X computes the infinity norm condition number of op(A)*diag(x) for Hermitian positive-def...
real function cla_porcond_c(UPLO, N, A, LDA, AF, LDAF, C, CAPPLY, INFO, WORK, RWORK)
CLA_PORCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for Hermitian positiv...
subroutine cporfsx(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)
CPORFSX