[BACK]Return to dlarfb.f CVS log [TXT] [DIR] Up to [local] / rpl / lapack / lapack

Diff for /rpl/lapack/lapack/dlarfb.f between versions 1.12 and 1.21

version 1.12, 2012/12/14 12:30:24 version 1.21, 2023/08/07 08:38:57
Line 2 Line 2
 *  *
 *  =========== DOCUMENTATION ===========  *  =========== DOCUMENTATION ===========
 *  *
 * Online html documentation available at   * Online html documentation available at
 *            http://www.netlib.org/lapack/explore-html/   *            http://www.netlib.org/lapack/explore-html/
 *  *
 *> \htmlonly  *> \htmlonly
 *> Download DLARFB + dependencies   *> Download DLARFB + dependencies
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">   *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarfb.f">
 *> [TGZ]</a>   *> [TGZ]</a>
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">   *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarfb.f">
 *> [ZIP]</a>   *> [ZIP]</a>
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">   *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarfb.f">
 *> [TXT]</a>  *> [TXT]</a>
 *> \endhtmlonly   *> \endhtmlonly
 *  *
 *  Definition:  *  Definition:
 *  ===========  *  ===========
 *  *
 *       SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,  *       SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
 *                          T, LDT, C, LDC, WORK, LDWORK )  *                          T, LDT, C, LDC, WORK, LDWORK )
 *   *
 *       .. Scalar Arguments ..  *       .. Scalar Arguments ..
 *       CHARACTER          DIRECT, SIDE, STOREV, TRANS  *       CHARACTER          DIRECT, SIDE, STOREV, TRANS
 *       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N  *       INTEGER            K, LDC, LDT, LDV, LDWORK, M, N
Line 29 Line 29
 *       DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),  *       DOUBLE PRECISION   C( LDC, * ), T( LDT, * ), V( LDV, * ),
 *      $                   WORK( LDWORK, * )  *      $                   WORK( LDWORK, * )
 *       ..  *       ..
 *    *
 *  *
 *> \par Purpose:  *> \par Purpose:
 *  =============  *  =============
Line 92 Line 92
 *>          K is INTEGER  *>          K is INTEGER
 *>          The order of the matrix T (= the number of elementary  *>          The order of the matrix T (= the number of elementary
 *>          reflectors whose product defines the block reflector).  *>          reflectors whose product defines the block reflector).
   *>          If SIDE = 'L', M >= K >= 0;
   *>          if SIDE = 'R', N >= K >= 0.
 *> \endverbatim  *> \endverbatim
 *>  *>
 *> \param[in] V  *> \param[in] V
Line 154 Line 156
 *  Authors:  *  Authors:
 *  ========  *  ========
 *  *
 *> \author Univ. of Tennessee   *> \author Univ. of Tennessee
 *> \author Univ. of California Berkeley   *> \author Univ. of California Berkeley
 *> \author Univ. of Colorado Denver   *> \author Univ. of Colorado Denver
 *> \author NAG Ltd.   *> \author NAG Ltd.
 *  
 *> \date September 2012  
 *  *
 *> \ingroup doubleOTHERauxiliary  *> \ingroup doubleOTHERauxiliary
 *  *
Line 195 Line 195
       SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,        SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
      $                   T, LDT, C, LDC, WORK, LDWORK )       $                   T, LDT, C, LDC, WORK, LDWORK )
 *  *
 *  -- LAPACK auxiliary routine (version 3.4.2) --  *  -- LAPACK auxiliary routine --
 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --  *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--  *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 *     September 2012  
 *  *
 *     .. Scalar Arguments ..  *     .. Scalar Arguments ..
       CHARACTER          DIRECT, SIDE, STOREV, TRANS        CHARACTER          DIRECT, SIDE, STOREV, TRANS
