394 $ af, ldaf, ipiv, colequ, c,
b, ldb,
395 $ y, ldy, berr_out, n_norms,
396 $ err_bnds_norm, err_bnds_comp, res,
397 $ ayb, dy, y_tail, rcond, ithresh,
398 $ rthresh, dz_ub, ignore_cwise,
407 INTEGER info, lda, ldaf, ldb, ldy, n, nrhs, prec_type,
410 LOGICAL colequ, ignore_cwise
415 COMPLEX a( lda, * ), af( ldaf, * ),
b( ldb, * ),
416 $ y( ldy, * ), res( * ), dy( * ), y_tail( * )
417 REAL c( * ), ayb( * ), rcond, berr_out( * ),
418 $ err_bnds_norm( nrhs, * ),
419 $ err_bnds_comp( nrhs, * )
425 INTEGER uplo2, cnt, i,
j, x_state, z_state,
427 REAL yk, dyk, ymin, normy, normx, normdx, dxrat,
428 $ dzrat, prevnormdx, prev_dz_z, dxratmax,
429 $ dzratmax, dx_x, dz_z, final_dx_x, final_dz_z,
430 $ eps, hugeval, incr_thresh
431 LOGICAL incr_prec, upper
435 INTEGER unstable_state, working_state, conv_state,
436 $ noprog_state, base_residual, extra_residual,
438 parameter( unstable_state = 0, working_state = 1,
439 $ conv_state = 2, noprog_state = 3 )
440 parameter( base_residual = 0, extra_residual = 1,
442 INTEGER final_nrm_err_i, final_cmp_err_i, berr_i
443 INTEGER rcond_i, nrm_rcond_i, nrm_err_i, cmp_rcond_i
444 INTEGER cmp_err_i, piv_growth_i
445 parameter( final_nrm_err_i = 1, final_cmp_err_i = 2,
447 parameter( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
448 parameter( cmp_rcond_i = 7, cmp_err_i = 8,
450 INTEGER la_linrx_itref_i, la_linrx_ithresh_i,
452 parameter( la_linrx_itref_i = 1,
453 $ la_linrx_ithresh_i = 2 )
454 parameter( la_linrx_cwise_i = 3 )
455 INTEGER la_linrx_trust_i, la_linrx_err_i,
457 parameter( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
458 parameter( la_linrx_rcond_i = 3 )
472 INTRINSIC abs,
REAL, aimag, max, min
478 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( aimag( zdum ) )
483 upper =
lsame( uplo,
'U' )
484 IF( .NOT.upper .AND. .NOT.
lsame( uplo,
'L' ) )
THEN
486 ELSE IF( n.LT.0 )
THEN
488 ELSE IF( nrhs.LT.0 )
THEN
490 ELSE IF( lda.LT.max( 1, n ) )
THEN
492 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
494 ELSE IF( ldb.LT.max( 1, n ) )
THEN
496 ELSE IF( ldy.LT.max( 1, n ) )
THEN
500 CALL
xerbla(
'CLA_SYRFSX_EXTENDED', -info )
504 hugeval =
slamch(
'Overflow' )
506 hugeval = hugeval * hugeval
508 incr_thresh =
REAL( N ) * eps
510 IF (
lsame( uplo,
'L' ) )
THEN
517 y_prec_state = extra_residual
518 IF ( y_prec_state .EQ. extra_y )
THEN
535 x_state = working_state
536 z_state = unstable_state
544 CALL
ccopy( n,
b( 1,
j ), 1, res, 1 )
545 IF ( y_prec_state .EQ. base_residual )
THEN
546 CALL
csymv( uplo, n, cmplx(-1.0), a, lda, y(1,
j), 1,
547 $ cmplx(1.0), res, 1 )
548 ELSE IF ( y_prec_state .EQ. extra_residual )
THEN
549 CALL blas_csymv_x( uplo2, n, cmplx(-1.0), a, lda,
550 $ y( 1,
j ), 1, cmplx(1.0), res, 1, prec_type )
552 CALL blas_csymv2_x(uplo2, n, cmplx(-1.0), a, lda,
553 $ y(1,
j), y_tail, 1, cmplx(1.0), res, 1, prec_type)
557 CALL
ccopy( n, res, 1, dy, 1 )
558 CALL
csytrs( uplo, n, 1, af, ldaf, ipiv, dy, n, info )
569 yk = cabs1( y( i,
j ) )
570 dyk = cabs1( dy( i ) )
572 IF ( yk .NE. 0.0 )
THEN
573 dz_z = max( dz_z, dyk / yk )
574 ELSE IF ( dyk .NE. 0.0 )
THEN
578 ymin = min( ymin, yk )
580 normy = max( normy, yk )
583 normx = max( normx, yk * c( i ) )
584 normdx = max( normdx, dyk * c( i ) )
587 normdx = max( normdx, dyk )
591 IF ( normx .NE. 0.0 )
THEN
592 dx_x = normdx / normx
593 ELSE IF ( normdx .EQ. 0.0 )
THEN
599 dxrat = normdx / prevnormdx
600 dzrat = dz_z / prev_dz_z
604 IF ( ymin*rcond .LT. incr_thresh*normy
605 $ .AND. y_prec_state .LT. extra_y )
608 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
609 $ x_state = working_state
610 IF ( x_state .EQ. working_state )
THEN
611 IF ( dx_x .LE. eps )
THEN
613 ELSE IF ( dxrat .GT. rthresh )
THEN
614 IF ( y_prec_state .NE. extra_y )
THEN
617 x_state = noprog_state
620 IF (dxrat .GT. dxratmax) dxratmax = dxrat
622 IF ( x_state .GT. working_state ) final_dx_x = dx_x
625 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
626 $ z_state = working_state
627 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
628 $ z_state = working_state
629 IF ( z_state .EQ. working_state )
THEN
630 IF ( dz_z .LE. eps )
THEN
632 ELSE IF ( dz_z .GT. dz_ub )
THEN
633 z_state = unstable_state
636 ELSE IF ( dzrat .GT. rthresh )
THEN
637 IF ( y_prec_state .NE. extra_y )
THEN
640 z_state = noprog_state
643 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
645 IF ( z_state .GT. working_state ) final_dz_z = dz_z
648 IF ( x_state.NE.working_state.AND.
649 $ ( ignore_cwise.OR.z_state.NE.working_state ) )
652 IF ( incr_prec )
THEN
654 y_prec_state = y_prec_state + 1
665 IF ( y_prec_state .LT. extra_y )
THEN
666 CALL
caxpy( n, cmplx(1.0), dy, 1, y(1,
j), 1 )
677 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
678 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
682 IF ( n_norms .GE. 1 )
THEN
683 err_bnds_norm(
j, la_linrx_err_i ) =
684 $ final_dx_x / (1 - dxratmax)
686 IF ( n_norms .GE. 2 )
THEN
687 err_bnds_comp(
j, la_linrx_err_i ) =
688 $ final_dz_z / (1 - dzratmax)
699 CALL
ccopy( n,
b( 1,
j ), 1, res, 1 )
700 CALL
csymv( uplo, n, cmplx(-1.0), a, lda, y(1,
j), 1,
701 $ cmplx(1.0), res, 1 )
704 ayb( i ) = cabs1(
b( i,
j ) )
710 $ a, lda, y(1,
j), 1, 1.0, ayb, 1 )
subroutine cla_syamv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bou...
subroutine cla_wwaddw(N, X, Y, W)
CLA_WWADDW adds a vector into a doubled-single vector.
integer function ilauplo(UPLO)
ILAUPLO
subroutine csymv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CSYMV computes a matrix-vector product for a complex symmetric matrix.
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY
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...
subroutine xerbla(SRNAME, INFO)
XERBLA
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
real function slamch(CMACH)
SLAMCH
subroutine cla_lin_berr(N, NZ, NRHS, RES, AYB, BERR)
CLA_LIN_BERR computes a component-wise relative backward error.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine csytrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
CSYTRS