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 dla_lin_berr(N, NZ, NRHS, RES, AYB, BERR)
DLA_LIN_BERR computes a component-wise relative backward error.
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine xerbla(SRNAME, INFO)
XERBLA
integer function ilauplo(UPLO)
ILAUPLO
subroutine dsytrs(UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
DSYTRS
subroutine dla_wwaddw(N, X, Y, W)
DLA_WWADDW adds a vector into a doubled-single vector.
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_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