Line 217 Line 216
 *     ..  *     ..
 *     .. Local Scalars ..  *     .. Local Scalars ..
       CHARACTER          TRANST        CHARACTER          TRANST
       INTEGER            I, J, LASTV, LASTC, lastv2        INTEGER            I, J
 *     ..  *     ..
 *     .. External Functions ..  *     .. External Functions ..
       LOGICAL            LSAME        LOGICAL            LSAME
       INTEGER            ILADLR, ILADLC        EXTERNAL           LSAME
       EXTERNAL           LSAME, ILADLR, ILADLC  
 *     ..  *     ..
 *     .. External Subroutines ..  *     .. External Subroutines ..
       EXTERNAL           DCOPY, DGEMM, DTRMM        EXTERNAL           DCOPY, DGEMM, DTRMM
Line 253 Line 251
 *              Form  H * C  or  H**T * C  where  C = ( C1 )  *              Form  H * C  or  H**T * C  where  C = ( C1 )
 *                                                    ( C2 )  *                                                    ( C2 )
 *  *
                LASTV = MAX( K, ILADLR( M, K, V, LDV ) )  
                LASTC = ILADLC( LASTV, N, C, LDC )  
 *  
 *              W := C**T * V  =  (C1**T * V1 + C2**T * V2)  (stored in WORK)  *              W := C**T * V  =  (C1**T * V1 + C2**T * V2)  (stored in WORK)
 *  *
 *              W := C1**T  *              W := C1**T
 *  *
                DO 10 J = 1, K                 DO 10 J = 1, K
                   CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )                    CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
    10          CONTINUE     10          CONTINUE
 *  *
 *              W := W * V1  *              W := W * V1
 *  *
                CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     K, ONE, V, LDV, WORK, LDWORK )
                IF( LASTV.GT.K ) THEN                 IF( M.GT.K ) THEN
 *  *
 *                 W := W + C2**T *V2  *                 W := W + C2**T * V2
 *  *
                   CALL DGEMM( 'Transpose', 'No transpose',                    CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
      $                 LASTC, K, LASTV-K,       $                        ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
      $                 ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,       $                        ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T**T  or  W * T  *              W := W * T**T  or  W * T
 *  *
                CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',                 CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - V * W**T  *              C := C - V * W**T
 *  *
                IF( LASTV.GT.K ) THEN                 IF( M.GT.K ) THEN
 *  *
 *                 C2 := C2 - V2 * W**T  *                 C2 := C2 - V2 * W**T
 *  *
                   CALL DGEMM( 'No transpose', 'Transpose',                    CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
      $                 LASTV-K, LASTC, K,       $                        -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
      $                 -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,       $                        C( K+1, 1 ), LDC )
      $                 C( K+1, 1 ), LDC )  
                END IF                 END IF
 *  *
 *              W := W * V1**T  *              W := W * V1**T
 *  *
                CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     ONE, V, LDV, WORK, LDWORK )
 *  *
 *              C1 := C1 - W**T  *              C1 := C1 - W**T
 *  *
                DO 30 J = 1, K                 DO 30 J = 1, K
                   DO 20 I = 1, LASTC                    DO 20 I = 1, N
                      C( J, I ) = C( J, I ) - WORK( I, J )                       C( J, I ) = C( J, I ) - WORK( I, J )
    20             CONTINUE     20             CONTINUE
    30          CONTINUE     30          CONTINUE
Line 312 Line 305
 *  *
 *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )  *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )
 *  *
                LASTV = MAX( K, ILADLR( N, K, V, LDV ) )  
                LASTC = ILADLR( M, LASTV, C, LDC )  
 *  
 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)  *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
 *  *
 *              W := C1  *              W := C1
 *  *
                DO 40 J = 1, K                 DO 40 J = 1, K
                   CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )                    CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
    40          CONTINUE     40          CONTINUE
 *  *
 *              W := W * V1  *              W := W * V1
 *  *
                CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     K, ONE, V, LDV, WORK, LDWORK )
                IF( LASTV.GT.K ) THEN                 IF( N.GT.K ) THEN
 *  *
 *                 W := W + C2 * V2  *                 W := W + C2 * V2
 *  *
                   CALL DGEMM( 'No transpose', 'No transpose',                    CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
      $                 LASTC, K, LASTV-K,       $                        ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
      $                 ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,       $                        ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T  or  W * T**T  *              W := W * T  or  W * T**T
 *  *
                CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',                 CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - W * V**T  *              C := C - W * V**T
 *  *
                IF( LASTV.GT.K ) THEN                 IF( N.GT.K ) THEN
 *  *
 *                 C2 := C2 - W * V2**T  *                 C2 := C2 - W * V2**T
 *  *
                   CALL DGEMM( 'No transpose', 'Transpose',                    CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
      $                 LASTC, LASTV-K, K,       $                        -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
      $                 -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,       $                        C( 1, K+1 ), LDC )
      $                 C( 1, K+1 ), LDC )  
                END IF                 END IF
 *  *
 *              W := W * V1**T  *              W := W * V1**T
 *  *
                CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     ONE, V, LDV, WORK, LDWORK )
 *  *
 *              C1 := C1 - W  *              C1 := C1 - W
 *  *
                DO 60 J = 1, K                 DO 60 J = 1, K
                   DO 50 I = 1, LASTC                    DO 50 I = 1, M
                      C( I, J ) = C( I, J ) - WORK( I, J )                       C( I, J ) = C( I, J ) - WORK( I, J )
    50             CONTINUE     50             CONTINUE
    60          CONTINUE     60          CONTINUE
Line 379 Line 367
 *              Form  H * C  or  H**T * C  where  C = ( C1 )  *              Form  H * C  or  H**T * C  where  C = ( C1 )
 *                                                    ( C2 )  *                                                    ( C2 )
 *  *
                LASTC = ILADLC( M, N, C, LDC )  
 *  
 *              W := C**T * V  =  (C1**T * V1 + C2**T * V2)  (stored in WORK)  *              W := C**T * V  =  (C1**T * V1 + C2**T * V2)  (stored in WORK)
 *  *
 *              W := C2**T  *              W := C2**T
 *  *
                DO 70 J = 1, K                 DO 70 J = 1, K
                   CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC,                    CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
      $                 WORK( 1, J ), 1 )  
    70          CONTINUE     70          CONTINUE
 *  *
 *              W := W * V2  *              W := W * V2
 *  *
                CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
      $              LASTC, K, ONE, V( M-K+1, 1 ), LDV,       $                     K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
                IF( M.GT.K ) THEN                 IF( M.GT.K ) THEN
 *  *
 *                 W := W + C1**T*V1  *                 W := W + C1**T * V1
 *  *
                   CALL DGEMM( 'Transpose', 'No transpose',                    CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
      $                 LASTC, K, M-K, ONE, C, LDC, V, LDV,       $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T**T  or  W * T  *              W := W * T**T  or  W * T
 *  *
                CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',                 CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - V * W**T  *              C := C - V * W**T
 *  *
Line 415 Line 398
 *  *
 *                 C1 := C1 - V1 * W**T  *                 C1 := C1 - V1 * W**T
 *  *
                   CALL DGEMM( 'No transpose', 'Transpose',                    CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
      $                 M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,       $                        -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
      $                 ONE, C, LDC )  
                END IF                 END IF
 *  *
 *              W := W * V2**T  *              W := W * V2**T
 *  *
                CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
      $              LASTC, K, ONE, V( M-K+1, 1 ), LDV,       $                     ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
 *  *
 *              C2 := C2 - W**T  *              C2 := C2 - W**T
 *  *
                DO 90 J = 1, K                 DO 90 J = 1, K
                   DO 80 I = 1, LASTC                    DO 80 I = 1, N
                      C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J)                       C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
    80             CONTINUE     80             CONTINUE
    90          CONTINUE     90          CONTINUE
 *  *
