dlarft()

recursive subroutine dlarft	(	character	direct,
		character	storev,
		integer	n,
		integer	k,
		double precision, dimension( ldv, * )	v,
		integer	ldv,
		double precision, dimension( * )	tau,
		double precision, dimension( ldt, * )	t,
		integer	ldt )

DLARFT forms the triangular factor T of a block reflector H = I - vtvH

Download DLARFT + dependencies [TGZ] [ZIP] [TXT]

Purpose:

!>
!> DLARFT forms the triangular factor T of a real block reflector H
!> of order n, which is defined as a product of k elementary reflectors.
!>
!> If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
!>
!> If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
!>
!> If STOREV = 'C', the vector which defines the elementary reflector
!> H(i) is stored in the i-th column of the array V, and
!>
!>    H  =  I - V * T * V**T
!>
!> If STOREV = 'R', the vector which defines the elementary reflector
!> H(i) is stored in the i-th row of the array V, and
!>
!>    H  =  I - V**T * T * V
!> 

Parameters

[in]	DIRECT	!> DIRECT is CHARACTER*1 !> Specifies the order in which the elementary reflectors are !> multiplied to form the block reflector: !> = 'F': H = H(1) H(2) . . . H(k) (Forward) !> = 'B': H = H(k) . . . H(2) H(1) (Backward) !>
[in]	STOREV	!> STOREV is CHARACTER*1 !> Specifies how the vectors which define the elementary !> reflectors are stored (see also Further Details): !> = 'C': columnwise !> = 'R': rowwise !>
[in]	N	!> N is INTEGER !> The order of the block reflector H. N >= 0. !>
[in]	K	!> K is INTEGER !> The order of the triangular factor T (= the number of !> elementary reflectors). K >= 1. !>
[in]	V	!> V is DOUBLE PRECISION array, dimension !> (LDV,K) if STOREV = 'C' !> (LDV,N) if STOREV = 'R' !> The matrix V. See further details. !>
[in]	LDV	!> LDV is INTEGER !> The leading dimension of the array V. !> If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. !>
[in]	TAU	!> TAU is DOUBLE PRECISION array, dimension (K) !> TAU(i) must contain the scalar factor of the elementary !> reflector H(i). !>
[out]	T	!> T is DOUBLE PRECISION array, dimension (LDT,K) !> The k by k triangular factor T of the block reflector. !> If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is !> lower triangular. The rest of the array is not used. !>
[in]	LDT	!> LDT is INTEGER !> The leading dimension of the array T. LDT >= K. !>

Author

Univ. of Tennessee

Univ. of California Berkeley

Univ. of Colorado Denver

NAG Ltd.

Further Details:

!>
!>  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.
!>
!>  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
!>
!>               V = (  1       )                 V = (  1 v1 v1 v1 v1 )
!>                   ( v1  1    )                     (     1 v2 v2 v2 )
!>                   ( v1 v2  1 )                     (        1 v3 v3 )
!>                   ( v1 v2 v3 )
!>                   ( v1 v2 v3 )
!>
!>  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
!>
!>               V = ( v1 v2 v3 )                 V = ( v1 v1  1       )
!>                   ( v1 v2 v3 )                     ( v2 v2 v2  1    )
!>                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 )
!>                   (     1 v3 )
!>                   (        1 )
!> 

Definition at line 160 of file dlarft.f.

*
*  -- LAPACK auxiliary routine --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
*        .. Scalar Arguments
*
      CHARACTER          DIRECT, STOREV
      INTEGER            K, LDT, LDV, N
*     ..
*     .. Array Arguments ..
*
      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
*     ..
*
*     .. Parameters ..
*
      DOUBLE PRECISION ONE, NEG_ONE, ZERO
      parameter(one=1.0d+0, zero = 0.0d+0, neg_one=-1.0d+0)
*
*     .. Local Scalars ..
*
      INTEGER           I,J,L
      LOGICAL           QR,LQ,QL,DIRF,COLV
*
*     .. External Subroutines ..
*
      EXTERNAL          dtrmm,dgemm,dlacpy
*
*     .. External Functions..
*
      LOGICAL           LSAME
      EXTERNAL          lsame
