LAPACK  3.9.0
LAPACK: Linear Algebra PACKage
slavsy_rook.f
Go to the documentation of this file.
1 *> \brief \b SLAVSY_ROOK
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 SLAVSY_ROOK( 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 * REAL A( LDA, * ), B( LDB, * )
21 * ..
22 *
23 *
24 *> \par Purpose:
25 * =============
26 *>
27 *> \verbatim
28 *>
29 *> SLAVSY_ROOK performs one of the matrix-vector operations
30 *> x := A*x or x := A'*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 SSYTRF_ROOK.
33 *>
34 *> If TRANS = 'N', multiplies by U or U * D (or L or L * D)
35 *> If TRANS = 'T', multiplies by U' or D * U' (or L' or D * L')
36 *> If TRANS = 'C', multiplies by U' or D * U' (or L' or D * L')
37 *> \endverbatim
38 *
39 * Arguments:
40 * ==========
41 *
42 *> \param[in] UPLO
43 *> \verbatim
44 *> UPLO is CHARACTER*1
45 *> Specifies whether the factor stored in A is upper or lower
46 *> triangular.
47 *> = 'U': Upper triangular
48 *> = 'L': Lower triangular
49 *> \endverbatim
50 *>
51 *> \param[in] TRANS
52 *> \verbatim
53 *> TRANS is CHARACTER*1
54 *> Specifies the operation to be performed:
55 *> = 'N': x := A*x
56 *> = 'T': x := A'*x
57 *> = 'C': x := A'*x
58 *> \endverbatim
59 *>
60 *> \param[in] DIAG
61 *> \verbatim
62 *> DIAG is CHARACTER*1
63 *> Specifies whether or not the diagonal blocks are unit
64 *> matrices. If the diagonal blocks are assumed to be unit,
65 *> then A = U or A = L, otherwise A = U*D or A = L*D.
66 *> = 'U': Diagonal blocks are assumed to be unit matrices.
67 *> = 'N': Diagonal blocks are assumed to be non-unit matrices.
68 *> \endverbatim
69 *>
70 *> \param[in] N
71 *> \verbatim
72 *> N is INTEGER
73 *> The number of rows and columns of the matrix A. N >= 0.
74 *> \endverbatim
75 *>
76 *> \param[in] NRHS
77 *> \verbatim
78 *> NRHS is INTEGER
79 *> The number of right hand sides, i.e., the number of vectors
80 *> x to be multiplied by A. NRHS >= 0.
81 *> \endverbatim
82 *>
83 *> \param[in] A
84 *> \verbatim
85 *> A is REAL array, dimension (LDA,N)
86 *> The block diagonal matrix D and the multipliers used to
87 *> obtain the factor U or L as computed by SSYTRF_ROOK.
88 *> Stored as a 2-D triangular matrix.
89 *> \endverbatim
90 *>
91 *> \param[in] LDA
92 *> \verbatim
93 *> LDA is INTEGER
94 *> The leading dimension of the array A. LDA >= max(1,N).
95 *> \endverbatim
96 *>
97 *> \param[in] IPIV
98 *> \verbatim
99 *> IPIV is INTEGER array, dimension (N)
100 *> Details of the interchanges and the block structure of D,
101 *> as determined by SSYTRF_ROOK.
102 *>
103 *> If UPLO = 'U':
104 *> If IPIV(k) > 0, then rows and columns k and IPIV(k)
105 *> were interchanged and D(k,k) is a 1-by-1 diagonal block.
106 *> (If IPIV( k ) = k, no interchange was done).
107 *>
108 *> If IPIV(k) < 0 and IPIV(k-1) < 0, then rows and
109 *> columns k and -IPIV(k) were interchanged and rows and
110 *> columns k-1 and -IPIV(k-1) were inerchaged,
111 *> D(k-1:k,k-1:k) is a 2-by-2 diagonal block.
112 *>
113 *> If UPLO = 'L':
114 *> If IPIV(k) > 0, then rows and columns k and IPIV(k)
115 *> were interchanged and D(k,k) is a 1-by-1 diagonal block.
116 *> (If IPIV( k ) = k, no interchange was done).
117 *>
118 *> If IPIV(k) < 0 and IPIV(k+1) < 0, then rows and
119 *> columns k and -IPIV(k) were interchanged and rows and
120 *> columns k+1 and -IPIV(k+1) were inerchaged,
121 *> D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
122 *> \endverbatim
123 *>
124 *> \param[in,out] B
125 *> \verbatim
126 *> B is REAL array, dimension (LDB,NRHS)
127 *> On entry, B contains NRHS vectors of length N.
128 *> On exit, B is overwritten with the product A * B.
129 *> \endverbatim
130 *>
131 *> \param[in] LDB
132 *> \verbatim
133 *> LDB is INTEGER
134 *> The leading dimension of the array B. LDB >= max(1,N).
135 *> \endverbatim
136 *>
137 *> \param[out] INFO
138 *> \verbatim
139 *> INFO is INTEGER
140 *> = 0: successful exit
141 *> < 0: if INFO = -k, the k-th argument had an illegal value
142 *> \endverbatim
143 *
144 * Authors:
145 * ========
146 *
147 *> \author Univ. of Tennessee
148 *> \author Univ. of California Berkeley
149 *> \author Univ. of Colorado Denver
150 *> \author NAG Ltd.
151 *
152 *> \date November 2013
153 *
154 *> \ingroup single_lin
155 *
156 * =====================================================================
157  SUBROUTINE slavsy_rook( UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV,
158  $ B, LDB, INFO )
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 *
584  END
slavsy_rook
subroutine slavsy_rook(UPLO, TRANS, DIAG, N, NRHS, A, LDA, IPIV, B, LDB, INFO)
SLAVSY_ROOK
Definition: slavsy_rook.f:159
sswap
subroutine sswap(N, SX, INCX, SY, INCY)
SSWAP
Definition: sswap.f:84
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:81
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
sger
subroutine sger(M, N, ALPHA, X, INCX, Y, INCY, A, LDA)
SGER
Definition: sger.f:132