Annotation of rpl/lapack/lapack/zlabrd.f, revision 1.18
1.12 bertrand 1: *> \brief \b ZLABRD reduces the first nb rows and columns of a general matrix to a bidiagonal form.
1.9 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.16 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.9 bertrand 7: *
8: *> \htmlonly
1.16 bertrand 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">
1.9 bertrand 15: *> [TXT]</a>
1.16 bertrand 16: *> \endhtmlonly
1.9 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
22: * LDY )
1.16 bertrand 23: *
1.9 bertrand 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: * ..
1.16 bertrand 32: *
1.9 bertrand 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
1.18 ! bertrand 114: *> TAUQ is COMPLEX*16 array, dimension (NB)
1.9 bertrand 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: *
1.16 bertrand 155: *> \author Univ. of Tennessee
156: *> \author Univ. of California Berkeley
157: *> \author Univ. of Colorado Denver
158: *> \author NAG Ltd.
1.9 bertrand 159: *
1.18 ! bertrand 160: *> \date June 2017
1.9 bertrand 161: *
162: *> \ingroup complex16OTHERauxiliary
163: *
164: *> \par Further Details:
165: * =====================
166: *>
167: *> \verbatim
168: *>
169: *> The matrices Q and P are represented as products of elementary
170: *> reflectors:
171: *>
172: *> Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
173: *>
174: *> Each H(i) and G(i) has the form:
175: *>
176: *> H(i) = I - tauq * v * v**H and G(i) = I - taup * u * u**H
177: *>
178: *> where tauq and taup are complex scalars, and v and u are complex
179: *> vectors.
180: *>
181: *> If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
182: *> A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1: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: *> If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
186: *> A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
187: *> A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
188: *>
189: *> The elements of the vectors v and u together form the m-by-nb matrix
190: *> V and the nb-by-n matrix U**H which are needed, with X and Y, to apply
191: *> the transformation to the unreduced part of the matrix, using a block
192: *> update of the form: A := A - V*Y**H - X*U**H.
193: *>
194: *> The contents of A on exit are illustrated by the following examples
195: *> with nb = 2:
196: *>
197: *> m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
198: *>
199: *> ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
200: *> ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
201: *> ( v1 v2 a a a ) ( v1 1 a a a a )
202: *> ( v1 v2 a a a ) ( v1 v2 a a a a )
203: *> ( v1 v2 a a a ) ( v1 v2 a a a a )
204: *> ( v1 v2 a a a )
205: *>
206: *> where a denotes an element of the original matrix which is unchanged,
207: *> vi denotes an element of the vector defining H(i), and ui an element
208: *> of the vector defining G(i).
209: *> \endverbatim
210: *>
211: * =====================================================================
1.1 bertrand 212: SUBROUTINE ZLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
213: $ LDY )
214: *
1.18 ! bertrand 215: * -- LAPACK auxiliary routine (version 3.7.1) --
1.1 bertrand 216: * -- LAPACK is a software package provided by Univ. of Tennessee, --
217: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.18 ! bertrand 218: * June 2017
1.1 bertrand 219: *
220: * .. Scalar Arguments ..
221: INTEGER LDA, LDX, LDY, M, N, NB
222: * ..
223: * .. Array Arguments ..
224: DOUBLE PRECISION D( * ), E( * )
225: COMPLEX*16 A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
226: $ Y( LDY, * )
227: * ..
228: *
229: * =====================================================================
230: *
231: * .. Parameters ..
232: COMPLEX*16 ZERO, ONE
233: PARAMETER ( ZERO = ( 0.0D+0, 0.0D+0 ),
234: $ ONE = ( 1.0D+0, 0.0D+0 ) )
235: * ..
236: * .. Local Scalars ..
237: INTEGER I
238: COMPLEX*16 ALPHA
239: * ..
240: * .. External Subroutines ..
241: EXTERNAL ZGEMV, ZLACGV, ZLARFG, ZSCAL
242: * ..
243: * .. Intrinsic Functions ..
244: INTRINSIC MIN
245: * ..
246: * .. Executable Statements ..
247: *
248: * Quick return if possible
249: *
250: IF( M.LE.0 .OR. N.LE.0 )
251: $ RETURN
252: *
253: IF( M.GE.N ) THEN
254: *
255: * Reduce to upper bidiagonal form
256: *
257: DO 10 I = 1, NB
258: *
259: * Update A(i:m,i)
260: *
261: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
262: CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
263: $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
264: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
265: CALL ZGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
266: $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
267: *
268: * Generate reflection Q(i) to annihilate A(i+1:m,i)
269: *
270: ALPHA = A( I, I )
271: CALL ZLARFG( M-I+1, ALPHA, A( MIN( I+1, M ), I ), 1,
272: $ TAUQ( I ) )
273: D( I ) = ALPHA
274: IF( I.LT.N ) THEN
275: A( I, I ) = ONE
276: *
277: * Compute Y(i+1:n,i)
278: *
279: CALL ZGEMV( 'Conjugate transpose', M-I+1, N-I, ONE,
280: $ A( I, I+1 ), LDA, A( I, I ), 1, ZERO,
281: $ Y( I+1, I ), 1 )
282: CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
283: $ A( I, 1 ), LDA, A( I, I ), 1, ZERO,
284: $ Y( 1, I ), 1 )
285: CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
286: $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
287: CALL ZGEMV( 'Conjugate transpose', M-I+1, I-1, ONE,
288: $ X( I, 1 ), LDX, A( I, I ), 1, ZERO,
289: $ Y( 1, I ), 1 )
290: CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
291: $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
292: $ Y( I+1, I ), 1 )
293: CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
294: *
295: * Update A(i,i+1:n)
296: *
297: CALL ZLACGV( N-I, A( I, I+1 ), LDA )
298: CALL ZLACGV( I, A( I, 1 ), LDA )
299: CALL ZGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
300: $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
301: CALL ZLACGV( I, A( I, 1 ), LDA )
302: CALL ZLACGV( I-1, X( I, 1 ), LDX )
303: CALL ZGEMV( 'Conjugate transpose', I-1, N-I, -ONE,
304: $ A( 1, I+1 ), LDA, X( I, 1 ), LDX, ONE,
305: $ A( I, I+1 ), LDA )
306: CALL ZLACGV( I-1, X( I, 1 ), LDX )
307: *
308: * Generate reflection P(i) to annihilate A(i,i+2:n)
309: *
310: ALPHA = A( I, I+1 )
311: CALL ZLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ), LDA,
312: $ TAUP( I ) )
313: E( I ) = ALPHA
314: A( I, I+1 ) = ONE
315: *
316: * Compute X(i+1:m,i)
317: *
318: CALL ZGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
319: $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
320: CALL ZGEMV( 'Conjugate transpose', N-I, I, ONE,
321: $ Y( I+1, 1 ), LDY, A( I, I+1 ), LDA, ZERO,
322: $ X( 1, I ), 1 )
323: CALL ZGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
324: $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
325: CALL ZGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
326: $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
327: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
328: $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
329: CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
330: CALL ZLACGV( N-I, A( I, I+1 ), LDA )
331: END IF
332: 10 CONTINUE
333: ELSE
334: *
335: * Reduce to lower bidiagonal form
336: *
337: DO 20 I = 1, NB
338: *
339: * Update A(i,i:n)
340: *
341: CALL ZLACGV( N-I+1, A( I, I ), LDA )
342: CALL ZLACGV( I-1, A( I, 1 ), LDA )
343: CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
344: $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
345: CALL ZLACGV( I-1, A( I, 1 ), LDA )
346: CALL ZLACGV( I-1, X( I, 1 ), LDX )
347: CALL ZGEMV( 'Conjugate transpose', I-1, N-I+1, -ONE,
348: $ A( 1, I ), LDA, X( I, 1 ), LDX, ONE, A( I, I ),
349: $ LDA )
350: CALL ZLACGV( I-1, X( I, 1 ), LDX )
351: *
352: * Generate reflection P(i) to annihilate A(i,i+1:n)
353: *
354: ALPHA = A( I, I )
355: CALL ZLARFG( N-I+1, ALPHA, A( I, MIN( I+1, N ) ), LDA,
356: $ TAUP( I ) )
357: D( I ) = ALPHA
358: IF( I.LT.M ) THEN
359: A( I, I ) = ONE
360: *
361: * Compute X(i+1:m,i)
362: *
363: CALL ZGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
364: $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
365: CALL ZGEMV( 'Conjugate transpose', N-I+1, I-1, ONE,
366: $ Y( I, 1 ), LDY, A( I, I ), LDA, ZERO,
367: $ X( 1, I ), 1 )
368: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
369: $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
370: CALL ZGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
371: $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
372: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
373: $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
374: CALL ZSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
375: CALL ZLACGV( N-I+1, A( I, I ), LDA )
376: *
377: * Update A(i+1:m,i)
378: *
379: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
380: CALL ZGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
381: $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
382: CALL ZLACGV( I-1, Y( I, 1 ), LDY )
383: CALL ZGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
384: $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
385: *
386: * Generate reflection Q(i) to annihilate A(i+2:m,i)
387: *
388: ALPHA = A( I+1, I )
389: CALL ZLARFG( M-I, ALPHA, A( MIN( I+2, M ), I ), 1,
390: $ TAUQ( I ) )
391: E( I ) = ALPHA
392: A( I+1, I ) = ONE
393: *
394: * Compute Y(i+1:n,i)
395: *
396: CALL ZGEMV( 'Conjugate transpose', M-I, N-I, ONE,
397: $ A( I+1, I+1 ), LDA, A( I+1, I ), 1, ZERO,
398: $ Y( I+1, I ), 1 )
399: CALL ZGEMV( 'Conjugate transpose', M-I, I-1, ONE,
400: $ A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
401: $ Y( 1, I ), 1 )
402: CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
403: $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
404: CALL ZGEMV( 'Conjugate transpose', M-I, I, ONE,
405: $ X( I+1, 1 ), LDX, A( I+1, I ), 1, ZERO,
406: $ Y( 1, I ), 1 )
407: CALL ZGEMV( 'Conjugate transpose', I, N-I, -ONE,
408: $ A( 1, I+1 ), LDA, Y( 1, I ), 1, ONE,
409: $ Y( I+1, I ), 1 )
410: CALL ZSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
411: ELSE
412: CALL ZLACGV( N-I+1, A( I, I ), LDA )
413: END IF
414: 20 CONTINUE
415: END IF
416: RETURN
417: *
418: * End of ZLABRD
419: *
420: 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