Line 438 Line 419
 *  *
 *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )  *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )
 *  *
                LASTC = ILADLR( M, N, C, LDC )  
 *  
 *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)  *              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK)
 *  *
 *              W := C2  *              W := C2
 *  *
                DO 100 J = 1, K                 DO 100 J = 1, K
                   CALL DCOPY( LASTC, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )                    CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
   100          CONTINUE    100          CONTINUE
 *  *
 *              W := W * V2  *              W := W * V2
 *  *
                CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
      $              LASTC, K, ONE, V( N-K+1, 1 ), LDV,       $                     K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
                IF( N.GT.K ) THEN                 IF( N.GT.K ) THEN
 *  *
 *                 W := W + C1 * V1  *                 W := W + C1 * V1
 *  *
                   CALL DGEMM( 'No transpose', 'No transpose',                    CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
      $                 LASTC, K, N-K, ONE, C, LDC, V, LDV,       $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T  or  W * T**T  *              W := W * T  or  W * T**T
 *  *
                CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',                 CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - W * V**T  *              C := C - W * V**T
 *  *
Line 473 Line 450
 *  *
 *                 C1 := C1 - W * V1**T  *                 C1 := C1 - W * V1**T
 *  *
                   CALL DGEMM( 'No transpose', 'Transpose',                    CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
      $                 LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,       $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
      $                 ONE, C, LDC )  
                END IF                 END IF
 *  *
 *              W := W * V2**T  *              W := W * V2**T
 *  *
                CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
      $              LASTC, K, ONE, V( N-K+1, 1 ), LDV,       $                     ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
 *  *
 *              C2 := C2 - W  *              C2 := C2 - W
 *  *
                DO 120 J = 1, K                 DO 120 J = 1, K
                   DO 110 I = 1, LASTC                    DO 110 I = 1, M
                      C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J)                       C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
   110             CONTINUE    110             CONTINUE
   120          CONTINUE    120          CONTINUE
             END IF              END IF
Line 506 Line 481
 *              Form  H * C  or  H**T * C  where  C = ( C1 )  *              Form  H * C  or  H**T * C  where  C = ( C1 )
 *                                                    ( C2 )  *                                                    ( C2 )
 *  *
                LASTV = MAX( K, ILADLC( K, M, V, LDV ) )  
                LASTC = ILADLC( LASTV, N, C, LDC )  
 *  
 *              W := C**T * V**T  =  (C1**T * V1**T + C2**T * V2**T) (stored in WORK)  *              W := C**T * V**T  =  (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
 *  *
 *              W := C1**T  *              W := C1**T
 *  *
                DO 130 J = 1, K                 DO 130 J = 1, K
                   CALL DCOPY( LASTC, C( J, 1 ), LDC, WORK( 1, J ), 1 )                    CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
   130          CONTINUE    130          CONTINUE
 *  *
 *              W := W * V1**T  *              W := W * V1**T
 *  *
                CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     ONE, V, LDV, WORK, LDWORK )
                IF( LASTV.GT.K ) THEN                 IF( M.GT.K ) THEN
 *  *
 *                 W := W + C2**T*V2**T  *                 W := W + C2**T * V2**T
 *  *
                   CALL DGEMM( 'Transpose', 'Transpose',                    CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
      $                 LASTC, K, LASTV-K,       $                        C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
      $                 ONE, C( K+1, 1 ), LDC, V( 1, K+1 ), LDV,       $                        WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T**T  or  W * T  *              W := W * T**T  or  W * T
 *  *
                CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit',                 CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - V**T * W**T  *              C := C - V**T * W**T
 *  *
                IF( LASTV.GT.K ) THEN                 IF( M.GT.K ) THEN
 *  *
 *                 C2 := C2 - V2**T * W**T  *                 C2 := C2 - V2**T * W**T
 *  *
                   CALL DGEMM( 'Transpose', 'Transpose',                    CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
      $                 LASTV-K, LASTC, K,       $                        V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
      $                 -ONE, V( 1, K+1 ), LDV, WORK, LDWORK,       $                        C( K+1, 1 ), LDC )
      $                 ONE, C( K+1, 1 ), LDC )  
                END IF                 END IF
 *  *
 *              W := W * V1  *              W := W * V1
 *  *
                CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     K, ONE, V, LDV, WORK, LDWORK )
 *  *
 *              C1 := C1 - W**T  *              C1 := C1 - W**T
 *  *
                DO 150 J = 1, K                 DO 150 J = 1, K
                   DO 140 I = 1, LASTC                    DO 140 I = 1, N
                      C( J, I ) = C( J, I ) - WORK( I, J )                       C( J, I ) = C( J, I ) - WORK( I, J )
   140             CONTINUE    140             CONTINUE
   150          CONTINUE    150          CONTINUE
