LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
zlarfb.f
Go to the documentation of this file.
00001 *> \brief \b ZLARFB
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download ZLARFB + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlarfb.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlarfb.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlarfb.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
00022 *                          T, LDT, C, LDC, WORK, LDWORK )
00023 * 
00024 *       .. Scalar Arguments ..
00025 *       CHARACTER          DIRECT, SIDE, STOREV, TRANS
00026 *       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
00027 *       ..
00028 *       .. Array Arguments ..
00029 *       COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
00030 *      $                   WORK( LDWORK, * )
00031 *       ..
00032 *  
00033 *
00034 *> \par Purpose:
00035 *  =============
00036 *>
00037 *> \verbatim
00038 *>
00039 *> ZLARFB applies a complex block reflector H or its transpose H**H to a
00040 *> complex M-by-N matrix C, from either the left or the right.
00041 *> \endverbatim
00042 *
00043 *  Arguments:
00044 *  ==========
00045 *
00046 *> \param[in] SIDE
00047 *> \verbatim
00048 *>          SIDE is CHARACTER*1
00049 *>          = 'L': apply H or H**H from the Left
00050 *>          = 'R': apply H or H**H from the Right
00051 *> \endverbatim
00052 *>
00053 *> \param[in] TRANS
00054 *> \verbatim
00055 *>          TRANS is CHARACTER*1
00056 *>          = 'N': apply H (No transpose)
00057 *>          = 'C': apply H**H (Conjugate transpose)
00058 *> \endverbatim
00059 *>
00060 *> \param[in] DIRECT
00061 *> \verbatim
00062 *>          DIRECT is CHARACTER*1
00063 *>          Indicates how H is formed from a product of elementary
00064 *>          reflectors
00065 *>          = 'F': H = H(1) H(2) . . . H(k) (Forward)
00066 *>          = 'B': H = H(k) . . . H(2) H(1) (Backward)
00067 *> \endverbatim
00068 *>
00069 *> \param[in] STOREV
00070 *> \verbatim
00071 *>          STOREV is CHARACTER*1
00072 *>          Indicates how the vectors which define the elementary
00073 *>          reflectors are stored:
00074 *>          = 'C': Columnwise
00075 *>          = 'R': Rowwise
00076 *> \endverbatim
00077 *>
00078 *> \param[in] M
00079 *> \verbatim
00080 *>          M is INTEGER
00081 *>          The number of rows of the matrix C.
00082 *> \endverbatim
00083 *>
00084 *> \param[in] N
00085 *> \verbatim
00086 *>          N is INTEGER
00087 *>          The number of columns of the matrix C.
00088 *> \endverbatim
00089 *>
00090 *> \param[in] K
00091 *> \verbatim
00092 *>          K is INTEGER
00093 *>          The order of the matrix T (= the number of elementary
00094 *>          reflectors whose product defines the block reflector).
00095 *> \endverbatim
00096 *>
00097 *> \param[in] V
00098 *> \verbatim
00099 *>          V is COMPLEX*16 array, dimension
00100 *>                                (LDV,K) if STOREV = 'C'
00101 *>                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
00102 *>                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
00103 *>          See Further Details.
00104 *> \endverbatim
00105 *>
00106 *> \param[in] LDV
00107 *> \verbatim
00108 *>          LDV is INTEGER
00109 *>          The leading dimension of the array V.
00110 *>          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
00111 *>          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
00112 *>          if STOREV = 'R', LDV >= K.
00113 *> \endverbatim
00114 *>
00115 *> \param[in] T
00116 *> \verbatim
00117 *>          T is COMPLEX*16 array, dimension (LDT,K)
00118 *>          The triangular K-by-K matrix T in the representation of the
00119 *>          block reflector.
00120 *> \endverbatim
00121 *>
00122 *> \param[in] LDT
00123 *> \verbatim
00124 *>          LDT is INTEGER
00125 *>          The leading dimension of the array T. LDT >= K.
00126 *> \endverbatim
00127 *>
00128 *> \param[in,out] C
00129 *> \verbatim
00130 *>          C is COMPLEX*16 array, dimension (LDC,N)
00131 *>          On entry, the M-by-N matrix C.
00132 *>          On exit, C is overwritten by H*C or H**H*C or C*H or C*H**H.
00133 *> \endverbatim
00134 *>
00135 *> \param[in] LDC
00136 *> \verbatim
00137 *>          LDC is INTEGER
00138 *>          The leading dimension of the array C. LDC >= max(1,M).
00139 *> \endverbatim
00140 *>
00141 *> \param[out] WORK
00142 *> \verbatim
00143 *>          WORK is COMPLEX*16 array, dimension (LDWORK,K)
00144 *> \endverbatim
00145 *>
00146 *> \param[in] LDWORK
00147 *> \verbatim
00148 *>          LDWORK is INTEGER
00149 *>          The leading dimension of the array WORK.
00150 *>          If SIDE = 'L', LDWORK >= max(1,N);
00151 *>          if SIDE = 'R', LDWORK >= max(1,M).
00152 *> \endverbatim
00153 *
00154 *  Authors:
00155 *  ========
00156 *
00157 *> \author Univ. of Tennessee 
00158 *> \author Univ. of California Berkeley 
00159 *> \author Univ. of Colorado Denver 
00160 *> \author NAG Ltd. 
00161 *
00162 *> \date November 2011
00163 *
00164 *> \ingroup complex16OTHERauxiliary
00165 *
00166 *> \par Further Details:
00167 *  =====================
00168 *>
00169 *> \verbatim
00170 *>
00171 *>  The shape of the matrix V and the storage of the vectors which define
00172 *>  the H(i) is best illustrated by the following example with n = 5 and
00173 *>  k = 3. The elements equal to 1 are not stored; the corresponding
00174 *>  array elements are modified but restored on exit. The rest of the
00175 *>  array is not used.
00176 *>
00177 *>  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
00178 *>
00179 *>               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
00180 *>                   ( v1  1    )                     (     1 v2 v2 v2 )
00181 *>                   ( v1 v2  1 )                     (        1 v3 v3 )
00182 *>                   ( v1 v2 v3 )
00183 *>                   ( v1 v2 v3 )
00184 *>
00185 *>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
00186 *>
00187 *>               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
00188 *>                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
00189 *>                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
00190 *>                   (     1 v3 )
00191 *>                   (        1 )
00192 *> \endverbatim
00193 *>
00194 *  =====================================================================
00195       SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
00196      $                   T, LDT, C, LDC, WORK, LDWORK )
00197 *
00198 *  -- LAPACK auxiliary routine (version 3.4.0) --
00199 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00200 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00201 *     November 2011
00202 *
00203 *     .. Scalar Arguments ..
00204       CHARACTER          DIRECT, SIDE, STOREV, TRANS
00205       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
00206 *     ..
00207 *     .. Array Arguments ..
00208       COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
00209      $                   WORK( LDWORK, * )
00210 *     ..
00211 *
00212 *  =====================================================================
00213 *
00214 *     .. Parameters ..
00215       COMPLEX*16         ONE
00216       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
00217 *     ..
00218 *     .. Local Scalars ..
00219       CHARACTER          TRANST
00220       INTEGER            I, J, LASTV, LASTC
00221 *     ..
00222 *     .. External Functions ..
00223       LOGICAL            LSAME
00224       INTEGER            ILAZLR, ILAZLC
00225       EXTERNAL           LSAME, ILAZLR, ILAZLC
00226 *     ..
00227 *     .. External Subroutines ..
00228       EXTERNAL           ZCOPY, ZGEMM, ZLACGV, ZTRMM
00229 *     ..
00230 *     .. Intrinsic Functions ..
00231       INTRINSIC          DCONJG
00232 *     ..
00233 *     .. Executable Statements ..
00234 *
00235 *     Quick return if possible
00236 *
00237       IF( M.LE.0 .OR. N.LE.0 )
00238      $   RETURN
00239 *
00240       IF( LSAME( TRANS, 'N' ) ) THEN
00241          TRANST = 'C'
00242       ELSE
00243          TRANST = 'N'
00244       END IF
00245 *
00246       IF( LSAME( STOREV, 'C' ) ) THEN
00247 *
00248          IF( LSAME( DIRECT, 'F' ) ) THEN
00249 *
00250 *           Let  V =  ( V1 )    (first K rows)
00251 *                     ( V2 )
00252 *           where  V1  is unit lower triangular.
00253 *
00254             IF( LSAME( SIDE, 'L' ) ) THEN
00255 *
00256 *              Form  H * C  or  H**H * C  where  C = ( C1 )
00257 *                                                    ( C2 )
00258 *
00259                LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
00260                LASTC = ILAZLC( LASTV, N, C, LDC )
00261 *
00262 *              W := C**H * V  =  (C1**H * V1 + C2**H * V2)  (stored in WORK)
00263 *
00264 *              W := C1**H
00265 *
00266                DO 10 J = 1, K
00267                   CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
00268                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
00269    10          CONTINUE
00270 *
00271 *              W := W * V1
00272 *
00273                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00274      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00275                IF( LASTV.GT.K ) THEN
00276 *
00277 *                 W := W + C2**H *V2
00278 *
00279                   CALL ZGEMM( 'Conjugate transpose', 'No transpose',
00280      $                 LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
00281      $                 V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
00282                END IF
00283 *
00284 *              W := W * T**H  or  W * T
00285 *
00286                CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
00287      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00288 *
00289 *              C := C - V * W**H
00290 *
00291                IF( M.GT.K ) THEN
00292 *
00293 *                 C2 := C2 - V2 * W**H
00294 *
00295                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
00296      $                 LASTV-K, LASTC, K,
00297      $                 -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
00298      $                 ONE, C( K+1, 1 ), LDC )
00299                END IF
00300 *
00301 *              W := W * V1**H
00302 *
00303                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
00304      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00305 *
00306 *              C1 := C1 - W**H
00307 *
00308                DO 30 J = 1, K
00309                   DO 20 I = 1, LASTC
00310                      C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
00311    20             CONTINUE
00312    30          CONTINUE
00313 *
00314             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00315 *
00316 *              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
00317 *
00318                LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
00319                LASTC = ILAZLR( M, LASTV, C, LDC )
00320 *
00321 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
00322 *
00323 *              W := C1
00324 *
00325                DO 40 J = 1, K
00326                   CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
00327    40          CONTINUE
00328 *
00329 *              W := W * V1
00330 *
00331                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00332      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00333                IF( LASTV.GT.K ) THEN
00334 *
00335 *                 W := W + C2 * V2
00336 *
00337                   CALL ZGEMM( 'No transpose', 'No transpose',
00338      $                 LASTC, K, LASTV-K,
00339      $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
00340      $                 ONE, WORK, LDWORK )
00341                END IF
00342 *
00343 *              W := W * T  or  W * T**H
00344 *
00345                CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
00346      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00347 *
00348 *              C := C - W * V**H
00349 *
00350                IF( LASTV.GT.K ) THEN
00351 *
00352 *                 C2 := C2 - W * V2**H
00353 *
00354                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
00355      $                 LASTC, LASTV-K, K,
00356      $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
00357      $                 ONE, C( 1, K+1 ), LDC )
00358                END IF
00359 *
00360 *              W := W * V1**H
00361 *
00362                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
00363      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00364 *
00365 *              C1 := C1 - W
00366 *
00367                DO 60 J = 1, K
00368                   DO 50 I = 1, LASTC
00369                      C( I, J ) = C( I, J ) - WORK( I, J )
00370    50             CONTINUE
00371    60          CONTINUE
00372             END IF
00373 *
00374          ELSE
00375 *
00376 *           Let  V =  ( V1 )
00377 *                     ( V2 )    (last K rows)
00378 *           where  V2  is unit upper triangular.
00379 *
00380             IF( LSAME( SIDE, 'L' ) ) THEN
00381 *
00382 *              Form  H * C  or  H**H * C  where  C = ( C1 )
00383 *                                                    ( C2 )
00384 *
00385                LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
00386                LASTC = ILAZLC( LASTV, N, C, LDC )
00387 *
00388 *              W := C**H * V  =  (C1**H * V1 + C2**H * V2)  (stored in WORK)
00389 *
00390 *              W := C2**H
00391 *
00392                DO 70 J = 1, K
00393                   CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
00394      $                 WORK( 1, J ), 1 )
00395                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
00396    70          CONTINUE
00397 *
00398 *              W := W * V2
00399 *
00400                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00401      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00402      $              WORK, LDWORK )
00403                IF( LASTV.GT.K ) THEN
00404 *
00405 *                 W := W + C1**H*V1
00406 *
00407                   CALL ZGEMM( 'Conjugate transpose', 'No transpose',
00408      $                 LASTC, K, LASTV-K,
00409      $                 ONE, C, LDC, V, LDV,
00410      $                 ONE, WORK, LDWORK )
00411                END IF
00412 *
00413 *              W := W * T**H  or  W * T
00414 *
00415                CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
00416      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00417 *
00418 *              C := C - V * W**H
00419 *
00420                IF( LASTV.GT.K ) THEN
00421 *
00422 *                 C1 := C1 - V1 * W**H
00423 *
00424                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
00425      $                 LASTV-K, LASTC, K,
00426      $                 -ONE, V, LDV, WORK, LDWORK,
00427      $                 ONE, C, LDC )
00428                END IF
00429 *
00430 *              W := W * V2**H
00431 *
00432                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
00433      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00434      $              WORK, LDWORK )
00435 *
00436 *              C2 := C2 - W**H
00437 *
00438                DO 90 J = 1, K
00439                   DO 80 I = 1, LASTC
00440                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
00441      $                               DCONJG( WORK( I, J ) )
00442    80             CONTINUE
00443    90          CONTINUE
00444 *
00445             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00446 *
00447 *              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
00448 *
00449                LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
00450                LASTC = ILAZLR( M, LASTV, C, LDC )
00451 *
00452 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
00453 *
00454 *              W := C2
00455 *
00456                DO 100 J = 1, K
00457                   CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
00458      $                 WORK( 1, J ), 1 )
00459   100          CONTINUE
00460 *
00461 *              W := W * V2
00462 *
00463                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00464      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00465      $              WORK, LDWORK )
00466                IF( LASTV.GT.K ) THEN
00467 *
00468 *                 W := W + C1 * V1
00469 *
00470                   CALL ZGEMM( 'No transpose', 'No transpose',
00471      $                 LASTC, K, LASTV-K,
00472      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
00473                END IF
00474 *
00475 *              W := W * T  or  W * T**H
00476 *
00477                CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
00478      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00479 *
00480 *              C := C - W * V**H
00481 *
00482                IF( LASTV.GT.K ) THEN
00483 *
00484 *                 C1 := C1 - W * V1**H
00485 *
00486                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
00487      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
00488      $                 ONE, C, LDC )
00489                END IF
00490 *
00491 *              W := W * V2**H
00492 *
00493                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
00494      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
00495      $              WORK, LDWORK )
00496 *
00497 *              C2 := C2 - W
00498 *
00499                DO 120 J = 1, K
00500                   DO 110 I = 1, LASTC
00501                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
00502      $                    - WORK( I, J )
00503   110             CONTINUE
00504   120          CONTINUE
00505             END IF
00506          END IF
00507 *
00508       ELSE IF( LSAME( STOREV, 'R' ) ) THEN
00509 *
00510          IF( LSAME( DIRECT, 'F' ) ) THEN
00511 *
00512 *           Let  V =  ( V1  V2 )    (V1: first K columns)
00513 *           where  V1  is unit upper triangular.
00514 *
00515             IF( LSAME( SIDE, 'L' ) ) THEN
00516 *
00517 *              Form  H * C  or  H**H * C  where  C = ( C1 )
00518 *                                                    ( C2 )
00519 *
00520                LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
00521                LASTC = ILAZLC( LASTV, N, C, LDC )
00522 *
00523 *              W := C**H * V**H  =  (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
00524 *
00525 *              W := C1**H
00526 *
00527                DO 130 J = 1, K
00528                   CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
00529                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
00530   130          CONTINUE
00531 *
00532 *              W := W * V1**H
00533 *
00534                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
00535      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00536                IF( LASTV.GT.K ) THEN
00537 *
00538 *                 W := W + C2**H*V2**H
00539 *
00540                   CALL ZGEMM( 'Conjugate transpose',
00541      $                 'Conjugate transpose', LASTC, K, LASTV-K,
00542      $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
00543      $                 ONE, WORK, LDWORK )
00544                END IF
00545 *
00546 *              W := W * T**H  or  W * T
00547 *
00548                CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
00549      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00550 *
00551 *              C := C - V**H * W**H
00552 *
00553                IF( LASTV.GT.K ) THEN
00554 *
00555 *                 C2 := C2 - V2**H * W**H
00556 *
00557                   CALL ZGEMM( 'Conjugate transpose',
00558      $                 'Conjugate transpose', LASTV-K, LASTC, K,
00559      $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
00560      $                 ONE, C( K+1, 1 ), LDC )
00561                END IF
00562 *
00563 *              W := W * V1
00564 *
00565                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00566      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00567 *
00568 *              C1 := C1 - W**H
00569 *
00570                DO 150 J = 1, K
00571                   DO 140 I = 1, LASTC
00572                      C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
00573   140             CONTINUE
00574   150          CONTINUE
00575 *
00576             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00577 *
00578 *              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
00579 *
00580                LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
00581                LASTC = ILAZLR( M, LASTV, C, LDC )
00582 *
00583 *              W := C * V**H  =  (C1*V1**H + C2*V2**H)  (stored in WORK)
00584 *
00585 *              W := C1
00586 *
00587                DO 160 J = 1, K
00588                   CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
00589   160          CONTINUE
00590 *
00591 *              W := W * V1**H
00592 *
00593                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
00594      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
00595                IF( LASTV.GT.K ) THEN
00596 *
00597 *                 W := W + C2 * V2**H
00598 *
00599                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
00600      $                 LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
00601      $                 V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
00602                END IF
00603 *
00604 *              W := W * T  or  W * T**H
00605 *
00606                CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
00607      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00608 *
00609 *              C := C - W * V
00610 *
00611                IF( LASTV.GT.K ) THEN
00612 *
00613 *                 C2 := C2 - W * V2
00614 *
00615                   CALL ZGEMM( 'No transpose', 'No transpose',
00616      $                 LASTC, LASTV-K, K,
00617      $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
00618      $                 ONE, C( 1, K+1 ), LDC )
00619                END IF
00620 *
00621 *              W := W * V1
00622 *
00623                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
00624      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
00625 *
00626 *              C1 := C1 - W
00627 *
00628                DO 180 J = 1, K
00629                   DO 170 I = 1, LASTC
00630                      C( I, J ) = C( I, J ) - WORK( I, J )
00631   170             CONTINUE
00632   180          CONTINUE
00633 *
00634             END IF
00635 *
00636          ELSE
00637 *
00638 *           Let  V =  ( V1  V2 )    (V2: last K columns)
00639 *           where  V2  is unit lower triangular.
00640 *
00641             IF( LSAME( SIDE, 'L' ) ) THEN
00642 *
00643 *              Form  H * C  or  H**H * C  where  C = ( C1 )
00644 *                                                    ( C2 )
00645 *
00646                LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
00647                LASTC = ILAZLC( LASTV, N, C, LDC )
00648 *
00649 *              W := C**H * V**H  =  (C1**H * V1**H + C2**H * V2**H) (stored in WORK)
00650 *
00651 *              W := C2**H
00652 *
00653                DO 190 J = 1, K
00654                   CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
00655      $                 WORK( 1, J ), 1 )
00656                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
00657   190          CONTINUE
00658 *
00659 *              W := W * V2**H
00660 *
00661                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
00662      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00663      $              WORK, LDWORK )
00664                IF( LASTV.GT.K ) THEN
00665 *
00666 *                 W := W + C1**H * V1**H
00667 *
00668                   CALL ZGEMM( 'Conjugate transpose',
00669      $                 'Conjugate transpose', LASTC, K, LASTV-K,
00670      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
00671                END IF
00672 *
00673 *              W := W * T**H  or  W * T
00674 *
00675                CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
00676      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00677 *
00678 *              C := C - V**H * W**H
00679 *
00680                IF( LASTV.GT.K ) THEN
00681 *
00682 *                 C1 := C1 - V1**H * W**H
00683 *
00684                   CALL ZGEMM( 'Conjugate transpose',
00685      $                 'Conjugate transpose', LASTV-K, LASTC, K,
00686      $                 -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
00687                END IF
00688 *
00689 *              W := W * V2
00690 *
00691                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00692      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00693      $              WORK, LDWORK )
00694 *
00695 *              C2 := C2 - W**H
00696 *
00697                DO 210 J = 1, K
00698                   DO 200 I = 1, LASTC
00699                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
00700      $                               DCONJG( WORK( I, J ) )
00701   200             CONTINUE
00702   210          CONTINUE
00703 *
00704             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
00705 *
00706 *              Form  C * H  or  C * H**H  where  C = ( C1  C2 )
00707 *
00708                LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
00709                LASTC = ILAZLR( M, LASTV, C, LDC )
00710 *
00711 *              W := C * V**H  =  (C1*V1**H + C2*V2**H)  (stored in WORK)
00712 *
00713 *              W := C2
00714 *
00715                DO 220 J = 1, K
00716                   CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
00717      $                 WORK( 1, J ), 1 )
00718   220          CONTINUE
00719 *
00720 *              W := W * V2**H
00721 *
00722                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
00723      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00724      $              WORK, LDWORK )
00725                IF( LASTV.GT.K ) THEN
00726 *
00727 *                 W := W + C1 * V1**H
00728 *
00729                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
00730      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
00731      $                 WORK, LDWORK )
00732                END IF
00733 *
00734 *              W := W * T  or  W * T**H
00735 *
00736                CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
00737      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
00738 *
00739 *              C := C - W * V
00740 *
00741                IF( LASTV.GT.K ) THEN
00742 *
00743 *                 C1 := C1 - W * V1
00744 *
00745                   CALL ZGEMM( 'No transpose', 'No transpose',
00746      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
00747      $                 ONE, C, LDC )
00748                END IF
00749 *
00750 *              W := W * V2
00751 *
00752                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
00753      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
00754      $              WORK, LDWORK )
00755 *
00756 *              C1 := C1 - W
00757 *
00758                DO 240 J = 1, K
00759                   DO 230 I = 1, LASTC
00760                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
00761      $                    - WORK( I, J )
00762   230             CONTINUE
00763   240          CONTINUE
00764 *
00765             END IF
00766 *
00767          END IF
00768       END IF
00769 *
00770       RETURN
00771 *
00772 *     End of ZLARFB
00773 *
00774       END
 All Files Functions