dlatrd.f

          SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
    *
    *  -- LAPACK auxiliary routine (version 3.1) --
    *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
    *     November 2006
    *
    *     .. Scalar Arguments ..
          CHARACTER          UPLO
          INTEGER            LDA, LDW, N, NB
    *     ..
    *     .. Array Arguments ..
          DOUBLE PRECISION   A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  DLATRD reduces NB rows and columns of a real symmetric matrix A to
    *  symmetric tridiagonal form by an orthogonal similarity
    *  transformation Q' * A * Q, and returns the matrices V and W which are
    *  needed to apply the transformation to the unreduced part of A.
    *
    *  If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
    *  matrix, of which the upper triangle is supplied;
    *  if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
    *  matrix, of which the lower triangle is supplied.
    *
    *  This is an auxiliary routine called by DSYTRD.
    *
    *  Arguments
    *  =========
    *
    *  UPLO    (input) CHARACTER*1
    *          Specifies whether the upper or lower triangular part of the
    *          symmetric matrix A is stored:
    *          = 'U': Upper triangular
    *          = 'L': Lower triangular
    *
    *  N       (input) INTEGER
    *          The order of the matrix A.
    *
    *  NB      (input) INTEGER
    *          The number of rows and columns to be reduced.
    *
    *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
    *          On entry, the symmetric matrix A.  If UPLO = 'U', the leading
    *          n-by-n upper triangular part of A contains the upper
    *          triangular part of the matrix A, and the strictly lower
    *          triangular part of A is not referenced.  If UPLO = 'L', the
    *          leading n-by-n lower triangular part of A contains the lower
    *          triangular part of the matrix A, and the strictly upper
    *          triangular part of A is not referenced.
    *          On exit:
    *          if UPLO = 'U', the last NB columns have been reduced to
    *            tridiagonal form, with the diagonal elements overwriting
    *            the diagonal elements of A; the elements above the diagonal
    *            with the array TAU, represent the orthogonal matrix Q as a
    *            product of elementary reflectors;
    *          if UPLO = 'L', the first NB columns have been reduced to
    *            tridiagonal form, with the diagonal elements overwriting
    *            the diagonal elements of A; the elements below the diagonal
    *            with the array TAU, represent the  orthogonal matrix Q as a
    *            product of elementary reflectors.
    *          See Further Details.
    *
    *  LDA     (input) INTEGER
    *          The leading dimension of the array A.  LDA >= (1,N).
    *
    *  E       (output) DOUBLE PRECISION array, dimension (N-1)
    *          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
    *          elements of the last NB columns of the reduced matrix;
    *          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
    *          the first NB columns of the reduced matrix.
    *
    *  TAU     (output) DOUBLE PRECISION array, dimension (N-1)
    *          The scalar factors of the elementary reflectors, stored in
    *          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
    *          See Further Details.
    *
    *  W       (output) DOUBLE PRECISION array, dimension (LDW,NB)
    *          The n-by-nb matrix W required to update the unreduced part
    *          of A.
    *
    *  LDW     (input) INTEGER
    *          The leading dimension of the array W. LDW >= max(1,N).
    *
    *  Further Details
    *  ===============
    *
    *  If UPLO = 'U', the matrix Q is represented as a product of elementary
    *  reflectors
    *
    *     Q = H(n) H(n-1) . . . H(n-nb+1).
    *
    *  Each H(i) has the form
    *
    *     H(i) = I - tau * v * v'
    *
    *  where tau is a real scalar, and v is a real vector with
    *  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
    *  and tau in TAU(i-1).
    *
    *  If UPLO = 'L', the matrix Q is represented as a product of elementary
    *  reflectors
    *
    *     Q = H(1) H(2) . . . H(nb).
    *
    *  Each H(i) has the form
    *
    *     H(i) = I - tau * v * v'
    *
    *  where tau is a real scalar, and v is a real vector with
    *  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
    *  and tau in TAU(i).
    *
    *  The elements of the vectors v together form the n-by-nb matrix V
    *  which is needed, with W, to apply the transformation to the unreduced
    *  part of the matrix, using a symmetric rank-2k update of the form:
    *  A := A - V*W' - W*V'.
    *
    *  The contents of A on exit are illustrated by the following examples
    *  with n = 5 and nb = 2:
    *
    *  if UPLO = 'U':                       if UPLO = 'L':
    *
    *    (  a   a   a   v4  v5 )              (  d                  )
    *    (      a   a   v4  v5 )              (  1   d              )
    *    (          a   1   v5 )              (  v1  1   a          )
    *    (              d   1  )              (  v1  v2  a   a      )
    *    (                  d  )              (  v1  v2  a   a   a  )
    *
    *  where d denotes a diagonal element of the reduced matrix, a denotes
    *  an element of the original matrix that is unchanged, and vi denotes
    *  an element of the vector defining H(i).
    *
    *  =====================================================================
    *
    *     .. Parameters ..
          DOUBLE PRECISION   ZERO, ONE, HALF
          PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
    *     ..
    *     .. Local Scalars ..
          INTEGER            I, IW
          DOUBLE PRECISION   ALPHA
    *     ..
    *     .. External Subroutines ..
          EXTERNAL           DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
    *     ..
    *     .. External Functions ..
          LOGICAL            LSAME
          DOUBLE PRECISION   DDOT
          EXTERNAL           LSAME, DDOT
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC          MIN
    *     ..
    *     .. Executable Statements ..
    *
    *     Quick return if possible
    *
          IF( N.LE.0 )
         $   RETURN
    *
          IF( LSAME( UPLO, 'U' ) ) THEN
    *
    *        Reduce last NB columns of upper triangle
    *
             DO 10 I = N, N - NB + 1, -1
                IW = I - N + NB
                IF( I.LT.N ) THEN
    *
    *              Update A(1:i,i)
    *
                   CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
         $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
                   CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
         $                     LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
                END IF
                IF( I.GT.1 ) THEN
    *
    *              Generate elementary reflector H(i) to annihilate
    *              A(1:i-2,i)
    *
                   CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
                   E( I-1 ) = A( I-1, I )
                   A( I-1, I ) = ONE
    *
    *              Compute W(1:i-1,i)
    *
                   CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
         $                     ZERO, W( 1, IW ), 1 )
                   IF( I.LT.N ) THEN
                      CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
         $                        LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
                      CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
         $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
         $                        W( 1, IW ), 1 )
                      CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
         $                        LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
                      CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
         $                        W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
         $                        W( 1, IW ), 1 )
                   END IF
                   CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
                   ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1,
         $                 A( 1, I ), 1 )
                   CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
                END IF
    *
       10    CONTINUE
          ELSE
    *
    *        Reduce first NB columns of lower triangle
    *
             DO 20 I = 1, NB
    *
    *           Update A(i:n,i)
    *
                CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
         $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
                CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
         $                  LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
                IF( I.LT.N ) THEN
    *
    *              Generate elementary reflector H(i) to annihilate
    *              A(i+2:n,i)
    *
                   CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
         $                      TAU( I ) )
                   E( I ) = A( I+1, I )
                   A( I+1, I ) = ONE
    *
    *              Compute W(i+1:n,i)
    *
                   CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
         $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
                   CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
         $                     A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
                   CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
         $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
                   CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
         $                     A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
                   CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
         $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
                   CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
                   ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1,
         $                 A( I+1, I ), 1 )
                   CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
                END IF
    *
       20    CONTINUE
          END IF
    *
          RETURN
    *
    *     End of DLATRD
    *
          END