*     
*     The general scheme used is inspired by the approach inside DGEQRT3
*     which was (at the time of writing this code):
*     Based on the algorithm of Elmroth and Gustavson,
*     IBM J. Res. Develop. Vol 44 No. 4 July 2000.
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF(n.EQ.0.OR.k.EQ.0) THEN
         RETURN
      END IF
*
*     Base case
*
      IF(n.EQ.1.OR.k.EQ.1) THEN
         t(1,1) = tau(1)
         RETURN
      END IF
*
*     Beginning of executable statements
*
      l = k / 2
*
*     Determine what kind of Q we need to compute
*     We assume that if the user doesn't provide 'F' for DIRECT,
*     then they meant to provide 'B' and if they don't provide
*     'C' for STOREV, then they meant to provide 'R'
*
      dirf = lsame(direct,'F')
      colv = lsame(storev,'C')
*
*     QR happens when we have forward direction in column storage
*
      qr = dirf.AND.colv
*
*     LQ happens when we have forward direction in row storage
*
      lq = dirf.AND.(.NOT.colv)
*
*     QL happens when we have backward direction in column storage
*
      ql = (.NOT.dirf).AND.colv
*
*     The last case is RQ. Due to how we structured this, if the
*     above 3 are false, then RQ must be true, so we never store 
*     this
*     RQ happens when we have backward direction in row storage
*     RQ = (.NOT.DIRF).AND.(.NOT.COLV)
*
      IF(qr) THEN
*
*        Break V apart into 6 components
*
*        V = |---------------|
*            |V_{1,1} 0      |
*            |V_{2,1} V_{2,2}|
*            |V_{3,1} V_{3,2}|
*            |---------------|
*
*        V_{1,1}\in\R^{l,l}      unit lower triangular
*        V_{2,1}\in\R^{k-l,l}    rectangular
*        V_{3,1}\in\R^{n-k,l}    rectangular
*        
*        V_{2,2}\in\R^{k-l,k-l}  unit lower triangular
*        V_{3,2}\in\R^{n-k,k-l}  rectangular
*
*        We will construct the T matrix 
*        T = |---------------|
*            |T_{1,1} T_{1,2}|
*            |0       T_{2,2}|
*            |---------------|
*
*        T is the triangular factor obtained from block reflectors. 
*        To motivate the structure, assume we have already computed T_{1,1}
*        and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
*        T_{1,1}\in\R^{l, l}     upper triangular
*        T_{2,2}\in\R^{k-l, k-l} upper triangular
*        T_{1,2}\in\R^{l, k-l}   rectangular
*
*        Where l = floor(k/2)
*
*        Then, consider the product:
*        
*        (I - V_1*T_{1,1}*V_1')*(I - V_2*T_{2,2}*V_2')
*        = I - V_1*T_{1,1}*V_1' - V_2*T_{2,2}*V_2' + V_1*T_{1,1}*V_1'*V_2*T_{2,2}*V_2'
*        
*        Define T_{1,2} = -T_{1,1}*V_1'*V_2*T_{2,2}
*        
*        Then, we can define the matrix V as 
*        V = |-------|
*            |V_1 V_2|
*            |-------|
*        
*        So, our product is equivalent to the matrix product
*        I - V*T*V'
*        This means, we can compute T_{1,1} and T_{2,2}, then use this information
*        to compute T_{1,2}
*
*        Compute T_{1,1} recursively
*
         CALL dlarft(direct, storev, n, l, v, ldv, tau, t, ldt)
*
*        Compute T_{2,2} recursively
*
         CALL dlarft(direct, storev, n-l, k-l, v(l+1, l+1), ldv, 
     $               tau(l+1), t(l+1, l+1), ldt)
*
*        Compute T_{1,2} 
*        T_{1,2} = V_{2,1}'
*
         DO j = 1, l
            DO i = 1, k-l
               t(j, l+i) = v(l+i, j)
            END DO
         END DO
*
*        T_{1,2} = T_{1,2}*V_{2,2}
*
         CALL dtrmm('Right', 'Lower', 'No transpose', 'Unit', l,
     $               k-l, one, v(l+1, l+1), ldv, t(1, l+1), ldt)
 
