Annotation of rpl/lapack/lapack/zlabrd.f, revision 1.9
1.9 ! bertrand 1: *> \brief \b ZLABRD
! 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: *> \date November 2011
! 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.9 ! bertrand 215: * -- LAPACK auxiliary routine (version 3.4.0) --
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.9 ! bertrand 218: * November 2011
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