LAPACK: SRC/clarfb.f Source File

Go to the documentation of this file.
00001       SUBROUTINE CLARFB( 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       COMPLEX            C( LDC, * ), T( LDT, * ), V( LDV, * ),
00016      $                   WORK( LDWORK, * )
00017 *     ..
00018 *
00019 *  Purpose
00020 *  =======
00021 *
00022 *  CLARFB applies a complex block reflector H or its transpose H' to a
00023 *  complex 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 *          = 'C': apply H' (Conjugate 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) COMPLEX 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) COMPLEX 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) COMPLEX 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. LDC >= max(1,M).
00083 *
00084 *  WORK    (workspace) COMPLEX 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       COMPLEX            ONE
00095       PARAMETER          ( ONE = ( 1.0E+0, 0.0E+0 ) )
00096 *     ..
00097 *     .. Local Scalars ..
00098       CHARACTER          TRANST
00099       INTEGER            I, J, LASTV, LASTC
00100 *     ..
00101 *     .. External Functions ..
00102       LOGICAL            LSAME
00103       INTEGER            ILACLR, ILACLC
00104       EXTERNAL           LSAME, ILACLR, ILACLC
00105 *     ..
00106 *     .. External Subroutines ..
00107       EXTERNAL           CCOPY, CGEMM, CLACGV, CTRMM
00108 *     ..
00109 *     .. Intrinsic Functions ..
00110       INTRINSIC          CONJG
00111 *     ..
00112 *     .. Executable Statements ..
00113 *
00114 *     Quick return if possible
00115 *
00116       IF( M.LE.0 .OR. N.LE.0 )
00117      $   RETURN
00118 *
00119       IF( LSAME( TRANS, 'N' ) ) THEN
00120          TRANST = 'C'
00121       ELSE
00122          TRANST = 'N'
00123       END IF
00124 *
00125       IF( LSAME( STOREV, 'C' ) ) THEN
00126 *
00127          IF( LSAME( DIRECT, 'F' ) ) THEN
00128 *
00129 *           Let  V =  ( V1 )    (first K rows)
00130 *                     ( V2 )
00131 *           where  V1  is unit lower triangular.
00132 *
00133             IF( LSAME( SIDE, 'L' ) ) THEN
00134 *
00135 *              Form  H * C  or  H' * C  where  C = ( C1 )
00136 *                                                  ( C2 )
00137 *
00138                LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
00139                LASTC = ILACLC( LASTV, N, C, LDC )
00140 *
00141 *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
00142 *
00143 *              W := C1'
00144 *
00145                DO 10 J = 1, K
00146                   CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
00147                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
00148    10          CONTINUE
00149 *
00150 *              W := W * V1
00151 *
00152                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00153      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00154                IF( LASTV.GT.K ) THEN
00155 *
00156 *                 W := W + C2'*V2
00157 *
00158                   CALL CGEMM( 'Conjugate transpose', 'No transpose',
00159      $                 LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
00160      $                 V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
00161                END IF
00162 *
00163 *              W := W * T'  or  W * T
00164 *
00165                CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
00166      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00167 *
00168 *              C := C - V * W'
00169 *
00170                IF( M.GT.K ) THEN
00171 *
00172 *                 C2 := C2 - V2 * W'
00173 *
00174                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
00175      $                 LASTV-K, LASTC, K, -ONE, V( K+1, 1 ), LDV,
00176      $                 WORK, LDWORK, ONE, C( K+1, 1 ), LDC )
00177                END IF
00178 *
00179 *              W := W * V1'
00180 *
00181                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
00182      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00183 *
00184 *              C1 := C1 - W'
00185 *
00186                DO 30 J = 1, K
00187                   DO 20 I = 1, LASTC
00188                      C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
00189    20             CONTINUE
00190    30          CONTINUE
00191 *
00192             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00193 *
00194 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00195 *
00196                LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
00197                LASTC = ILACLR( M, LASTV, C, LDC )
00198 *
00199 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
00200 *
00201 *              W := C1
00202 *
00203                DO 40 J = 1, K
00204                   CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
00205    40          CONTINUE
00206 *
00207 *              W := W * V1
00208 *
00209                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00210      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00211                IF( LASTV.GT.K ) THEN
00212 *
00213 *                 W := W + C2 * V2
00214 *
00215                   CALL CGEMM( 'No transpose', 'No transpose',
00216      $                 LASTC, K, LASTV-K,
00217      $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
00218      $                 ONE, WORK, LDWORK )
00219                END IF
00220 *
00221 *              W := W * T  or  W * T'
00222 *
00223                CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
00224      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00225 *
00226 *              C := C - W * V'
00227 *
00228                IF( LASTV.GT.K ) THEN
00229 *
00230 *                 C2 := C2 - W * V2'
00231 *
00232                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
00233      $                 LASTC, LASTV-K, K,
00234      $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
00235      $                 ONE, C( 1, K+1 ), LDC )
00236                END IF
00237 *
00238 *              W := W * V1'
00239 *
00240                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
00241      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00242 *
00243 *              C1 := C1 - W
00244 *
00245                DO 60 J = 1, K
00246                   DO 50 I = 1, LASTC
00247                      C( I, J ) = C( I, J ) - WORK( I, J )
00248    50             CONTINUE
00249    60          CONTINUE
00250             END IF
00251 *
00252          ELSE
00253 *
00254 *           Let  V =  ( V1 )
00255 *                     ( V2 )    (last K rows)
00256 *           where  V2  is unit upper triangular.
00257 *
00258             IF( LSAME( SIDE, 'L' ) ) THEN
00259 *
00260 *              Form  H * C  or  H' * C  where  C = ( C1 )
00261 *                                                  ( C2 )
00262 *
00263                LASTV = MAX( K, ILACLR( M, K, V, LDV ) )
00264                LASTC = ILACLC( LASTV, N, C, LDC )
00265 *
00266 *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
00267 *
00268 *              W := C2'
00269 *
00270                DO 70 J = 1, K
00271                   CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
00272      $                 WORK( 1, J ), 1 )
00273                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
00274    70          CONTINUE
00275 *
00276 *              W := W * V2
00277 *
00278                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00279      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00280      $              WORK, LDWORK )
00281                IF( LASTV.GT.K ) THEN
00282 *
00283 *                 W := W + C1'*V1
00284 *
00285                   CALL CGEMM( 'Conjugate transpose', 'No transpose',
00286      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV,
00287      $                 ONE, WORK, LDWORK )
00288                END IF
00289 *
00290 *              W := W * T'  or  W * T
00291 *
00292                CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
00293      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00294 *
00295 *              C := C - V * W'
00296 *
00297                IF( LASTV.GT.K ) THEN
00298 *
00299 *                 C1 := C1 - V1 * W'
00300 *
00301                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
00302      $                 LASTV-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,
00303      $                 ONE, C, LDC )
00304                END IF
00305 *
00306 *              W := W * V2'
00307 *
00308                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
00309      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00310      $              WORK, LDWORK )
00311 *
00312 *              C2 := C2 - W'
00313 *
00314                DO 90 J = 1, K
00315                   DO 80 I = 1, LASTC
00316                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
00317      $                               CONJG( WORK( I, J ) )
00318    80             CONTINUE
00319    90          CONTINUE
00320 *
00321             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00322 *
00323 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00324 *
00325                LASTV = MAX( K, ILACLR( N, K, V, LDV ) )
00326                LASTC = ILACLR( M, LASTV, C, LDC )
00327 *
00328 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
00329 *
00330 *              W := C2
00331 *
00332                DO 100 J = 1, K
00333                   CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
00334      $                 WORK( 1, J ), 1 )
00335   100          CONTINUE
00336 *
00337 *              W := W * V2
00338 *
00339                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00340      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00341      $              WORK, LDWORK )
00342                IF( LASTV.GT.K ) THEN
00343 *
00344 *                 W := W + C1 * V1
00345 *
00346                   CALL CGEMM( 'No transpose', 'No transpose',
00347      $                 LASTC, K, LASTV-K,
00348      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
00349                END IF
00350 *
00351 *              W := W * T  or  W * T'
00352 *
00353                CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
00354      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00355 *
00356 *              C := C - W * V'
00357 *
00358                IF( LASTV.GT.K ) THEN
00359 *
00360 *                 C1 := C1 - W * V1'
00361 *
00362                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
00363      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
00364      $                 ONE, C, LDC )
00365                END IF
00366 *
00367 *              W := W * V2'
00368 *
00369                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
00370      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00371      $              WORK, LDWORK )
00372 *
00373 *              C2 := C2 - W
00374 *
00375                DO 120 J = 1, K
00376                   DO 110 I = 1, LASTC
00377                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
00378      $                    - WORK( I, J )
00379   110             CONTINUE
00380   120          CONTINUE
00381             END IF
00382          END IF
00383 *
00384       ELSE IF( LSAME( STOREV, 'R' ) ) THEN
00385 *
00386          IF( LSAME( DIRECT, 'F' ) ) THEN
00387 *
00388 *           Let  V =  ( V1  V2 )    (V1: first K columns)
00389 *           where  V1  is unit upper triangular.
00390 *
00391             IF( LSAME( SIDE, 'L' ) ) THEN
00392 *
00393 *              Form  H * C  or  H' * C  where  C = ( C1 )
00394 *                                                  ( C2 )
00395 *
00396                LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
00397                LASTC = ILACLC( LASTV, N, C, LDC )
00398 *
00399 *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
00400 *
00401 *              W := C1'
00402 *
00403                DO 130 J = 1, K
00404                   CALL CCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
00405                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
00406   130          CONTINUE
00407 *
00408 *              W := W * V1'
00409 *
00410                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
00411      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00412                IF( LASTV.GT.K ) THEN
00413 *
00414 *                 W := W + C2'*V2'
00415 *
00416                   CALL CGEMM( 'Conjugate transpose',
00417      $                 'Conjugate transpose', LASTC, K, LASTV-K,
00418      $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
00419      $                 ONE, WORK, LDWORK )
00420                END IF
00421 *
00422 *              W := W * T'  or  W * T
00423 *
00424                CALL CTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
00425      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00426 *
00427 *              C := C - V' * W'
00428 *
00429                IF( LASTV.GT.K ) THEN
00430 *
00431 *                 C2 := C2 - V2' * W'
00432 *
00433                   CALL CGEMM( 'Conjugate transpose',
00434      $                 'Conjugate transpose', LASTV-K, LASTC, K,
00435      $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
00436      $                 ONE, C( K+1, 1 ), LDC )
00437                END IF
00438 *
00439 *              W := W * V1
00440 *
00441                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00442      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00443 *
00444 *              C1 := C1 - W'
00445 *
00446                DO 150 J = 1, K
00447                   DO 140 I = 1, LASTC
00448                      C( J, I ) = C( J, I ) - CONJG( WORK( I, J ) )
00449   140             CONTINUE
00450   150          CONTINUE
00451 *
00452             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00453 *
00454 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00455 *
00456                LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
00457                LASTC = ILACLR( M, LASTV, C, LDC )
00458 *
00459 *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
00460 *
00461 *              W := C1
00462 *
00463                DO 160 J = 1, K
00464                   CALL CCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
00465   160          CONTINUE
00466 *
00467 *              W := W * V1'
00468 *
00469                CALL CTRMM( 'Right', 'Upper', 'Conjugate transpose',
00470      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00471                IF( LASTV.GT.K ) THEN
00472 *
00473 *                 W := W + C2 * V2'
00474 *
00475                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
00476      $                 LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
00477      $                 V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
00478                END IF
00479 *
00480 *              W := W * T  or  W * T'
00481 *
00482                CALL CTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
00483      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00484 *
00485 *              C := C - W * V
00486 *
00487                IF( LASTV.GT.K ) THEN
00488 *
00489 *                 C2 := C2 - W * V2
00490 *
00491                   CALL CGEMM( 'No transpose', 'No transpose',
00492      $                 LASTC, LASTV-K, K,
00493      $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
00494      $                 ONE, C( 1, K+1 ), LDC )
00495                END IF
00496 *
00497 *              W := W * V1
00498 *
00499                CALL CTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00500      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00501 *
00502 *              C1 := C1 - W
00503 *
00504                DO 180 J = 1, K
00505                   DO 170 I = 1, LASTC
00506                      C( I, J ) = C( I, J ) - WORK( I, J )
00507   170             CONTINUE
00508   180          CONTINUE
00509 *
00510             END IF
00511 *
00512          ELSE
00513 *
00514 *           Let  V =  ( V1  V2 )    (V2: last K columns)
00515 *           where  V2  is unit lower triangular.
00516 *
00517             IF( LSAME( SIDE, 'L' ) ) THEN
00518 *
00519 *              Form  H * C  or  H' * C  where  C = ( C1 )
00520 *                                                  ( C2 )
00521 *
00522                LASTV = MAX( K, ILACLC( K, M, V, LDV ) )
00523                LASTC = ILACLC( LASTV, N, C, LDC )
00524 *
00525 *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
00526 *
00527 *              W := C2'
00528 *
00529                DO 190 J = 1, K
00530                   CALL CCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
00531      $                 WORK( 1, J ), 1 )
00532                   CALL CLACGV( LASTC, WORK( 1, J ), 1 )
00533   190          CONTINUE
00534 *
00535 *              W := W * V2'
00536 *
00537                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
00538      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00539      $              WORK, LDWORK )
00540                IF( LASTV.GT.K ) THEN
00541 *
00542 *                 W := W + C1'*V1'
00543 *
00544                   CALL CGEMM( 'Conjugate transpose',
00545      $                 'Conjugate transpose', LASTC, K, LASTV-K,
00546      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
00547                END IF
00548 *
00549 *              W := W * T'  or  W * T
00550 *
00551                CALL CTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
00552      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00553 *
00554 *              C := C - V' * W'
00555 *
00556                IF( LASTV.GT.K ) THEN
00557 *
00558 *                 C1 := C1 - V1' * W'
00559 *
00560                   CALL CGEMM( 'Conjugate transpose',
00561      $                 'Conjugate transpose', LASTV-K, LASTC, K,
00562      $                 -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
00563                END IF
00564 *
00565 *              W := W * V2
00566 *
00567                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00568      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00569      $              WORK, LDWORK )
00570 *
00571 *              C2 := C2 - W'
00572 *
00573                DO 210 J = 1, K
00574                   DO 200 I = 1, LASTC
00575                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
00576      $                               CONJG( WORK( I, J ) )
00577   200             CONTINUE
00578   210          CONTINUE
00579 *
00580             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00581 *
00582 *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
00583 *
00584                LASTV = MAX( K, ILACLC( K, N, V, LDV ) )
00585                LASTC = ILACLR( M, LASTV, C, LDC )
00586 *
00587 *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
00588 *
00589 *              W := C2
00590 *
00591                DO 220 J = 1, K
00592                   CALL CCOPY( LASTC, C( 1, LASTV-K+J ), 1,
00593      $                 WORK( 1, J ), 1 )
00594   220          CONTINUE
00595 *
00596 *              W := W * V2'
00597 *
00598                CALL CTRMM( 'Right', 'Lower', 'Conjugate transpose',
00599      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00600      $              WORK, LDWORK )
00601                IF( LASTV.GT.K ) THEN
00602 *
00603 *                 W := W + C1 * V1'
00604 *
00605                   CALL CGEMM( 'No transpose', 'Conjugate transpose',
00606      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
00607      $                 WORK, LDWORK )
00608                END IF
00609 *
00610 *              W := W * T  or  W * T'
00611 *
00612                CALL CTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
00613      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00614 *
00615 *              C := C - W * V
00616 *
00617                IF( LASTV.GT.K ) THEN
00618 *
00619 *                 C1 := C1 - W * V1
00620 *
00621                   CALL CGEMM( 'No transpose', 'No transpose',
00622      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
00623      $                 ONE, C, LDC )
00624                END IF
00625 *
00626 *              W := W * V2
00627 *
00628                CALL CTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00629      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00630      $              WORK, LDWORK )
00631 *
00632 *              C1 := C1 - W
00633 *
00634                DO 240 J = 1, K
00635                   DO 230 I = 1, LASTC
00636                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
00637      $                    - WORK( I, J )
00638   230             CONTINUE
00639   240          CONTINUE
00640 *
00641             END IF
00642 *
00643          END IF
00644       END IF
00645 *
00646       RETURN
00647 *
00648 *     End of CLARFB
00649 *
00650       END