*
*        T_{1,2} = V_{3,1}'*V_{3,2} + T_{1,2}
*        Note: We assume K <= N, and GEMM will do nothing if N=K
*
         CALL dgemm('Transpose', 'No transpose', l, k-l, n-k, one, 
     $               v(k+1, 1), ldv, v(k+1, l+1), ldv, one, 
     $               t(1, l+1), ldt)
*
*        At this point, we have that T_{1,2} = V_1'*V_2
*        All that is left is to pre and post multiply by -T_{1,1} and T_{2,2}
*        respectively.
*
*        T_{1,2} = -T_{1,1}*T_{1,2}
*
         CALL dtrmm('Left', 'Upper', 'No transpose', 'Non-unit', l,
     $               k-l, neg_one, t, ldt, t(1, l+1), ldt)
*
*        T_{1,2} = T_{1,2}*T_{2,2}
*
         CALL dtrmm('Right', 'Upper', 'No transpose', 'Non-unit', l, 
     $               k-l, one, t(l+1, l+1), ldt, t(1, l+1), ldt)
 
      ELSE IF(lq) THEN
*
*        Break V apart into 6 components
*
*        V = |----------------------|
*            |V_{1,1} V_{1,2} V{1,3}|
*            |0       V_{2,2} V{2,3}|
*            |----------------------|
*
*        V_{1,1}\in\R^{l,l}      unit upper triangular
*        V_{1,2}\in\R^{l,k-l}    rectangular
*        V_{1,3}\in\R^{l,n-k}    rectangular
*        
*        V_{2,2}\in\R^{k-l,k-l}  unit upper triangular
*        V_{2,3}\in\R^{k-l,n-k}  rectangular
*
*        Where l = floor(k/2)
*
*        We will construct the T matrix 
*        T = |---------------|
*            |T_{1,1} T_{1,2}|
*            |0       T_{2,2}|
*            |---------------|
*
*        T is the triangular factor obtained from block reflectors. 
*        To motivate the structure, assume we have already computed T_{1,1}
*        and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
*        T_{1,1}\in\R^{l, l}     upper triangular
*        T_{2,2}\in\R^{k-l, k-l} upper triangular
*        T_{1,2}\in\R^{l, k-l}   rectangular
*
*        Then, consider the product:
*        
*        (I - V_1'*T_{1,1}*V_1)*(I - V_2'*T_{2,2}*V_2)
*        = I - V_1'*T_{1,1}*V_1 - V_2'*T_{2,2}*V_2 + V_1'*T_{1,1}*V_1*V_2'*T_{2,2}*V_2
*        
*        Define T_{1,2} = -T_{1,1}*V_1*V_2'*T_{2,2}
*        
*        Then, we can define the matrix V as 
*        V = |---|
*            |V_1|
*            |V_2|
*            |---|
*        
*        So, our product is equivalent to the matrix product
*        I - V'*T*V
*        This means, we can compute T_{1,1} and T_{2,2}, then use this information
*        to compute T_{1,2}
*
*        Compute T_{1,1} recursively
*
         CALL dlarft(direct, storev, n, l, v, ldv, tau, t, ldt)
*
*        Compute T_{2,2} recursively
*
         CALL dlarft(direct, storev, n-l, k-l, v(l+1, l+1), ldv, 
     $      tau(l+1), t(l+1, l+1), ldt)
 
*
*        Compute T_{1,2}
*        T_{1,2} = V_{1,2}
*
         CALL dlacpy('All', l, k-l, v(1, l+1), ldv, t(1, l+1), ldt)
*
*        T_{1,2} = T_{1,2}*V_{2,2}'
*
         CALL dtrmm('Right', 'Upper', 'Transpose', 'Unit', l, k-l,
     $               one, v(l+1, l+1), ldv, t(1, l+1), ldt)
 
*
*        T_{1,2} = V_{1,3}*V_{2,3}' + T_{1,2}
*        Note: We assume K <= N, and GEMM will do nothing if N=K
*
         CALL dgemm('No transpose', 'Transpose', l, k-l, n-k, one,
     $               v(1, k+1), ldv, v(l+1, k+1), ldv, one, 
     $               t(1, l+1), ldt)
