410 $ nrhs, ab, ldab, afb, ldafb, ipiv,
411 $ colequ, c, b, ldb, y, ldy,
412 $ berr_out, n_norms, err_bnds_norm,
413 $ err_bnds_comp, res, ayb, dy,
414 $ y_tail, rcond, ithresh, rthresh,
415 $ dz_ub, ignore_cwise, info )
423 INTEGER INFO, LDAB, LDAFB, LDB, LDY, N, KL, KU, NRHS,
424 $ prec_type, trans_type, n_norms, ithresh
425 LOGICAL COLEQU, IGNORE_CWISE
426 DOUBLE PRECISION RTHRESH, DZ_UB
430 DOUBLE PRECISION AB( ldab, * ), AFB( ldafb, * ), B( ldb, * ),
431 $ y( ldy, * ), res(*), dy(*), y_tail(*)
432 DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT(*),
433 $ err_bnds_norm( nrhs, * ),
434 $ err_bnds_comp( nrhs, * )
441 INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE
442 DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
443 $ dzrat, prevnormdx, prev_dz_z, dxratmax,
444 $ dzratmax, dx_x, dz_z, final_dx_x, final_dz_z,
445 $ eps, hugeval, incr_thresh
449 INTEGER UNSTABLE_STATE, WORKING_STATE, CONV_STATE,
450 $ noprog_state, base_residual, extra_residual,
452 parameter ( unstable_state = 0, working_state = 1,
453 $ conv_state = 2, noprog_state = 3 )
454 parameter ( base_residual = 0, extra_residual = 1,
456 INTEGER FINAL_NRM_ERR_I, FINAL_CMP_ERR_I, BERR_I
457 INTEGER RCOND_I, NRM_RCOND_I, NRM_ERR_I, CMP_RCOND_I
458 INTEGER CMP_ERR_I, PIV_GROWTH_I
459 parameter ( final_nrm_err_i = 1, final_cmp_err_i = 2,
461 parameter ( rcond_i = 4, nrm_rcond_i = 5, nrm_err_i = 6 )
462 parameter ( cmp_rcond_i = 7, cmp_err_i = 8,
464 INTEGER LA_LINRX_ITREF_I, LA_LINRX_ITHRESH_I,
466 parameter ( la_linrx_itref_i = 1,
467 $ la_linrx_ithresh_i = 2 )
468 parameter ( la_linrx_cwise_i = 3 )
469 INTEGER LA_LINRX_TRUST_I, LA_LINRX_ERR_I,
471 parameter ( la_linrx_trust_i = 1, la_linrx_err_i = 2 )
472 parameter ( la_linrx_rcond_i = 3 )
478 DOUBLE PRECISION DLAMCH
479 CHARACTER CHLA_TRANSTYPE
482 INTRINSIC abs, max, min
486 IF (info.NE.0)
RETURN
487 trans = chla_transtype(trans_type)
488 eps = dlamch(
'Epsilon' )
489 hugeval = dlamch(
'Overflow' )
491 hugeval = hugeval * hugeval
493 incr_thresh = dble( n ) * eps
497 y_prec_state = extra_residual
498 IF ( y_prec_state .EQ. extra_y )
THEN
515 x_state = working_state
516 z_state = unstable_state
524 CALL dcopy( n, b( 1, j ), 1, res, 1 )
525 IF ( y_prec_state .EQ. base_residual )
THEN
526 CALL dgbmv( trans, m, n, kl, ku, -1.0d+0, ab, ldab,
527 $ y( 1, j ), 1, 1.0d+0, res, 1 )
528 ELSE IF ( y_prec_state .EQ. extra_residual )
THEN
529 CALL blas_dgbmv_x( trans_type, n, n, kl, ku,
530 $ -1.0d+0, ab, ldab, y( 1, j ), 1, 1.0d+0, res, 1,
533 CALL blas_dgbmv2_x( trans_type, n, n, kl, ku, -1.0d+0,
534 $ ab, ldab, y( 1, j ), y_tail, 1, 1.0d+0, res, 1,
539 CALL dcopy( n, res, 1, dy, 1 )
540 CALL dgbtrs( trans, n, kl, ku, 1, afb, ldafb, ipiv, dy, n,
552 yk = abs( y( i, j ) )
555 IF ( yk .NE. 0.0d+0 )
THEN
556 dz_z = max( dz_z, dyk / yk )
557 ELSE IF ( dyk .NE. 0.0d+0 )
THEN
561 ymin = min( ymin, yk )
563 normy = max( normy, yk )
566 normx = max( normx, yk * c( i ) )
567 normdx = max( normdx, dyk * c( i ) )
570 normdx = max( normdx, dyk )
574 IF ( normx .NE. 0.0d+0 )
THEN
575 dx_x = normdx / normx
576 ELSE IF ( normdx .EQ. 0.0d+0 )
THEN
582 dxrat = normdx / prevnormdx
583 dzrat = dz_z / prev_dz_z
587 IF ( .NOT.ignore_cwise
588 $ .AND. ymin*rcond .LT. incr_thresh*normy
589 $ .AND. y_prec_state .LT. extra_y )
592 IF ( x_state .EQ. noprog_state .AND. dxrat .LE. rthresh )
593 $ x_state = working_state
594 IF ( x_state .EQ. working_state )
THEN
595 IF ( dx_x .LE. eps )
THEN
597 ELSE IF ( dxrat .GT. rthresh )
THEN
598 IF ( y_prec_state .NE. extra_y )
THEN
601 x_state = noprog_state
604 IF ( dxrat .GT. dxratmax ) dxratmax = dxrat
606 IF ( x_state .GT. working_state ) final_dx_x = dx_x
609 IF ( z_state .EQ. unstable_state .AND. dz_z .LE. dz_ub )
610 $ z_state = working_state
611 IF ( z_state .EQ. noprog_state .AND. dzrat .LE. rthresh )
612 $ z_state = working_state
613 IF ( z_state .EQ. working_state )
THEN
614 IF ( dz_z .LE. eps )
THEN
616 ELSE IF ( dz_z .GT. dz_ub )
THEN
617 z_state = unstable_state
620 ELSE IF ( dzrat .GT. rthresh )
THEN
621 IF ( y_prec_state .NE. extra_y )
THEN
624 z_state = noprog_state
627 IF ( dzrat .GT. dzratmax ) dzratmax = dzrat
629 IF ( z_state .GT. working_state ) final_dz_z = dz_z
636 IF ( x_state.NE.working_state )
THEN
637 IF ( ignore_cwise )
GOTO 666
638 IF ( z_state.EQ.noprog_state .OR. z_state.EQ.conv_state )
640 IF ( z_state.EQ.unstable_state .AND. cnt.GT.1 )
GOTO 666
643 IF ( incr_prec )
THEN
645 y_prec_state = y_prec_state + 1
656 IF (y_prec_state .LT. extra_y)
THEN
657 CALL daxpy( n, 1.0d+0, dy, 1, y(1,j), 1 )
668 IF ( x_state .EQ. working_state ) final_dx_x = dx_x
669 IF ( z_state .EQ. working_state ) final_dz_z = dz_z
673 IF ( n_norms .GE. 1 )
THEN
674 err_bnds_norm( j, la_linrx_err_i ) =
675 $ final_dx_x / (1 - dxratmax)
677 IF (n_norms .GE. 2)
THEN
678 err_bnds_comp( j, la_linrx_err_i ) =
679 $ final_dz_z / (1 - dzratmax)
690 CALL dcopy( n, b( 1, j ), 1, res, 1 )
691 CALL dgbmv(trans, n, n, kl, ku, -1.0d+0, ab, ldab, y(1,j),
692 $ 1, 1.0d+0, res, 1 )
695 ayb( i ) = abs( b( i, j ) )
700 CALL dla_gbamv( trans_type, n, n, kl, ku, 1.0d+0,
701 $ ab, ldab, y(1, j), 1, 1.0d+0, ayb, 1 )
double precision function dlamch(CMACH)
DLAMCH
subroutine dcopy(N, DX, INCX, DY, INCY)
DCOPY
subroutine dla_gbamv(TRANS, M, N, KL, KU, ALPHA, AB, LDAB, X, INCX, BETA, Y, INCY)
DLA_GBAMV performs a matrix-vector operation to calculate error bounds.
subroutine dla_gbrfsx_extended(PREC_TYPE, TRANS_TYPE, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, 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_GBRFSX_EXTENDED improves the computed solution to a system of linear equations for general banded...
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
subroutine dgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGBMV
subroutine dla_wwaddw(N, X, Y, W)
DLA_WWADDW adds a vector into a doubled-single vector.
subroutine dla_lin_berr(N, NZ, NRHS, RES, AYB, BERR)
DLA_LIN_BERR computes a component-wise relative backward error.
character *1 function chla_transtype(TRANS)
CHLA_TRANSTYPE
subroutine dgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBTRS