LAPACK 3.11.0 LAPACK: Linear Algebra PACKage
Loading...
Searching...
No Matches

## ◆ clavsy_rook()

 subroutine clavsy_rook ( character UPLO, character TRANS, character DIAG, integer N, integer NRHS, complex, dimension( lda, * ) A, integer LDA, integer, dimension( * ) IPIV, complex, dimension( ldb, * ) B, integer LDB, integer INFO )

CLAVSY_ROOK

Purpose:
``` CLAVSY_ROOK performs one of the matrix-vector operations
x := A*x  or  x := A'*x,
where x is an N element vector and  A is one of the factors
from the block U*D*U' or L*D*L' factorization computed by CSYTRF_ROOK.

If TRANS = 'N', multiplies by U  or U * D  (or L  or L * D)
If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')```
Parameters
 [in] UPLO ``` UPLO is CHARACTER*1 Specifies whether the factor stored in A is upper or lower triangular. = 'U': Upper triangular = 'L': Lower triangular``` [in] TRANS ``` TRANS is CHARACTER*1 Specifies the operation to be performed: = 'N': x := A*x = 'T': x := A'*x``` [in] DIAG ``` DIAG is CHARACTER*1 Specifies whether or not the diagonal blocks are unit matrices. If the diagonal blocks are assumed to be unit, then A = U or A = L, otherwise A = U*D or A = L*D. = 'U': Diagonal blocks are assumed to be unit matrices. = 'N': Diagonal blocks are assumed to be non-unit matrices.``` [in] N ``` N is INTEGER The number of rows and columns of the matrix A. N >= 0.``` [in] NRHS ``` NRHS is INTEGER The number of right hand sides, i.e., the number of vectors x to be multiplied by A. NRHS >= 0.``` [in] A ``` A is COMPLEX array, dimension (LDA,N) The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by CSYTRF_ROOK. Stored as a 2-D triangular matrix.``` [in] LDA ``` LDA is INTEGER The leading dimension of the array A. LDA >= max(1,N).``` [in] IPIV ``` IPIV is INTEGER array, dimension (N) Details of the interchanges and the block structure of D, as determined by CSYTRF_ROOK. If UPLO = 'U': If IPIV(k) > 0, then rows and columns k and IPIV(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. (If IPIV( k ) = k, no interchange was done). If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and columns k and -IPIV(k) were interchanged and rows and columns k-1 and -IPIV(k-1) were inerchaged, D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L': If IPIV(k) > 0, then rows and columns k and IPIV(k) were interchanged and D(k,k) is a 1-by-1 diagonal block. (If IPIV( k ) = k, no interchange was done). If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and columns k and -IPIV(k) were interchanged and rows and columns k+1 and -IPIV(k+1) were inerchaged, D(k:k+1,k:k+1) is a 2-by-2 diagonal block.``` [in,out] B ``` B is COMPLEX array, dimension (LDB,NRHS) On entry, B contains NRHS vectors of length N. On exit, B is overwritten with the product A * B.``` [in] LDB ``` LDB is INTEGER The leading dimension of the array B. LDB >= max(1,N).``` [out] INFO ``` INFO is INTEGER = 0: successful exit < 0: if INFO = -k, the k-th argument had an illegal value```

Definition at line 153 of file clavsy_rook.f.

155*
156* -- LAPACK test routine --
157* -- LAPACK is a software package provided by Univ. of Tennessee, --
158* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
159*
160* .. Scalar Arguments ..
161 CHARACTER DIAG, TRANS, UPLO
162 INTEGER INFO, LDA, LDB, N, NRHS
163* ..
164* .. Array Arguments ..
165 INTEGER IPIV( * )
166 COMPLEX A( LDA, * ), B( LDB, * )
167* ..
168*
169* =====================================================================
170*
171* .. Parameters ..
172 COMPLEX CONE
173 parameter( cone = ( 1.0e+0, 0.0e+0 ) )
174* ..
175* .. Local Scalars ..
176 LOGICAL NOUNIT
177 INTEGER J, K, KP
178 COMPLEX D11, D12, D21, D22, T1, T2
179* ..
180* .. External Functions ..
181 LOGICAL LSAME
182 EXTERNAL lsame
183* ..
184* .. External Subroutines ..
185 EXTERNAL cgemv, cgeru, cscal, cswap, xerbla
186* ..
187* .. Intrinsic Functions ..
188 INTRINSIC abs, max
189* ..
190* .. Executable Statements ..
191*
192* Test the input parameters.
193*
194 info = 0
195 IF( .NOT.lsame( uplo, 'U' ) .AND. .NOT.lsame( uplo, 'L' ) ) THEN
196 info = -1
197 ELSE IF( .NOT.lsame( trans, 'N' ) .AND. .NOT.lsame( trans, 'T' ) )
198 \$ THEN
199 info = -2
200 ELSE IF( .NOT.lsame( diag, 'U' ) .AND. .NOT.lsame( diag, 'N' ) )
201 \$ THEN
202 info = -3
203 ELSE IF( n.LT.0 ) THEN
204 info = -4
205 ELSE IF( lda.LT.max( 1, n ) ) THEN
206 info = -6
207 ELSE IF( ldb.LT.max( 1, n ) ) THEN
208 info = -9
209 END IF
210 IF( info.NE.0 ) THEN
211 CALL xerbla( 'CLAVSY_ROOK ', -info )
212 RETURN
213 END IF
214*
215* Quick return if possible.
216*
217 IF( n.EQ.0 )
218 \$ RETURN
219*
220 nounit = lsame( diag, 'N' )
221*------------------------------------------
222*
223* Compute B := A * B (No transpose)
224*
225*------------------------------------------
226 IF( lsame( trans, 'N' ) ) THEN
227*
228* Compute B := U*B
229* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
230*
231 IF( lsame( uplo, 'U' ) ) THEN
232*
233* Loop forward applying the transformations.
234*
235 k = 1
236 10 CONTINUE
237 IF( k.GT.n )
238 \$ GO TO 30
239 IF( ipiv( k ).GT.0 ) THEN
240*
241* 1 x 1 pivot block
242*
243* Multiply by the diagonal element if forming U * D.
244*
245 IF( nounit )
246 \$ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
247*
248* Multiply by P(K) * inv(U(K)) if K > 1.
249*
250 IF( k.GT.1 ) THEN
251*
252* Apply the transformation.
253*
254 CALL cgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
255 \$ ldb, b( 1, 1 ), ldb )
256*
257* Interchange if P(K) != I.
258*
259 kp = ipiv( k )
260 IF( kp.NE.k )
261 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
262 END IF
263 k = k + 1
264 ELSE
265*
266* 2 x 2 pivot block
267*
268* Multiply by the diagonal block if forming U * D.
269*
270 IF( nounit ) THEN
271 d11 = a( k, k )
272 d22 = a( k+1, k+1 )
273 d12 = a( k, k+1 )
274 d21 = d12
275 DO 20 j = 1, nrhs
276 t1 = b( k, j )
277 t2 = b( k+1, j )
278 b( k, j ) = d11*t1 + d12*t2
279 b( k+1, j ) = d21*t1 + d22*t2
280 20 CONTINUE
281 END IF
282*
283* Multiply by P(K) * inv(U(K)) if K > 1.
284*
285 IF( k.GT.1 ) THEN
286*
287* Apply the transformations.
288*
289 CALL cgeru( k-1, nrhs, cone, a( 1, k ), 1, b( k, 1 ),
290 \$ ldb, b( 1, 1 ), ldb )
291 CALL cgeru( k-1, nrhs, cone, a( 1, k+1 ), 1,
292 \$ b( k+1, 1 ), ldb, b( 1, 1 ), ldb )
293*
294* Interchange if a permutation was applied at the
295* K-th step of the factorization.
296*
297* Swap the first of pair with IMAXth
298*
299 kp = abs( ipiv( k ) )
300 IF( kp.NE.k )
301 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
302*
303* NOW swap the first of pair with Pth
304*
305 kp = abs( ipiv( k+1 ) )
306 IF( kp.NE.k+1 )
307 \$ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
308 \$ ldb )
309 END IF
310 k = k + 2
311 END IF
312 GO TO 10
313 30 CONTINUE
314*
315* Compute B := L*B
316* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m)) .
317*
318 ELSE
319*
320* Loop backward applying the transformations to B.
321*
322 k = n
323 40 CONTINUE
324 IF( k.LT.1 )
325 \$ GO TO 60
326*
327* Test the pivot index. If greater than zero, a 1 x 1
328* pivot was used, otherwise a 2 x 2 pivot was used.
329*
330 IF( ipiv( k ).GT.0 ) THEN
331*
332* 1 x 1 pivot block:
333*
334* Multiply by the diagonal element if forming L * D.
335*
336 IF( nounit )
337 \$ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
338*
339* Multiply by P(K) * inv(L(K)) if K < N.
340*
341 IF( k.NE.n ) THEN
342 kp = ipiv( k )
343*
344* Apply the transformation.
345*
346 CALL cgeru( n-k, nrhs, cone, a( k+1, k ), 1,
347 \$ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
348*
349* Interchange if a permutation was applied at the
350* K-th step of the factorization.
351*
352 IF( kp.NE.k )
353 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
354 END IF
355 k = k - 1
356*
357 ELSE
358*
359* 2 x 2 pivot block:
360*
361* Multiply by the diagonal block if forming L * D.
362*
363 IF( nounit ) THEN
364 d11 = a( k-1, k-1 )
365 d22 = a( k, k )
366 d21 = a( k, k-1 )
367 d12 = d21
368 DO 50 j = 1, nrhs
369 t1 = b( k-1, j )
370 t2 = b( k, j )
371 b( k-1, j ) = d11*t1 + d12*t2
372 b( k, j ) = d21*t1 + d22*t2
373 50 CONTINUE
374 END IF
375*
376* Multiply by P(K) * inv(L(K)) if K < N.
377*
378 IF( k.NE.n ) THEN
379*
380* Apply the transformation.
381*
382 CALL cgeru( n-k, nrhs, cone, a( k+1, k ), 1,
383 \$ b( k, 1 ), ldb, b( k+1, 1 ), ldb )
384 CALL cgeru( n-k, nrhs, cone, a( k+1, k-1 ), 1,
385 \$ b( k-1, 1 ), ldb, b( k+1, 1 ), ldb )
386*
387* Interchange if a permutation was applied at the
388* K-th step of the factorization.
389*
390* Swap the second of pair with IMAXth
391*
392 kp = abs( ipiv( k ) )
393 IF( kp.NE.k )
394 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
395*
396* NOW swap the first of pair with Pth
397*
398 kp = abs( ipiv( k-1 ) )
399 IF( kp.NE.k-1 )
400 \$ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
401 \$ ldb )
402 END IF
403 k = k - 2
404 END IF
405 GO TO 40
406 60 CONTINUE
407 END IF
408*----------------------------------------
409*
410* Compute B := A' * B (transpose)
411*
412*----------------------------------------
413 ELSE IF( lsame( trans, 'T' ) ) THEN
414*
415* Form B := U'*B
416* where U = P(m)*inv(U(m))* ... *P(1)*inv(U(1))
417* and U' = inv(U'(1))*P(1)* ... *inv(U'(m))*P(m)
418*
419 IF( lsame( uplo, 'U' ) ) THEN
420*
421* Loop backward applying the transformations.
422*
423 k = n
424 70 IF( k.LT.1 )
425 \$ GO TO 90
426*
427* 1 x 1 pivot block.
428*
429 IF( ipiv( k ).GT.0 ) THEN
430 IF( k.GT.1 ) THEN
431*
432* Interchange if P(K) != I.
433*
434 kp = ipiv( k )
435 IF( kp.NE.k )
436 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
437*
438* Apply the transformation
439*
440 CALL cgemv( 'Transpose', k-1, nrhs, cone, b, ldb,
441 \$ a( 1, k ), 1, cone, b( k, 1 ), ldb )
442 END IF
443 IF( nounit )
444 \$ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
445 k = k - 1
446*
447* 2 x 2 pivot block.
448*
449 ELSE
450 IF( k.GT.2 ) THEN
451*
452* Swap the second of pair with Pth
453*
454 kp = abs( ipiv( k ) )
455 IF( kp.NE.k )
456 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
457*
458* Now swap the first of pair with IMAX(r)th
459*
460 kp = abs( ipiv( k-1 ) )
461 IF( kp.NE.k-1 )
462 \$ CALL cswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
463 \$ ldb )
464*
465* Apply the transformations
466*
467 CALL cgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
468 \$ a( 1, k ), 1, cone, b( k, 1 ), ldb )
469 CALL cgemv( 'Transpose', k-2, nrhs, cone, b, ldb,
470 \$ a( 1, k-1 ), 1, cone, b( k-1, 1 ), ldb )
471 END IF
472*
473* Multiply by the diagonal block if non-unit.
474*
475 IF( nounit ) THEN
476 d11 = a( k-1, k-1 )
477 d22 = a( k, k )
478 d12 = a( k-1, k )
479 d21 = d12
480 DO 80 j = 1, nrhs
481 t1 = b( k-1, j )
482 t2 = b( k, j )
483 b( k-1, j ) = d11*t1 + d12*t2
484 b( k, j ) = d21*t1 + d22*t2
485 80 CONTINUE
486 END IF
487 k = k - 2
488 END IF
489 GO TO 70
490 90 CONTINUE
491*
492* Form B := L'*B
493* where L = P(1)*inv(L(1))* ... *P(m)*inv(L(m))
494* and L' = inv(L'(m))*P(m)* ... *inv(L'(1))*P(1)
495*
496 ELSE
497*
498* Loop forward applying the L-transformations.
499*
500 k = 1
501 100 CONTINUE
502 IF( k.GT.n )
503 \$ GO TO 120
504*
505* 1 x 1 pivot block
506*
507 IF( ipiv( k ).GT.0 ) THEN
508 IF( k.LT.n ) THEN
509*
510* Interchange if P(K) != I.
511*
512 kp = ipiv( k )
513 IF( kp.NE.k )
514 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
515*
516* Apply the transformation
517*
518 CALL cgemv( 'Transpose', n-k, nrhs, cone, b( k+1, 1 ),
519 \$ ldb, a( k+1, k ), 1, cone, b( k, 1 ), ldb )
520 END IF
521 IF( nounit )
522 \$ CALL cscal( nrhs, a( k, k ), b( k, 1 ), ldb )
523 k = k + 1
524*
525* 2 x 2 pivot block.
526*
527 ELSE
528 IF( k.LT.n-1 ) THEN
529*
530* Swap the first of pair with Pth
531*
532 kp = abs( ipiv( k ) )
533 IF( kp.NE.k )
534 \$ CALL cswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
535*
536* Now swap the second of pair with IMAX(r)th
537*
538 kp = abs( ipiv( k+1 ) )
539 IF( kp.NE.k+1 )
540 \$ CALL cswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
541 \$ ldb )
542*
543* Apply the transformation
544*
545 CALL cgemv( 'Transpose', n-k-1, nrhs, cone,
546 \$ b( k+2, 1 ), ldb, a( k+2, k+1 ), 1, cone,
547 \$ b( k+1, 1 ), ldb )
548 CALL cgemv( 'Transpose', n-k-1, nrhs, cone,
549 \$ b( k+2, 1 ), ldb, a( k+2, k ), 1, cone,
550 \$ b( k, 1 ), ldb )
551 END IF
552*
553* Multiply by the diagonal block if non-unit.
554*
555 IF( nounit ) THEN
556 d11 = a( k, k )
557 d22 = a( k+1, k+1 )
558 d21 = a( k+1, k )
559 d12 = d21
560 DO 110 j = 1, nrhs
561 t1 = b( k, j )
562 t2 = b( k+1, j )
563 b( k, j ) = d11*t1 + d12*t2
564 b( k+1, j ) = d21*t1 + d22*t2
565 110 CONTINUE
566 END IF
567 k = k + 2
568 END IF
569 GO TO 100
570 120 CONTINUE
571 END IF
572 END IF
573 RETURN
574*
575* End of CLAVSY_ROOK
576*
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:60
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:53
subroutine cswap(N, CX, INCX, CY, INCY)
CSWAP
Definition: cswap.f:81
subroutine cscal(N, CA, CX, INCX)
CSCAL
Definition: cscal.f:78
subroutine cgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
CGEMV
Definition: cgemv.f:158
subroutine cgeru(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
CGERU
Definition: cgeru.f:130
Here is the call graph for this function:
Here is the caller graph for this function: