File:  [local] / rpl / lapack / lapack / zlarfb.f
Revision 1.6: download - view: text, annotated - select for diffs - revision graph
Fri Aug 13 21:04:10 2010 UTC (13 years, 9 months ago) by bertrand
Branches: MAIN
CVS tags: rpl-4_0_19, rpl-4_0_18, HEAD
Patches pour OS/2

    1:       SUBROUTINE ZLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
    2:      $                   T, LDT, C, LDC, WORK, LDWORK )
    3:       IMPLICIT NONE
    4: *
    5: *  -- LAPACK auxiliary routine (version 3.2) --
    6: *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
    7: *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
    8: *     November 2006
    9: *
   10: *     .. Scalar Arguments ..
   11:       CHARACTER          DIRECT, SIDE, STOREV, TRANS
   12:       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
   13: *     ..
   14: *     .. Array Arguments ..
   15:       COMPLEX*16         C( LDC, * ), T( LDT, * ), V( LDV, * ),
   16:      $                   WORK( LDWORK, * )
   17: *     ..
   18: *
   19: *  Purpose
   20: *  =======
   21: *
   22: *  ZLARFB applies a complex block reflector H or its transpose H' to a
   23: *  complex M-by-N matrix C, from either the left or the right.
   24: *
   25: *  Arguments
   26: *  =========
   27: *
   28: *  SIDE    (input) CHARACTER*1
   29: *          = 'L': apply H or H' from the Left
   30: *          = 'R': apply H or H' from the Right
   31: *
   32: *  TRANS   (input) CHARACTER*1
   33: *          = 'N': apply H (No transpose)
   34: *          = 'C': apply H' (Conjugate transpose)
   35: *
   36: *  DIRECT  (input) CHARACTER*1
   37: *          Indicates how H is formed from a product of elementary
   38: *          reflectors
   39: *          = 'F': H = H(1) H(2) . . . H(k) (Forward)
   40: *          = 'B': H = H(k) . . . H(2) H(1) (Backward)
   41: *
   42: *  STOREV  (input) CHARACTER*1
   43: *          Indicates how the vectors which define the elementary
   44: *          reflectors are stored:
   45: *          = 'C': Columnwise
   46: *          = 'R': Rowwise
   47: *
   48: *  M       (input) INTEGER
   49: *          The number of rows of the matrix C.
   50: *
   51: *  N       (input) INTEGER
   52: *          The number of columns of the matrix C.
   53: *
   54: *  K       (input) INTEGER
   55: *          The order of the matrix T (= the number of elementary
   56: *          reflectors whose product defines the block reflector).
   57: *
   58: *  V       (input) COMPLEX*16 array, dimension
   59: *                                (LDV,K) if STOREV = 'C'
   60: *                                (LDV,M) if STOREV = 'R' and SIDE = 'L'
   61: *                                (LDV,N) if STOREV = 'R' and SIDE = 'R'
   62: *          The matrix V. See further details.
   63: *
   64: *  LDV     (input) INTEGER
   65: *          The leading dimension of the array V.
   66: *          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
   67: *          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
   68: *          if STOREV = 'R', LDV >= K.
   69: *
   70: *  T       (input) COMPLEX*16 array, dimension (LDT,K)
   71: *          The triangular K-by-K matrix T in the representation of the
   72: *          block reflector.
   73: *
   74: *  LDT     (input) INTEGER
   75: *          The leading dimension of the array T. LDT >= K.
   76: *
   77: *  C       (input/output) COMPLEX*16 array, dimension (LDC,N)
   78: *          On entry, the M-by-N matrix C.
   79: *          On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
   80: *
   81: *  LDC     (input) INTEGER
   82: *          The leading dimension of the array C. LDC >= max(1,M).
   83: *
   84: *  WORK    (workspace) COMPLEX*16 array, dimension (LDWORK,K)
   85: *
   86: *  LDWORK  (input) INTEGER
   87: *          The leading dimension of the array WORK.
   88: *          If SIDE = 'L', LDWORK >= max(1,N);
   89: *          if SIDE = 'R', LDWORK >= max(1,M).
   90: *
   91: *  =====================================================================
   92: *
   93: *     .. Parameters ..
   94:       COMPLEX*16         ONE
   95:       PARAMETER          ( ONE = ( 1.0D+0, 0.0D+0 ) )
   96: *     ..
   97: *     .. Local Scalars ..
   98:       CHARACTER          TRANST
   99:       INTEGER            I, J, LASTV, LASTC
  100: *     ..
  101: *     .. External Functions ..
  102:       LOGICAL            LSAME
  103:       INTEGER            ILAZLR, ILAZLC
  104:       EXTERNAL           LSAME, ILAZLR, ILAZLC
  105: *     ..
  106: *     .. External Subroutines ..
  107:       EXTERNAL           ZCOPY, ZGEMM, ZLACGV, ZTRMM
  108: *     ..
  109: *     .. Intrinsic Functions ..
  110:       INTRINSIC          DCONJG
  111: *     ..
  112: *     .. Executable Statements ..
  113: *
  114: *     Quick return if possible
  115: *
  116:       IF( M.LE.0 .OR. N.LE.0 )
  117:      $   RETURN
  118: *
  119:       IF( LSAME( TRANS, 'N' ) ) THEN
  120:          TRANST = 'C'
  121:       ELSE
  122:          TRANST = 'N'
  123:       END IF
  124: *
  125:       IF( LSAME( STOREV, 'C' ) ) THEN
  126: *
  127:          IF( LSAME( DIRECT, 'F' ) ) THEN
  128: *
  129: *           Let  V =  ( V1 )    (first K rows)
  130: *                     ( V2 )
  131: *           where  V1  is unit lower triangular.
  132: *
  133:             IF( LSAME( SIDE, 'L' ) ) THEN
  134: *
  135: *              Form  H * C  or  H' * C  where  C = ( C1 )
  136: *                                                  ( C2 )
  137: *
  138:                LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
  139:                LASTC = ILAZLC( LASTV, N, C, LDC )
  140: *
  141: *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
  142: *
  143: *              W := C1'
  144: *
  145:                DO 10 J = 1, K
  146:                   CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  147:                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
  148:    10          CONTINUE
  149: *
  150: *              W := W * V1
  151: *
  152:                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
  153:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
  154:                IF( LASTV.GT.K ) THEN
  155: *
  156: *                 W := W + C2'*V2
  157: *
  158:                   CALL ZGEMM( 'Conjugate transpose', 'No transpose',
  159:      $                 LASTC, K, LASTV-K, ONE, C( K+1, 1 ), LDC,
  160:      $                 V( K+1, 1 ), LDV, ONE, WORK, LDWORK )
  161:                END IF
  162: *
  163: *              W := W * T'  or  W * T
  164: *
  165:                CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
  166:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  167: *
  168: *              C := C - V * W'
  169: *
  170:                IF( M.GT.K ) THEN
  171: *
  172: *                 C2 := C2 - V2 * W'
  173: *
  174:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
  175:      $                 LASTV-K, LASTC, K,
  176:      $                 -ONE, V( K+1, 1 ), LDV, WORK, LDWORK,
  177:      $                 ONE, C( K+1, 1 ), LDC )
  178:                END IF
  179: *
  180: *              W := W * V1'
  181: *
  182:                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
  183:      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
  184: *
  185: *              C1 := C1 - W'
  186: *
  187:                DO 30 J = 1, K
  188:                   DO 20 I = 1, LASTC
  189:                      C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
  190:    20             CONTINUE
  191:    30          CONTINUE
  192: *
  193:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  194: *
  195: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
  196: *
  197:                LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
  198:                LASTC = ILAZLR( M, LASTV, C, LDC )
  199: *
  200: *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
  201: *
  202: *              W := C1
  203: *
  204:                DO 40 J = 1, K
  205:                   CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
  206:    40          CONTINUE
  207: *
  208: *              W := W * V1
  209: *
  210:                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
  211:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
  212:                IF( LASTV.GT.K ) THEN
  213: *
  214: *                 W := W + C2 * V2
  215: *
  216:                   CALL ZGEMM( 'No transpose', 'No transpose',
  217:      $                 LASTC, K, LASTV-K,
  218:      $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
  219:      $                 ONE, WORK, LDWORK )
  220:                END IF
  221: *
  222: *              W := W * T  or  W * T'
  223: *
  224:                CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
  225:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  226: *
  227: *              C := C - W * V'
  228: *
  229:                IF( LASTV.GT.K ) THEN
  230: *
  231: *                 C2 := C2 - W * V2'
  232: *
  233:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
  234:      $                 LASTC, LASTV-K, K,
  235:      $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV,
  236:      $                 ONE, C( 1, K+1 ), LDC )
  237:                END IF
  238: *
  239: *              W := W * V1'
  240: *
  241:                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
  242:      $              'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
  243: *
  244: *              C1 := C1 - W
  245: *
  246:                DO 60 J = 1, K
  247:                   DO 50 I = 1, LASTC
  248:                      C( I, J ) = C( I, J ) - WORK( I, J )
  249:    50             CONTINUE
  250:    60          CONTINUE
  251:             END IF
  252: *
  253:          ELSE
  254: *
  255: *           Let  V =  ( V1 )
  256: *                     ( V2 )    (last K rows)
  257: *           where  V2  is unit upper triangular.
  258: *
  259:             IF( LSAME( SIDE, 'L' ) ) THEN
  260: *
  261: *              Form  H * C  or  H' * C  where  C = ( C1 )
  262: *                                                  ( C2 )
  263: *
  264:                LASTV = MAX( K, ILAZLR( M, K, V, LDV ) )
  265:                LASTC = ILAZLC( LASTV, N, C, LDC )
  266: *
  267: *              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK)
  268: *
  269: *              W := C2'
  270: *
  271:                DO 70 J = 1, K
  272:                   CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
  273:      $                 WORK( 1, J ), 1 )
  274:                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
  275:    70          CONTINUE
  276: *
  277: *              W := W * V2
  278: *
  279:                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
  280:      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
  281:      $              WORK, LDWORK )
  282:                IF( LASTV.GT.K ) THEN
  283: *
  284: *                 W := W + C1'*V1
  285: *
  286:                   CALL ZGEMM( 'Conjugate transpose', 'No transpose',
  287:      $                 LASTC, K, LASTV-K,
  288:      $                 ONE, C, LDC, V, LDV,
  289:      $                 ONE, WORK, LDWORK )
  290:                END IF
  291: *
  292: *              W := W * T'  or  W * T
  293: *
  294:                CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
  295:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  296: *
  297: *              C := C - V * W'
  298: *
  299:                IF( LASTV.GT.K ) THEN
  300: *
  301: *                 C1 := C1 - V1 * W'
  302: *
  303:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
  304:      $                 LASTV-K, LASTC, K,
  305:      $                 -ONE, V, LDV, WORK, LDWORK,
  306:      $                 ONE, C, LDC )
  307:                END IF
  308: *
  309: *              W := W * V2'
  310: *
  311:                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
  312:      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
  313:      $              WORK, LDWORK )
  314: *
  315: *              C2 := C2 - W'
  316: *
  317:                DO 90 J = 1, K
  318:                   DO 80 I = 1, LASTC
  319:                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
  320:      $                               DCONJG( WORK( I, J ) )
  321:    80             CONTINUE
  322:    90          CONTINUE
  323: *
  324:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  325: *
  326: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
  327: *
  328:                LASTV = MAX( K, ILAZLR( N, K, V, LDV ) )
  329:                LASTC = ILAZLR( M, LASTV, C, LDC )
  330: *
  331: *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
  332: *
  333: *              W := C2
  334: *
  335:                DO 100 J = 1, K
  336:                   CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
  337:      $                 WORK( 1, J ), 1 )
  338:   100          CONTINUE
  339: *
  340: *              W := W * V2
  341: *
  342:                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
  343:      $              LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
  344:      $              WORK, LDWORK )
  345:                IF( LASTV.GT.K ) THEN
  346: *
  347: *                 W := W + C1 * V1
  348: *
  349:                   CALL ZGEMM( 'No transpose', 'No transpose',
  350:      $                 LASTC, K, LASTV-K,
  351:      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
  352:                END IF
  353: *
  354: *              W := W * T  or  W * T'
  355: *
  356:                CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
  357:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  358: *
  359: *              C := C - W * V'
  360: *
  361:                IF( LASTV.GT.K ) THEN
  362: *
  363: *                 C1 := C1 - W * V1'
  364: *
  365:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
  366:      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
  367:      $                 ONE, C, LDC )
  368:                END IF
  369: *
  370: *              W := W * V2'
  371: *
  372:                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
  373:      $              'Unit', LASTC, K, ONE, V( LASTV-K+1, 1 ), LDV,
  374:      $              WORK, LDWORK )
  375: *
  376: *              C2 := C2 - W
  377: *
  378:                DO 120 J = 1, K
  379:                   DO 110 I = 1, LASTC
  380:                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
  381:      $                    - WORK( I, J )
  382:   110             CONTINUE
  383:   120          CONTINUE
  384:             END IF
  385:          END IF
  386: *
  387:       ELSE IF( LSAME( STOREV, 'R' ) ) THEN
  388: *
  389:          IF( LSAME( DIRECT, 'F' ) ) THEN
  390: *
  391: *           Let  V =  ( V1  V2 )    (V1: first K columns)
  392: *           where  V1  is unit upper triangular.
  393: *
  394:             IF( LSAME( SIDE, 'L' ) ) THEN
  395: *
  396: *              Form  H * C  or  H' * C  where  C = ( C1 )
  397: *                                                  ( C2 )
  398: *
  399:                LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
  400:                LASTC = ILAZLC( LASTV, N, C, LDC )
  401: *
  402: *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
  403: *
  404: *              W := C1'
  405: *
  406:                DO 130 J = 1, K
  407:                   CALL ZCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )
  408:                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
  409:   130          CONTINUE
  410: *
  411: *              W := W * V1'
  412: *
  413:                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
  414:      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
  415:                IF( LASTV.GT.K ) THEN
  416: *
  417: *                 W := W + C2'*V2'
  418: *
  419:                   CALL ZGEMM( 'Conjugate transpose',
  420:      $                 'Conjugate transpose', LASTC, K, LASTV-K,
  421:      $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,
  422:      $                 ONE, WORK, LDWORK )
  423:                END IF
  424: *
  425: *              W := W * T'  or  W * T
  426: *
  427:                CALL ZTRMM( 'Right', 'Upper', TRANST, 'Non-unit',
  428:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  429: *
  430: *              C := C - V' * W'
  431: *
  432:                IF( LASTV.GT.K ) THEN
  433: *
  434: *                 C2 := C2 - V2' * W'
  435: *
  436:                   CALL ZGEMM( 'Conjugate transpose',
  437:      $                 'Conjugate transpose', LASTV-K, LASTC, K,
  438:      $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,
  439:      $                 ONE, C( K+1, 1 ), LDC )
  440:                END IF
  441: *
  442: *              W := W * V1
  443: *
  444:                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
  445:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
  446: *
  447: *              C1 := C1 - W'
  448: *
  449:                DO 150 J = 1, K
  450:                   DO 140 I = 1, LASTC
  451:                      C( J, I ) = C( J, I ) - DCONJG( WORK( I, J ) )
  452:   140             CONTINUE
  453:   150          CONTINUE
  454: *
  455:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  456: *
  457: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
  458: *
  459:                LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
  460:                LASTC = ILAZLR( M, LASTV, C, LDC )
  461: *
  462: *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
  463: *
  464: *              W := C1
  465: *
  466:                DO 160 J = 1, K
  467:                   CALL ZCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )
  468:   160          CONTINUE
  469: *
  470: *              W := W * V1'
  471: *
  472:                CALL ZTRMM( 'Right', 'Upper', 'Conjugate transpose',
  473:      $                     'Unit', LASTC, K, ONE, V, LDV, WORK, LDWORK )
  474:                IF( LASTV.GT.K ) THEN
  475: *
  476: *                 W := W + C2 * V2'
  477: *
  478:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
  479:      $                 LASTC, K, LASTV-K, ONE, C( 1, K+1 ), LDC,
  480:      $                 V( 1, K+1 ), LDV, ONE, WORK, LDWORK )
  481:                END IF
  482: *
  483: *              W := W * T  or  W * T'
  484: *
  485:                CALL ZTRMM( 'Right', 'Upper', TRANS, 'Non-unit',
  486:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  487: *
  488: *              C := C - W * V
  489: *
  490:                IF( LASTV.GT.K ) THEN
  491: *
  492: *                 C2 := C2 - W * V2
  493: *
  494:                   CALL ZGEMM( 'No transpose', 'No transpose',
  495:      $                 LASTC, LASTV-K, K,
  496:      $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,
  497:      $                 ONE, C( 1, K+1 ), LDC )
  498:                END IF
  499: *
  500: *              W := W * V1
  501: *
  502:                CALL ZTRMM( 'Right', 'Upper', 'No transpose', 'Unit',
  503:      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )
  504: *
  505: *              C1 := C1 - W
  506: *
  507:                DO 180 J = 1, K
  508:                   DO 170 I = 1, LASTC
  509:                      C( I, J ) = C( I, J ) - WORK( I, J )
  510:   170             CONTINUE
  511:   180          CONTINUE
  512: *
  513:             END IF
  514: *
  515:          ELSE
  516: *
  517: *           Let  V =  ( V1  V2 )    (V2: last K columns)
  518: *           where  V2  is unit lower triangular.
  519: *
  520:             IF( LSAME( SIDE, 'L' ) ) THEN
  521: *
  522: *              Form  H * C  or  H' * C  where  C = ( C1 )
  523: *                                                  ( C2 )
  524: *
  525:                LASTV = MAX( K, ILAZLC( K, M, V, LDV ) )
  526:                LASTC = ILAZLC( LASTV, N, C, LDC )
  527: *
  528: *              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK)
  529: *
  530: *              W := C2'
  531: *
  532:                DO 190 J = 1, K
  533:                   CALL ZCOPY( LASTC, C( LASTV-K+J, 1 ), LDC,
  534:      $                 WORK( 1, J ), 1 )
  535:                   CALL ZLACGV( LASTC, WORK( 1, J ), 1 )
  536:   190          CONTINUE
  537: *
  538: *              W := W * V2'
  539: *
  540:                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
  541:      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
  542:      $              WORK, LDWORK )
  543:                IF( LASTV.GT.K ) THEN
  544: *
  545: *                 W := W + C1'*V1'
  546: *
  547:                   CALL ZGEMM( 'Conjugate transpose',
  548:      $                 'Conjugate transpose', LASTC, K, LASTV-K,
  549:      $                 ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
  550:                END IF
  551: *
  552: *              W := W * T'  or  W * T
  553: *
  554:                CALL ZTRMM( 'Right', 'Lower', TRANST, 'Non-unit',
  555:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  556: *
  557: *              C := C - V' * W'
  558: *
  559:                IF( LASTV.GT.K ) THEN
  560: *
  561: *                 C1 := C1 - V1' * W'
  562: *
  563:                   CALL ZGEMM( 'Conjugate transpose',
  564:      $                 'Conjugate transpose', LASTV-K, LASTC, K,
  565:      $                 -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
  566:                END IF
  567: *
  568: *              W := W * V2
  569: *
  570:                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
  571:      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
  572:      $              WORK, LDWORK )
  573: *
  574: *              C2 := C2 - W'
  575: *
  576:                DO 210 J = 1, K
  577:                   DO 200 I = 1, LASTC
  578:                      C( LASTV-K+J, I ) = C( LASTV-K+J, I ) -
  579:      $                               DCONJG( WORK( I, J ) )
  580:   200             CONTINUE
  581:   210          CONTINUE
  582: *
  583:             ELSE IF( LSAME( SIDE, 'R' ) ) THEN
  584: *
  585: *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
  586: *
  587:                LASTV = MAX( K, ILAZLC( K, N, V, LDV ) )
  588:                LASTC = ILAZLR( M, LASTV, C, LDC )
  589: *
  590: *              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK)
  591: *
  592: *              W := C2
  593: *
  594:                DO 220 J = 1, K
  595:                   CALL ZCOPY( LASTC, C( 1, LASTV-K+J ), 1,
  596:      $                 WORK( 1, J ), 1 )
  597:   220          CONTINUE
  598: *
  599: *              W := W * V2'
  600: *
  601:                CALL ZTRMM( 'Right', 'Lower', 'Conjugate transpose',
  602:      $              'Unit', LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
  603:      $              WORK, LDWORK )
  604:                IF( LASTV.GT.K ) THEN
  605: *
  606: *                 W := W + C1 * V1'
  607: *
  608:                   CALL ZGEMM( 'No transpose', 'Conjugate transpose',
  609:      $                 LASTC, K, LASTV-K, ONE, C, LDC, V, LDV, ONE,
  610:      $                 WORK, LDWORK )
  611:                END IF
  612: *
  613: *              W := W * T  or  W * T'
  614: *
  615:                CALL ZTRMM( 'Right', 'Lower', TRANS, 'Non-unit',
  616:      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )
  617: *
  618: *              C := C - W * V
  619: *
  620:                IF( LASTV.GT.K ) THEN
  621: *
  622: *                 C1 := C1 - W * V1
  623: *
  624:                   CALL ZGEMM( 'No transpose', 'No transpose',
  625:      $                 LASTC, LASTV-K, K, -ONE, WORK, LDWORK, V, LDV,
  626:      $                 ONE, C, LDC )
  627:                END IF
  628: *
  629: *              W := W * V2
  630: *
  631:                CALL ZTRMM( 'Right', 'Lower', 'No transpose', 'Unit',
  632:      $              LASTC, K, ONE, V( 1, LASTV-K+1 ), LDV,
  633:      $              WORK, LDWORK )
  634: *
  635: *              C1 := C1 - W
  636: *
  637:                DO 240 J = 1, K
  638:                   DO 230 I = 1, LASTC
  639:                      C( I, LASTV-K+J ) = C( I, LASTV-K+J )
  640:      $                    - WORK( I, J )
  641:   230             CONTINUE
  642:   240          CONTINUE
  643: *
  644:             END IF
  645: *
  646:          END IF
  647:       END IF
  648: *
  649:       RETURN
  650: *
  651: *     End of ZLARFB
  652: *
  653:       END

CVSweb interface <joel.bertrand@systella.fr>