Line 565 Line 535
 *  *
 *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )  *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )
 *  *
                LASTV = MAX( K, ILADLC( K, N, V, LDV ) )  
                LASTC = ILADLR( M, LASTV, C, LDC )  
 *  
 *              W := C * V**T  =  (C1*V1**T + C2*V2**T)  (stored in WORK)  *              W := C * V**T  =  (C1*V1**T + C2*V2**T)  (stored in WORK)
 *  *
 *              W := C1  *              W := C1
 *  *
                DO 160 J = 1, K                 DO 160 J = 1, K
                   CALL DCOPY( LASTC, C( 1, J ), 1, WORK( 1, J ), 1 )                    CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
   160          CONTINUE    160          CONTINUE
 *  *
 *              W := W * V1**T  *              W := W * V1**T
 *  *
                CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     ONE, V, LDV, WORK, LDWORK )
                IF( LASTV.GT.K ) THEN                 IF( N.GT.K ) THEN
 *  *
 *                 W := W + C2 * V2**T  *                 W := W + C2 * V2**T
 *  *
                   CALL DGEMM( 'No transpose', 'Transpose',                    CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
      $                 LASTC, K, LASTV-K,       $                        ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
      $                 ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,       $                        ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T  or  W * T**T  *              W := W * T  or  W * T**T
 *  *
                CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit',                 CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - W * V  *              C := C - W * V
 *  *
                IF( LASTV.GT.K ) THEN                 IF( N.GT.K ) THEN
 *  *
 *                 C2 := C2 - W * V2  *                 C2 := C2 - W * V2
 *  *
                   CALL DGEMM( 'No transpose', 'No transpose',                    CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
      $                 LASTC, LASTV-K, K,       $                        -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
      $                 -ONE, WORK, LDWORK, V( 1, K+1 ), LDV,       $                        C( 1, K+1 ), LDC )
      $                 ONE, C( 1, K+1 ), LDC )  
                END IF                 END IF
 *  *
 *              W := W * V1  *              W := W * V1
 *  *
                CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
      $              LASTC, K, ONE, V, LDV, WORK, LDWORK )       $                     K, ONE, V, LDV, WORK, LDWORK )
 *  *
 *              C1 := C1 - W  *              C1 := C1 - W
 *  *
                DO 180 J = 1, K                 DO 180 J = 1, K
                   DO 170 I = 1, LASTC                    DO 170 I = 1, M
                      C( I, J ) = C( I, J ) - WORK( I, J )                       C( I, J ) = C( I, J ) - WORK( I, J )
   170             CONTINUE    170             CONTINUE
   180          CONTINUE    180          CONTINUE
