Statistiques
| Révision :

root / src / lapack / double / dlarzt.f @ 10

Historique | Voir | Annoter | Télécharger (5,87 ko)

1 
      SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
2 
*
3 
*  -- LAPACK routine (version 3.2) --
4 
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
5 
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
6 
*     November 2006
7 
*
8 
*     .. Scalar Arguments ..
9 
      CHARACTER          DIRECT, STOREV
10 
      INTEGER            K, LDT, LDV, N
11 
*     ..
12 
*     .. Array Arguments ..
13 
      DOUBLE PRECISION   T( LDT, * ), TAU( * ), V( LDV, * )
14 
*     ..
15 
*
16 
*  Purpose
17 
*  =======
18 
*
19 
*  DLARZT forms the triangular factor T of a real block reflector
20 
*  H of order > n, which is defined as a product of k elementary
21 
*  reflectors.
22 
*
23 
*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
24 
*
25 
*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
26 
*
27 
*  If STOREV = 'C', the vector which defines the elementary reflector
28 
*  H(i) is stored in the i-th column of the array V, and
29 
*
30 
*     H  =  I - V * T * V'
31 
*
32 
*  If STOREV = 'R', the vector which defines the elementary reflector
33 
*  H(i) is stored in the i-th row of the array V, and
34 
*
35 
*     H  =  I - V' * T * V
36 
*
37 
*  Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
38 
*
39 
*  Arguments
40 
*  =========
41 
*
42 
*  DIRECT  (input) CHARACTER*1
43 
*          Specifies the order in which the elementary reflectors are
44 
*          multiplied to form the block reflector:
45 
*          = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
46 
*          = 'B': H = H(k) . . . H(2) H(1) (Backward)
47 
*
48 
*  STOREV  (input) CHARACTER*1
49 
*          Specifies how the vectors which define the elementary
50 
*          reflectors are stored (see also Further Details):
51 
*          = 'C': columnwise                        (not supported yet)
52 
*          = 'R': rowwise
53 
*
54 
*  N       (input) INTEGER
55 
*          The order of the block reflector H. N >= 0.
56 
*
57 
*  K       (input) INTEGER
58 
*          The order of the triangular factor T (= the number of
59 
*          elementary reflectors). K >= 1.
60 
*
61 
*  V       (input/output) DOUBLE PRECISION array, dimension
62 
*                               (LDV,K) if STOREV = 'C'
63 
*                               (LDV,N) if STOREV = 'R'
64 
*          The matrix V. See further details.
65 
*
66 
*  LDV     (input) INTEGER
67 
*          The leading dimension of the array V.
68 
*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
69 
*
70 
*  TAU     (input) DOUBLE PRECISION array, dimension (K)
71 
*          TAU(i) must contain the scalar factor of the elementary
72 
*          reflector H(i).
73 
*
74 
*  T       (output) DOUBLE PRECISION array, dimension (LDT,K)
75 
*          The k by k triangular factor T of the block reflector.
76 
*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
77 
*          lower triangular. The rest of the array is not used.
78 
*
79 
*  LDT     (input) INTEGER
80 
*          The leading dimension of the array T. LDT >= K.
81 
*
82 
*  Further Details
83 
*  ===============
84 
*
85 
*  Based on contributions by
86 
*    A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
87 
*
88 
*  The shape of the matrix V and the storage of the vectors which define
89 
*  the H(i) is best illustrated by the following example with n = 5 and
90 
*  k = 3. The elements equal to 1 are not stored; the corresponding
91 
*  array elements are modified but restored on exit. The rest of the
92 
*  array is not used.
93 
*
94 
*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R':
95 
*
96 
*                                              ______V_____
97 
*         ( v1 v2 v3 )                        /            \
98 
*         ( v1 v2 v3 )                      ( v1 v1 v1 v1 v1 . . . . 1 )
99 
*     V = ( v1 v2 v3 )                      ( v2 v2 v2 v2 v2 . . . 1   )
100 
*         ( v1 v2 v3 )                      ( v3 v3 v3 v3 v3 . . 1     )
101 
*         ( v1 v2 v3 )
102 
*            .  .  .
103 
*            .  .  .
104 
*            1  .  .
105 
*               1  .
106 
*                  1
107 
*
108 
*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R':
109 
*
110 
*                                                        ______V_____
111 
*            1                                          /            \
112 
*            .  1                           ( 1 . . . . v1 v1 v1 v1 v1 )
113 
*            .  .  1                        ( . 1 . . . v2 v2 v2 v2 v2 )
114 
*            .  .  .                        ( . . 1 . . v3 v3 v3 v3 v3 )
115 
*            .  .  .
116 
*         ( v1 v2 v3 )
117 
*         ( v1 v2 v3 )
118 
*     V = ( v1 v2 v3 )
119 
*         ( v1 v2 v3 )
120 
*         ( v1 v2 v3 )
121 
*
122 
*  =====================================================================
123 
*
124 
*     .. Parameters ..
125 
      DOUBLE PRECISION   ZERO
126 
      PARAMETER          ( ZERO = 0.0D+0 )
127 
*     ..
128 
*     .. Local Scalars ..
129 
      INTEGER            I, INFO, J
130 
*     ..
131 
*     .. External Subroutines ..
132 
      EXTERNAL           DGEMV, DTRMV, XERBLA
133 
*     ..
134 
*     .. External Functions ..
135 
      LOGICAL            LSAME
136 
      EXTERNAL           LSAME
137 
*     ..
138 
*     .. Executable Statements ..
139 
*
140 
*     Check for currently supported options
141 
*
142 
      INFO = 0
143 
      IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
144 
         INFO = -1
145 
      ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
146 
         INFO = -2
147 
      END IF
148 
      IF( INFO.NE.0 ) THEN
149 
         CALL XERBLA( 'DLARZT', -INFO )
150 
         RETURN
151 
      END IF
152 
*
153 
      DO 20 I = K, 1, -1
154 
         IF( TAU( I ).EQ.ZERO ) THEN
155 
*
156 
*           H(i)  =  I
157 
*
158 
            DO 10 J = I, K
159 
               T( J, I ) = ZERO
160 
   10       CONTINUE
161 
         ELSE
162 
*
163 
*           general case
164 
*
165 
            IF( I.LT.K ) THEN
166 
*
167 
*              T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
168 
*
169 
               CALL DGEMV( 'No transpose', K-I, N, -TAU( I ),
170 
     $                     V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
171 
     $                     T( I+1, I ), 1 )
172 
*
173 
*              T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
174 
*
175 
               CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
176 
     $                     T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
177 
            END IF
178 
            T( I, I ) = TAU( I )
179 
         END IF
180 
   20 CONTINUE
181 
      RETURN
182 
*
183 
*     End of DLARZT
184 
*
185 
      END