LAPACK: SRC/dlabrd.f Source File

Go to the documentation of this file.
00001       SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
00002      $                   LDY )
00003 *
00004 *  -- LAPACK auxiliary routine (version 3.2) --
00005 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00006 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00007 *     November 2006
00008 *
00009 *     .. Scalar Arguments ..
00010       INTEGER            LDA, LDX, LDY, M, N, NB
00011 *     ..
00012 *     .. Array Arguments ..
00013       DOUBLE PRECISION   A( LDA, * ), D( * ), E( * ), TAUP( * ),
00014      $                   TAUQ( * ), X( LDX, * ), Y( LDY, * )
00015 *     ..
00016 *
00017 *  Purpose
00018 *  =======
00019 *
00020 *  DLABRD reduces the first NB rows and columns of a real general
00021 *  m by n matrix A to upper or lower bidiagonal form by an orthogonal
00022 *  transformation Q' * A * P, and returns the matrices X and Y which
00023 *  are needed to apply the transformation to the unreduced part of A.
00024 *
00025 *  If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
00026 *  bidiagonal form.
00027 *
00028 *  This is an auxiliary routine called by DGEBRD
00029 *
00030 *  Arguments
00031 *  =========
00032 *
00033 *  M       (input) INTEGER
00034 *          The number of rows in the matrix A.
00035 *
00036 *  N       (input) INTEGER
00037 *          The number of columns in the matrix A.
00038 *
00039 *  NB      (input) INTEGER
00040 *          The number of leading rows and columns of A to be reduced.
00041 *
00042 *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
00043 *          On entry, the m by n general matrix to be reduced.
00044 *          On exit, the first NB rows and columns of the matrix are
00045 *          overwritten; the rest of the array is unchanged.
00046 *          If m >= n, elements on and below the diagonal in the first NB
00047 *            columns, with the array TAUQ, represent the orthogonal
00048 *            matrix Q as a product of elementary reflectors; and
00049 *            elements above the diagonal in the first NB rows, with the
00050 *            array TAUP, represent the orthogonal matrix P as a product
00051 *            of elementary reflectors.
00052 *          If m < n, elements below the diagonal in the first NB
00053 *            columns, with the array TAUQ, represent the orthogonal
00054 *            matrix Q as a product of elementary reflectors, and
00055 *            elements on and above the diagonal in the first NB rows,
00056 *            with the array TAUP, represent the orthogonal matrix P as
00057 *            a product of elementary reflectors.
00058 *          See Further Details.
00059 *
00060 *  LDA     (input) INTEGER
00061 *          The leading dimension of the array A.  LDA >= max(1,M).
00062 *
00063 *  D       (output) DOUBLE PRECISION array, dimension (NB)
00064 *          The diagonal elements of the first NB rows and columns of
00065 *          the reduced matrix.  D(i) = A(i,i).
00066 *
00067 *  E       (output) DOUBLE PRECISION array, dimension (NB)
00068 *          The off-diagonal elements of the first NB rows and columns of
00069 *          the reduced matrix.
00070 *
00071 *  TAUQ    (output) DOUBLE PRECISION array dimension (NB)
00072 *          The scalar factors of the elementary reflectors which
00073 *          represent the orthogonal matrix Q. See Further Details.
00074 *
00075 *  TAUP    (output) DOUBLE PRECISION array, dimension (NB)
00076 *          The scalar factors of the elementary reflectors which
00077 *          represent the orthogonal matrix P. See Further Details.
00078 *
00079 *  X       (output) DOUBLE PRECISION array, dimension (LDX,NB)
00080 *          The m-by-nb matrix X required to update the unreduced part
00081 *          of A.
00082 *
00083 *  LDX     (input) INTEGER
00084 *          The leading dimension of the array X. LDX >= M.
00085 *
00086 *  Y       (output) DOUBLE PRECISION array, dimension (LDY,NB)
00087 *          The n-by-nb matrix Y required to update the unreduced part
00088 *          of A.
00089 *
00090 *  LDY     (input) INTEGER
00091 *          The leading dimension of the array Y. LDY >= N.
00092 *
00093 *  Further Details
00094 *  ===============
00095 *
00096 *  The matrices Q and P are represented as products of elementary
00097 *  reflectors:
00098 *
00099 *     Q = H(1) H(2) . . . H(nb)  and  P = G(1) G(2) . . . G(nb)
00100 *
00101 *  Each H(i) and G(i) has the form:
00102 *
00103 *     H(i) = I - tauq * v * v'  and G(i) = I - taup * u * u'
00104 *
00105 *  where tauq and taup are real scalars, and v and u are real vectors.
00106 *
00107 *  If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
00108 *  A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
00109 *  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
00110 *
00111 *  If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
00112 *  A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
00113 *  A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
00114 *
00115 *  The elements of the vectors v and u together form the m-by-nb matrix
00116 *  V and the nb-by-n matrix U' which are needed, with X and Y, to apply
00117 *  the transformation to the unreduced part of the matrix, using a block
00118 *  update of the form:  A := A - V*Y' - X*U'.
00119 *
00120 *  The contents of A on exit are illustrated by the following examples
00121 *  with nb = 2:
00122 *
00123 *  m = 6 and n = 5 (m > n):          m = 5 and n = 6 (m < n):
00124 *
00125 *    (  1   1   u1  u1  u1 )           (  1   u1  u1  u1  u1  u1 )
00126 *    (  v1  1   1   u2  u2 )           (  1   1   u2  u2  u2  u2 )
00127 *    (  v1  v2  a   a   a  )           (  v1  1   a   a   a   a  )
00128 *    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
00129 *    (  v1  v2  a   a   a  )           (  v1  v2  a   a   a   a  )
00130 *    (  v1  v2  a   a   a  )
00131 *
00132 *  where a denotes an element of the original matrix which is unchanged,
00133 *  vi denotes an element of the vector defining H(i), and ui an element
00134 *  of the vector defining G(i).
00135 *
00136 *  =====================================================================
00137 *
00138 *     .. Parameters ..
00139       DOUBLE PRECISION   ZERO, ONE
00140       PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
00141 *     ..
00142 *     .. Local Scalars ..
00143       INTEGER            I
00144 *     ..
00145 *     .. External Subroutines ..
00146       EXTERNAL           DGEMV, DLARFG, DSCAL
00147 *     ..
00148 *     .. Intrinsic Functions ..
00149       INTRINSIC          MIN
00150 *     ..
00151 *     .. Executable Statements ..
00152 *
00153 *     Quick return if possible
00154 *
00155       IF( M.LE.0 .OR. N.LE.0 )
00156      $   RETURN
00157 *
00158       IF( M.GE.N ) THEN
00159 *
00160 *        Reduce to upper bidiagonal form
00161 *
00162          DO 10 I = 1, NB
00163 *
00164 *           Update A(i:m,i)
00165 *
00166             CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
00167      $                  LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
00168             CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
00169      $                  LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
00170 *
00171 *           Generate reflection Q(i) to annihilate A(i+1:m,i)
00172 *
00173             CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
00174      $                   TAUQ( I ) )
00175             D( I ) = A( I, I )
00176             IF( I.LT.N ) THEN
00177                A( I, I ) = ONE
00178 *
00179 *              Compute Y(i+1:n,i)
00180 *
00181                CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
00182      $                     LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
00183                CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
00184      $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
00185                CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
00186      $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
00187                CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
00188      $                     A( I, I ), 1, ZERO, Y( 1, I ), 1 )
00189                CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
00190      $                     LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
00191                CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
00192 *
00193 *              Update A(i,i+1:n)
00194 *
00195                CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
00196      $                     LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
00197                CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
00198      $                     LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
00199 *
00200 *              Generate reflection P(i) to annihilate A(i,i+2:n)
00201 *
00202                CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
00203      $                      LDA, TAUP( I ) )
00204                E( I ) = A( I, I+1 )
00205                A( I, I+1 ) = ONE
00206 *
00207 *              Compute X(i+1:m,i)
00208 *
00209                CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
00210      $                     LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
00211                CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
00212      $                     A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
00213                CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
00214      $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
00215                CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
00216      $                     LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
00217                CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
00218      $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
00219                CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
00220             END IF
00221    10    CONTINUE
00222       ELSE
00223 *
00224 *        Reduce to lower bidiagonal form
00225 *
00226          DO 20 I = 1, NB
00227 *
00228 *           Update A(i,i:n)
00229 *
00230             CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
00231      $                  LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
00232             CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
00233      $                  X( I, 1 ), LDX, ONE, A( I, I ), LDA )
00234 *
00235 *           Generate reflection P(i) to annihilate A(i,i+1:n)
00236 *
00237             CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
00238      $                   TAUP( I ) )
00239             D( I ) = A( I, I )
00240             IF( I.LT.M ) THEN
00241                A( I, I ) = ONE
00242 *
00243 *              Compute X(i+1:m,i)
00244 *
00245                CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
00246      $                     LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
00247                CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
00248      $                     A( I, I ), LDA, ZERO, X( 1, I ), 1 )
00249                CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
00250      $                     LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
00251                CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
00252      $                     LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
00253                CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
00254      $                     LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
00255                CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
00256 *
00257 *              Update A(i+1:m,i)
00258 *
00259                CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
00260      $                     LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
00261                CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
00262      $                     LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
00263 *
00264 *              Generate reflection Q(i) to annihilate A(i+2:m,i)
00265 *
00266                CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
00267      $                      TAUQ( I ) )
00268                E( I ) = A( I+1, I )
00269                A( I+1, I ) = ONE
00270 *
00271 *              Compute Y(i+1:n,i)
00272 *
00273                CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
00274      $                     LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
00275                CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
00276      $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
00277                CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
00278      $                     LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
00279                CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
00280      $                     A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
00281                CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
00282      $                     Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
00283                CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
00284             END IF
00285    20    CONTINUE
00286       END IF
00287       RETURN
00288 *
00289 *     End of DLABRD
00290 *
00291       END