392 SUBROUTINE sporfsx( UPLO, EQUED, N, NRHS, A, LDA, AF, LDAF, S, B,
393 $ ldb, x, ldx, rcond, berr, n_err_bnds,
394 $ err_bnds_norm, err_bnds_comp, nparams, params,
395 $ work, iwork, info )
403 CHARACTER uplo, equed
404 INTEGER info, lda, ldaf, ldb, ldx, n, nrhs, nparams,
410 REAL a( lda, * ), af( ldaf, * ), b( ldb, * ),
411 $ x( ldx, * ), work( * )
412 REAL s( * ), params( * ), berr( * ),
413 $ err_bnds_norm( nrhs, * ),
414 $ err_bnds_comp( nrhs, * )
421 parameter( zero = 0.0e+0, one = 1.0e+0 )
422 REAL itref_default, ithresh_default,
423 $ componentwise_default
424 REAL rthresh_default, dzthresh_default
425 parameter( itref_default = 1.0 )
426 parameter( ithresh_default = 10.0 )
427 parameter( componentwise_default = 1.0 )
428 parameter( rthresh_default = 0.5 )
429 parameter( dzthresh_default = 0.25 )
430 INTEGER la_linrx_itref_i, la_linrx_ithresh_i,
432 parameter( la_linrx_itref_i = 1,
433 $ la_linrx_ithresh_i = 2 )
434 parameter( la_linrx_cwise_i = 3 )
435 INTEGER la_linrx_trust_i, la_linrx_err_i,
437 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
438 parameter( la_linrx_rcond_i = 3 )
443 INTEGER j, prec_type, ref_type
445 REAL anorm, rcond_tmp
446 REAL illrcond_thresh, err_lbnd, cwise_wrong
449 REAL rthresh, unstable_thresh
462 INTEGER blas_fpinfo_x
470 ref_type = int( itref_default )
471 IF ( nparams .GE. la_linrx_itref_i )
THEN
472 IF ( params( la_linrx_itref_i ) .LT. 0.0 )
THEN
473 params( la_linrx_itref_i ) = itref_default
475 ref_type = params( la_linrx_itref_i )
481 illrcond_thresh =
REAL( N ) *
slamch(
'Epsilon' )
482 ithresh = int( ithresh_default )
483 rthresh = rthresh_default
484 unstable_thresh = dzthresh_default
485 ignore_cwise = componentwise_default .EQ. 0.0
487 IF ( nparams.GE.la_linrx_ithresh_i )
THEN
488 IF ( params( la_linrx_ithresh_i ).LT.0.0 )
THEN
489 params( la_linrx_ithresh_i ) = ithresh
491 ithresh = int( params( la_linrx_ithresh_i ) )
494 IF ( nparams.GE.la_linrx_cwise_i )
THEN
495 IF ( params( la_linrx_cwise_i ).LT.0.0 )
THEN
496 IF ( ignore_cwise )
THEN
497 params( la_linrx_cwise_i ) = 0.0
499 params( la_linrx_cwise_i ) = 1.0
502 ignore_cwise = params( la_linrx_cwise_i ) .EQ. 0.0
505 IF ( ref_type .EQ. 0 .OR. n_err_bnds .EQ. 0 )
THEN
507 ELSE IF ( ignore_cwise )
THEN
513 rcequ =
lsame( equed,
'Y' )
517 IF (.NOT.
lsame(uplo,
'U') .AND. .NOT.
lsame(uplo,
'L'))
THEN
519 ELSE IF( .NOT.rcequ .AND. .NOT.
lsame( equed,
'N' ) )
THEN
521 ELSE IF( n.LT.0 )
THEN
523 ELSE IF( nrhs.LT.0 )
THEN
525 ELSE IF( lda.LT.max( 1, n ) )
THEN
527 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
529 ELSE IF( ldb.LT.max( 1, n ) )
THEN
531 ELSE IF( ldx.LT.max( 1, n ) )
THEN
535 CALL
xerbla(
'SPORFSX', -info )
541 IF( n.EQ.0 .OR. nrhs.EQ.0 )
THEN
545 IF ( n_err_bnds .GE. 1 )
THEN
546 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
547 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
549 IF ( n_err_bnds .GE. 2 )
THEN
550 err_bnds_norm( j, la_linrx_err_i ) = 0.0
551 err_bnds_comp( j, la_linrx_err_i ) = 0.0
553 IF ( n_err_bnds .GE. 3 )
THEN
554 err_bnds_norm( j, la_linrx_rcond_i ) = 1.0
555 err_bnds_comp( j, la_linrx_rcond_i ) = 1.0
566 IF ( n_err_bnds .GE. 1 )
THEN
567 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
568 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
570 IF ( n_err_bnds .GE. 2 )
THEN
571 err_bnds_norm( j, la_linrx_err_i ) = 1.0
572 err_bnds_comp( j, la_linrx_err_i ) = 1.0
574 IF ( n_err_bnds .GE. 3 )
THEN
575 err_bnds_norm( j, la_linrx_rcond_i ) = 0.0
576 err_bnds_comp( j, la_linrx_rcond_i ) = 0.0
584 anorm =
slansy( norm, uplo, n, a, lda, work )
585 CALL
spocon( uplo, n, af, ldaf, anorm, rcond, work,
590 IF ( ref_type .NE. 0 )
THEN
595 $ nrhs, a, lda, af, ldaf, rcequ, s, b,
596 $ ldb, x, ldx, berr, n_norms, err_bnds_norm, err_bnds_comp,
597 $ work( n+1 ), work( 1 ), work( 2*n+1 ), work( 1 ), rcond,
598 $ ithresh, rthresh, unstable_thresh, ignore_cwise,
602 err_lbnd = max( 10.0, sqrt(
REAL( N ) ) ) *
slamch(
'Epsilon' )
603 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 1 )
THEN
608 rcond_tmp =
sla_porcond( uplo, n, a, lda, af, ldaf,
609 $ -1, s, info, work, iwork )
611 rcond_tmp =
sla_porcond( uplo, n, a, lda, af, ldaf,
612 $ 0, s, info, work, iwork )
618 IF ( n_err_bnds .GE. la_linrx_err_i
619 $ .AND. err_bnds_norm( j, la_linrx_err_i ) .GT. 1.0 )
620 $ err_bnds_norm( j, la_linrx_err_i ) = 1.0
624 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
625 err_bnds_norm( j, la_linrx_err_i ) = 1.0
626 err_bnds_norm( j, la_linrx_trust_i ) = 0.0
627 IF ( info .LE. n ) info = n + j
628 ELSE IF ( err_bnds_norm( j, la_linrx_err_i ) .LT. err_lbnd )
630 err_bnds_norm( j, la_linrx_err_i ) = err_lbnd
631 err_bnds_norm( j, la_linrx_trust_i ) = 1.0
636 IF (n_err_bnds .GE. la_linrx_rcond_i)
THEN
637 err_bnds_norm( j, la_linrx_rcond_i ) = rcond_tmp
642 IF ( n_err_bnds .GE. 1 .AND. n_norms .GE. 2 )
THEN
652 cwise_wrong = sqrt(
slamch(
'Epsilon' ) )
654 IF (err_bnds_comp( j, la_linrx_err_i ) .LT. cwise_wrong )
656 rcond_tmp =
sla_porcond( uplo, n, a, lda, af, ldaf, 1,
657 $ x( 1, j ), info, work, iwork )
664 IF ( n_err_bnds .GE. la_linrx_err_i
665 $ .AND. err_bnds_comp( j, la_linrx_err_i ) .GT. 1.0 )
666 $ err_bnds_comp( j, la_linrx_err_i ) = 1.0
670 IF ( rcond_tmp .LT. illrcond_thresh )
THEN
671 err_bnds_comp( j, la_linrx_err_i ) = 1.0
672 err_bnds_comp( j, la_linrx_trust_i ) = 0.0
673 IF ( params( la_linrx_cwise_i ) .EQ. 1.0
674 $ .AND. info.LT.n + j ) info = n + j
675 ELSE IF ( err_bnds_comp( j, la_linrx_err_i )
676 $ .LT. err_lbnd )
THEN
677 err_bnds_comp( j, la_linrx_err_i ) = err_lbnd
678 err_bnds_comp( j, la_linrx_trust_i ) = 1.0
683 IF ( n_err_bnds .GE. la_linrx_rcond_i )
THEN
684 err_bnds_comp( j, la_linrx_rcond_i ) = rcond_tmp