Line 632 Line 597
 *              Form  H * C  or  H**T * C  where  C = ( C1 )  *              Form  H * C  or  H**T * C  where  C = ( C1 )
 *                                                    ( C2 )  *                                                    ( C2 )
 *  *
                LASTC = ILADLC( M, N, C, LDC )  
 *  
 *              W := C**T * V**T  =  (C1**T * V1**T + C2**T * V2**T) (stored in WORK)  *              W := C**T * V**T  =  (C1**T * V1**T + C2**T * V2**T) (stored in WORK)
 *  *
 *              W := C2**T  *              W := C2**T
 *  *
                DO 190 J = 1, K                 DO 190 J = 1, K
                   CALL DCOPY( LASTC, C( M-K+J, 1 ), LDC,                    CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
      $                 WORK( 1, J ), 1 )  
   190          CONTINUE    190          CONTINUE
 *  *
 *              W := W * V2**T  *              W := W * V2**T
 *  *
                CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
      $              LASTC, K, ONE, V( 1, M-K+1 ), LDV,       $                     ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
                IF( M.GT.K ) THEN                 IF( M.GT.K ) THEN
 *  *
 *                 W := W + C1**T * V1**T  *                 W := W + C1**T * V1**T
 *  *
                   CALL DGEMM( 'Transpose', 'Transpose',                    CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
      $                 LASTC, K, M-K, ONE, C, LDC, V, LDV,       $                        C, LDC, V, LDV, ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T**T  or  W * T  *              W := W * T**T  or  W * T
 *  *
                CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit',                 CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - V**T * W**T  *              C := C - V**T * W**T
 *  *
Line 668 Line 628
 *  *
 *                 C1 := C1 - V1**T * W**T  *                 C1 := C1 - V1**T * W**T
 *  *
                   CALL DGEMM( 'Transpose', 'Transpose',                    CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
      $                 M-K, LASTC, K, -ONE, V, LDV, WORK, LDWORK,       $                        V, LDV, WORK, LDWORK, ONE, C, LDC )
      $                 ONE, C, LDC )  
                END IF                 END IF
 *  *
 *              W := W * V2  *              W := W * V2
 *  *
                CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
      $              LASTC, K, ONE, V( 1, M-K+1 ), LDV,       $                     K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
 *  *
 *              C2 := C2 - W**T  *              C2 := C2 - W**T
 *  *
                DO 210 J = 1, K                 DO 210 J = 1, K
                   DO 200 I = 1, LASTC                    DO 200 I = 1, N
                      C( M-K+J, I ) = C( M-K+J, I ) - WORK(I, J)                       C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
   200             CONTINUE    200             CONTINUE
   210          CONTINUE    210          CONTINUE
 *  *
             ELSE IF( LSAME( SIDE, 'R' ) ) THEN              ELSE IF( LSAME( SIDE, 'R' ) ) THEN
 *  *
 *              Form  C * H  or  C * H**T  where  C = ( C1  C2 )  *              Form  C * H  or  C * H'  where  C = ( C1  C2 )
 *  
                LASTC = ILADLR( M, N, C, LDC )  
 *  *
 *              W := C * V**T  =  (C1*V1**T + C2*V2**T)  (stored in WORK)  *              W := C * V**T  =  (C1*V1**T + C2*V2**T)  (stored in WORK)
 *  *
 *              W := C2  *              W := C2
 *  *
                DO 220 J = 1, K                 DO 220 J = 1, K
                   CALL DCOPY( LASTC, C( 1, N-K+J ), 1,                    CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
      $                 WORK( 1, J ), 1 )  
   220          CONTINUE    220          CONTINUE
 *  *
 *              W := W * V2**T  *              W := W * V2**T
 *  *
                CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
      $              LASTC, K, ONE, V( 1, N-K+1 ), LDV,       $                     ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
                IF( N.GT.K ) THEN                 IF( N.GT.K ) THEN
 *  *
 *                 W := W + C1 * V1**T  *                 W := W + C1 * V1**T
 *  *
                   CALL DGEMM( 'No transpose', 'Transpose',                    CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
      $                 LASTC, K, N-K, ONE, C, LDC, V, LDV,       $                        ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
      $                 ONE, WORK, LDWORK )  
                END IF                 END IF
 *  *
 *              W := W * T  or  W * T**T  *              W := W * T  or  W * T**T
 *  *
                CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit',                 CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
      $              LASTC, K, ONE, T, LDT, WORK, LDWORK )       $                     ONE, T, LDT, WORK, LDWORK )
 *  *
 *              C := C - W * V  *              C := C - W * V
 *  *
Line 727 Line 680
 *  *
 *                 C1 := C1 - W * V1  *                 C1 := C1 - W * V1
 *  *
                   CALL DGEMM( 'No transpose', 'No transpose',                    CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
      $                 LASTC, N-K, K, -ONE, WORK, LDWORK, V, LDV,       $                        -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
      $                 ONE, C, LDC )  
                END IF                 END IF
 *  *
 *              W := W * V2  *              W := W * V2
 *  *
                CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit',                 CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
      $              LASTC, K, ONE, V( 1, N-K+1 ), LDV,       $                     K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
      $              WORK, LDWORK )  
 *  *
 *              C1 := C1 - W  *              C1 := C1 - W
 *  *
                DO 240 J = 1, K                 DO 240 J = 1, K
                   DO 230 I = 1, LASTC                    DO 230 I = 1, M
                      C( I, N-K+J ) = C( I, N-K+J ) - WORK(I, J)                       C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
   230             CONTINUE    230             CONTINUE
   240          CONTINUE    240          CONTINUE
 *  *
Removed from v.1.12  
changed lines
  Added in v.1.21

CVSweb interface <joel.bertrand@systella.fr>