386 $ af, ldaf, colequ, c, b, ldb, y,
387 $ ldy, berr_out, n_norms,
388 $ err_bnds_norm, err_bnds_comp, res,
389 $ ayb, dy, y_tail, rcond, ithresh,
390 $ rthresh, dz_ub, ignore_cwise,
399 INTEGER INFO, LDA, LDAF, LDB, LDY, N, NRHS, PREC_TYPE,
402 LOGICAL COLEQU, IGNORE_CWISE
406 COMPLEX A( lda, * ), AF( ldaf, * ), B( ldb, * ),
407 $ y( ldy, * ), res( * ), dy( * ), y_tail( * )
408 REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
409 $ err_bnds_norm( nrhs, * ),
410 $ err_bnds_comp( nrhs, * )
416 INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
418 REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
419 $ dzrat, prevnormdx, prev_dz_z, dxratmax,
420 $ dzratmax, dx_x, dz_z, final_dx_x, final_dz_z,
421 $ eps, hugeval, incr_thresh
426 INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE,
427 $ noprog_state, base_residual, extra_residual,
429 parameter ( unstable_state = 0, working_state = 1,
430 $ conv_state = 2, noprog_state = 3 )
431 parameter ( base_residual = 0, extra_residual = 1,
433 INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I
434 INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I
435 INTEGER CMP_ERR_I, PIV_GROWTH_I
436 parameter ( final_nrm_err_i = 1, final_cmp_err_i = 2,
438 parameter ( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
439 parameter ( cmp_rcond_i = 7, cmp_err_i = 8,
441 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
443 parameter ( la_linrx_itref_i = 1,
444 $ la_linrx_ithresh_i = 2 )
445 parameter ( la_linrx_cwise_i = 3 )
446 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
448 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
449 parameter ( la_linrx_rcond_i = 3 )
463 INTRINSIC abs,
REAL, AIMAG, MAX, MIN
469 cabs1( zdum ) = abs(
REAL( ZDUM ) ) + abs( AIMAG( zdum ) )
473 IF (info.NE.0)
RETURN
474 eps = slamch(
'Epsilon' )
475 hugeval = slamch(
'Overflow' )
477 hugeval = hugeval * hugeval
479 incr_thresh =
REAL(N) * EPS
481 IF (lsame(uplo,
'L'))
THEN
482 uplo2 = ilauplo(
'L' )
484 uplo2 = ilauplo(
'U' )
488 y_prec_state = extra_residual
489 IF (y_prec_state .EQ. extra_y)
THEN
506 x_state = working_state
507 z_state = unstable_state
515 CALL ccopy( n, b( 1, j ), 1, res, 1 )
516 IF (y_prec_state .EQ. base_residual)
THEN
517 CALL chemv(uplo, n, cmplx(-1.0), a, lda, y(1,j), 1,
518 $ cmplx(1.0), res, 1)
519 ELSE IF (y_prec_state .EQ. extra_residual)
THEN
520 CALL blas_chemv_x(uplo2, n, cmplx(-1.0), a, lda,
521 $ y( 1, j ), 1, cmplx(1.0), res, 1, prec_type)
523 CALL blas_chemv2_x(uplo2, n, cmplx(-1.0), a, lda,
524 $ y(1, j), y_tail, 1, cmplx(1.0), res, 1, prec_type)
528 CALL ccopy( n, res, 1, dy, 1 )
529 CALL cpotrs( uplo, n, 1, af, ldaf, dy, n, info)
543 IF (yk .NE. 0.0)
THEN
544 dz_z = max( dz_z, dyk / yk )
545 ELSE IF (dyk .NE. 0.0)
THEN
549 ymin = min( ymin, yk )
551 normy = max( normy, yk )
554 normx = max(normx, yk * c(i))
555 normdx = max(normdx, dyk * c(i))
558 normdx = max(normdx, dyk)
562 IF (normx .NE. 0.0)
THEN
563 dx_x = normdx / normx
564 ELSE IF (normdx .EQ. 0.0)
THEN
570 dxrat = normdx / prevnormdx
571 dzrat = dz_z / prev_dz_z
575 IF (ymin*rcond .LT. incr_thresh*normy
576 $ .AND. y_prec_state .LT. extra_y)
579 IF (x_state .EQ. noprog_state .AND. dxrat .LE. rthresh)
580 $ x_state = working_state
581 IF (x_state .EQ. working_state)
THEN
582 IF (dx_x .LE. eps)
THEN
584 ELSE IF (dxrat .GT. rthresh)
THEN
585 IF (y_prec_state .NE. extra_y)
THEN
588 x_state = noprog_state
591 IF (dxrat .GT. dxratmax) dxratmax = dxrat
593 IF (x_state .GT. working_state) final_dx_x = dx_x
596 IF (z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub)
597 $ z_state = working_state
598 IF (z_state .EQ. noprog_state .AND. dzrat .LE. rthresh)
599 $ z_state = working_state
600 IF (z_state .EQ. working_state)
THEN
601 IF (dz_z .LE. eps)
THEN
603 ELSE IF (dz_z .GT. dz_ub)
THEN
604 z_state = unstable_state
607 ELSE IF (dzrat .GT. rthresh)
THEN
608 IF (y_prec_state .NE. extra_y)
THEN
611 z_state = noprog_state
614 IF (dzrat .GT. dzratmax) dzratmax = dzrat
616 IF (z_state .GT. working_state) final_dz_z = dz_z
619 IF ( x_state.NE.working_state.AND.
620 $ (ignore_cwise.OR.z_state.NE.working_state) )
625 y_prec_state = y_prec_state + 1
636 IF (y_prec_state .LT. extra_y)
THEN
637 CALL caxpy( n, cmplx(1.0), dy, 1, y(1,j), 1 )
648 IF (x_state .EQ. working_state) final_dx_x = dx_x
649 IF (z_state .EQ. working_state) final_dz_z = dz_z
653 IF (n_norms .GE. 1)
THEN
654 err_bnds_norm( j, la_linrx_err_i ) =
655 $ final_dx_x / (1 - dxratmax)
657 IF (n_norms .GE. 2)
THEN
658 err_bnds_comp( j, la_linrx_err_i ) =
659 $ final_dz_z / (1 - dzratmax)
670 CALL ccopy( n, b( 1, j ), 1, res, 1 )
671 CALL chemv(uplo, n, cmplx(-1.0), a, lda, y(1,j), 1, cmplx(1.0),
675 ayb( i ) = cabs1( b( i, j ) )
681 $ a, lda, y(1, j), 1, 1.0, ayb, 1)
subroutine cla_wwaddw(N, X, Y, W)
CLA_WWADDW adds a vector into a doubled-single vector.
subroutine cla_porfsx_extended(PREC_TYPE, UPLO, N, NRHS, A, LDA, AF, LDAF, 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_PORFSX_EXTENDED improves the computed solution to a system of linear equations for symmetric or H...
subroutine cpotrs(UPLO, N, NRHS, A, LDA, B, LDB, INFO)
CPOTRS
subroutine cla_lin_berr(N, NZ, NRHS, RES, AYB, BERR)
CLA_LIN_BERR computes a component-wise relative backward error.
subroutine chemv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CHEMV
real function slamch(CMACH)
SLAMCH
integer function ilauplo(UPLO)
ILAUPLO
subroutine cla_heamv(UPLO, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CLA_HEAMV computes a matrix-vector product using a Hermitian indefinite matrix to calculate error bou...
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine caxpy(N, CA, CX, INCX, CY, INCY)
CAXPY