SRC/slarz.f

   1 *> \brief \b SLARZ applies an elementary reflector (as returned by stzrzf) to a general matrix.
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *> \htmlonly
   9 *> Download SLARZ + dependencies
  10 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/slarz.f">
  11 *> [TGZ]</a>
  12 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/slarz.f">
  13 *> [ZIP]</a>
  14 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/slarz.f">
  15 *> [TXT]</a>
  16 *> \endhtmlonly
  17 *
  18 *  Definition:
  19 *  ===========
  20 *
  21 *       SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
  22 *
  23 *       .. Scalar Arguments ..
  24 *       CHARACTER          SIDE
  25 *       INTEGER            INCV, L, LDC, M, N
  26 *       REAL               TAU
  27 *       ..
  28 *       .. Array Arguments ..
  29 *       REAL               C( LDC, * ), V( * ), WORK( * )
  30 *       ..
  31 *
  32 *
  33 *> \par Purpose:
  34 *  =============
  35 *>
  36 *> \verbatim
  37 *>
  38 *> SLARZ applies a real elementary reflector H to a real M-by-N
  39 *> matrix C, from either the left or the right. H is represented in the
  40 *> form
  41 *>
  42 *>       H = I - tau * v * v**T
  43 *>
  44 *> where tau is a real scalar and v is a real vector.
  45 *>
  46 *> If tau = 0, then H is taken to be the unit matrix.
  47 *>
  48 *>
  49 *> H is a product of k elementary reflectors as returned by STZRZF.
  50 *> \endverbatim
  51 *
  52 *  Arguments:
  53 *  ==========
  54 *
  55 *> \param[in] SIDE
  56 *> \verbatim
  57 *>          SIDE is CHARACTER*1
  58 *>          = 'L': form  H * C
  59 *>          = 'R': form  C * H
  60 *> \endverbatim
  61 *>
  62 *> \param[in] M
  63 *> \verbatim
  64 *>          M is INTEGER
  65 *>          The number of rows of the matrix C.
  66 *> \endverbatim
  67 *>
  68 *> \param[in] N
  69 *> \verbatim
  70 *>          N is INTEGER
  71 *>          The number of columns of the matrix C.
  72 *> \endverbatim
  73 *>
  74 *> \param[in] L
  75 *> \verbatim
  76 *>          L is INTEGER
  77 *>          The number of entries of the vector V containing
  78 *>          the meaningful part of the Householder vectors.
  79 *>          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
  80 *> \endverbatim
  81 *>
  82 *> \param[in] V
  83 *> \verbatim
  84 *>          V is REAL array, dimension (1+(L-1)*abs(INCV))
  85 *>          The vector v in the representation of H as returned by
  86 *>          STZRZF. V is not used if TAU = 0.
  87 *> \endverbatim
  88 *>
  89 *> \param[in] INCV
  90 *> \verbatim
  91 *>          INCV is INTEGER
  92 *>          The increment between elements of v. INCV <> 0.
  93 *> \endverbatim
  94 *>
  95 *> \param[in] TAU
  96 *> \verbatim
  97 *>          TAU is REAL
  98 *>          The value tau in the representation of H.
  99 *> \endverbatim
 100 *>
 101 *> \param[in,out] C
 102 *> \verbatim
 103 *>          C is REAL array, dimension (LDC,N)
 104 *>          On entry, the M-by-N matrix C.
 105 *>          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
 106 *>          or C * H if SIDE = 'R'.
 107 *> \endverbatim
 108 *>
 109 *> \param[in] LDC
 110 *> \verbatim
 111 *>          LDC is INTEGER
 112 *>          The leading dimension of the array C. LDC >= max(1,M).
 113 *> \endverbatim
 114 *>
 115 *> \param[out] WORK
 116 *> \verbatim
 117 *>          WORK is REAL array, dimension
 118 *>                         (N) if SIDE = 'L'
 119 *>                      or (M) if SIDE = 'R'
 120 *> \endverbatim
 121 *
 122 *  Authors:
 123 *  ========
 124 *
 125 *> \author Univ. of Tennessee
 126 *> \author Univ. of California Berkeley
 127 *> \author Univ. of Colorado Denver
 128 *> \author NAG Ltd.
 129 *
 130 *> \date September 2012
 131 *
 132 *> \ingroup realOTHERcomputational
 133 *
 134 *> \par Contributors:
 135 *  ==================
 136 *>
 137 *>    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
 138 *
 139 *> \par Further Details:
 140 *  =====================
 141 *>
 142 *> \verbatim
 143 *> \endverbatim
 144 *>
 145 *  =====================================================================
 146       SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
 147 *
 148 *  -- LAPACK computational routine (version 3.4.2) --
 149 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 150 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 151 *     September 2012
 152 *
 153 *     .. Scalar Arguments ..
 154       CHARACTER          SIDE
 155       INTEGER            INCV, L, LDC, M, N
 156       REAL               TAU
 157 *     ..
 158 *     .. Array Arguments ..
 159       REAL               C( LDC, * ), V( * ), WORK( * )
 160 *     ..
 161 *
 162 *  =====================================================================
 163 *
 164 *     .. Parameters ..
 165       REAL               ONE, ZERO
 166       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
 167 *     ..
 168 *     .. External Subroutines ..
 169       EXTERNAL           SAXPY, SCOPY, SGEMV, SGER
 170 *     ..
 171 *     .. External Functions ..
 172       LOGICAL            LSAME
 173       EXTERNAL           LSAME
 174 *     ..
 175 *     .. Executable Statements ..
 176 *
 177       IF( LSAME( SIDE, 'L' ) ) THEN
 178 *
 179 *        Form  H * C
 180 *
 181          IF( TAU.NE.ZERO ) THEN
 182 *
 183 *           w( 1:n ) = C( 1, 1:n )
 184 *
 185             CALL SCOPY( N, C, LDC, WORK, 1 )
 186 *
 187 *           w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )**T * v( 1:l )
 188 *
 189             CALL SGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
 190      $                  INCV, ONE, WORK, 1 )
 191 *
 192 *           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
 193 *
 194             CALL SAXPY( N, -TAU, WORK, 1, C, LDC )
 195 *
 196 *           C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
 197 *                               tau * v( 1:l ) * w( 1:n )**T
 198 *
 199             CALL SGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
 200      $                 LDC )
 201          END IF
 202 *
 203       ELSE
 204 *
 205 *        Form  C * H
 206 *
 207          IF( TAU.NE.ZERO ) THEN
 208 *
 209 *           w( 1:m ) = C( 1:m, 1 )
 210 *
 211             CALL SCOPY( M, C, 1, WORK, 1 )
 212 *
 213 *           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
 214 *
 215             CALL SGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
 216      $                  V, INCV, ONE, WORK, 1 )
 217 *
 218 *           C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
 219 *
 220             CALL SAXPY( M, -TAU, WORK, 1, C, 1 )
 221 *
 222 *           C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
 223 *                               tau * w( 1:m ) * v( 1:l )**T
 224 *
 225             CALL SGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
 226      $                 LDC )
 227 *
 228          END IF
 229 *
 230       END IF
 231 *
 232       RETURN
 233 *
 234 *     End of SLARZ
 235 *
 236       END