OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
slabrd.f
Go to the documentation of this file.
1*> \brief \b SLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
2*
3* =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6* http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SLABRD + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slabrd.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slabrd.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slabrd.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18* Definition:
19* ===========
20*
21* SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
22* LDY )
23*
24* .. Scalar Arguments ..
25* INTEGER LDA, LDX, LDY, M, N, NB
26* ..
27* .. Array Arguments ..
28* REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
29* $ TAUQ( * ), X( LDX, * ), Y( LDY, * )
30* ..
31*
32*
33*> \par Purpose:
34* =============
35*>
36*> \verbatim
37*>
38*> SLABRD reduces the first NB rows and columns of a real general
39*> m by n matrix A to upper or lower bidiagonal form by an orthogonal
40*> transformation Q**T * A * P, and returns the matrices X and Y which
41*> are needed to apply the transformation to the unreduced part of A.
42*>
43*> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
44*> bidiagonal form.
45*>
46*> This is an auxiliary routine called by SGEBRD
47*> \endverbatim
48*
49* Arguments:
50* ==========
51*
52*> \param[in] M
53*> \verbatim
54*> M is INTEGER
55*> The number of rows in the matrix A.
56*> \endverbatim
57*>
58*> \param[in] N
59*> \verbatim
60*> N is INTEGER
61*> The number of columns in the matrix A.
62*> \endverbatim
63*>
64*> \param[in] NB
65*> \verbatim
66*> NB is INTEGER
67*> The number of leading rows and columns of A to be reduced.
68*> \endverbatim
69*>
70*> \param[in,out] A
71*> \verbatim
72*> A is REAL array, dimension (LDA,N)
73*> On entry, the m by n general matrix to be reduced.
74*> On exit, the first NB rows and columns of the matrix are
75*> overwritten; the rest of the array is unchanged.
76*> If m >= n, elements on and below the diagonal in the first NB
77*> columns, with the array TAUQ, represent the orthogonal
78*> matrix Q as a product of elementary reflectors; and
79*> elements above the diagonal in the first NB rows, with the
80*> array TAUP, represent the orthogonal matrix P as a product
81*> of elementary reflectors.
82*> If m < n, elements below the diagonal in the first NB
83*> columns, with the array TAUQ, represent the orthogonal
84*> matrix Q as a product of elementary reflectors, and
85*> elements on and above the diagonal in the first NB rows,
86*> with the array TAUP, represent the orthogonal matrix P as
87*> a product of elementary reflectors.
88*> See Further Details.
89*> \endverbatim
90*>
91*> \param[in] LDA
92*> \verbatim
93*> LDA is INTEGER
94*> The leading dimension of the array A. LDA >= max(1,M).
95*> \endverbatim
96*>
97*> \param[out] D
98*> \verbatim
99*> D is REAL array, dimension (NB)
100*> The diagonal elements of the first NB rows and columns of
101*> the reduced matrix. D(i) = A(i,i).
102*> \endverbatim
103*>
104*> \param[out] E
105*> \verbatim
106*> E is REAL array, dimension (NB)
107*> The off-diagonal elements of the first NB rows and columns of
108*> the reduced matrix.
109*> \endverbatim
110*>
111*> \param[out] TAUQ
112*> \verbatim
113*> TAUQ is REAL array, dimension (NB)
114*> The scalar factors of the elementary reflectors which
115*> represent the orthogonal matrix Q. See Further Details.
116*> \endverbatim
117*>
118*> \param[out] TAUP
119*> \verbatim
120*> TAUP is REAL array, dimension (NB)
121*> The scalar factors of the elementary reflectors which
122*> represent the orthogonal matrix P. See Further Details.
123*> \endverbatim
124*>
125*> \param[out] X
126*> \verbatim
127*> X is REAL array, dimension (LDX,NB)
128*> The m-by-nb matrix X required to update the unreduced part
129*> of A.
130*> \endverbatim
131*>
132*> \param[in] LDX
133*> \verbatim
134*> LDX is INTEGER
135*> The leading dimension of the array X. LDX >= max(1,M).
136*> \endverbatim
137*>
138*> \param[out] Y
139*> \verbatim
140*> Y is REAL array, dimension (LDY,NB)
141*> The n-by-nb matrix Y required to update the unreduced part
142*> of A.
143*> \endverbatim
144*>
145*> \param[in] LDY
146*> \verbatim
147*> LDY is INTEGER
148*> The leading dimension of the array Y. LDY >= max(1,N).
149*> \endverbatim
150*
151* Authors:
152* ========
153*
154*> \author Univ. of Tennessee
155*> \author Univ. of California Berkeley
156*> \author Univ. of Colorado Denver
157*> \author NAG Ltd.
158*
159*> \ingroup realOTHERauxiliary
160*
161*> \par Further Details:
162* =====================
163*>
164*> \verbatim
165*>
166*> The matrices Q and P are represented as products of elementary
167*> reflectors:
168*>
169*> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
170*>
171*> Each H(i) and G(i) has the form:
172*>
173*> H(i) = I - tauq * v * v**T and G(i) = I - taup * u * u**T
174*>
175*> where tauq and taup are real scalars, and v and u are real vectors.
176*>
177*> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
178*> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
179*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
180*>
181*> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
182*> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
183*> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
184*>
185*> The elements of the vectors v and u together form the m-by-nb matrix
186*> V and the nb-by-n matrix U**T which are needed, with X and Y, to apply
187*> the transformation to the unreduced part of the matrix, using a block
188*> update of the form: A := A - V*Y**T - X*U**T.
189*>
190*> The contents of A on exit are illustrated by the following examples
191*> with nb = 2:
192*>
193*> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
194*>
195*> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
196*> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
197*> ( v1 v2 a a a ) ( v1 1 a a a a )
198*> ( v1 v2 a a a ) ( v1 v2 a a a a )
199*> ( v1 v2 a a a ) ( v1 v2 a a a a )
200*> ( v1 v2 a a a )
201*>
202*> where a denotes an element of the original matrix which is unchanged,
203*> vi denotes an element of the vector defining H(i), and ui an element
204*> of the vector defining G(i).
205*> \endverbatim
206*>
207* =====================================================================
208 SUBROUTINE slabrd( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
209 $ LDY )
210*
211* -- LAPACK auxiliary routine --
212* -- LAPACK is a software package provided by Univ. of Tennessee, --
213* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
214*
215* .. Scalar Arguments ..
216 INTEGER LDA, LDX, LDY, M, N, NB
217* ..
218* .. Array Arguments ..
219 REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
220 $ tauq( * ), x( ldx, * ), y( ldy, * )
221* ..
222*
223* =====================================================================
224*
225* .. Parameters ..
226 REAL ZERO, ONE
227 parameter( zero = 0.0e0, one = 1.0e0 )
228* ..
229* .. Local Scalars ..
230 INTEGER I
231* ..
232* .. External Subroutines ..
233 EXTERNAL sgemv, slarfg, sscal
234* ..
235* .. Intrinsic Functions ..
236 INTRINSIC min
237* ..
238* .. Executable Statements ..
239*
240* Quick return if possible
241*
242 IF( m.LE.0 .OR. n.LE.0 )
243 $ RETURN
244*
245 IF( m.GE.n ) THEN
246*
247* Reduce to upper bidiagonal form
248*
249 DO 10 i = 1, nb
250*
251* Update A(i:m,i)
252*
253 CALL sgemv( 'No transpose', m-i+1, i-1, -one, a( i, 1 ),
254 $ lda, y( i, 1 ), ldy, one, a( i, i ), 1 )
255 CALL sgemv( 'No transpose', m-i+1, i-1, -one, x( i, 1 ),
256 $ ldx, a( 1, i ), 1, one, a( i, i ), 1 )
257*
258* Generate reflection Q(i) to annihilate A(i+1:m,i)
259*
260 CALL slarfg( m-i+1, a( i, i ), a( min( i+1, m ), i ), 1,
261 $ tauq( i ) )
262 d( i ) = a( i, i )
263 IF( i.LT.n ) THEN
264 a( i, i ) = one
265*
266* Compute Y(i+1:n,i)
267*
268 CALL sgemv( 'Transpose', m-i+1, n-i, one, a( i, i+1 ),
269 $ lda, a( i, i ), 1, zero, y( i+1, i ), 1 )
270 CALL sgemv( 'Transpose', m-i+1, i-1, one, a( i, 1 ), lda,
271 $ a( i, i ), 1, zero, y( 1, i ), 1 )
272 CALL sgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ),
273 $ ldy, y( 1, i ), 1, one, y( i+1, i ), 1 )
274 CALL sgemv( 'Transpose', m-i+1, i-1, one, x( i, 1 ), ldx,
275 $ a( i, i ), 1, zero, y( 1, i ), 1 )
276 CALL sgemv( 'Transpose', i-1, n-i, -one, a( 1, i+1 ),
277 $ lda, y( 1, i ), 1, one, y( i+1, i ), 1 )
278 CALL sscal( n-i, tauq( i ), y( i+1, i ), 1 )
279*
280* Update A(i,i+1:n)
281*
282 CALL sgemv( 'No transpose', n-i, i, -one, y( i+1, 1 ),
283 $ ldy, a( i, 1 ), lda, one, a( i, i+1 ), lda )
284 CALL sgemv( 'Transpose', i-1, n-i, -one, a( 1, i+1 ),
285 $ lda, x( i, 1 ), ldx, one, a( i, i+1 ), lda )
286*
287* Generate reflection P(i) to annihilate A(i,i+2:n)
288*
289 CALL slarfg( n-i, a( i, i+1 ), a( i, min( i+2, n ) ),
290 $ lda, taup( i ) )
291 e( i ) = a( i, i+1 )
292 a( i, i+1 ) = one
293*
294* Compute X(i+1:m,i)
295*
296 CALL sgemv( 'No transpose', m-i, n-i, one, a( i+1, i+1 ),
297 $ lda, a( i, i+1 ), lda, zero, x( i+1, i ), 1 )
298 CALL sgemv( 'Transpose', n-i, i, one, y( i+1, 1 ), ldy,
299 $ a( i, i+1 ), lda, zero, x( 1, i ), 1 )
300 CALL sgemv( 'No transpose', m-i, i, -one, a( i+1, 1 ),
301 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
302 CALL sgemv( 'No transpose', i-1, n-i, one, a( 1, i+1 ),
303 $ lda, a( i, i+1 ), lda, zero, x( 1, i ), 1 )
304 CALL sgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ),
305 $ ldx, x( 1, i ), 1, one, x( i+1, i ), 1 )
306 CALL sscal( m-i, taup( i ), x( i+1, i ), 1 )
307 END IF
308 10 CONTINUE
309 ELSE
310*
311* Reduce to lower bidiagonal form
312*
313 DO 20 i = 1, nb
314*
315* Update A(i,i:n)
316*
317 CALL sgemv( 'No transpose', n-i+1, i-1, -one, y( i, 1 ),
318 $ ldy, a( i, 1 ), lda, one, a( i, i ), lda )
319 CALL sgemv( 'Transpose', i-1, n-i+1, -one, a( 1, i ), lda,
320 $ x( i, 1 ), ldx, one, a( i, i ), lda )
321*
322* Generate reflection P(i) to annihilate A(i,i+1:n)
323*
324 CALL slarfg( n-i+1, a( i, i ), a( i, min( i+1, n ) ), lda,
325 $ taup( i ) )
326 d( i ) = a( i, i )
327 IF( i.LT.m ) THEN
328 a( i, i ) = one
329*
330* Compute X(i+1:m,i)
331*
332 CALL sgemv( 'No transpose', m-i, n-i+1, one, a( i+1, i ),
333 $ lda, a( i, i ), lda, zero, x( i+1, i ), 1 )
334 CALL sgemv( 'Transpose', n-i+1, i-1, one, y( i, 1 ), ldy,
335 $ a( i, i ), lda, zero, x( 1, i ), 1 )
336 CALL sgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ),
337 $ lda, x( 1, i ), 1, one, x( i+1, i ), 1 )
338 CALL sgemv( 'No transpose', i-1, n-i+1, one, a( 1, i ),
339 $ lda, a( i, i ), lda, zero, x( 1, i ), 1 )
340 CALL sgemv( 'No transpose', m-i, i-1, -one, x( i+1, 1 ),
341 $ ldx, x( 1, i ), 1, one, x( i+1, i ), 1 )
342 CALL sscal( m-i, taup( i ), x( i+1, i ), 1 )
343*
344* Update A(i+1:m,i)
345*
346 CALL sgemv( 'No transpose', m-i, i-1, -one, a( i+1, 1 ),
347 $ lda, y( i, 1 ), ldy, one, a( i+1, i ), 1 )
348 CALL sgemv( 'No transpose', m-i, i, -one, x( i+1, 1 ),
349 $ ldx, a( 1, i ), 1, one, a( i+1, i ), 1 )
350*
351* Generate reflection Q(i) to annihilate A(i+2:m,i)
352*
353 CALL slarfg( m-i, a( i+1, i ), a( min( i+2, m ), i ), 1,
354 $ tauq( i ) )
355 e( i ) = a( i+1, i )
356 a( i+1, i ) = one
357*
358* Compute Y(i+1:n,i)
359*
360 CALL sgemv( 'Transpose', m-i, n-i, one, a( i+1, i+1 ),
361 $ lda, a( i+1, i ), 1, zero, y( i+1, i ), 1 )
362 CALL sgemv( 'Transpose', m-i, i-1, one, a( i+1, 1 ), lda,
363 $ a( i+1, i ), 1, zero, y( 1, i ), 1 )
364 CALL sgemv( 'No transpose', n-i, i-1, -one, y( i+1, 1 ),
365 $ ldy, y( 1, i ), 1, one, y( i+1, i ), 1 )
366 CALL sgemv( 'Transpose', m-i, i, one, x( i+1, 1 ), ldx,
367 $ a( i+1, i ), 1, zero, y( 1, i ), 1 )
368 CALL sgemv( 'Transpose', i, n-i, -one, a( 1, i+1 ), lda,
369 $ y( 1, i ), 1, one, y( i+1, i ), 1 )
370 CALL sscal( n-i, tauq( i ), y( i+1, i ), 1 )
371 END IF
372 20 CONTINUE
373 END IF
374 RETURN
375*
376* End of SLABRD
377*
378 END
slabrd
subroutine slabrd(m, n, nb, a, lda, d, e, tauq, taup, x, ldx, y, ldy)
SLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
Definition slabrd.f:210
slarfg
subroutine slarfg(n, alpha, x, incx, tau)
SLARFG generates an elementary reflector (Householder matrix).
Definition slarfg.f:106
sscal
subroutine sscal(n, sa, sx, incx)
SSCAL
Definition sscal.f:79
sgemv
subroutine sgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
SGEMV
Definition sgemv.f:156
min
#define min(a, b)
Definition macros.h:20