395 $ af, ldaf, ipiv, colequ, c, b, ldb,
396 $ y, ldy, berr_out, n_norms,
397 $ err_bnds_norm, err_bnds_comp, res,
398 $ ayb, dy, y_tail, rcond, ithresh,
399 $ rthresh, dz_ub, ignore_cwise,
408 INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE,
411 LOGICAL COLEQU, IGNORE_CWISE
412 DOUBLE PRECISION RTHRESH, DZ_UB
416 DOUBLE PRECISION A( lda, * ), AF( ldaf, * ), B( ldb, * ),
417 $ y( ldy, * ), res( * ), dy( * ), y_tail( * )
418 DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
419 $ err_bnds_norm( nrhs, * ),
420 $ err_bnds_comp( nrhs, * )
426 INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE
427 DOUBLE PRECISION 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
434 INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE,
435 $ noprog_state, y_prec_state, base_residual,
436 $ extra_residual, extra_y
437 parameter ( unstable_state = 0, working_state = 1,
438 $ conv_state = 2, noprog_state = 3 )
439 parameter ( base_residual = 0, extra_residual = 1,
441 INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I
442 INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I
443 INTEGER CMP_ERR_I, PIV_GROWTH_I
444 parameter ( final_nrm_err_i = 1, final_cmp_err_i = 2,
446 parameter ( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
447 parameter ( cmp_rcond_i = 7, cmp_err_i = 8,
449 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
451 parameter ( la_linrx_itref_i = 1,
452 $ la_linrx_ithresh_i = 2 )
453 parameter ( la_linrx_cwise_i = 3 )
454 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
456 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
457 parameter ( la_linrx_rcond_i = 3 )
468 DOUBLE PRECISION DLAMCH
471 INTRINSIC abs, max, min
476 upper = lsame( uplo,
'U' )
477 IF( .NOT.upper .AND. .NOT.lsame( uplo,
'L' ) )
THEN
479 ELSE IF( n.LT.0 )
THEN
481 ELSE IF( nrhs.LT.0 )
THEN
483 ELSE IF( lda.LT.max( 1, n ) )
THEN
485 ELSE IF( ldaf.LT.max( 1, n ) )
THEN
487 ELSE IF( ldb.LT.max( 1, n ) )
THEN
489 ELSE IF( ldy.LT.max( 1, n ) )
THEN
493 CALL xerbla(
'DLA_SYRFSX_EXTENDED', -info )
496 eps = dlamch(
'Epsilon' )
497 hugeval = dlamch(
'Overflow' )
499 hugeval = hugeval * hugeval
501 incr_thresh = dble( n )*eps
503 IF ( lsame( uplo,
'L' ) )
THEN
504 uplo2 = ilauplo(
'L' )
506 uplo2 = ilauplo(
'U' )
510 y_prec_state = extra_residual
511 IF ( y_prec_state .EQ. extra_y )
THEN
528 x_state = working_state
529 z_state = unstable_state
537 CALL dcopy( n, b( 1, j ), 1, res, 1 )
538 IF (y_prec_state .EQ. base_residual)
THEN
539 CALL dsymv( uplo, n, -1.0d+0, a, lda, y(1,j), 1,
541 ELSE IF (y_prec_state .EQ. extra_residual)
THEN
542 CALL blas_dsymv_x( uplo2, n, -1.0d+0, a, lda,
543 $ y( 1, j ), 1, 1.0d+0, res, 1, prec_type )
545 CALL blas_dsymv2_x(uplo2, n, -1.0d+0, a, lda,
546 $ y(1, j), y_tail, 1, 1.0d+0, res, 1, prec_type)
550 CALL dcopy( n, res, 1, dy, 1 )
551 CALL dsytrs( uplo, n, 1, af, ldaf, ipiv, dy, n, info )
562 yk = abs( y( i, j ) )
565 IF ( yk .NE. 0.0d+0 )
THEN
566 dz_z = max( dz_z, dyk / yk )
567 ELSE IF ( dyk .NE. 0.0d+0 )
THEN
571 ymin = min( ymin, yk )
573 normy = max( normy, yk )
576 normx = max( normx, yk * c( i ) )
577 normdx = max( normdx, dyk * c( i ) )
580 normdx = max(normdx, dyk)
584 IF ( normx .NE. 0.0d+0 )
THEN
585 dx_x = normdx / normx
586 ELSE IF ( normdx .EQ. 0.0d+0 )
THEN
592 dxrat = normdx / prevnormdx
593 dzrat = dz_z / prev_dz_z
597 IF ( ymin*rcond .LT. incr_thresh*normy
598 $ .AND. y_prec_state .LT. extra_y )
601 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
602 $ x_state = working_state
603 IF ( x_state .EQ. working_state )
THEN
604 IF ( dx_x .LE. eps )
THEN
606 ELSE IF ( dxrat .GT. rthresh )
THEN
607 IF ( y_prec_state .NE. extra_y )
THEN
610 x_state = noprog_state
613 IF ( dxrat .GT. dxratmax ) dxratmax = dxrat
615 IF ( x_state .GT. working_state ) final_dx_x = dx_x
618 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
619 $ z_state = working_state
620 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
621 $ z_state = working_state
622 IF ( z_state .EQ. working_state )
THEN
623 IF ( dz_z .LE. eps )
THEN
625 ELSE IF ( dz_z .GT. dz_ub )
THEN
626 z_state = unstable_state
629 ELSE IF ( dzrat .GT. rthresh )
THEN
630 IF ( y_prec_state .NE. extra_y )
THEN
633 z_state = noprog_state
636 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
638 IF ( z_state .GT. working_state ) final_dz_z = dz_z
641 IF ( x_state.NE.working_state.AND.
642 $ ( ignore_cwise.OR.z_state.NE.working_state ) )
645 IF ( incr_prec )
THEN
647 y_prec_state = y_prec_state + 1
658 IF (y_prec_state .LT. extra_y)
THEN
659 CALL daxpy( n, 1.0d+0, dy, 1, y(1,j), 1 )
670 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
671 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
675 IF ( n_norms .GE. 1 )
THEN
676 err_bnds_norm( j, la_linrx_err_i ) =
677 $ final_dx_x / (1 - dxratmax)
679 IF ( n_norms .GE. 2 )
THEN
680 err_bnds_comp( j, la_linrx_err_i ) =
681 $ final_dz_z / (1 - dzratmax)
691 CALL dcopy( n, b( 1, j ), 1, res, 1 )
692 CALL dsymv( uplo, n, -1.0d+0, a, lda, y(1,j), 1, 1.0d+0, res,
696 ayb( i ) = abs( b( i, j ) )
702 $ a, lda, y(1, j), 1, 1.0d+0, ayb, 1 )
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dla_wwaddw(N, X, Y, W)
DLA_WWADDW adds a vector into a doubled-single vector.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dsytrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DSYTRS
integer function ilauplo(UPLO)
ILAUPLO
subroutine dla_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)
DLA_SYRFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric inde...
subroutine dla_lin_berr(N, NZ, NRHS, RES, AYB, BERR)
DLA_LIN_BERR computes a component-wise relative backward error.
subroutine dla_syamv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DLA_SYAMV computes a matrix-vector product using a symmetric indefinite matrix to calculate error bou...
subroutine dsymv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DSYMV