Return to zlarf.f CVS log

Up to [local] / rpl / lapack / lapack

Commit initial.

    1:       SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
    2:       IMPLICIT NONE
    3: *
    4: *  -- LAPACK auxiliary routine (version 3.2) --
    5: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
    6: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
    7: *     November 2006
    8: *
    9: *     .. Scalar Arguments ..
   10:       CHARACTER          SIDE
   11:       INTEGER            INCV, LDC, M, N
   12:       COMPLEX*16         TAU
   13: *     ..
   14: *     .. Array Arguments ..
   15:       COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
   16: *     ..
   17: *
   18: *  Purpose
   19: *  =======
   20: *
   21: *  ZLARF applies a complex elementary reflector H to a complex M-by-N
   22: *  matrix C, from either the left or the right. H is represented in the
   23: *  form
   24: *
   25: *        H = I - tau * v * v'
   26: *
   27: *  where tau is a complex scalar and v is a complex vector.
   28: *
   29: *  If tau = 0, then H is taken to be the unit matrix.
   30: *
   31: *  To apply H' (the conjugate transpose of H), supply conjg(tau) instead
   32: *  tau.
   33: *
   34: *  Arguments
   35: *  =========
   36: *
   37: *  SIDE    (input) CHARACTER*1
   38: *          = 'L': form  H * C
   39: *          = 'R': form  C * H
   40: *
   41: *  M       (input) INTEGER
   42: *          The number of rows of the matrix C.
   43: *
   44: *  N       (input) INTEGER
   45: *          The number of columns of the matrix C.
   46: *
   47: *  V       (input) COMPLEX*16 array, dimension
   48: *                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
   49: *                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
   50: *          The vector v in the representation of H. V is not used if
   51: *          TAU = 0.
   52: *
   53: *  INCV    (input) INTEGER
   54: *          The increment between elements of v. INCV <> 0.
   55: *
   56: *  TAU     (input) COMPLEX*16
   57: *          The value tau in the representation of H.
   58: *
   59: *  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
   60: *          On entry, the M-by-N matrix C.
   61: *          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
   62: *          or C * H if SIDE = 'R'.
   63: *
   64: *  LDC     (input) INTEGER
   65: *          The leading dimension of the array C. LDC >= max(1,M).
   66: *
   67: *  WORK    (workspace) COMPLEX*16 array, dimension
   68: *                         (N) if SIDE = 'L'
   69: *                      or (M) if SIDE = 'R'
   70: *
   71: *  =====================================================================
   72: *
   73: *     .. Parameters ..
   74:       COMPLEX*16         ONE, ZERO
   75:       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
   76:      $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
   77: *     ..
   78: *     .. Local Scalars ..
   79:       LOGICAL            APPLYLEFT
   80:       INTEGER            I, LASTV, LASTC
   81: *     ..
   82: *     .. External Subroutines ..
   83:       EXTERNAL           ZGEMV, ZGERC
   84: *     ..
   85: *     .. External Functions ..
   86:       LOGICAL            LSAME
   87:       INTEGER            ILAZLR, ILAZLC
   88:       EXTERNAL           LSAME, ILAZLR, ILAZLC
   89: *     ..
   90: *     .. Executable Statements ..
   91: *
   92:       APPLYLEFT = LSAME( SIDE, 'L' )
   93:       LASTV = 0
   94:       LASTC = 0
   95:       IF( TAU.NE.ZERO ) THEN
   96: !     Set up variables for scanning V.  LASTV begins pointing to the end
   97: !     of V.
   98:          IF( APPLYLEFT ) THEN
   99:             LASTV = M
  100:          ELSE
  101:             LASTV = N
  102:          END IF
  103:          IF( INCV.GT.0 ) THEN
  104:             I = 1 + (LASTV-1) * INCV
  105:          ELSE
  106:             I = 1
  107:          END IF
  108: !     Look for the last non-zero row in V.
  109:          DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
  110:             LASTV = LASTV - 1
  111:             I = I - INCV
  112:          END DO
  113:          IF( APPLYLEFT ) THEN
  114: !     Scan for the last non-zero column in C(1:lastv,:).
  115:             LASTC = ILAZLC(LASTV, N, C, LDC)
  116:          ELSE
  117: !     Scan for the last non-zero row in C(:,1:lastv).
  118:             LASTC = ILAZLR(M, LASTV, C, LDC)
  119:          END IF
  120:       END IF
  121: !     Note that lastc.eq.0 renders the BLAS operations null; no special
  122: !     case is needed at this level.
  123:       IF( APPLYLEFT ) THEN
  124: *
  125: *        Form  H * C
  126: *
  127:          IF( LASTV.GT.0 ) THEN
  128: *
  129: *           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
  130: *
  131:             CALL ZGEMV( 'Conjugate transpose', LASTV, LASTC, ONE,
  132:      $           C, LDC, V, INCV, ZERO, WORK, 1 )
  133: *
  134: *           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
  135: *
  136:             CALL ZGERC( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
  137:          END IF
  138:       ELSE
  139: *
  140: *        Form  C * H
  141: *
  142:          IF( LASTV.GT.0 ) THEN
  143: *
  144: *           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
  145: *
  146:             CALL ZGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
  147:      $           V, INCV, ZERO, WORK, 1 )
  148: *
  149: *           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
  150: *
  151:             CALL ZGERC( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
  152:          END IF
  153:       END IF
  154:       RETURN
  155: *
  156: *     End of ZLARF
  157: *
  158:       END