ENH: Improving the travis dashboard name
[platform/upstream/lapack.git] / SRC / clabrd.f
1 *> \brief \b CLABRD 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 CLABRD + dependencies
10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/clabrd.f">
11 *> [TGZ]</a>
12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/clabrd.f">
13 *> [ZIP]</a>
14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/clabrd.f">
15 *> [TXT]</a>
16 *> \endhtmlonly
17 *
18 *  Definition:
19 *  ===========
20 *
21 *       SUBROUTINE CLABRD( 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               D( * ), E( * )
29 *       COMPLEX            A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
30 *      $                   Y( LDY, * )
31 *       ..
32 *
33 *
34 *> \par Purpose:
35 *  =============
36 *>
37 *> \verbatim
38 *>
39 *> CLABRD 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 CGEBRD
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 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 REAL 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 REAL 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 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 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 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 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 September 2012
161 *
162 *> \ingroup complexOTHERauxiliary
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 *  =====================================================================
212       SUBROUTINE CLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
213      $                   LDY )
214 *
215 *  -- LAPACK auxiliary routine (version 3.4.2) --
216 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
217 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
218 *     September 2012
219 *
220 *     .. Scalar Arguments ..
221       INTEGER            LDA, LDX, LDY, M, N, NB
222 *     ..
223 *     .. Array Arguments ..
224       REAL               D( * ), E( * )
225       COMPLEX            A( LDA, * ), TAUP( * ), TAUQ( * ), X( LDX, * ),
226      $                   Y( LDY, * )
227 *     ..
228 *
229 *  =====================================================================
230 *
231 *     .. Parameters ..
232       COMPLEX            ZERO, ONE
233       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ),
234      $                   ONE = ( 1.0E+0, 0.0E+0 ) )
235 *     ..
236 *     .. Local Scalars ..
237       INTEGER            I
238       COMPLEX            ALPHA
239 *     ..
240 *     .. External Subroutines ..
241       EXTERNAL           CGEMV, CLACGV, CLARFG, CSCAL
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 CLACGV( I-1, Y( I, 1 ), LDY )
262             CALL CGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
263      $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
264             CALL CLACGV( I-1, Y( I, 1 ), LDY )
265             CALL CGEMV( '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 CLARFG( 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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
294 *
295 *              Update A(i,i+1:n)
296 *
297                CALL CLACGV( N-I, A( I, I+1 ), LDA )
298                CALL CLACGV( I, A( I, 1 ), LDA )
299                CALL CGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
300      $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
301                CALL CLACGV( I, A( I, 1 ), LDA )
302                CALL CLACGV( I-1, X( I, 1 ), LDX )
303                CALL CGEMV( '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 CLACGV( 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 CLARFG( N-I, ALPHA, A( I, MIN( I+2, N ) ),
312      $                      LDA, TAUP( I ) )
313                E( I ) = ALPHA
314                A( I, I+1 ) = ONE
315 *
316 *              Compute X(i+1:m,i)
317 *
318                CALL CGEMV( '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 CGEMV( '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 CGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
324      $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
325                CALL CGEMV( '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 CGEMV( '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 CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
330                CALL CLACGV( 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 CLACGV( N-I+1, A( I, I ), LDA )
342             CALL CLACGV( I-1, A( I, 1 ), LDA )
343             CALL CGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
344      $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
345             CALL CLACGV( I-1, A( I, 1 ), LDA )
346             CALL CLACGV( I-1, X( I, 1 ), LDX )
347             CALL CGEMV( '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 CLACGV( 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 CLARFG( 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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
371      $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
372                CALL CGEMV( '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 CSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
375                CALL CLACGV( N-I+1, A( I, I ), LDA )
376 *
377 *              Update A(i+1:m,i)
378 *
379                CALL CLACGV( I-1, Y( I, 1 ), LDY )
380                CALL CGEMV( '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 CLACGV( I-1, Y( I, 1 ), LDY )
383                CALL CGEMV( '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 CLARFG( 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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CGEMV( '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 CSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
411             ELSE
412                CALL CLACGV( N-I+1, A( I, I ), LDA )
413             END IF
414    20    CONTINUE
415       END IF
416       RETURN
417 *
418 *     End of CLABRD
419 *
420       END