LAPACK: SRC/slarfb.f Source File

Go to the documentation of this file.
00001       SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
00002      $                   T, LDT, C, LDC, WORK, LDWORK )
00003       IMPLICIT NONE
00004 *
00005 *  -- LAPACK auxiliary routine (version 3.2) --
00006 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00007 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00008 *     November 2006
00009 *
00010 *     .. Scalar Arguments ..
00011       CHARACTER          DIRECT, SIDE, STOREV, TRANS
00012       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
00013 *     ..
00014 *     .. Array Arguments ..
00015       REAL               C( LDC, * ), T( LDT, * ), V( LDV, * ),
00016      $                   WORK( LDWORK, * )
00017 *     ..
00018 *
00019 *  Purpose
00020 *  =======
00021 *
00022 *  SLARFB applies a real block reflector H or its transpose H' to a
00023 *  real m by n matrix C, from either the left or the right.
00024 *
00025 *  Arguments
00026 *  =========
00027 *
00028 *  SIDE    (input) CHARACTER*1
00029 *          = 'L': apply H or H' from the Left
00030 *          = 'R': apply H or H' from the Right
00031 *
00032 *  TRANS   (input) CHARACTER*1
00033 *          = 'N': apply H (No transpose)
00034 *          = 'T': apply H' (Transpose)
00035 *
00036 *  DIRECT  (input) CHARACTER*1
00037 *          Indicates how H is formed from a product of elementary
00038 *          reflectors
00039 *          = 'F': H = H(1) H(2) . . . H(k) (Forward)
00040 *          = 'B': H = H(k) . . . H(2) H(1) (Backward)
00041 *
00042 *  STOREV  (input) CHARACTER*1
00043 *          Indicates how the vectors which define the elementary
00044 *          reflectors are stored:
00045 *          = 'C': Columnwise
00046 *          = 'R': Rowwise
00047 *
00048 *  M       (input) INTEGER
00049 *          The number of rows of the matrix C.
00050 *
00051 *  N       (input) INTEGER
00052 *          The number of columns of the matrix C.
00053 *
00054 *  K       (input) INTEGER
00055 *          The order of the matrix T (= the number of elementary
00056 *          reflectors whose product defines the block reflector).
00057 *
00058 *  V       (input) REAL array, dimension
00059 *                                (LDV,K) if STOREV = 'C'
00060 *                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
00061 *                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
00062 *          The matrix V. See further details.
00063 *
00064 *  LDV     (input) INTEGER
00065 *          The leading dimension of the array V.
00066 *          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
00067 *          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
00068 *          if STOREV = 'R', LDV >= K.
00069 *
00070 *  T       (input) REAL array, dimension (LDT,K)
00071 *          The triangular k by k matrix T in the representation of the
00072 *          block reflector.
00073 *
00074 *  LDT     (input) INTEGER
00075 *          The leading dimension of the array T. LDT >= K.
00076 *
00077 *  C       (input/output) REAL array, dimension (LDC,N)
00078 *          On entry, the m by n matrix C.
00079 *          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
00080 *
00081 *  LDC     (input) INTEGER
00082 *          The leading dimension of the array C. LDA >= max(1,M).
00083 *
00084 *  WORK    (workspace) REAL array, dimension (LDWORK,K)
00085 *
00086 *  LDWORK  (input) INTEGER
00087 *          The leading dimension of the array WORK.
00088 *          If SIDE = 'L', LDWORK >= max(1,N);
00089 *          if SIDE = 'R', LDWORK >= max(1,M).
00090 *
00091 *  =====================================================================
00092 *
00093 *     .. Parameters ..
00094       REAL               ONE
00095       PARAMETER          ( ONE = 1.0E+0 )
00096 *     ..
00097 *     .. Local Scalars ..
00098       CHARACTER          TRANST
00099       INTEGER            I, J, LASTV, LASTC
00100 *     ..
00101 *     .. External Functions ..
00102       LOGICAL            LSAME
00103       INTEGER            ILASLR, ILASLC
00104       EXTERNAL           LSAME, ILASLR, ILASLC
00105 *     ..
00106 *     .. External Subroutines ..
00107       EXTERNAL           SCOPY, SGEMM, STRMM
00108 *     ..
00109 *     .. Executable Statements ..
00110 *
00111 *     Quick return if possible
00112 *
00113       IF( M.LE.0 .OR. N.LE.0 )
00114      $   RETURN
00115 *
00116       IF( LSAME( TRANS, 'N' ) ) THEN
00117          TRANST = 'T'
00118       ELSE
00119          TRANST = 'N'
00120       END IF
00121 *
00122       IF( LSAME( STOREV, 'C' ) ) THEN
00123 *
00124          IF( LSAME( DIRECT, 'F' ) ) THEN
00125 *
00126 *           Let  V =  ( V1 )    (first K rows)
00127 *                     ( V2 )
00128 *           where  V1  is unit lower triangular.
00129 *
00130             IF( LSAME( SIDE, 'L' ) ) THEN
00131 *
00132 *              Form  H * C  or  H' * C  where  C = ( C1 )
00133 *                                                  ( C2 )
00134 *
00135                LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
00136                LASTC = ILASLC( LASTV, N, C, LDC )
00137 *
00138 *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
00139 *
00140 *              W := C1'
00141 *
00142                DO 10 J = 1, K
00143                   CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
00144    10          CONTINUE
00145 *
00146 *              W := W * V1
00147 *
00148                CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00149      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00150                IF( LASTV.GT.K ) THEN
00151 *
00152 *                 W := W + C2'*V2
00153 *
00154                   CALL SGEMM( 'Transpose', 'No transpose',
00155      $                 LASTC, K, LASTV-K,
00156      $                 ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
00157      $                 ONE, WORK, LDWORK )
00158                END IF
00159 *
00160 *              W := W * T'  or  W * T
00161 *
00162                CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
00163      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00164 *
00165 *              C := C - V * W'
00166 *
00167                IF( LASTV.GT.K ) THEN
00168 *
00169 *                 C2 := C2 - V2 * W'
00170 *
00171                   CALL SGEMM( 'No transpose', 'Transpose',
00172      $                 LASTV-K, LASTC, K,
00173      $                 -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
00174      $                 C( K+1, 1 ), LDC )
00175                END IF
00176 *
00177 *              W := W * V1'
00178 *
00179                CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
00180      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00181 *
00182 *              C1 := C1 - W'
00183 *
00184                DO 30 J = 1, K
00185                   DO 20 I = 1, LASTC
00186                      C( J, I ) = C( J, I ) - WORK( I, J )
00187    20             CONTINUE
00188    30          CONTINUE
00189 *
00190             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00191 *
00192 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00193 *
00194                LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
00195                LASTC = ILASLR( M, LASTV, C, LDC )
00196 *
00197 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
00198 *
00199 *              W := C1
00200 *
00201                DO 40 J = 1, K
00202                   CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
00203    40          CONTINUE
00204 *
00205 *              W := W * V1
00206 *
00207                CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00208      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00209                IF( LASTV.GT.K ) THEN
00210 *
00211 *                 W := W + C2 * V2
00212 *
00213                   CALL SGEMM( 'No transpose', 'No transpose',
00214      $                 LASTC, K, LASTV-K,
00215      $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
00216      $                 ONE, WORK, LDWORK )
00217                END IF
00218 *
00219 *              W := W * T  or  W * T'
00220 *
00221                CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
00222      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00223 *
00224 *              C := C - W * V'
00225 *
00226                IF( LASTV.GT.K ) THEN
00227 *
00228 *                 C2 := C2 - W * V2'
00229 *
00230                   CALL SGEMM( 'No transpose', 'Transpose',
00231      $                 LASTC, LASTV-K, K,
00232      $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
00233      $                 C( 1, K+1 ), LDC )
00234                END IF
00235 *
00236 *              W := W * V1'
00237 *
00238                CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
00239      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00240 *
00241 *              C1 := C1 - W
00242 *
00243                DO 60 J = 1, K
00244                   DO 50 I = 1, LASTC
00245                      C( I, J ) = C( I, J ) - WORK( I, J )
00246    50             CONTINUE
00247    60          CONTINUE
00248             END IF
00249 *
00250          ELSE
00251 *
00252 *           Let  V =  ( V1 )
00253 *                     ( V2 )    (last K rows)
00254 *           where  V2  is unit upper triangular.
00255 *
00256             IF( LSAME( SIDE, 'L' ) ) THEN
00257 *
00258 *              Form  H * C  or  H' * C  where  C = ( C1 )
00259 *                                                  ( C2 )
00260 *
00261                LASTV = MAX( K, ILASLR( M, K, V, LDV ) )
00262                LASTC = ILASLC( LASTV, N, C, LDC )
00263 *
00264 *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
00265 *
00266 *              W := C2'
00267 *
00268                DO 70 J = 1, K
00269                   CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
00270      $                 WORK( 1, J ), 1 )
00271    70          CONTINUE
00272 *
00273 *              W := W * V2
00274 *
00275                CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00276      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00277      $              WORK, LDWORK )
00278                IF( LASTV.GT.K ) THEN
00279 *
00280 *                 W := W + C1'*V1
00281 *
00282                   CALL SGEMM( 'Transpose', 'No transpose',
00283      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
00284      $                 ONE, WORK, LDWORK )
00285                END IF
00286 *
00287 *              W := W * T'  or  W * T
00288 *
00289                CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
00290      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00291 *
00292 *              C := C - V * W'
00293 *
00294                IF( LASTV.GT.K ) THEN
00295 *
00296 *                 C1 := C1 - V1 * W'
00297 *
00298                   CALL SGEMM( 'No transpose', 'Transpose',
00299      $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
00300      $                 ONE, C, LDC )
00301                END IF
00302 *
00303 *              W := W * V2'
00304 *
00305                CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
00306      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00307      $              WORK, LDWORK )
00308 *
00309 *              C2 := C2 - W'
00310 *
00311                DO 90 J = 1, K
00312                   DO 80 I = 1, LASTC
00313                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
00314    80             CONTINUE
00315    90          CONTINUE
00316 *
00317             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00318 *
00319 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00320 *
00321                LASTV = MAX( K, ILASLR( N, K, V, LDV ) )
00322                LASTC = ILASLR( M, LASTV, C, LDC )
00323 *
00324 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
00325 *
00326 *              W := C2
00327 *
00328                DO 100 J = 1, K
00329                   CALL SCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
00330   100          CONTINUE
00331 *
00332 *              W := W * V2
00333 *
00334                CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00335      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00336      $              WORK, LDWORK )
00337                IF( LASTV.GT.K ) THEN
00338 *
00339 *                 W := W + C1 * V1
00340 *
00341                   CALL SGEMM( 'No transpose', 'No transpose',
00342      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
00343      $                 ONE, WORK, LDWORK )
00344                END IF
00345 *
00346 *              W := W * T  or  W * T'
00347 *
00348                CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
00349      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00350 *
00351 *              C := C - W * V'
00352 *
00353                IF( LASTV.GT.K ) THEN
00354 *
00355 *                 C1 := C1 - W * V1'
00356 *
00357                   CALL SGEMM( 'No transpose', 'Transpose',
00358      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
00359      $                 ONE, C, LDC )
00360                END IF
00361 *
00362 *              W := W * V2'
00363 *
00364                CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
00365      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00366      $              WORK, LDWORK )
00367 *
00368 *              C2 := C2 - W
00369 *
00370                DO 120 J = 1, K
00371                   DO 110 I = 1, LASTC
00372                      C( I, LASTV-K+J ) = C( I, LASTV-K+J ) - WORK(I, J)
00373   110             CONTINUE
00374   120          CONTINUE
00375             END IF
00376          END IF
00377 *
00378       ELSE IF( LSAME( STOREV, 'R' ) ) THEN
00379 *
00380          IF( LSAME( DIRECT, 'F' ) ) THEN
00381 *
00382 *           Let  V =  ( V1  V2 )    (V1: first K columns)
00383 *           where  V1  is unit upper triangular.
00384 *
00385             IF( LSAME( SIDE, 'L' ) ) THEN
00386 *
00387 *              Form  H * C  or  H' * C  where  C = ( C1 )
00388 *                                                  ( C2 )
00389 *
00390                LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
00391                LASTC = ILASLC( LASTV, N, C, LDC )
00392 *
00393 *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
00394 *
00395 *              W := C1'
00396 *
00397                DO 130 J = 1, K
00398                   CALL SCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
00399   130          CONTINUE
00400 *
00401 *              W := W * V1'
00402 *
00403                CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
00404      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00405                IF( LASTV.GT.K ) THEN
00406 *
00407 *                 W := W + C2'*V2'
00408 *
00409                   CALL SGEMM( 'Transpose', 'Transpose',
00410      $                 LASTC, K, LASTV-K,
00411      $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
00412      $                 ONE, WORK, LDWORK )
00413                END IF
00414 *
00415 *              W := W * T'  or  W * T
00416 *
00417                CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit',
00418      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00419 *
00420 *              C := C - V' * W'
00421 *
00422                IF( LASTV.GT.K ) THEN
00423 *
00424 *                 C2 := C2 - V2' * W'
00425 *
00426                   CALL SGEMM( 'Transpose', 'Transpose',
00427      $                 LASTV-K, LASTC, K,
00428      $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
00429      $                 ONE, C( K+1, 1 ), LDC )
00430                END IF
00431 *
00432 *              W := W * V1
00433 *
00434                CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00435      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00436 *
00437 *              C1 := C1 - W'
00438 *
00439                DO 150 J = 1, K
00440                   DO 140 I = 1, LASTC
00441                      C( J, I ) = C( J, I ) - WORK( I, J )
00442   140             CONTINUE
00443   150          CONTINUE
00444 *
00445             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00446 *
00447 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00448 *
00449                LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
00450                LASTC = ILASLR( M, LASTV, C, LDC )
00451 *
00452 *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
00453 *
00454 *              W := C1
00455 *
00456                DO 160 J = 1, K
00457                   CALL SCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
00458   160          CONTINUE
00459 *
00460 *              W := W * V1'
00461 *
00462                CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit',
00463      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00464                IF( LASTV.GT.K ) THEN
00465 *
00466 *                 W := W + C2 * V2'
00467 *
00468                   CALL SGEMM( 'No transpose', 'Transpose',
00469      $                 LASTC, K, LASTV-K,
00470      $                 ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
00471      $                 ONE, WORK, LDWORK )
00472                END IF
00473 *
00474 *              W := W * T  or  W * T'
00475 *
00476                CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit',
00477      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00478 *
00479 *              C := C - W * V
00480 *
00481                IF( LASTV.GT.K ) THEN
00482 *
00483 *                 C2 := C2 - W * V2
00484 *
00485                   CALL SGEMM( 'No transpose', 'No transpose',
00486      $                 LASTC, LASTV-K, K,
00487      $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
00488      $                 ONE, C( 1, K+1 ), LDC )
00489                END IF
00490 *
00491 *              W := W * V1
00492 *
00493                CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00494      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00495 *
00496 *              C1 := C1 - W
00497 *
00498                DO 180 J = 1, K
00499                   DO 170 I = 1, LASTC
00500                      C( I, J ) = C( I, J ) - WORK( I, J )
00501   170             CONTINUE
00502   180          CONTINUE
00503 *
00504             END IF
00505 *
00506          ELSE
00507 *
00508 *           Let  V =  ( V1  V2 )    (V2: last K columns)
00509 *           where  V2  is unit lower triangular.
00510 *
00511             IF( LSAME( SIDE, 'L' ) ) THEN
00512 *
00513 *              Form  H * C  or  H' * C  where  C = ( C1 )
00514 *                                                  ( C2 )
00515 *
00516                LASTV = MAX( K, ILASLC( K, M, V, LDV ) )
00517                LASTC = ILASLC( LASTV, N, C, LDC )
00518 *
00519 *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
00520 *
00521 *              W := C2'
00522 *
00523                DO 190 J = 1, K
00524                   CALL SCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
00525      $                 WORK( 1, J ), 1 )
00526   190          CONTINUE
00527 *
00528 *              W := W * V2'
00529 *
00530                CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
00531      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00532      $              WORK, LDWORK )
00533                IF( LASTV.GT.K ) THEN
00534 *
00535 *                 W := W + C1'*V1'
00536 *
00537                   CALL SGEMM( 'Transpose', 'Transpose',
00538      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
00539      $                 ONE, WORK, LDWORK )
00540                END IF
00541 *
00542 *              W := W * T'  or  W * T
00543 *
00544                CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit',
00545      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00546 *
00547 *              C := C - V' * W'
00548 *
00549                IF( LASTV.GT.K ) THEN
00550 *
00551 *                 C1 := C1 - V1' * W'
00552 *
00553                   CALL SGEMM( 'Transpose', 'Transpose',
00554      $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
00555      $                 ONE, C, LDC )
00556                END IF
00557 *
00558 *              W := W * V2
00559 *
00560                CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00561      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00562      $              WORK, LDWORK )
00563 *
00564 *              C2 := C2 - W'
00565 *
00566                DO 210 J = 1, K
00567                   DO 200 I = 1, LASTC
00568                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) - WORK(I, J)
00569   200             CONTINUE
00570   210          CONTINUE
00571 *
00572             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00573 *
00574 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00575 *
00576                LASTV = MAX( K, ILASLC( K, N, V, LDV ) )
00577                LASTC = ILASLR( M, LASTV, C, LDC )
00578 *
00579 *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
00580 *
00581 *              W := C2
00582 *
00583                DO 220 J = 1, K
00584                   CALL SCOPY( LASTC, C( 1, LASTV-K+J ), 1,
00585      $                 WORK( 1, J ), 1 )
00586   220          CONTINUE
00587 *
00588 *              W := W * V2'
00589 *
00590                CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit',
00591      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00592      $              WORK, LDWORK )
00593                IF( LASTV.GT.K ) THEN
00594 *
00595 *                 W := W + C1 * V1'
00596 *
00597                   CALL SGEMM( 'No transpose', 'Transpose',
00598      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
00599      $                 ONE, WORK, LDWORK )
00600                END IF
00601 *
00602 *              W := W * T  or  W * T'
00603 *
00604                CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit',
00605      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00606 *
00607 *              C := C - W * V
00608 *
00609                IF( LASTV.GT.K ) THEN
00610 *
00611 *                 C1 := C1 - W * V1
00612 *
00613                   CALL SGEMM( 'No transpose', 'No transpose',
00614      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
00615      $                 ONE, C, LDC )
00616                END IF
00617 *
00618 *              W := W * V2
00619 *
00620                CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00621      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00622      $              WORK, LDWORK )
00623 *
00624 *              C1 := C1 - W
00625 *
00626                DO 240 J = 1, K
00627                   DO 230 I = 1, LASTC
00628                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
00629      $                    - WORK( I, J )
00630   230             CONTINUE
00631   240          CONTINUE
00632 *
00633             END IF
00634 *
00635          END IF
00636       END IF
00637 *
00638       RETURN
00639 *
00640 *     End of SLARFB
00641 *
00642       END