1: *> \brief \b ZLABRD 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 ZLABRD + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlabrd.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlabrd.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlabrd.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE ZLABRD( 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: * DOUBLE PRECISION D( * ), E( * )
29: * COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
30: * $ Y( LDY, * )
31: * ..
32: *
33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> ZLABRD reduces the first NB rows and columns of a complex general
40: *> m by n matrix A to upper or lower real bidiagonal form by a unitary
41: *> transformation Q**H * A * P, and returns the matrices X and Y which
42: *> are needed to apply the transformation to the unreduced part of A.
43: *>
44: *> If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
45: *> bidiagonal form.
46: *>
47: *> This is an auxiliary routine called by ZGEBRD
48: *> \endverbatim
49: *
50: * Arguments:
51: * ==========
52: *
53: *> \param[in] M
54: *> \verbatim
55: *> M is INTEGER
56: *> The number of rows in the matrix A.
57: *> \endverbatim
58: *>
59: *> \param[in] N
60: *> \verbatim
61: *> N is INTEGER
62: *> The number of columns in the matrix A.
63: *> \endverbatim
64: *>
65: *> \param[in] NB
66: *> \verbatim
67: *> NB is INTEGER
68: *> The number of leading rows and columns of A to be reduced.
69: *> \endverbatim
70: *>
71: *> \param[in,out] A
72: *> \verbatim
73: *> A is COMPLEX*16 array, dimension (LDA,N)
74: *> On entry, the m by n general matrix to be reduced.
75: *> On exit, the first NB rows and columns of the matrix are
76: *> overwritten; the rest of the array is unchanged.
77: *> If m >= n, elements on and below the diagonal in the first NB
78: *> columns, with the array TAUQ, represent the unitary
79: *> matrix Q as a product of elementary reflectors; and
80: *> elements above the diagonal in the first NB rows, with the
81: *> array TAUP, represent the unitary matrix P as a product
82: *> of elementary reflectors.
83: *> If m < n, elements below the diagonal in the first NB
84: *> columns, with the array TAUQ, represent the unitary
85: *> matrix Q as a product of elementary reflectors, and
86: *> elements on and above the diagonal in the first NB rows,
87: *> with the array TAUP, represent the unitary matrix P as
88: *> a product of elementary reflectors.
89: *> See Further Details.
90: *> \endverbatim
91: *>
92: *> \param[in] LDA
93: *> \verbatim
94: *> LDA is INTEGER
95: *> The leading dimension of the array A. LDA >= max(1,M).
96: *> \endverbatim
97: *>
98: *> \param[out] D
99: *> \verbatim
100: *> D is DOUBLE PRECISION array, dimension (NB)
101: *> The diagonal elements of the first NB rows and columns of
102: *> the reduced matrix. D(i) = A(i,i).
103: *> \endverbatim
104: *>
105: *> \param[out] E
106: *> \verbatim
107: *> E is DOUBLE PRECISION array, dimension (NB)
108: *> The off-diagonal elements of the first NB rows and columns of
109: *> the reduced matrix.
110: *> \endverbatim
111: *>
112: *> \param[out] TAUQ
113: *> \verbatim
114: *> TAUQ is COMPLEX*16 array, dimension (NB)
115: *> The scalar factors of the elementary reflectors which
116: *> represent the unitary matrix Q. See Further Details.
117: *> \endverbatim
118: *>
119: *> \param[out] TAUP
120: *> \verbatim
121: *> TAUP is COMPLEX*16 array, dimension (NB)
122: *> The scalar factors of the elementary reflectors which
123: *> represent the unitary matrix P. See Further Details.
124: *> \endverbatim
125: *>
126: *> \param[out] X
127: *> \verbatim
128: *> X is COMPLEX*16 array, dimension (LDX,NB)
129: *> The m-by-nb matrix X required to update the unreduced part
130: *> of A.
131: *> \endverbatim
132: *>
133: *> \param[in] LDX
134: *> \verbatim
135: *> LDX is INTEGER
136: *> The leading dimension of the array X. LDX >= max(1,M).
137: *> \endverbatim
138: *>
139: *> \param[out] Y
140: *> \verbatim
141: *> Y is COMPLEX*16 array, dimension (LDY,NB)
142: *> The n-by-nb matrix Y required to update the unreduced part
143: *> of A.
144: *> \endverbatim
145: *>
146: *> \param[in] LDY
147: *> \verbatim
148: *> LDY is INTEGER
149: *> The leading dimension of the array Y. LDY >= max(1,N).
150: *> \endverbatim
151: *
152: * Authors:
153: * ========
154: *
155: *> \author Univ. of Tennessee
156: *> \author Univ. of California Berkeley
157: *> \author Univ. of Colorado Denver
158: *> \author NAG Ltd.
159: *
160: *> \ingroup complex16OTHERauxiliary
161: *
162: *> \par Further Details:
163: * =====================
164: *>
165: *> \verbatim
166: *>
167: *> The matrices Q and P are represented as products of elementary
168: *> reflectors:
169: *>
170: *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
171: *>
172: *> Each H(i) and G(i) has the form:
173: *>
174: *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
175: *>
176: *> where tauq and taup are complex scalars, and v and u are complex
177: *> vectors.
178: *>
179: *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
180: *> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
181: *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
182: *>
183: *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
184: *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
185: *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
186: *>
187: *> The elements of the vectors v and u together form the m-by-nb matrix
188: *> V and the nb-by-n matrix U**H which are needed, with X and Y, to apply
189: *> the transformation to the unreduced part of the matrix, using a block
190: *> update of the form: A := A - V*Y**H - X*U**H.
191: *>
192: *> The contents of A on exit are illustrated by the following examples
193: *> with nb = 2:
194: *>
195: *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
196: *>
197: *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
198: *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
199: *> ( v1 v2 a a a ) ( v1 1 a a a a )
200: *> ( v1 v2 a a a ) ( v1 v2 a a a a )
201: *> ( v1 v2 a a a ) ( v1 v2 a a a a )
202: *> ( v1 v2 a a a )
203: *>
204: *> where a denotes an element of the original matrix which is unchanged,
205: *> vi denotes an element of the vector defining H(i), and ui an element
206: *> of the vector defining G(i).
207: *> \endverbatim
208: *>
209: * =====================================================================
210: SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
211: $ LDY )
212: *
213: * -- LAPACK auxiliary routine --
214: * -- LAPACK is a software package provided by Univ. of Tennessee, --
215: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
216: *
217: * .. Scalar Arguments ..
218: INTEGER LDA, LDX, LDY, M, N, NB
219: * ..
220: * .. Array Arguments ..
221: DOUBLE PRECISION D( * ), E( * )
222: COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
223: $ Y( LDY, * )
224: * ..
225: *
226: * =====================================================================
227: *
228: * .. Parameters ..
229: COMPLEX*16 ZERO, ONE
230: PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
231: $ ONE = ( 1.0D+0, 0.0D+0 ) )
232: * ..
233: * .. Local Scalars ..
234: INTEGER I
235: COMPLEX*16 ALPHA
236: * ..
237: * .. External Subroutines ..
238: EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL
239: * ..
240: * .. Intrinsic Functions ..
241: INTRINSIC MIN
242: * ..
243: * .. Executable Statements ..
244: *
245: * Quick return if possible
246: *
247: IF( M.LE.0 .OR. N.LE.0 )
248: $ RETURN
249: *
250: IF( M.GE.N ) THEN
251: *
252: * Reduce to upper bidiagonal form
253: *
254: DO 10 I = 1, NB
255: *
256: * Update A(i:m,i)
257: *
258: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
259: CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
260: $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
261: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
262: CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
263: $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
264: *
265: * Generate reflection Q(i) to annihilate A(i+1:m,i)
266: *
267: ALPHA = A( I, I )
268: CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
269: $ TAUQ( I ) )
270: D( I ) = DBLE( ALPHA )
271: IF( I.LT.N ) THEN
272: A( I, I ) = ONE
273: *
274: * Compute Y(i+1:n,i)
275: *
276: CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
277: $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
278: $ Y( I+1, I ), 1 )
279: CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
280: $ A( I, 1 ), LDA, A( I, I ), 1, ZERO,
281: $ Y( 1, I ), 1 )
282: CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
283: $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
284: CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
285: $ X( I, 1 ), LDX, A( I, I ), 1, ZERO,
286: $ Y( 1, I ), 1 )
287: CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
288: $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
289: $ Y( I+1, I ), 1 )
290: CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
291: *
292: * Update A(i,i+1:n)
293: *
294: CALL ZLACGV( N-I, A( I, I+1 ), LDA )
295: CALL ZLACGV( I, A( I, 1 ), LDA )
296: CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
297: $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
298: CALL ZLACGV( I, A( I, 1 ), LDA )
299: CALL ZLACGV( I-1, X( I, 1 ), LDX )
300: CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
301: $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
302: $ A( I, I+1 ), LDA )
303: CALL ZLACGV( I-1, X( I, 1 ), LDX )
304: *
305: * Generate reflection P(i) to annihilate A(i,i+2:n)
306: *
307: ALPHA = A( I, I+1 )
308: CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
309: $ TAUP( I ) )
310: E( I ) = DBLE( ALPHA )
311: A( I, I+1 ) = ONE
312: *
313: * Compute X(i+1:m,i)
314: *
315: CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
316: $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
317: CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE,
318: $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
319: $ X( 1, I ), 1 )
320: CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
321: $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
322: CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
323: $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
324: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
325: $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
326: CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
327: CALL ZLACGV( N-I, A( I, I+1 ), LDA )
328: END IF
329: 10 CONTINUE
330: ELSE
331: *
332: * Reduce to lower bidiagonal form
333: *
334: DO 20 I = 1, NB
335: *
336: * Update A(i,i:n)
337: *
338: CALL ZLACGV( N-I+1, A( I, I ), LDA )
339: CALL ZLACGV( I-1, A( I, 1 ), LDA )
340: CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
341: $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
342: CALL ZLACGV( I-1, A( I, 1 ), LDA )
343: CALL ZLACGV( I-1, X( I, 1 ), LDX )
344: CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
345: $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
346: $ LDA )
347: CALL ZLACGV( I-1, X( I, 1 ), LDX )
348: *
349: * Generate reflection P(i) to annihilate A(i,i+1:n)
350: *
351: ALPHA = A( I, I )
352: CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
353: $ TAUP( I ) )
354: D( I ) = DBLE( ALPHA )
355: IF( I.LT.M ) THEN
356: A( I, I ) = ONE
357: *
358: * Compute X(i+1:m,i)
359: *
360: CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
361: $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
362: CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
363: $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
364: $ X( 1, I ), 1 )
365: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
366: $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
367: CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
368: $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
369: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
370: $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
371: CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
372: CALL ZLACGV( N-I+1, A( I, I ), LDA )
373: *
374: * Update A(i+1:m,i)
375: *
376: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
377: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
378: $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
379: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
380: CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
381: $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
382: *
383: * Generate reflection Q(i) to annihilate A(i+2:m,i)
384: *
385: ALPHA = A( I+1, I )
386: CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
387: $ TAUQ( I ) )
388: E( I ) = DBLE( ALPHA )
389: A( I+1, I ) = ONE
390: *
391: * Compute Y(i+1:n,i)
392: *
393: CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE,
394: $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
395: $ Y( I+1, I ), 1 )
396: CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE,
397: $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
398: $ Y( 1, I ), 1 )
399: CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
400: $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
401: CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE,
402: $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
403: $ Y( 1, I ), 1 )
404: CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE,
405: $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
406: $ Y( I+1, I ), 1 )
407: CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
408: ELSE
409: CALL ZLACGV( N-I+1, A( I, I ), LDA )
410: END IF
411: 20 CONTINUE
412: END IF
413: RETURN
414: *
415: * End of ZLABRD
416: *
417: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to zlabrd.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack