d5/d4a/zpprfs_8f_source.html

 *> \brief \b ZPPRFS
 *
 *  =========== DOCUMENTATION ===========
 *
 * Online html documentation available at
 *            http://www.netlib.org/lapack/explore-html/
 *
 *> \htmlonly
 *> Download ZPPRFS + dependencies
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpprfs.f">
 *> [TGZ]</a>
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpprfs.f">
 *> [ZIP]</a>
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpprfs.f">
 *> [TXT]</a>
 *> \endhtmlonly
 *
 *  Definition:
 *  ===========
 *
 *       SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
 *                          BERR, WORK, RWORK, INFO )
 *
 *       .. Scalar Arguments ..
 *       CHARACTER          UPLO
 *       INTEGER            INFO, LDB, LDX, N, NRHS
 *       ..
 *       .. Array Arguments ..
 *       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
 *       COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
 *      $                   X( LDX, * )
 *       ..
 *
 *
 *> \par Purpose:
 *  =============
 *>
 *> \verbatim
 *>
 *> ZPPRFS improves the computed solution to a system of linear
 *> equations when the coefficient matrix is Hermitian positive definite
 *> and packed, and provides error bounds and backward error estimates
 *> for the solution.
 *> \endverbatim
 *
 *  Arguments:
 *  ==========
 *
 *> \param[in] UPLO
 *> \verbatim
 *>          UPLO is CHARACTER*1
 *>          = 'U':  Upper triangle of A is stored;
 *>          = 'L':  Lower triangle of A is stored.
 *> \endverbatim
 *>
 *> \param[in] N
 *> \verbatim
 *>          N is INTEGER
 *>          The order of the matrix A.  N >= 0.
 *> \endverbatim
 *>
 *> \param[in] NRHS
 *> \verbatim
 *>          NRHS is INTEGER
 *>          The number of right hand sides, i.e., the number of columns
 *>          of the matrices B and X.  NRHS >= 0.
 *> \endverbatim
 *>
 *> \param[in] AP
 *> \verbatim
 *>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
 *>          The upper or lower triangle of the Hermitian matrix A, packed
 *>          columnwise in a linear array.  The j-th column of A is stored
 *>          in the array AP as follows:
 *>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
 *>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
 *> \endverbatim
 *>
 *> \param[in] AFP
 *> \verbatim
 *>          AFP is COMPLEX*16 array, dimension (N*(N+1)/2)
 *>          The triangular factor U or L from the Cholesky factorization
 *>          A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,
 *>          packed columnwise in a linear array in the same format as A
 *>          (see AP).
 *> \endverbatim
 *>
 *> \param[in] B
 *> \verbatim
 *>          B is COMPLEX*16 array, dimension (LDB,NRHS)
 *>          The right hand side matrix B.
 *> \endverbatim
 *>
 *> \param[in] LDB
 *> \verbatim
 *>          LDB is INTEGER
 *>          The leading dimension of the array B.  LDB >= max(1,N).
 *> \endverbatim
 *>
 *> \param[in,out] X
 *> \verbatim
 *>          X is COMPLEX*16 array, dimension (LDX,NRHS)
 *>          On entry, the solution matrix X, as computed by ZPPTRS.
 *>          On exit, the improved solution matrix X.
 *> \endverbatim
 *>
 *> \param[in] LDX
 *> \verbatim
 *>          LDX is INTEGER
 *>          The leading dimension of the array X.  LDX >= max(1,N).
 *> \endverbatim
 *>
 *> \param[out] FERR
 *> \verbatim
 *>          FERR is DOUBLE PRECISION array, dimension (NRHS)
 *>          The estimated forward error bound for each solution vector
 *>          X(j) (the j-th column of the solution matrix X).
 *>          If XTRUE is the true solution corresponding to X(j), FERR(j)
 *>          is an estimated upper bound for the magnitude of the largest
 *>          element in (X(j) - XTRUE) divided by the magnitude of the
 *>          largest element in X(j).  The estimate is as reliable as
 *>          the estimate for RCOND, and is almost always a slight
 *>          overestimate of the true error.
 *> \endverbatim
 *>
 *> \param[out] BERR
 *> \verbatim
 *>          BERR is DOUBLE PRECISION array, dimension (NRHS)
 *>          The componentwise relative backward error of each solution
 *>          vector X(j) (i.e., the smallest relative change in
 *>          any element of A or B that makes X(j) an exact solution).
 *> \endverbatim
 *>
 *> \param[out] WORK
 *> \verbatim
 *>          WORK is COMPLEX*16 array, dimension (2*N)
 *> \endverbatim
 *>
 *> \param[out] RWORK
 *> \verbatim
 *>          RWORK is DOUBLE PRECISION array, dimension (N)
 *> \endverbatim
 *>
 *> \param[out] INFO
 *> \verbatim
 *>          INFO is INTEGER
 *>          = 0:  successful exit
 *>          < 0:  if INFO = -i, the i-th argument had an illegal value
 *> \endverbatim
 *
 *> \par Internal Parameters:
 *  =========================
 *>
 *> \verbatim
 *>  ITMAX is the maximum number of steps of iterative refinement.
 *> \endverbatim
 *
 *  Authors:
 *  ========
 *
 *> \author Univ. of Tennessee
 *> \author Univ. of California Berkeley
 *> \author Univ. of Colorado Denver
 *> \author NAG Ltd.
 *
 *> \date December 2016
 *
 *> \ingroup complex16OTHERcomputational
 *
 *  =====================================================================
       SUBROUTINE zpprfs( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
      $                   BERR, WORK, RWORK, INFO )
 *
 *  -- LAPACK computational routine (version 3.7.0) --
 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 *     December 2016
 *
 *     .. Scalar Arguments ..
       CHARACTER          UPLO
       INTEGER            INFO, LDB, LDX, N, NRHS
 *     ..
 *     .. Array Arguments ..
       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
       COMPLEX*16         AFP( * ), AP( * ), B( ldb, * ), WORK( * ),
      $                   x( ldx, * )
 *     ..
 *
 *  ====================================================================
 *
 *     .. Parameters ..
       INTEGER            ITMAX
       parameter( itmax = 5 )
       DOUBLE PRECISION   ZERO
       parameter( zero = 0.0d+0 )
       COMPLEX*16         CONE
       parameter( cone = ( 1.0d+0, 0.0d+0 ) )
       DOUBLE PRECISION   TWO
       parameter( two = 2.0d+0 )
       DOUBLE PRECISION   THREE
       parameter( three = 3.0d+0 )
 *     ..
 *     .. Local Scalars ..
       LOGICAL            UPPER
       INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
       DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
       COMPLEX*16         ZDUM
 *     ..
 *     .. Local Arrays ..
       INTEGER            ISAVE( 3 )
 *     ..
 *     .. External Subroutines ..
       EXTERNAL           xerbla, zaxpy, zcopy, zhpmv, zlacn2, zpptrs
 *     ..
 *     .. Intrinsic Functions ..
       INTRINSIC          abs, dble, dimag, max
 *     ..
 *     .. External Functions ..
       LOGICAL            LSAME
       DOUBLE PRECISION   DLAMCH
       EXTERNAL           lsame, dlamch
 *     ..
 *     .. Statement Functions ..
       DOUBLE PRECISION   CABS1
 *     ..
 *     .. Statement Function definitions ..
       cabs1( zdum ) = abs( dble( zdum ) ) + abs( dimag( zdum ) )
 *     ..
 *     .. Executable Statements ..
 *
 *     Test the input parameters.
 *
       info = 0
       upper = lsame( uplo, 'U' )
       IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN
          info = -1
       ELSE IF( n.LT.0 ) THEN
          info = -2
       ELSE IF( nrhs.LT.0 ) THEN
          info = -3
       ELSE IF( ldb.LT.max( 1, n ) ) THEN
          info = -7
       ELSE IF( ldx.LT.max( 1, n ) ) THEN
          info = -9
       END IF
       IF( info.NE.0 ) THEN
          CALL xerbla( 'ZPPRFS', -info )
          RETURN
       END IF
 *
 *     Quick return if possible
 *
       IF( n.EQ.0 .OR. nrhs.EQ.0 ) THEN
          DO 10 j = 1, nrhs
             ferr( j ) = zero
             berr( j ) = zero
    10    CONTINUE
          RETURN
       END IF
 *
 *     NZ = maximum number of nonzero elements in each row of A, plus 1
 *
       nz = n + 1
       eps = dlamch( 'Epsilon' )
       safmin = dlamch( 'Safe minimum' )
       safe1 = nz*safmin
       safe2 = safe1 / eps
 *
 *     Do for each right hand side
 *
       DO 140 j = 1, nrhs
 *
          count = 1
          lstres = three
    20    CONTINUE
 *
 *        Loop until stopping criterion is satisfied.
 *
 *        Compute residual R = B - A * X
 *
          CALL zcopy( n, b( 1, j ), 1, work, 1 )
          CALL zhpmv( uplo, n, -cone, ap, x( 1, j ), 1, cone, work, 1 )
 *
 *        Compute componentwise relative backward error from formula
 *
 *        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
 *
 *        where abs(Z) is the componentwise absolute value of the matrix
 *        or vector Z.  If the i-th component of the denominator is less
 *        than SAFE2, then SAFE1 is added to the i-th components of the
 *        numerator and denominator before dividing.
 *
          DO 30 i = 1, n
             rwork( i ) = cabs1( b( i, j ) )
    30    CONTINUE
 *
 *        Compute abs(A)*abs(X) + abs(B).
 *
          kk = 1
          IF( upper ) THEN
             DO 50 k = 1, n
                s = zero
                xk = cabs1( x( k, j ) )
                ik = kk
                DO 40 i = 1, k - 1
                   rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
                   s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
                   ik = ik + 1
    40          CONTINUE
                rwork( k ) = rwork( k ) + abs( dble( ap( kk+k-1 ) ) )*
      $                      xk + s
                kk = kk + k
    50       CONTINUE
          ELSE
             DO 70 k = 1, n
                s = zero
                xk = cabs1( x( k, j ) )
                rwork( k ) = rwork( k ) + abs( dble( ap( kk ) ) )*xk
                ik = kk + 1
                DO 60 i = k + 1, n
                   rwork( i ) = rwork( i ) + cabs1( ap( ik ) )*xk
                   s = s + cabs1( ap( ik ) )*cabs1( x( i, j ) )
                   ik = ik + 1
    60          CONTINUE
                rwork( k ) = rwork( k ) + s
                kk = kk + ( n-k+1 )
    70       CONTINUE
          END IF
          s = zero
          DO 80 i = 1, n
             IF( rwork( i ).GT.safe2 ) THEN
                s = max( s, cabs1( work( i ) ) / rwork( i ) )
             ELSE
                s = max( s, ( cabs1( work( i ) )+safe1 ) /
      $             ( rwork( i )+safe1 ) )
             END IF
    80    CONTINUE
          berr( j ) = s
 *
 *        Test stopping criterion. Continue iterating if
 *           1) The residual BERR(J) is larger than machine epsilon, and
 *           2) BERR(J) decreased by at least a factor of 2 during the
 *              last iteration, and
 *           3) At most ITMAX iterations tried.
 *
          IF( berr( j ).GT.eps .AND. two*berr( j ).LE.lstres .AND.
      $       count.LE.itmax ) THEN
 *
 *           Update solution and try again.
 *
             CALL zpptrs( uplo, n, 1, afp, work, n, info )
             CALL zaxpy( n, cone, work, 1, x( 1, j ), 1 )
             lstres = berr( j )
             count = count + 1
             GO TO 20
          END IF
 *
 *        Bound error from formula
 *
 *        norm(X - XTRUE) / norm(X) .le. FERR =
 *        norm( abs(inv(A))*
 *           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
 *
 *        where
 *          norm(Z) is the magnitude of the largest component of Z
 *          inv(A) is the inverse of A
 *          abs(Z) is the componentwise absolute value of the matrix or
 *             vector Z
 *          NZ is the maximum number of nonzeros in any row of A, plus 1
 *          EPS is machine epsilon
 *
 *        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
 *        is incremented by SAFE1 if the i-th component of
 *        abs(A)*abs(X) + abs(B) is less than SAFE2.
 *
 *        Use ZLACN2 to estimate the infinity-norm of the matrix
 *           inv(A) * diag(W),
 *        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
 *
          DO 90 i = 1, n
             IF( rwork( i ).GT.safe2 ) THEN
                rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i )
             ELSE
                rwork( i ) = cabs1( work( i ) ) + nz*eps*rwork( i ) +
      $                      safe1
             END IF
    90    CONTINUE
 *
          kase = 0
   100    CONTINUE
          CALL zlacn2( n, work( n+1 ), work, ferr( j ), kase, isave )
          IF( kase.NE.0 ) THEN
             IF( kase.EQ.1 ) THEN
 *
 *              Multiply by diag(W)*inv(A**H).
 *
                CALL zpptrs( uplo, n, 1, afp, work, n, info )
                DO 110 i = 1, n
                   work( i ) = rwork( i )*work( i )
   110          CONTINUE
             ELSE IF( kase.EQ.2 ) THEN
 *
 *              Multiply by inv(A)*diag(W).
 *
                DO 120 i = 1, n
                   work( i ) = rwork( i )*work( i )
   120          CONTINUE
                CALL zpptrs( uplo, n, 1, afp, work, n, info )
             END IF
             GO TO 100
          END IF
 *
 *        Normalize error.
 *
          lstres = zero
          DO 130 i = 1, n
             lstres = max( lstres, cabs1( x( i, j ) ) )
   130    CONTINUE
          IF( lstres.NE.zero )
      $      ferr( j ) = ferr( j ) / lstres
 *
   140 CONTINUE
 *
       RETURN
 *
 *     End of ZPPRFS
 *
       END
zpptrs
subroutine zpptrs(UPLO, N, NRHS, AP, B, LDB, INFO)
ZPPTRS
Definition: zpptrs.f:110

zcopy
subroutine zcopy(N, ZX, INCX, ZY, INCY)
ZCOPY
Definition: zcopy.f:83

zlacn2
subroutine zlacn2(N, V, X, EST, KASE, ISAVE)
ZLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vec...
Definition: zlacn2.f:135

xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62

zhpmv
subroutine zhpmv(UPLO, N, ALPHA, AP, X, INCX, BETA, Y, INCY)
ZHPMV
Definition: zhpmv.f:151

zaxpy
subroutine zaxpy(N, ZA, ZX, INCX, ZY, INCY)
ZAXPY
Definition: zaxpy.f:90

zpprfs
subroutine zpprfs(UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR, WORK, RWORK, INFO)
ZPPRFS
Definition: zpprfs.f:173