LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Searching...
No Matches
zlavhe.f
Go to the documentation of this file.
1*> \brief \b ZLAVHE
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8* Definition:
9* ===========
10*
11* SUBROUTINE ZLAVHE( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
12* LDB, INFO )
13*
14* .. Scalar Arguments ..
15* CHARACTER DIAG, TRANS, UPLO
16* INTEGER INFO, LDA, LDB, N, NRHS
17* ..
18* .. Array Arguments ..
19* INTEGER IPIV( * )
20* COMPLEX*16 A( LDA, * ), B( LDB, * )
21* ..
22*
23*
24*> \par Purpose:
25* =============
26*>
27*> \verbatim
28*>
29*> ZLAVHE performs one of the matrix-vector operations
30*> x := A*x or x := A^H*x,
31*> where x is an N element vector and A is one of the factors
32*> from the block U*D*U' or L*D*L' factorization computed by ZHETRF.
33*>
34*> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
35*> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
36*> \endverbatim
37*
38* Arguments:
39* ==========
40*
41*> \param[in] UPLO
42*> \verbatim
43*> UPLO is CHARACTER*1
44*> Specifies whether the factor stored in A is upper or lower
45*> triangular.
46*> = 'U': Upper triangular
47*> = 'L': Lower triangular
48*> \endverbatim
49*>
50*> \param[in] TRANS
51*> \verbatim
52*> TRANS is CHARACTER*1
53*> Specifies the operation to be performed:
54*> = 'N': x := A*x
55*> = 'C': x := A'*x
56*> \endverbatim
57*>
58*> \param[in] DIAG
59*> \verbatim
60*> DIAG is CHARACTER*1
61*> Specifies whether or not the diagonal blocks are unit
62*> matrices. If the diagonal blocks are assumed to be unit,
63*> then A = U or A = L, otherwise A = U*D or A = L*D.
64*> = 'U': Diagonal blocks are assumed to be unit matrices.
65*> = 'N': Diagonal blocks are assumed to be non-unit matrices.
66*> \endverbatim
67*>
68*> \param[in] N
69*> \verbatim
70*> N is INTEGER
71*> The number of rows and columns of the matrix A. N >= 0.
72*> \endverbatim
73*>
74*> \param[in] NRHS
75*> \verbatim
76*> NRHS is INTEGER
77*> The number of right hand sides, i.e., the number of vectors
78*> x to be multiplied by A. NRHS >= 0.
79*> \endverbatim
80*>
81*> \param[in] A
82*> \verbatim
83*> A is COMPLEX*16 array, dimension (LDA,N)
84*> The block diagonal matrix D and the multipliers used to
85*> obtain the factor U or L as computed by ZHETRF.
86*> Stored as a 2-D triangular matrix.
87*> \endverbatim
88*>
89*> \param[in] LDA
90*> \verbatim
91*> LDA is INTEGER
92*> The leading dimension of the array A. LDA >= max(1,N).
93*> \endverbatim
94*>
95*> \param[in] IPIV
96*> \verbatim
97*> IPIV is INTEGER array, dimension (N)
98*> Details of the interchanges and the block structure of D,
99*> as determined by ZHETRF.
100*>
101*> If UPLO = 'U':
102*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
103*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
104*> (If IPIV( k ) = k, no interchange was done).
105*>
106*> If IPIV(k) = IPIV(k-1) < 0, then rows and
107*> columns k-1 and -IPIV(k) were interchanged,
108*> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
109*>
110*> If UPLO = 'L':
111*> If IPIV(k) > 0, then rows and columns k and IPIV(k)
112*> were interchanged and D(k,k) is a 1-by-1 diagonal block.
113*> (If IPIV( k ) = k, no interchange was done).
114*>
115*> If IPIV(k) = IPIV(k+1) < 0, then rows and
116*> columns k+1 and -IPIV(k) were interchanged,
117*> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
118*> \endverbatim
119*>
120*> \param[in,out] B
121*> \verbatim
122*> B is COMPLEX*16 array, dimension (LDB,NRHS)
123*> On entry, B contains NRHS vectors of length N.
124*> On exit, B is overwritten with the product A * B.
125*> \endverbatim
126*>
127*> \param[in] LDB
128*> \verbatim
129*> LDB is INTEGER
130*> The leading dimension of the array B. LDB >= max(1,N).
131*> \endverbatim
132*>
133*> \param[out] INFO
134*> \verbatim
135*> INFO is INTEGER
136*> = 0: successful exit
137*> < 0: if INFO = -k, the k-th argument had an illegal value
138*> \endverbatim
139*
140* Authors:
141* ========
142*
143*> \author Univ. of Tennessee
144*> \author Univ. of California Berkeley
145*> \author Univ. of Colorado Denver
146*> \author NAG Ltd.
147*
148*> \ingroup complex16_lin
149*
150* =====================================================================
151 SUBROUTINE zlavhe( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B,
152 \$ LDB, INFO )
153*
154* -- LAPACK test routine --
155* -- LAPACK is a software package provided by Univ. of Tennessee, --
156* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
157*
158* .. Scalar Arguments ..
159 CHARACTER DIAG, TRANS, UPLO
160 INTEGER INFO, LDA, LDB, N, NRHS
161* ..
162* .. Array Arguments ..
163 INTEGER IPIV( * )
164 COMPLEX*16 A( LDA, * ), B( LDB, * )
165* ..
166*
167* =====================================================================
168*
169* .. Parameters ..
170 COMPLEX*16 ONE
171 parameter( one = ( 1.0d+0, 0.0d+0 ) )
172* ..
173* .. Local Scalars ..
174 LOGICAL NOUNIT
175 INTEGER J, K, KP
176 COMPLEX*16 D11, D12, D21, D22, T1, T2
177* ..
178* .. External Functions ..
179 LOGICAL LSAME
180 EXTERNAL lsame
181* ..
182* .. External Subroutines ..
183 EXTERNAL xerbla, zgemv, zgeru, zlacgv, zscal, zswap
184* ..
185* .. Intrinsic Functions ..
186 INTRINSIC abs, dconjg, max
187* ..
188* .. Executable Statements ..
189*
190* Test the input parameters.
191*
192 info = 0
193 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
194 info = -1
195 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'C' ) )
196 \$ THEN
197 info = -2
198 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
199 \$ THEN
200 info = -3
201 ELSE IF( n.LT.0 ) THEN
202 info = -4
203 ELSE IF( lda.LT.max( 1, n ) ) THEN
204 info = -6
205 ELSE IF( ldb.LT.max( 1, n ) ) THEN
206 info = -9
207 END IF
208 IF( info.NE.0 ) THEN
209 CALL xerbla( 'ZLAVHE ', -info )
210 RETURN
211 END IF
212*
213* Quick return if possible.
214*
215 IF( n.EQ.0 )
216 \$ RETURN
217*
218 nounit = lsame( diag, 'N' )
219*------------------------------------------
220*
221* Compute B := A * B (No transpose)
222*
223*------------------------------------------
224 IF( lsame( trans, 'N' ) ) THEN
225*
226* Compute B := U*B
227* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
228*
229 IF( lsame( uplo, 'U' ) ) THEN
230*
231* Loop forward applying the transformations.
232*
233 k = 1
234 10 CONTINUE
235 IF( k.GT.n )
236 \$ GO TO 30
237 IF( ipiv( k ).GT.0 ) THEN
238*
239* 1 x 1 pivot block
240*
241* Multiply by the diagonal element if forming U * D.
242*
243 IF( nounit )
244 \$ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
245*
246* Multiply by P(K) * inv(U(K)) if K > 1.
247*
248 IF( k.GT.1 ) THEN
249*
250* Apply the transformation.
251*
252 CALL zgeru( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
253 \$ ldb, b( 1, 1 ), ldb )
254*
255* Interchange if P(K) != I.
256*
257 kp = ipiv( k )
258 IF( kp.NE.k )
259 \$ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
260 END IF
261 k = k + 1
262 ELSE
263*
264* 2 x 2 pivot block
265*
266* Multiply by the diagonal block if forming U * D.
267*
268 IF( nounit ) THEN
269 d11 = a( k, k )
270 d22 = a( k+1, k+1 )
271 d12 = a( k, k+1 )
272 d21 = dconjg( d12 )
273 DO 20 j = 1, nrhs
274 t1 = b( k, j )
275 t2 = b( k+1, j )
276 b( k, j ) = d11*t1 + d12*t2
277 b( k+1, j ) = d21*t1 + d22*t2
278 20 CONTINUE
279 END IF
280*
281* Multiply by P(K) * inv(U(K)) if K > 1.
282*
283 IF( k.GT.1 ) THEN
284*
285* Apply the transformations.
286*
287 CALL zgeru( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
288 \$ ldb, b( 1, 1 ), ldb )
289 CALL zgeru( k-1, nrhs, one, a( 1, k+1 ), 1,
290 \$ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
291*
292* Interchange if P(K) != I.
293*
294 kp = abs( ipiv( k ) )
295 IF( kp.NE.k )
296 \$ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
297 END IF
298 k = k + 2
299 END IF
300 GO TO 10
301 30 CONTINUE
302*
303* Compute B := L*B
304* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
305*
306 ELSE
307*
308* Loop backward applying the transformations to B.
309*
310 k = n
311 40 CONTINUE
312 IF( k.LT.1 )
313 \$ GO TO 60
314*
315* Test the pivot index. If greater than zero, a 1 x 1
316* pivot was used, otherwise a 2 x 2 pivot was used.
317*
318 IF( ipiv( k ).GT.0 ) THEN
319*
320* 1 x 1 pivot block:
321*
322* Multiply by the diagonal element if forming L * D.
323*
324 IF( nounit )
325 \$ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
326*
327* Multiply by P(K) * inv(L(K)) if K < N.
328*
329 IF( k.NE.n ) THEN
330 kp = ipiv( k )
331*
332* Apply the transformation.
333*
334 CALL zgeru( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
335 \$ ldb, b( k+1, 1 ), ldb )
336*
337* Interchange if a permutation was applied at the
338* K-th step of the factorization.
339*
340 IF( kp.NE.k )
341 \$ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
342 END IF
343 k = k - 1
344*
345 ELSE
346*
347* 2 x 2 pivot block:
348*
349* Multiply by the diagonal block if forming L * D.
350*
351 IF( nounit ) THEN
352 d11 = a( k-1, k-1 )
353 d22 = a( k, k )
354 d21 = a( k, k-1 )
355 d12 = dconjg( d21 )
356 DO 50 j = 1, nrhs
357 t1 = b( k-1, j )
358 t2 = b( k, j )
359 b( k-1, j ) = d11*t1 + d12*t2
360 b( k, j ) = d21*t1 + d22*t2
361 50 CONTINUE
362 END IF
363*
364* Multiply by P(K) * inv(L(K)) if K < N.
365*
366 IF( k.NE.n ) THEN
367*
368* Apply the transformation.
369*
370 CALL zgeru( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
371 \$ ldb, b( k+1, 1 ), ldb )
372 CALL zgeru( n-k, nrhs, one, a( k+1, k-1 ), 1,
373 \$ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
374*
375* Interchange if a permutation was applied at the
376* K-th step of the factorization.
377*
378 kp = abs( ipiv( k ) )
379 IF( kp.NE.k )
380 \$ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
381 END IF
382 k = k - 2
383 END IF
384 GO TO 40
385 60 CONTINUE
386 END IF
387*--------------------------------------------------
388*
389* Compute B := A^H * B (conjugate transpose)
390*
391*--------------------------------------------------
392 ELSE
393*
394* Form B := U^H*B
395* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
396* and U^H = inv(U^H(1))*P(1)* ... *inv(U^H(m))*P(m)
397*
398 IF( lsame( uplo, 'U' ) ) THEN
399*
400* Loop backward applying the transformations.
401*
402 k = n
403 70 CONTINUE
404 IF( k.LT.1 )
405 \$ GO TO 90
406*
407* 1 x 1 pivot block.
408*
409 IF( ipiv( k ).GT.0 ) THEN
410 IF( k.GT.1 ) THEN
411*
412* Interchange if P(K) != I.
413*
414 kp = ipiv( k )
415 IF( kp.NE.k )
416 \$ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
417*
418* Apply the transformation
419* y = y - B' conjg(x),
420* where x is a column of A and y is a row of B.
421*
422 CALL zlacgv( nrhs, b( k, 1 ), ldb )
423 CALL zgemv( 'Conjugate', k-1, nrhs, one, b, ldb,
424 \$ a( 1, k ), 1, one, b( k, 1 ), ldb )
425 CALL zlacgv( nrhs, b( k, 1 ), ldb )
426 END IF
427 IF( nounit )
428 \$ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
429 k = k - 1
430*
431* 2 x 2 pivot block.
432*
433 ELSE
434 IF( k.GT.2 ) THEN
435*
436* Interchange if P(K) != I.
437*
438 kp = abs( ipiv( k ) )
439 IF( kp.NE.k-1 )
440 \$ CALL zswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
441 \$ ldb )
442*
443* Apply the transformations
444* y = y - B' conjg(x),
445* where x is a block column of A and y is a block
446* row of B.
447*
448 CALL zlacgv( nrhs, b( k, 1 ), ldb )
449 CALL zgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
450 \$ a( 1, k ), 1, one, b( k, 1 ), ldb )
451 CALL zlacgv( nrhs, b( k, 1 ), ldb )
452*
453 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
454 CALL zgemv( 'Conjugate', k-2, nrhs, one, b, ldb,
455 \$ a( 1, k-1 ), 1, one, b( k-1, 1 ), ldb )
456 CALL zlacgv( nrhs, b( k-1, 1 ), ldb )
457 END IF
458*
459* Multiply by the diagonal block if non-unit.
460*
461 IF( nounit ) THEN
462 d11 = a( k-1, k-1 )
463 d22 = a( k, k )
464 d12 = a( k-1, k )
465 d21 = dconjg( d12 )
466 DO 80 j = 1, nrhs
467 t1 = b( k-1, j )
468 t2 = b( k, j )
469 b( k-1, j ) = d11*t1 + d12*t2
470 b( k, j ) = d21*t1 + d22*t2
471 80 CONTINUE
472 END IF
473 k = k - 2
474 END IF
475 GO TO 70
476 90 CONTINUE
477*
478* Form B := L^H*B
479* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
480* and L^H = inv(L^H(m))*P(m)* ... *inv(L^H(1))*P(1)
481*
482 ELSE
483*
484* Loop forward applying the L-transformations.
485*
486 k = 1
487 100 CONTINUE
488 IF( k.GT.n )
489 \$ GO TO 120
490*
491* 1 x 1 pivot block
492*
493 IF( ipiv( k ).GT.0 ) THEN
494 IF( k.LT.n ) THEN
495*
496* Interchange if P(K) != I.
497*
498 kp = ipiv( k )
499 IF( kp.NE.k )
500 \$ CALL zswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
501*
502* Apply the transformation
503*
504 CALL zlacgv( nrhs, b( k, 1 ), ldb )
505 CALL zgemv( 'Conjugate', n-k, nrhs, one, b( k+1, 1 ),
506 \$ ldb, a( k+1, k ), 1, one, b( k, 1 ), ldb )
507 CALL zlacgv( nrhs, b( k, 1 ), ldb )
508 END IF
509 IF( nounit )
510 \$ CALL zscal( nrhs, a( k, k ), b( k, 1 ), ldb )
511 k = k + 1
512*
513* 2 x 2 pivot block.
514*
515 ELSE
516 IF( k.LT.n-1 ) THEN
517*
518* Interchange if P(K) != I.
519*
520 kp = abs( ipiv( k ) )
521 IF( kp.NE.k+1 )
522 \$ CALL zswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
523 \$ ldb )
524*
525* Apply the transformation
526*
527 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
528 CALL zgemv( 'Conjugate', n-k-1, nrhs, one,
529 \$ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, one,
530 \$ b( k+1, 1 ), ldb )
531 CALL zlacgv( nrhs, b( k+1, 1 ), ldb )
532*
533 CALL zlacgv( nrhs, b( k, 1 ), ldb )
534 CALL zgemv( 'Conjugate', n-k-1, nrhs, one,
535 \$ b( k+2, 1 ), ldb, a( k+2, k ), 1, one,
536 \$ b( k, 1 ), ldb )
537 CALL zlacgv( nrhs, b( k, 1 ), ldb )
538 END IF
539*
540* Multiply by the diagonal block if non-unit.
541*
542 IF( nounit ) THEN
543 d11 = a( k, k )
544 d22 = a( k+1, k+1 )
545 d21 = a( k+1, k )
546 d12 = dconjg( d21 )
547 DO 110 j = 1, nrhs
548 t1 = b( k, j )
549 t2 = b( k+1, j )
550 b( k, j ) = d11*t1 + d12*t2
551 b( k+1, j ) = d21*t1 + d22*t2
552 110 CONTINUE
553 END IF
554 k = k + 2
555 END IF
556 GO TO 100
557 120 CONTINUE
558 END IF
559*
560 END IF
561 RETURN
562*
563* End of ZLAVHE
564*
565 END
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
subroutine zswap(N, ZX, INCX, ZY, INCY)
ZSWAP
Definition: zswap.f:81
subroutine zscal(N, ZA, ZX, INCX)
ZSCAL
Definition: zscal.f:78
subroutine zgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
ZGERU
Definition: zgeru.f:130
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
Definition: zgemv.f:158
subroutine zlavhe(UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
ZLAVHE
Definition: zlavhe.f:153
subroutine zlacgv(N, X, INCX)
ZLACGV conjugates a complex vector.
Definition: zlacgv.f:74