*
*        At this point, we have that T_{1,2} = V_1*V_2'
*        All that is left is to pre and post multiply by -T_{1,1} and T_{2,2}
*        respectively.
*
*        T_{1,2} = -T_{1,1}*T_{1,2}
*
         CALL dtrmm('Left', 'Upper', 'No transpose', 'Non-unit', l,
     $               k-l, neg_one, t, ldt, t(1, l+1), ldt)
 
*
*        T_{1,2} = T_{1,2}*T_{2,2}
*
         CALL dtrmm('Right', 'Upper', 'No transpose', 'Non-unit', l,
     $               k-l, one, t(l+1, l+1), ldt, t(1, l+1), ldt)
      ELSE IF(ql) THEN
*
*        Break V apart into 6 components
*
*        V = |---------------|
*            |V_{1,1} V_{1,2}|
*            |V_{2,1} V_{2,2}|
*            |0       V_{3,2}|
*            |---------------|
*
*        V_{1,1}\in\R^{n-k,k-l}  rectangular
*        V_{2,1}\in\R^{k-l,k-l}  unit upper triangular
*        
*        V_{1,2}\in\R^{n-k,l}    rectangular
*        V_{2,2}\in\R^{k-l,l}    rectangular
*        V_{3,2}\in\R^{l,l}      unit upper triangular
*
*        We will construct the T matrix 
*        T = |---------------|
*            |T_{1,1} 0      |
*            |T_{2,1} T_{2,2}|
*            |---------------|
*
*        T is the triangular factor obtained from block reflectors. 
*        To motivate the structure, assume we have already computed T_{1,1}
*        and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
*        T_{1,1}\in\R^{k-l, k-l} non-unit lower triangular
*        T_{2,2}\in\R^{l, l}     non-unit lower triangular
*        T_{2,1}\in\R^{k-l, l}   rectangular
*
*        Where l = floor(k/2)
*
*        Then, consider the product:
*        
*        (I - V_2*T_{2,2}*V_2')*(I - V_1*T_{1,1}*V_1')
*        = I - V_2*T_{2,2}*V_2' - V_1*T_{1,1}*V_1' + V_2*T_{2,2}*V_2'*V_1*T_{1,1}*V_1'
*        
*        Define T_{2,1} = -T_{2,2}*V_2'*V_1*T_{1,1}
*        
*        Then, we can define the matrix V as 
*        V = |-------|
*            |V_1 V_2|
*            |-------|
*        
*        So, our product is equivalent to the matrix product
*        I - V*T*V'
*        This means, we can compute T_{1,1} and T_{2,2}, then use this information
*        to compute T_{2,1}
*
*        Compute T_{1,1} recursively
*
         CALL dlarft(direct, storev, n-l, k-l, v, ldv, tau, t, ldt)
*
*        Compute T_{2,2} recursively
*
         CALL dlarft(direct, storev, n, l, v(1, k-l+1), ldv,
     $               tau(k-l+1), t(k-l+1, k-l+1), ldt)
*
*        Compute T_{2,1}
*        T_{2,1} = V_{2,2}'
*
         DO j = 1, k-l
            DO i = 1, l
               t(k-l+i, j) = v(n-k+j, k-l+i)
            END DO
         END DO
*
*        T_{2,1} = T_{2,1}*V_{2,1}
*
         CALL dtrmm('Right', 'Upper', 'No transpose', 'Unit', l,
     $               k-l, one, v(n-k+1, 1), ldv, t(k-l+1, 1), ldt)
 
*
*        T_{2,1} = V_{2,2}'*V_{2,1} + T_{2,1}
*        Note: We assume K <= N, and GEMM will do nothing if N=K
*
         CALL dgemm('Transpose', 'No transpose', l, k-l, n-k, one,
     $               v(1, k-l+1), ldv, v, ldv, one, t(k-l+1, 1),
     $               ldt)
*
*        At this point, we have that T_{2,1} = V_2'*V_1
*        All that is left is to pre and post multiply by -T_{2,2} and T_{1,1}
*        respectively.
*
*        T_{2,1} = -T_{2,2}*T_{2,1}
*
         CALL dtrmm('Left', 'Lower', 'No transpose', 'Non-unit', l,
     $               k-l, neg_one, t(k-l+1, k-l+1), ldt,
     $               t(k-l+1, 1), ldt)
