001:       SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
002:       IMPLICIT NONE
003: *
004: *  -- LAPACK auxiliary routine (version 3.2) --
005: *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
006: *     November 2006
007: *
008: *     .. Scalar Arguments ..
009:       CHARACTER          SIDE
010:       INTEGER            INCV, LDC, M, N
011:       REAL               TAU
012: *     ..
013: *     .. Array Arguments ..
014:       REAL               C( LDC, * ), V( * ), WORK( * )
015: *     ..
016: *
017: *  Purpose
018: *  =======
019: *
020: *  SLARF applies a real elementary reflector H to a real m by n matrix
021: *  C, from either the left or the right. H is represented in the form
022: *
023: *        H = I - tau * v * v'
024: *
025: *  where tau is a real scalar and v is a real vector.
026: *
027: *  If tau = 0, then H is taken to be the unit matrix.
028: *
029: *  Arguments
030: *  =========
031: *
032: *  SIDE    (input) CHARACTER*1
033: *          = 'L': form  H * C
034: *          = 'R': form  C * H
035: *
036: *  M       (input) INTEGER
037: *          The number of rows of the matrix C.
038: *
039: *  N       (input) INTEGER
040: *          The number of columns of the matrix C.
041: *
042: *  V       (input) REAL array, dimension
043: *                     (1 + (M-1)*abs(INCV)) if SIDE = 'L'
044: *                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
045: *          The vector v in the representation of H. V is not used if
046: *          TAU = 0.
047: *
048: *  INCV    (input) INTEGER
049: *          The increment between elements of v. INCV <> 0.
050: *
051: *  TAU     (input) REAL
052: *          The value tau in the representation of H.
053: *
054: *  C       (input/output) REAL array, dimension (LDC,N)
055: *          On entry, the m by n matrix C.
056: *          On exit, C is overwritten by the matrix H * C if SIDE = 'L',
057: *          or C * H if SIDE = 'R'.
058: *
059: *  LDC     (input) INTEGER
060: *          The leading dimension of the array C. LDC >= max(1,M).
061: *
062: *  WORK    (workspace) REAL array, dimension
063: *                         (N) if SIDE = 'L'
064: *                      or (M) if SIDE = 'R'
065: *
066: *  =====================================================================
067: *
068: *     .. Parameters ..
069:       REAL               ONE, ZERO
070:       PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
071: *     ..
072: *     .. Local Scalars ..
073:       LOGICAL            APPLYLEFT
074:       INTEGER            I, LASTV, LASTC
075: *     ..
076: *     .. External Subroutines ..
077:       EXTERNAL           SGEMV, SGER
078: *     ..
079: *     .. External Functions ..
080:       LOGICAL            LSAME
081:       INTEGER            ILASLR, ILASLC
082:       EXTERNAL           LSAME, ILASLR, ILASLC
083: *     ..
084: *     .. Executable Statements ..
085: *
086:       APPLYLEFT = LSAME( SIDE, 'L' )
087:       LASTV = 0
088:       LASTC = 0
089:       IF( TAU.NE.ZERO ) THEN
090: !     Set up variables for scanning V.  LASTV begins pointing to the end
091: !     of V.
092:          IF( APPLYLEFT ) THEN
093:             LASTV = M
094:          ELSE
095:             LASTV = N
096:          END IF
097:          IF( INCV.GT.0 ) THEN
098:             I = 1 + (LASTV-1) * INCV
099:          ELSE
100:             I = 1
101:          END IF
102: !     Look for the last non-zero row in V.
103:          DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
104:             LASTV = LASTV - 1
105:             I = I - INCV
106:          END DO
107:          IF( APPLYLEFT ) THEN
108: !     Scan for the last non-zero column in C(1:lastv,:).
109:             LASTC = ILASLC(LASTV, N, C, LDC)
110:          ELSE
111: !     Scan for the last non-zero row in C(:,1:lastv).
112:             LASTC = ILASLR(M, LASTV, C, LDC)
113:          END IF
114:       END IF
115: !     Note that lastc.eq.0 renders the BLAS operations null; no special
116: !     case is needed at this level.
117:       IF( APPLYLEFT ) THEN
118: *
119: *        Form  H * C
120: *
121:          IF( LASTV.GT.0 ) THEN
122: *
123: *           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1)
124: *
125:             CALL SGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V, INCV,
126:      $           ZERO, WORK, 1 )
127: *
128: *           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)'
129: *
130:             CALL SGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
131:          END IF
132:       ELSE
133: *
134: *        Form  C * H
135: *
136:          IF( LASTV.GT.0 ) THEN
137: *
138: *           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
139: *
140:             CALL SGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
141:      $           V, INCV, ZERO, WORK, 1 )
142: *
143: *           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)'
144: *
145:             CALL SGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
146:          END IF
147:       END IF
148:       RETURN
149: *
150: *     End of SLARF
151: *
152:       END
153: