001:       SUBROUTINE ZLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
002:       IMPLICIT NONE
003: *
004: *  -- LAPACK auxiliary routine (version 3.2) --
005: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
006: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
007: *     November 2006
008: *
009: *     .. Scalar Arguments ..
010:       CHARACTER          SIDE
011:       INTEGER            INCV, LDC, M, N
012:       COMPLEX*16         TAU
013: *     ..
014: *     .. Array Arguments ..
015:       COMPLEX*16         C( LDC, * ), V( * ), WORK( * )
016: *     ..
017: *
018: *  Purpose
019: *  =======
020: *
021: *  ZLARF applies a complex elementary reflector H to a complex M-by-N
022: *  matrix C, from either the left or the right. H is represented in the
023: *  form
024: *
025: *        H = I - tau * v * v'
026: *
027: *  where tau is a complex scalar and v is a complex vector.
028: *
029: *  If tau = 0, then H is taken to be the unit matrix.
030: *
031: *  To apply H' (the conjugate transpose of H), supply conjg(tau) instead
032: *  tau.
033: *
034: *  Arguments
035: *  =========
036: *
037: *  SIDE    (input) CHARACTER*1
038: *          = 'L': form  H * C
039: *          = 'R': form  C * H
040: *
041: *  M       (input) INTEGER
042: *          The number of rows of the matrix C.
043: *
044: *  N       (input) INTEGER
045: *          The number of columns of the matrix C.
046: *
047: *  V       (input) COMPLEX*16 array, dimension
048: *                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
049: *                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
050: *          The vector v in the representation of H. V is not used if
051: *          TAU = 0.
052: *
053: *  INCV    (input) INTEGER
054: *          The increment between elements of v. INCV <> 0.
055: *
056: *  TAU     (input) COMPLEX*16
057: *          The value tau in the representation of H.
058: *
059: *  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
060: *          On entry, the M-by-N matrix C.
061: *          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
062: *          or C * H if SIDE = 'R'.
063: *
064: *  LDC     (input) INTEGER
065: *          The leading dimension of the array C. LDC >= max(1,M).
066: *
067: *  WORK    (workspace) COMPLEX*16 array, dimension
068: *                         (N) if SIDE = 'L'
069: *                      or (M) if SIDE = 'R'
070: *
071: *  =====================================================================
072: *
073: *     .. Parameters ..
074:       COMPLEX*16         ONE, ZERO
075:       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ),
076:      $                   ZERO = ( 0.0D+0, 0.0D+0 ) )
077: *     ..
078: *     .. Local Scalars ..
079:       LOGICAL            APPLYLEFT
080:       INTEGER            I, LASTV, LASTC
081: *     ..
082: *     .. External Subroutines ..
083:       EXTERNAL           ZGEMV, ZGERC
084: *     ..
085: *     .. External Functions ..
086:       LOGICAL            LSAME
087:       INTEGER            ILAZLR, ILAZLC
088:       EXTERNAL           LSAME, ILAZLR, ILAZLC
089: *     ..
090: *     .. Executable Statements ..
091: *
092:       APPLYLEFT = LSAME( SIDE, 'L' )
093:       LASTV = 0
094:       LASTC = 0
095:       IF( TAU.NE.ZERO ) THEN
096: !     Set up variables for scanning V.  LASTV begins pointing to the end
097: !     of V.
098:          IF( APPLYLEFT ) THEN
099:             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
159: