400 SUBROUTINE csyrfsx( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, IPIV,
401 $ s, b, ldb, x, ldx, rcond, berr, n_err_bnds,
402 $ err_bnds_norm, err_bnds_comp, nparams, params,
403 $ work, rwork, info )
411 CHARACTER UPLO, EQUED
412 INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS, NPARAMS,
418 COMPLEX A( lda, * ), AF( ldaf, * ), B( ldb, * ),
419 $ x( ldx, * ), work( * )
420 REAL S( * ), PARAMS( * ), BERR( * ), RWORK( * ),
421 $ err_bnds_norm( nrhs, * ),
422 $ err_bnds_comp( nrhs, * )
429 parameter ( zero = 0.0e+0, one = 1.0e+0 )
430 REAL ITREF_DEFAULT, ITHRESH_DEFAULT,
431 $ componentwise_default
432 REAL RTHRESH_DEFAULT, DZTHRESH_DEFAULT
433 parameter ( itref_default = 1.0 )
434 parameter ( ithresh_default = 10.0 )
435 parameter ( componentwise_default = 1.0 )
436 parameter ( rthresh_default = 0.5 )
437 parameter ( dzthresh_default = 0.25 )
438 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
440 parameter ( la_linrx_itref_i = 1,
441 $ la_linrx_ithresh_i = 2 )
442 parameter ( la_linrx_cwise_i = 3 )
443 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
445 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
446 parameter ( la_linrx_rcond_i = 3 )
451 INTEGER J, PREC_TYPE, REF_TYPE
453 REAL ANORM, RCOND_TMP
454 REAL ILLRCOND_THRESH, ERR_LBND, CWISE_WRONG
457 REAL RTHRESH, UNSTABLE_THRESH
463 INTRINSIC max, sqrt, transfer
468 REAL SLAMCH, CLANSY, CLA_SYRCOND_X, CLA_SYRCOND_C
477 ref_type = int( itref_default )
478 IF ( nparams .GE. la_linrx_itref_i )
THEN
479 IF ( params( la_linrx_itref_i ) .LT. 0.0 )
THEN
480 params( la_linrx_itref_i ) = itref_default
482 ref_type = params( la_linrx_itref_i )
488 illrcond_thresh =
REAL( N ) * SLAMCH(
'Epsilon' )
489 ithresh = int( ithresh_default )
490 rthresh = rthresh_default
491 unstable_thresh = dzthresh_default
492 ignore_cwise = componentwise_default .EQ. 0.0
494 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
495 IF ( params( la_linrx_ithresh_i ).LT.0.0 )
THEN
496 params( la_linrx_ithresh_i ) = ithresh
498 ithresh = int( params( la_linrx_ithresh_i ) )
501 IF ( nparams.GE.la_linrx_cwise_i )
THEN
502 IF ( params( la_linrx_cwise_i ).LT.0.0 )
THEN
503 IF ( ignore_cwise )
THEN
504 params( la_linrx_cwise_i ) = 0.0
506 params( la_linrx_cwise_i ) = 1.0
509 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
512 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
514 ELSE IF ( ignore_cwise )
THEN
520 rcequ = lsame( equed,
'Y' )
524 IF ( .NOT.lsame( uplo,
'U' ) .AND. .NOT.lsame( uplo,
'L' ) )
THEN
526 ELSE IF( .NOT.rcequ .AND. .NOT.lsame( equed,
'N' ) )
THEN
528 ELSE IF( n.LT.0 )
THEN
530 ELSE IF( nrhs.LT.0 )
THEN
532 ELSE IF( lda.LT.max( 1, n ) )
THEN
534 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
536 ELSE IF( ldb.LT.max( 1, n ) )
THEN
538 ELSE IF( ldx.LT.max( 1, n ) )
THEN
542 CALL xerbla(
'CSYRFSX', -info )
548 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
552 IF ( n_err_bnds .GE. 1 )
THEN
553 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
554 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
556 IF ( n_err_bnds .GE. 2 )
THEN
557 err_bnds_norm( j, la_linrx_err_i ) = 0.0
558 err_bnds_comp( j, la_linrx_err_i ) = 0.0
560 IF ( n_err_bnds .GE. 3 )
THEN
561 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
562 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
573 IF ( n_err_bnds .GE. 1 )
THEN
574 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
575 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
577 IF ( n_err_bnds .GE. 2 )
THEN
578 err_bnds_norm( j, la_linrx_err_i ) = 1.0
579 err_bnds_comp( j, la_linrx_err_i ) = 1.0
581 IF ( n_err_bnds .GE. 3 )
THEN
582 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
583 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
591 anorm = clansy( norm, uplo, n, a, lda, rwork )
592 CALL csycon( uplo, n, af, ldaf, ipiv, anorm, rcond, work,
597 IF ( ref_type .NE. 0 )
THEN
599 prec_type = ilaprec(
'D' )
602 $ nrhs, a, lda, af, ldaf, ipiv, rcequ, s, b,
603 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
604 $ work, rwork, work(n+1),
605 $ transfer(rwork(1:2*n), (/ (zero, zero) /), n), rcond,
606 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
610 err_lbnd = max( 10.0, sqrt(
REAL( N ) ) ) * slamch(
'Epsilon' )
611 IF (n_err_bnds .GE. 1 .AND. n_norms .GE. 1)
THEN
616 rcond_tmp = cla_syrcond_c( uplo, n, a, lda, af, ldaf, ipiv,
617 $ s, .true., info, work, rwork )
619 rcond_tmp = cla_syrcond_c( uplo, n, a, lda, af, ldaf, ipiv,
620 $ s, .false., info, work, rwork )
626 IF ( n_err_bnds .GE. la_linrx_err_i
627 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
628 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
632 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
633 err_bnds_norm( j, la_linrx_err_i ) = 1.0
634 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
635 IF ( info .LE. n ) info = n + j
636 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
638 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
639 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
644 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
645 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
650 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
660 cwise_wrong = sqrt( slamch(
'Epsilon' ) )
662 IF ( err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
664 rcond_tmp = cla_syrcond_x( uplo, n, a, lda, af, ldaf,
665 $ ipiv, x(1,j), info, work, rwork )
672 IF ( n_err_bnds .GE. la_linrx_err_i
673 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
674 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
679 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
680 err_bnds_comp( j, la_linrx_err_i ) = 1.0
681 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
682 IF ( .NOT. ignore_cwise
683 $ .AND. info.LT.n + j ) info = n + j
684 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
685 $ .LT. err_lbnd )
THEN
686 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
687 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
692 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
693 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp
real function cla_syrcond_x(UPLO, N, A, LDA, AF, LDAF, IPIV, X, INFO, WORK, RWORK)
CLA_SYRCOND_X computes the infinity norm condition number of op(A)*diag(x) for symmetric indefinite m...
subroutine csyrfsx(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)
CSYRFSX
real function cla_syrcond_c(UPLO, N, A, LDA, AF, LDAF, IPIV, C, CAPPLY, INFO, WORK, RWORK)
CLA_SYRCOND_C computes the infinity norm condition number of op(A)*inv(diag(c)) for symmetric indefin...
integer function ilaprec(PREC)
ILAPREC
subroutine xerbla(SRNAME, INFO)
XERBLA
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
subroutine csycon(UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK, INFO)
CSYCON
real function clansy(NORM, UPLO, N, A, LDA, WORK)
CLANSY 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 symmetric matrix.
subroutine cla_syrfsx_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_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric inde...