Chimie Théorique » OpenPath

      SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )

*

*  -- LAPACK routine (version 3.2) --

*  -- LAPACK is a software package provided by Univ. of Tennessee,    --

*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--

*     November 2006

*

*     .. Scalar Arguments ..

      CHARACTER          SIDE

      INTEGER            INCV, L, LDC, M, N

      DOUBLE PRECISION   TAU

*     ..

*     .. Array Arguments ..

      DOUBLE PRECISION   C( LDC, * ), V( * ), WORK( * )

*     ..

*

*  Purpose

*  =======

*

*  DLARZ applies a real elementary reflector H to a real M-by-N

*  matrix C, from either the left or the right. H is represented in the

*  form

*

*        H = I - tau * v * v'

*

*  where tau is a real scalar and v is a real vector.

*

*  If tau = 0, then H is taken to be the unit matrix.

*

*

*  H is a product of k elementary reflectors as returned by DTZRZF.

*

*  Arguments

*  =========

*

*  SIDE    (input) CHARACTER*1

*          = 'L': form  H * C

*          = 'R': form  C * H

*

*  M       (input) INTEGER

*          The number of rows of the matrix C.

*

*  N       (input) INTEGER

*          The number of columns of the matrix C.

*

*  L       (input) INTEGER

*          The number of entries of the vector V containing

*          the meaningful part of the Householder vectors.

*          If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.

*

*  V       (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))

*          The vector v in the representation of H as returned by

*          DTZRZF. V is not used if TAU = 0.

*

*  INCV    (input) INTEGER

*          The increment between elements of v. INCV <> 0.

*

*  TAU     (input) DOUBLE PRECISION

*          The value tau in the representation of H.

*

*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)

*          On entry, the M-by-N matrix C.

*          On exit, C is overwritten by the matrix H * C if SIDE = 'L',

*          or C * H if SIDE = 'R'.

*

*  LDC     (input) INTEGER

*          The leading dimension of the array C. LDC >= max(1,M).

*

*  WORK    (workspace) DOUBLE PRECISION array, dimension

*                         (N) if SIDE = 'L'

*                      or (M) if SIDE = 'R'

*

*  Further Details

*  ===============

*

*  Based on contributions by

*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA

*

*  =====================================================================

*

*     .. Parameters ..

      DOUBLE PRECISION   ONE, ZERO

      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )

*     ..

*     .. External Subroutines ..

      EXTERNAL           DAXPY, DCOPY, DGEMV, DGER

*     ..

*     .. External Functions ..

      LOGICAL            LSAME

      EXTERNAL           LSAME

*     ..

*     .. Executable Statements ..

*

      IF( LSAME( SIDE, 'L' ) ) THEN

*

*        Form  H * C

*

         IF( TAU.NE.ZERO ) THEN

*

*           w( 1:n ) = C( 1, 1:n )

*

            CALL DCOPY( N, C, LDC, WORK, 1 )

*

*           w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )

*

            CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,

     $                  INCV, ONE, WORK, 1 )

*

*           C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )

*

            CALL DAXPY( N, -TAU, WORK, 1, C, LDC )

*

*           C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...

*                               tau * v( 1:l ) * w( 1:n )'

*

            CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),

     $                 LDC )

         END IF

*

      ELSE

*

*        Form  C * H

*

         IF( TAU.NE.ZERO ) THEN

*

*           w( 1:m ) = C( 1:m, 1 )

*

            CALL DCOPY( M, C, 1, WORK, 1 )

*

*           w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )

*

            CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,

     $                  V, INCV, ONE, WORK, 1 )

*

*           C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )

*

            CALL DAXPY( M, -TAU, WORK, 1, C, 1 )

*

*           C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...

*                               tau * w( 1:m ) * v( 1:l )'

*

            CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),

     $                 LDC )

*

         END IF

*

      END IF

*

      RETURN

*

*     End of DLARZ

*

      END