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

SLAVSY_ROOK

Purpose: 
 SLAVSY_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 SSYTRF_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 REAL array, dimension (LDA,N)
          The block diagonal matrix D and the multipliers used to
          obtain the factor U or L as computed by SSYTRF_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 SSYTRF_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 REAL 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
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
November 2013

Definition at line 159 of file slavsy_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  REAL a( lda, * ), b( ldb, * )
172 * ..
173 *
174 * =====================================================================
175 *
176 * .. Parameters ..
177  REAL one
178  parameter ( one = 1.0e+0 )
179 * ..
180 * .. Local Scalars ..
181  LOGICAL nounit
182  INTEGER j, k, kp
183  REAL d11, d12, d21, d22, t1, t2
184 * ..
185 * .. External Functions ..
186  LOGICAL lsame
187  EXTERNAL lsame
188 * ..
189 * .. External Subroutines ..
190  EXTERNAL sgemv, sger, sscal, sswap, 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( 'SLAVSY_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 sscal( 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 sger( 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 sswap( 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 sger( k-1, nrhs, one, a( 1, k ), 1, b( k, 1 ),
295  $ ldb, b( 1, 1 ), ldb )
296  CALL sger( 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 sswap( 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 sswap( 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 sscal( 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 sger( 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 sswap( 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 sger( n-k, nrhs, one, a( k+1, k ), 1, b( k, 1 ),
388  $ ldb, b( k+1, 1 ), ldb )
389  CALL sger( 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 sswap( 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 sswap( 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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
443 *
444 * Apply the transformation
445 *
446  CALL sgemv( '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 sscal( 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 sswap( 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 sswap( nrhs, b( k-1, 1 ), ldb, b( kp, 1 ),
469  $ ldb )
470 *
471 * Apply the transformations
472 *
473  CALL sgemv( 'Transpose', k-2, nrhs, one, b, ldb,
474  $ a( 1, k ), 1, one, b( k, 1 ), ldb )
475  CALL sgemv( '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 sswap( nrhs, b( k, 1 ), ldb, b( kp, 1 ), ldb )
521 *
522 * Apply the transformation
523 *
524  CALL sgemv( '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 sscal( 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 sswap( 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 sswap( nrhs, b( k+1, 1 ), ldb, b( kp, 1 ),
547  $ ldb )
548 *
549 * Apply the transformation
550 *
551  CALL sgemv( '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 sgemv( '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 SLAVSY_ROOK
583 *
sger
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
Definition: sger.f:132
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
sgemv
subroutine sgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
SGEMV
Definition: sgemv.f:158
sscal
subroutine sscal(N, SA, SX, INCX)
SSCAL
Definition: sscal.f:55
sswap
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
Definition: sswap.f:53
lsame
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: