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