1*> \brief \b ZPPRFS
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download ZPPRFS + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zpprfs.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zpprfs.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zpprfs.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
22*                          BERR, WORK, RWORK, INFO )
23*
24*       .. Scalar Arguments ..
25*       CHARACTER          UPLO
26*       INTEGER            INFO, LDB, LDX, N, NRHS
27*       ..
28*       .. Array Arguments ..
29*       DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
30*       COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
31*      $                   X( LDX, * )
32*       ..
33*
34*
35*> \par Purpose:
36*  =============
37*>
38*> \verbatim
39*>
40*> ZPPRFS improves the computed solution to a system of linear
41*> equations when the coefficient matrix is Hermitian positive definite
42*> and packed, and provides error bounds and backward error estimates
43*> for the solution.
44*> \endverbatim
45*
46*  Arguments:
47*  ==========
48*
49*> \param[in] UPLO
50*> \verbatim
51*>          UPLO is CHARACTER*1
52*>          = 'U':  Upper triangle of A is stored;
53*>          = 'L':  Lower triangle of A is stored.
54*> \endverbatim
55*>
56*> \param[in] N
57*> \verbatim
58*>          N is INTEGER
59*>          The order of the matrix A.  N >= 0.
60*> \endverbatim
61*>
62*> \param[in] NRHS
63*> \verbatim
64*>          NRHS is INTEGER
65*>          The number of right hand sides, i.e., the number of columns
66*>          of the matrices B and X.  NRHS >= 0.
67*> \endverbatim
68*>
69*> \param[in] AP
70*> \verbatim
71*>          AP is COMPLEX*16 array, dimension (N*(N+1)/2)
72*>          The upper or lower triangle of the Hermitian matrix A, packed
73*>          columnwise in a linear array.  The j-th column of A is stored
74*>          in the array AP as follows:
75*>          if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
76*>          if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
77*> \endverbatim
78*>
79*> \param[in] AFP
80*> \verbatim
81*>          AFP is COMPLEX*16 array, dimension (N*(N+1)/2)
82*>          The triangular factor U or L from the Cholesky factorization
83*>          A = U**H*U or A = L*L**H, as computed by DPPTRF/ZPPTRF,
84*>          packed columnwise in a linear array in the same format as A
85*>          (see AP).
86*> \endverbatim
87*>
88*> \param[in] B
89*> \verbatim
90*>          B is COMPLEX*16 array, dimension (LDB,NRHS)
91*>          The right hand side matrix B.
92*> \endverbatim
93*>
94*> \param[in] LDB
95*> \verbatim
96*>          LDB is INTEGER
97*>          The leading dimension of the array B.  LDB >= max(1,N).
98*> \endverbatim
99*>
100*> \param[in,out] X
101*> \verbatim
102*>          X is COMPLEX*16 array, dimension (LDX,NRHS)
103*>          On entry, the solution matrix X, as computed by ZPPTRS.
104*>          On exit, the improved solution matrix X.
105*> \endverbatim
106*>
107*> \param[in] LDX
108*> \verbatim
109*>          LDX is INTEGER
110*>          The leading dimension of the array X.  LDX >= max(1,N).
111*> \endverbatim
112*>
113*> \param[out] FERR
114*> \verbatim
115*>          FERR is DOUBLE PRECISION array, dimension (NRHS)
116*>          The estimated forward error bound for each solution vector
117*>          X(j) (the j-th column of the solution matrix X).
118*>          If XTRUE is the true solution corresponding to X(j), FERR(j)
119*>          is an estimated upper bound for the magnitude of the largest
120*>          element in (X(j) - XTRUE) divided by the magnitude of the
121*>          largest element in X(j).  The estimate is as reliable as
122*>          the estimate for RCOND, and is almost always a slight
123*>          overestimate of the true error.
124*> \endverbatim
125*>
126*> \param[out] BERR
127*> \verbatim
128*>          BERR is DOUBLE PRECISION array, dimension (NRHS)
129*>          The componentwise relative backward error of each solution
130*>          vector X(j) (i.e., the smallest relative change in
131*>          any element of A or B that makes X(j) an exact solution).
132*> \endverbatim
133*>
134*> \param[out] WORK
135*> \verbatim
136*>          WORK is COMPLEX*16 array, dimension (2*N)
137*> \endverbatim
138*>
139*> \param[out] RWORK
140*> \verbatim
141*>          RWORK is DOUBLE PRECISION array, dimension (N)
142*> \endverbatim
143*>
144*> \param[out] INFO
145*> \verbatim
146*>          INFO is INTEGER
147*>          = 0:  successful exit
148*>          < 0:  if INFO = -i, the i-th argument had an illegal value
149*> \endverbatim
150*
151*> \par Internal Parameters:
152*  =========================
153*>
154*> \verbatim
155*>  ITMAX is the maximum number of steps of iterative refinement.
156*> \endverbatim
157*
158*  Authors:
159*  ========
160*
161*> \author Univ. of Tennessee
162*> \author Univ. of California Berkeley
163*> \author Univ. of Colorado Denver
164*> \author NAG Ltd.
165*
166*> \date November 2011
167*
168*> \ingroup complex16OTHERcomputational
169*
170*  =====================================================================
171      SUBROUTINE ZPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
172     $                   BERR, WORK, RWORK, INFO )
173*
174*  -- LAPACK computational routine (version 3.4.0) --
175*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
176*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
177*     November 2011
178*
179*     .. Scalar Arguments ..
180      CHARACTER          UPLO
181      INTEGER            INFO, LDB, LDX, N, NRHS
182*     ..
183*     .. Array Arguments ..
184      DOUBLE PRECISION   BERR( * ), FERR( * ), RWORK( * )
185      COMPLEX*16         AFP( * ), AP( * ), B( LDB, * ), WORK( * ),
186     $                   X( LDX, * )
187*     ..
188*
189*  ====================================================================
190*
191*     .. Parameters ..
192      INTEGER            ITMAX
193      PARAMETER          ( ITMAX = 5 )
194      DOUBLE PRECISION   ZERO
195      PARAMETER          ( ZERO = 0.0D+0 )
196      COMPLEX*16         CONE
197      PARAMETER          ( CONE = ( 1.0D+0, 0.0D+0 ) )
198      DOUBLE PRECISION   TWO
199      PARAMETER          ( TWO = 2.0D+0 )
200      DOUBLE PRECISION   THREE
201      PARAMETER          ( THREE = 3.0D+0 )
202*     ..
203*     .. Local Scalars ..
204      LOGICAL            UPPER
205      INTEGER            COUNT, I, IK, J, K, KASE, KK, NZ
206      DOUBLE PRECISION   EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
207      COMPLEX*16         ZDUM
208*     ..
209*     .. Local Arrays ..
210      INTEGER            ISAVE( 3 )
211*     ..
212*     .. External Subroutines ..
213      EXTERNAL           XERBLA, ZAXPY, ZCOPY, ZHPMV, ZLACN2, ZPPTRS
214*     ..
215*     .. Intrinsic Functions ..
216      INTRINSIC          ABS, DBLE, DIMAG, MAX
217*     ..
218*     .. External Functions ..
219      LOGICAL            LSAME
220      DOUBLE PRECISION   DLAMCH
221      EXTERNAL           LSAME, DLAMCH
222*     ..
223*     .. Statement Functions ..
224      DOUBLE PRECISION   CABS1
225*     ..
226*     .. Statement Function definitions ..
227      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
228*     ..
229*     .. Executable Statements ..
230*
231*     Test the input parameters.
232*
233      INFO = 0
234      UPPER = LSAME( UPLO, 'U' )
235      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
236         INFO = -1
237      ELSE IF( N.LT.0 ) THEN
238         INFO = -2
239      ELSE IF( NRHS.LT.0 ) THEN
240         INFO = -3
241      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
242         INFO = -7
243      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
244         INFO = -9
245      END IF
246      IF( INFO.NE.0 ) THEN
247         CALL XERBLA( 'ZPPRFS', -INFO )
248         RETURN
249      END IF
250*
251*     Quick return if possible
252*
253      IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
254         DO 10 J = 1, NRHS
255            FERR( J ) = ZERO
256            BERR( J ) = ZERO
257   10    CONTINUE
258         RETURN
259      END IF
260*
261*     NZ = maximum number of nonzero elements in each row of A, plus 1
262*
263      NZ = N + 1
264      EPS = DLAMCH( 'Epsilon' )
265      SAFMIN = DLAMCH( 'Safe minimum' )
266      SAFE1 = NZ*SAFMIN
267      SAFE2 = SAFE1 / EPS
268*
269*     Do for each right hand side
270*
271      DO 140 J = 1, NRHS
272*
273         COUNT = 1
274         LSTRES = THREE
275   20    CONTINUE
276*
277*        Loop until stopping criterion is satisfied.
278*
279*        Compute residual R = B - A * X
280*
281         CALL ZCOPY( N, B( 1, J ), 1, WORK, 1 )
282         CALL ZHPMV( UPLO, N, -CONE, AP, X( 1, J ), 1, CONE, WORK, 1 )
283*
284*        Compute componentwise relative backward error from formula
285*
286*        max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
287*
288*        where abs(Z) is the componentwise absolute value of the matrix
289*        or vector Z.  If the i-th component of the denominator is less
290*        than SAFE2, then SAFE1 is added to the i-th components of the
291*        numerator and denominator before dividing.
292*
293         DO 30 I = 1, N
294            RWORK( I ) = CABS1( B( I, J ) )
295   30    CONTINUE
296*
297*        Compute abs(A)*abs(X) + abs(B).
298*
299         KK = 1
300         IF( UPPER ) THEN
301            DO 50 K = 1, N
302               S = ZERO
303               XK = CABS1( X( K, J ) )
304               IK = KK
305               DO 40 I = 1, K - 1
306                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
307                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
308                  IK = IK + 1
309   40          CONTINUE
310               RWORK( K ) = RWORK( K ) + ABS( DBLE( AP( KK+K-1 ) ) )*
311     $                      XK + S
312               KK = KK + K
313   50       CONTINUE
314         ELSE
315            DO 70 K = 1, N
316               S = ZERO
317               XK = CABS1( X( K, J ) )
318               RWORK( K ) = RWORK( K ) + ABS( DBLE( AP( KK ) ) )*XK
319               IK = KK + 1
320               DO 60 I = K + 1, N
321                  RWORK( I ) = RWORK( I ) + CABS1( AP( IK ) )*XK
322                  S = S + CABS1( AP( IK ) )*CABS1( X( I, J ) )
323                  IK = IK + 1
324   60          CONTINUE
325               RWORK( K ) = RWORK( K ) + S
326               KK = KK + ( N-K+1 )
327   70       CONTINUE
328         END IF
329         S = ZERO
330         DO 80 I = 1, N
331            IF( RWORK( I ).GT.SAFE2 ) THEN
332               S = MAX( S, CABS1( WORK( I ) ) / RWORK( I ) )
333            ELSE
334               S = MAX( S, ( CABS1( WORK( I ) )+SAFE1 ) /
335     $             ( RWORK( I )+SAFE1 ) )
336            END IF
337   80    CONTINUE
338         BERR( J ) = S
339*
340*        Test stopping criterion. Continue iterating if
341*           1) The residual BERR(J) is larger than machine epsilon, and
342*           2) BERR(J) decreased by at least a factor of 2 during the
343*              last iteration, and
344*           3) At most ITMAX iterations tried.
345*
346         IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
347     $       COUNT.LE.ITMAX ) THEN
348*
349*           Update solution and try again.
350*
351            CALL ZPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
352            CALL ZAXPY( N, CONE, WORK, 1, X( 1, J ), 1 )
353            LSTRES = BERR( J )
354            COUNT = COUNT + 1
355            GO TO 20
356         END IF
357*
358*        Bound error from formula
359*
360*        norm(X - XTRUE) / norm(X) .le. FERR =
361*        norm( abs(inv(A))*
362*           ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
363*
364*        where
365*          norm(Z) is the magnitude of the largest component of Z
366*          inv(A) is the inverse of A
367*          abs(Z) is the componentwise absolute value of the matrix or
368*             vector Z
369*          NZ is the maximum number of nonzeros in any row of A, plus 1
370*          EPS is machine epsilon
371*
372*        The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
373*        is incremented by SAFE1 if the i-th component of
374*        abs(A)*abs(X) + abs(B) is less than SAFE2.
375*
376*        Use ZLACN2 to estimate the infinity-norm of the matrix
377*           inv(A) * diag(W),
378*        where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
379*
380         DO 90 I = 1, N
381            IF( RWORK( I ).GT.SAFE2 ) THEN
382               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I )
383            ELSE
384               RWORK( I ) = CABS1( WORK( I ) ) + NZ*EPS*RWORK( I ) +
385     $                      SAFE1
386            END IF
387   90    CONTINUE
388*
389         KASE = 0
390  100    CONTINUE
391         CALL ZLACN2( N, WORK( N+1 ), WORK, FERR( J ), KASE, ISAVE )
392         IF( KASE.NE.0 ) THEN
393            IF( KASE.EQ.1 ) THEN
394*
395*              Multiply by diag(W)*inv(A**H).
396*
397               CALL ZPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
398               DO 110 I = 1, N
399                  WORK( I ) = RWORK( I )*WORK( I )
400  110          CONTINUE
401            ELSE IF( KASE.EQ.2 ) THEN
402*
403*              Multiply by inv(A)*diag(W).
404*
405               DO 120 I = 1, N
406                  WORK( I ) = RWORK( I )*WORK( I )
407  120          CONTINUE
408               CALL ZPPTRS( UPLO, N, 1, AFP, WORK, N, INFO )
409            END IF
410            GO TO 100
411         END IF
412*
413*        Normalize error.
414*
415         LSTRES = ZERO
416         DO 130 I = 1, N
417            LSTRES = MAX( LSTRES, CABS1( X( I, J ) ) )
418  130    CONTINUE
419         IF( LSTRES.NE.ZERO )
420     $      FERR( J ) = FERR( J ) / LSTRES
421*
422  140 CONTINUE
423*
424      RETURN
425*
426*     End of ZPPRFS
427*
428      END
429