--- rpl/lapack/lapack/dlarft.f 2011/11/21 22:19:33 1.10 +++ rpl/lapack/lapack/dlarft.f 2023/08/07 08:38:57 1.20 @@ -1,25 +1,25 @@ -*> \brief \b DLARFT +*> \brief \b DLARFT forms the triangular factor T of a block reflector H = I - vtvH * * =========== DOCUMENTATION =========== * -* Online html documentation available at -* http://www.netlib.org/lapack/explore-html/ +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * *> \htmlonly -*> Download DLARFT + dependencies -*> -*> [TGZ] -*> -*> [ZIP] -*> +*> Download DLARFT + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> *> [TXT] -*> \endhtmlonly +*> \endhtmlonly * * Definition: * =========== * * SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) -* +* * .. Scalar Arguments .. * CHARACTER DIRECT, STOREV * INTEGER K, LDT, LDV, N @@ -27,7 +27,7 @@ * .. Array Arguments .. * DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * ) * .. -* +* * *> \par Purpose: * ============= @@ -86,7 +86,7 @@ *> elementary reflectors). K >= 1. *> \endverbatim *> -*> \param[in,out] V +*> \param[in] V *> \verbatim *> V is DOUBLE PRECISION array, dimension *> (LDV,K) if STOREV = 'C' @@ -125,12 +125,10 @@ * Authors: * ======== * -*> \author Univ. of Tennessee -*> \author Univ. of California Berkeley -*> \author Univ. of Colorado Denver -*> \author NAG Ltd. -* -*> \date November 2011 +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. * *> \ingroup doubleOTHERauxiliary * @@ -141,9 +139,7 @@ *> *> The shape of the matrix V and the storage of the vectors which define *> the H(i) is best illustrated by the following example with n = 5 and -*> k = 3. The elements equal to 1 are not stored; the corresponding -*> array elements are modified but restored on exit. The rest of the -*> array is not used. +*> k = 3. The elements equal to 1 are not stored. *> *> DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R': *> @@ -165,10 +161,9 @@ * ===================================================================== SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT ) * -* -- LAPACK auxiliary routine (version 3.4.0) -- +* -- LAPACK auxiliary routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- -* November 2011 * * .. Scalar Arguments .. CHARACTER DIRECT, STOREV @@ -186,7 +181,6 @@ * .. * .. Local Scalars .. INTEGER I, J, PREVLASTV, LASTV - DOUBLE PRECISION VII * .. * .. External Subroutines .. EXTERNAL DGEMV, DTRMV @@ -204,47 +198,50 @@ * IF( LSAME( DIRECT, 'F' ) ) THEN PREVLASTV = N - DO 20 I = 1, K + DO I = 1, K PREVLASTV = MAX( I, PREVLASTV ) IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * - DO 10 J = 1, I + DO J = 1, I T( J, I ) = ZERO - 10 CONTINUE + END DO ELSE * * general case * - VII = V( I, I ) - V( I, I ) = ONE IF( LSAME( STOREV, 'C' ) ) THEN -! Skip any trailing zeros. +* Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO + DO J = 1, I-1 + T( J, I ) = -TAU( I ) * V( I , J ) + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)**T * V(i:j,i) * - CALL DGEMV( 'Transpose', J-I+1, I-1, -TAU( I ), - $ V( I, 1 ), LDV, V( I, I ), 1, ZERO, + CALL DGEMV( 'Transpose', J-I, I-1, -TAU( I ), + $ V( I+1, 1 ), LDV, V( I+1, I ), 1, ONE, $ T( 1, I ), 1 ) ELSE -! Skip any trailing zeros. +* Skip any trailing zeros. DO LASTV = N, I+1, -1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO + DO J = 1, I-1 + T( J, I ) = -TAU( I ) * V( J , I ) + END DO J = MIN( LASTV, PREVLASTV ) * * T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)**T * - CALL DGEMV( 'No transpose', I-1, J-I+1, -TAU( I ), - $ V( 1, I ), LDV, V( I, I ), LDV, ZERO, + CALL DGEMV( 'No transpose', I-1, J-I, -TAU( I ), + $ V( 1, I+1 ), LDV, V( I, I+1 ), LDV, ONE, $ T( 1, I ), 1 ) END IF - V( I, I ) = VII * * T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) * @@ -257,54 +254,52 @@ PREVLASTV = LASTV END IF END IF - 20 CONTINUE + END DO ELSE PREVLASTV = 1 - DO 40 I = K, 1, -1 + DO I = K, 1, -1 IF( TAU( I ).EQ.ZERO ) THEN * * H(i) = I * - DO 30 J = I, K + DO J = I, K T( J, I ) = ZERO - 30 CONTINUE + END DO ELSE * * general case * IF( I.LT.K ) THEN IF( LSAME( STOREV, 'C' ) ) THEN - VII = V( N-K+I, I ) - V( N-K+I, I ) = ONE -! Skip any leading zeros. +* Skip any leading zeros. DO LASTV = 1, I-1 IF( V( LASTV, I ).NE.ZERO ) EXIT END DO + DO J = I+1, K + T( J, I ) = -TAU( I ) * V( N-K+I , J ) + END DO J = MAX( LASTV, PREVLASTV ) * -* T(i+1:k,i) := -* - tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) +* T(i+1:k,i) = -tau(i) * V(j:n-k+i,i+1:k)**T * V(j:n-k+i,i) * - CALL DGEMV( 'Transpose', N-K+I-J+1, K-I, -TAU( I ), - $ V( J, I+1 ), LDV, V( J, I ), 1, ZERO, + CALL DGEMV( 'Transpose', N-K+I-J, K-I, -TAU( I ), + $ V( J, I+1 ), LDV, V( J, I ), 1, ONE, $ T( I+1, I ), 1 ) - V( N-K+I, I ) = VII ELSE - VII = V( I, N-K+I ) - V( I, N-K+I ) = ONE -! Skip any leading zeros. +* Skip any leading zeros. DO LASTV = 1, I-1 IF( V( I, LASTV ).NE.ZERO ) EXIT END DO + DO J = I+1, K + T( J, I ) = -TAU( I ) * V( J, N-K+I ) + END DO J = MAX( LASTV, PREVLASTV ) * -* T(i+1:k,i) := -* - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T +* T(i+1:k,i) = -tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)**T * - CALL DGEMV( 'No transpose', K-I, N-K+I-J+1, + CALL DGEMV( 'No transpose', K-I, N-K+I-J, $ -TAU( I ), V( I+1, J ), LDV, V( I, J ), LDV, - $ ZERO, T( I+1, I ), 1 ) - V( I, N-K+I ) = VII + $ ONE, T( I+1, I ), 1 ) END IF * * T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) @@ -319,7 +314,7 @@ END IF T( I, I ) = TAU( I ) END IF - 40 CONTINUE + END DO END IF RETURN *