SRC/zlatrd.f

   1 *> \brief \b ZLATRD reduces the first nb rows and columns of a symmetric/Hermitian matrix A to real tridiagonal form by an unitary similarity transformation.
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download ZLATRD + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlatrd.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlatrd.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlatrd.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          UPLO
  25 *       INTEGER            LDA, LDW, N, NB
  26 *       ..
  27 *       .. Array Arguments ..
  28 *       DOUBLE PRECISION   E( * )
  29 *       COMPLEX*16         A( LDA, * ), TAU( * ), W( LDW, * )
  30 *       ..
  31 *
  32 *
  33 *> \par Purpose:
  34 *  =============
  35 *>
  36 *> \verbatim
  37 *>
  38 *> ZLATRD reduces NB rows and columns of a complex Hermitian matrix A to
  39 *> Hermitian tridiagonal form by a unitary similarity
  40 *> transformation Q**H * A * Q, and returns the matrices V and W which are
  41 *> needed to apply the transformation to the unreduced part of A.
  42 *>
  43 *> If UPLO = 'U', ZLATRD reduces the last NB rows and columns of a
  44 *> matrix, of which the upper triangle is supplied;
  45 *> if UPLO = 'L', ZLATRD reduces the first NB rows and columns of a
  46 *> matrix, of which the lower triangle is supplied.
  47 *>
  48 *> This is an auxiliary routine called by ZHETRD.
  49 *> \endverbatim
  50 *
  51 *  Arguments:
  52 *  ==========
  53 *
  54 *> \param[in] UPLO
  55 *> \verbatim
  56 *>          UPLO is CHARACTER*1
  57 *>          Specifies whether the upper or lower triangular part of the
  58 *>          Hermitian matrix A is stored:
  59 *>          = 'U': Upper triangular
  60 *>          = 'L': Lower triangular
  61 *> \endverbatim
  62 *>
  63 *> \param[in] N
  64 *> \verbatim
  65 *>          N is INTEGER
  66 *>          The order of the matrix A.
  67 *> \endverbatim
  68 *>
  69 *> \param[in] NB
  70 *> \verbatim
  71 *>          NB is INTEGER
  72 *>          The number of rows and columns to be reduced.
  73 *> \endverbatim
  74 *>
  75 *> \param[in,out] A
  76 *> \verbatim
  77 *>          A is COMPLEX*16 array, dimension (LDA,N)
  78 *>          On entry, the Hermitian matrix A.  If UPLO = 'U', the leading
  79 *>          n-by-n upper triangular part of A contains the upper
  80 *>          triangular part of the matrix A, and the strictly lower
  81 *>          triangular part of A is not referenced.  If UPLO = 'L', the
  82 *>          leading n-by-n lower triangular part of A contains the lower
  83 *>          triangular part of the matrix A, and the strictly upper
  84 *>          triangular part of A is not referenced.
  85 *>          On exit:
  86 *>          if UPLO = 'U', the last NB columns have been reduced to
  87 *>            tridiagonal form, with the diagonal elements overwriting
  88 *>            the diagonal elements of A; the elements above the diagonal
  89 *>            with the array TAU, represent the unitary matrix Q as a
  90 *>            product of elementary reflectors;
  91 *>          if UPLO = 'L', the first NB columns have been reduced to
  92 *>            tridiagonal form, with the diagonal elements overwriting
  93 *>            the diagonal elements of A; the elements below the diagonal
  94 *>            with the array TAU, represent the  unitary matrix Q as a
  95 *>            product of elementary reflectors.
  96 *>          See Further Details.
  97 *> \endverbatim
  98 *>
  99 *> \param[in] LDA
 100 *> \verbatim
 101 *>          LDA is INTEGER
 102 *>          The leading dimension of the array A.  LDA >= max(1,N).
 103 *> \endverbatim
 104 *>
 105 *> \param[out] E
 106 *> \verbatim
 107 *>          E is DOUBLE PRECISION array, dimension (N-1)
 108 *>          If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
 109 *>          elements of the last NB columns of the reduced matrix;
 110 *>          if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
 111 *>          the first NB columns of the reduced matrix.
 112 *> \endverbatim
 113 *>
 114 *> \param[out] TAU
 115 *> \verbatim
 116 *>          TAU is COMPLEX*16 array, dimension (N-1)
 117 *>          The scalar factors of the elementary reflectors, stored in
 118 *>          TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
 119 *>          See Further Details.
 120 *> \endverbatim
 121 *>
 122 *> \param[out] W
 123 *> \verbatim
 124 *>          W is COMPLEX*16 array, dimension (LDW,NB)
 125 *>          The n-by-nb matrix W required to update the unreduced part
 126 *>          of A.
 127 *> \endverbatim
 128 *>
 129 *> \param[in] LDW
 130 *> \verbatim
 131 *>          LDW is INTEGER
 132 *>          The leading dimension of the array W. LDW >= max(1,N).
 133 *> \endverbatim
 134 *
 135 *  Authors:
 136 *  ========
 137 *
 138 *> \author Univ. of Tennessee
 139 *> \author Univ. of California Berkeley
 140 *> \author Univ. of Colorado Denver
 141 *> \author NAG Ltd.
 142 *
 143 *> \date September 2012
 144 *
 145 *> \ingroup complex16OTHERauxiliary
 146 *
 147 *> \par Further Details:
 148 *  =====================
 149 *>
 150 *> \verbatim
 151 *>
 152 *>  If UPLO = 'U', the matrix Q is represented as a product of elementary
 153 *>  reflectors
 154 *>
 155 *>     Q = H(n) H(n-1) . . . H(n-nb+1).
 156 *>
 157 *>  Each H(i) has the form
 158 *>
 159 *>     H(i) = I - tau * v * v**H
 160 *>
 161 *>  where tau is a complex scalar, and v is a complex vector with
 162 *>  v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
 163 *>  and tau in TAU(i-1).
 164 *>
 165 *>  If UPLO = 'L', the matrix Q is represented as a product of elementary
 166 *>  reflectors
 167 *>
 168 *>     Q = H(1) H(2) . . . H(nb).
 169 *>
 170 *>  Each H(i) has the form
 171 *>
 172 *>     H(i) = I - tau * v * v**H
 173 *>
 174 *>  where tau is a complex scalar, and v is a complex vector with
 175 *>  v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
 176 *>  and tau in TAU(i).
 177 *>
 178 *>  The elements of the vectors v together form the n-by-nb matrix V
 179 *>  which is needed, with W, to apply the transformation to the unreduced
 180 *>  part of the matrix, using a Hermitian rank-2k update of the form:
 181 *>  A := A - V*W**H - W*V**H.
 182 *>
 183 *>  The contents of A on exit are illustrated by the following examples
 184 *>  with n = 5 and nb = 2:
 185 *>
 186 *>  if UPLO = 'U':                       if UPLO = 'L':
 187 *>
 188 *>    (  a   a   a   v4  v5 )              (  d                  )
 189 *>    (      a   a   v4  v5 )              (  1   d              )
 190 *>    (          a   1   v5 )              (  v1  1   a          )
 191 *>    (              d   1  )              (  v1  v2  a   a      )
 192 *>    (                  d  )              (  v1  v2  a   a   a  )
 193 *>
 194 *>  where d denotes a diagonal element of the reduced matrix, a denotes
 195 *>  an element of the original matrix that is unchanged, and vi denotes
 196 *>  an element of the vector defining H(i).
 197 *> \endverbatim
 198 *>
 199 *  =====================================================================
 200       SUBROUTINE ZLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
 201 *
 202 *  -- LAPACK auxiliary routine (version 3.4.2) --
 203 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 204 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 205 *     September 2012
 206 *
 207 *     .. Scalar Arguments ..
 208       CHARACTER          UPLO
 209       INTEGER            LDA, LDW, N, NB
 210 *     ..
 211 *     .. Array Arguments ..
 212       DOUBLE PRECISION   E( * )
 213       COMPLEX*16         A( LDA, * ), TAU( * ), W( LDW, * )
 214 *     ..
 215 *
 216 *  =====================================================================
 217 *
 218 *     .. Parameters ..
 219       COMPLEX*16         ZERO, ONE, HALF
 220       PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ),
 221      $                   ONE = ( 1.0D+0, 0.0D+0 ),
 222      $                   HALF = ( 0.5D+0, 0.0D+0 ) )
 223 *     ..
 224 *     .. Local Scalars ..
 225       INTEGER            I, IW
 226       COMPLEX*16         ALPHA
 227 *     ..
 228 *     .. External Subroutines ..
 229       EXTERNAL           ZAXPY, ZGEMV, ZHEMV, ZLACGV, ZLARFG, ZSCAL
 230 *     ..
 231 *     .. External Functions ..
 232       LOGICAL            LSAME
 233       COMPLEX*16         ZDOTC
 234       EXTERNAL           LSAME, ZDOTC
 235 *     ..
 236 *     .. Intrinsic Functions ..
 237       INTRINSIC          DBLE, MIN
 238 *     ..
 239 *     .. Executable Statements ..
 240 *
 241 *     Quick return if possible
 242 *
 243       IF( N.LE.0 )
 244      $   RETURN
 245 *
 246       IF( LSAME( UPLO, 'U' ) ) THEN
 247 *
 248 *        Reduce last NB columns of upper triangle
 249 *
 250          DO 10 I = N, N - NB + 1, -1
 251             IW = I - N + NB
 252             IF( I.LT.N ) THEN
 253 *
 254 *              Update A(1:i,i)
 255 *
 256                A( I, I ) = DBLE( A( I, I ) )
 257                CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
 258                CALL ZGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
 259      $                     LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
 260                CALL ZLACGV( N-I, W( I, IW+1 ), LDW )
 261                CALL ZLACGV( N-I, A( I, I+1 ), LDA )
 262                CALL ZGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
 263      $                     LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
 264                CALL ZLACGV( N-I, A( I, I+1 ), LDA )
 265                A( I, I ) = DBLE( A( I, I ) )
 266             END IF
 267             IF( I.GT.1 ) THEN
 268 *
 269 *              Generate elementary reflector H(i) to annihilate
 270 *              A(1:i-2,i)
 271 *
 272                ALPHA = A( I-1, I )
 273                CALL ZLARFG( I-1, ALPHA, A( 1, I ), 1, TAU( I-1 ) )
 274                E( I-1 ) = ALPHA
 275                A( I-1, I ) = ONE
 276 *
 277 *              Compute W(1:i-1,i)
 278 *
 279                CALL ZHEMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
 280      $                     ZERO, W( 1, IW ), 1 )
 281                IF( I.LT.N ) THEN
 282                   CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
 283      $                        W( 1, IW+1 ), LDW, A( 1, I ), 1, ZERO,
 284      $                        W( I+1, IW ), 1 )
 285                   CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
 286      $                        A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
 287      $                        W( 1, IW ), 1 )
 288                   CALL ZGEMV( 'Conjugate transpose', I-1, N-I, ONE,
 289      $                        A( 1, I+1 ), LDA, A( 1, I ), 1, ZERO,
 290      $                        W( I+1, IW ), 1 )
 291                   CALL ZGEMV( 'No transpose', I-1, N-I, -ONE,
 292      $                        W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
 293      $                        W( 1, IW ), 1 )
 294                END IF
 295                CALL ZSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
 296                ALPHA = -HALF*TAU( I-1 )*ZDOTC( I-1, W( 1, IW ), 1,
 297      $                 A( 1, I ), 1 )
 298                CALL ZAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
 299             END IF
 300 *
 301    10    CONTINUE
 302       ELSE
 303 *
 304 *        Reduce first NB columns of lower triangle
 305 *
 306          DO 20 I = 1, NB
 307 *
 308 *           Update A(i:n,i)
 309 *
 310             A( I, I ) = DBLE( A( I, I ) )
 311             CALL ZLACGV( I-1, W( I, 1 ), LDW )
 312             CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
 313      $                  LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
 314             CALL ZLACGV( I-1, W( I, 1 ), LDW )
 315             CALL ZLACGV( I-1, A( I, 1 ), LDA )
 316             CALL ZGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
 317      $                  LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
 318             CALL ZLACGV( I-1, A( I, 1 ), LDA )
 319             A( I, I ) = DBLE( A( I, I ) )
 320             IF( I.LT.N ) THEN
 321 *
 322 *              Generate elementary reflector H(i) to annihilate
 323 *              A(i+2:n,i)
 324 *
 325                ALPHA = A( I+1, I )
 326                CALL ZLARFG( N-I, ALPHA, A( MIN( I+2, N ), I ), 1,
 327      $                      TAU( I ) )
 328                E( I ) = ALPHA
 329                A( I+1, I ) = ONE
 330 *
 331 *              Compute W(i+1:n,i)
 332 *
 333                CALL ZHEMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
 334      $                     A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
 335                CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
 336      $                     W( I+1, 1 ), LDW, A( I+1, I ), 1, ZERO,
 337      $                     W( 1, I ), 1 )
 338                CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
 339      $                     LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
 340                CALL ZGEMV( 'Conjugate transpose', N-I, I-1, ONE,
 341      $                     A( I+1, 1 ), LDA, A( I+1, I ), 1, ZERO,
 342      $                     W( 1, I ), 1 )
 343                CALL ZGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
 344      $                     LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
 345                CALL ZSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
 346                ALPHA = -HALF*TAU( I )*ZDOTC( N-I, W( I+1, I ), 1,
 347      $                 A( I+1, I ), 1 )
 348                CALL ZAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
 349             END IF
 350 *
 351    20    CONTINUE
 352       END IF
 353 *
 354       RETURN
 355 *
 356 *     End of ZLATRD
 357 *
 358       END