*
*        T_{2,1} = T_{2,1}*T_{1,1}
*
         CALL dtrmm('Right', 'Lower', 'No transpose', 'Non-unit', l,
     $               k-l, one, t, ldt, t(k-l+1, 1), ldt)
      ELSE
*
*        Else means RQ case
*
*        Break V apart into 6 components
*
*        V = |-----------------------|
*            |V_{1,1} V_{1,2} 0      |
*            |V_{2,1} V_{2,2} V_{2,3}|
*            |-----------------------|
*
*        V_{1,1}\in\R^{k-l,n-k}  rectangular
*        V_{1,2}\in\R^{k-l,k-l}  unit lower triangular
*
*        V_{2,1}\in\R^{l,n-k}    rectangular
*        V_{2,2}\in\R^{l,k-l}    rectangular
*        V_{2,3}\in\R^{l,l}      unit lower triangular
*
*        We will construct the T matrix 
*        T = |---------------|
*            |T_{1,1} 0      |
*            |T_{2,1} T_{2,2}|
*            |---------------|
*
*        T is the triangular factor obtained from block reflectors. 
*        To motivate the structure, assume we have already computed T_{1,1}
*        and T_{2,2}. Then collect the associated reflectors in V_1 and V_2
*
*        T_{1,1}\in\R^{k-l, k-l} non-unit lower triangular
*        T_{2,2}\in\R^{l, l}     non-unit lower triangular
*        T_{2,1}\in\R^{k-l, l}   rectangular
*
*        Where l = floor(k/2)
*
*        Then, consider the product:
*        
*        (I - V_2'*T_{2,2}*V_2)*(I - V_1'*T_{1,1}*V_1)
*        = I - V_2'*T_{2,2}*V_2 - V_1'*T_{1,1}*V_1 + V_2'*T_{2,2}*V_2*V_1'*T_{1,1}*V_1
*        
*        Define T_{2,1} = -T_{2,2}*V_2*V_1'*T_{1,1}
*        
*        Then, we can define the matrix V as 
*        V = |---|
*            |V_1|
*            |V_2|
*            |---|
*        
*        So, our product is equivalent to the matrix product
*        I - V'*T*V
*        This means, we can compute T_{1,1} and T_{2,2}, then use this information
*        to compute T_{2,1}
*
*        Compute T_{1,1} recursively
*
         CALL dlarft(direct, storev, n-l, k-l, v, ldv, tau, t, ldt)
*
*        Compute T_{2,2} recursively
*
         CALL dlarft(direct, storev, n, l, v(k-l+1, 1), ldv,
     $               tau(k-l+1), t(k-l+1, k-l+1), ldt)
*
*        Compute T_{2,1}
*        T_{2,1} = V_{2,2}
*
         CALL dlacpy('All', l, k-l, v(k-l+1, n-k+1), ldv,
     $               t(k-l+1, 1), ldt)
 
*
*        T_{2,1} = T_{2,1}*V_{1,2}'
*
         CALL dtrmm('Right', 'Lower', 'Transpose', 'Unit', l, k-l,
     $               one, v(1, n-k+1), ldv, t(k-l+1, 1), ldt)
 
*
*        T_{2,1} = V_{2,1}*V_{1,1}' + T_{2,1} 
*        Note: We assume K <= N, and GEMM will do nothing if N=K
*
         CALL dgemm('No transpose', 'Transpose', l, k-l, n-k, one, 
     $               v(k-l+1, 1), ldv, v, ldv, one, t(k-l+1, 1),
     $               ldt)
 
*
*        At this point, we have that T_{2,1} = V_2*V_1'
*        All that is left is to pre and post multiply by -T_{2,2} and T_{1,1}
*        respectively.
*
*        T_{2,1} = -T_{2,2}*T_{2,1}
*
         CALL dtrmm('Left', 'Lower', 'No tranpose', 'Non-unit', l,
     $               k-l, neg_one, t(k-l+1, k-l+1), ldt,
     $               t(k-l+1, 1), ldt)
 
*
*        T_{2,1} = T_{2,1}*T_{1,1}
*
         CALL dtrmm('Right', 'Lower', 'No tranpose', 'Non-unit', l,
     $               k-l, one, t, ldt, t(k-l+1, 1), ldt)
      END IF

Here is the call graph for this function:

Here is the caller graph for this function: