LAPACK  3.6.1 LAPACK: Linear Algebra PACKage
 subroutine dlavsy_rook ( character UPLO, character TRANS, character DIAG, integer N, integer NRHS, double precision, dimension( lda, * ) A, integer LDA, integer, dimension( * ) IPIV, double precision, dimension( ldb, * ) B, integer LDB, integer INFO )

DLAVSY_ROOK

Purpose:
``` DLAVSY_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 DSYTRF_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')
If TRANS = 'C', 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 = 'C': 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 DOUBLE PRECISION array, dimension (LDA,N) The block diagonal matrix D and the multipliers used to obtain the factor U or L as computed by DSYTRF_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 DSYTRF_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 DOUBLE PRECISION 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```
Date
November 2013

Definition at line 159 of file dlavsy_rook.f.

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

Here is the call graph for this function:

Here is the caller graph for this function: