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 )
482 INTRINSIC abs, max, min
486 IF (info.NE.0)
RETURN
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 )
CHARACTER *1 function chla_transtype(TRANS)
CHLA_TRANSTYPE
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 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 dla_wwaddw(N, X, Y, W)
DLA_WWADDW adds a vector into a doubled-single vector.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine dgbmv(TRANS, M, N, KL, KU, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
DGBMV
subroutine dgbtrs(TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO)
DGBTRS
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine daxpy(N, DA, DX, INCX, DY, INCY)
DAXPY
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
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.