Annotation of rpl/lapack/lapack/dlarzb.f, revision 1.19
1.12 bertrand 1: *> \brief \b DLARZB applies a block reflector or its transpose to a general matrix.
1.9 bertrand 2: *
3: * =========== DOCUMENTATION ===========
4: *
1.16 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.9 bertrand 7: *
8: *> \htmlonly
1.16 bertrand 9: *> Download DLARZB + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dlarzb.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dlarzb.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dlarzb.f">
1.9 bertrand 15: *> [TXT]</a>
1.16 bertrand 16: *> \endhtmlonly
1.9 bertrand 17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
22: * LDV, T, LDT, C, LDC, WORK, LDWORK )
1.16 bertrand 23: *
1.9 bertrand 24: * .. Scalar Arguments ..
25: * CHARACTER DIRECT, SIDE, STOREV, TRANS
26: * INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
27: * ..
28: * .. Array Arguments ..
29: * DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
30: * $ WORK( LDWORK, * )
31: * ..
1.16 bertrand 32: *
1.9 bertrand 33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> DLARZB applies a real block reflector H or its transpose H**T to
40: *> a real distributed M-by-N C from the left or the right.
41: *>
42: *> Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
43: *> \endverbatim
44: *
45: * Arguments:
46: * ==========
47: *
48: *> \param[in] SIDE
49: *> \verbatim
50: *> SIDE is CHARACTER*1
51: *> = 'L': apply H or H**T from the Left
52: *> = 'R': apply H or H**T from the Right
53: *> \endverbatim
54: *>
55: *> \param[in] TRANS
56: *> \verbatim
57: *> TRANS is CHARACTER*1
58: *> = 'N': apply H (No transpose)
59: *> = 'C': apply H**T (Transpose)
60: *> \endverbatim
61: *>
62: *> \param[in] DIRECT
63: *> \verbatim
64: *> DIRECT is CHARACTER*1
65: *> Indicates how H is formed from a product of elementary
66: *> reflectors
67: *> = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
68: *> = 'B': H = H(k) . . . H(2) H(1) (Backward)
69: *> \endverbatim
70: *>
71: *> \param[in] STOREV
72: *> \verbatim
73: *> STOREV is CHARACTER*1
74: *> Indicates how the vectors which define the elementary
75: *> reflectors are stored:
76: *> = 'C': Columnwise (not supported yet)
77: *> = 'R': Rowwise
78: *> \endverbatim
79: *>
80: *> \param[in] M
81: *> \verbatim
82: *> M is INTEGER
83: *> The number of rows of the matrix C.
84: *> \endverbatim
85: *>
86: *> \param[in] N
87: *> \verbatim
88: *> N is INTEGER
89: *> The number of columns of the matrix C.
90: *> \endverbatim
91: *>
92: *> \param[in] K
93: *> \verbatim
94: *> K is INTEGER
95: *> The order of the matrix T (= the number of elementary
96: *> reflectors whose product defines the block reflector).
97: *> \endverbatim
98: *>
99: *> \param[in] L
100: *> \verbatim
101: *> L is INTEGER
102: *> The number of columns of the matrix V containing the
103: *> meaningful part of the Householder reflectors.
104: *> If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
105: *> \endverbatim
106: *>
107: *> \param[in] V
108: *> \verbatim
109: *> V is DOUBLE PRECISION array, dimension (LDV,NV).
110: *> If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
111: *> \endverbatim
112: *>
113: *> \param[in] LDV
114: *> \verbatim
115: *> LDV is INTEGER
116: *> The leading dimension of the array V.
117: *> If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
118: *> \endverbatim
119: *>
120: *> \param[in] T
121: *> \verbatim
122: *> T is DOUBLE PRECISION array, dimension (LDT,K)
123: *> The triangular K-by-K matrix T in the representation of the
124: *> block reflector.
125: *> \endverbatim
126: *>
127: *> \param[in] LDT
128: *> \verbatim
129: *> LDT is INTEGER
130: *> The leading dimension of the array T. LDT >= K.
131: *> \endverbatim
132: *>
133: *> \param[in,out] C
134: *> \verbatim
135: *> C is DOUBLE PRECISION array, dimension (LDC,N)
136: *> On entry, the M-by-N matrix C.
137: *> On exit, C is overwritten by H*C or H**T*C or C*H or C*H**T.
138: *> \endverbatim
139: *>
140: *> \param[in] LDC
141: *> \verbatim
142: *> LDC is INTEGER
143: *> The leading dimension of the array C. LDC >= max(1,M).
144: *> \endverbatim
145: *>
146: *> \param[out] WORK
147: *> \verbatim
148: *> WORK is DOUBLE PRECISION array, dimension (LDWORK,K)
149: *> \endverbatim
150: *>
151: *> \param[in] LDWORK
152: *> \verbatim
153: *> LDWORK is INTEGER
154: *> The leading dimension of the array WORK.
155: *> If SIDE = 'L', LDWORK >= max(1,N);
156: *> if SIDE = 'R', LDWORK >= max(1,M).
157: *> \endverbatim
158: *
159: * Authors:
160: * ========
161: *
1.16 bertrand 162: *> \author Univ. of Tennessee
163: *> \author Univ. of California Berkeley
164: *> \author Univ. of Colorado Denver
165: *> \author NAG Ltd.
1.9 bertrand 166: *
167: *> \ingroup doubleOTHERcomputational
168: *
169: *> \par Contributors:
170: * ==================
171: *>
172: *> A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
173: *
174: *> \par Further Details:
175: * =====================
176: *>
177: *> \verbatim
178: *> \endverbatim
179: *>
180: * =====================================================================
1.1 bertrand 181: SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
182: $ LDV, T, LDT, C, LDC, WORK, LDWORK )
183: *
1.19 ! bertrand 184: * -- LAPACK computational routine --
1.1 bertrand 185: * -- LAPACK is a software package provided by Univ. of Tennessee, --
186: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
187: *
188: * .. Scalar Arguments ..
189: CHARACTER DIRECT, SIDE, STOREV, TRANS
190: INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
191: * ..
192: * .. Array Arguments ..
193: DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
194: $ WORK( LDWORK, * )
195: * ..
196: *
197: * =====================================================================
198: *
199: * .. Parameters ..
200: DOUBLE PRECISION ONE
201: PARAMETER ( ONE = 1.0D+0 )
202: * ..
203: * .. Local Scalars ..
204: CHARACTER TRANST
205: INTEGER I, INFO, J
206: * ..
207: * .. External Functions ..
208: LOGICAL LSAME
209: EXTERNAL LSAME
210: * ..
211: * .. External Subroutines ..
212: EXTERNAL DCOPY, DGEMM, DTRMM, XERBLA
213: * ..
214: * .. Executable Statements ..
215: *
216: * Quick return if possible
217: *
218: IF( M.LE.0 .OR. N.LE.0 )
219: $ RETURN
220: *
221: * Check for currently supported options
222: *
223: INFO = 0
224: IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
225: INFO = -3
226: ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
227: INFO = -4
228: END IF
229: IF( INFO.NE.0 ) THEN
230: CALL XERBLA( 'DLARZB', -INFO )
231: RETURN
232: END IF
233: *
234: IF( LSAME( TRANS, 'N' ) ) THEN
235: TRANST = 'T'
236: ELSE
237: TRANST = 'N'
238: END IF
239: *
240: IF( LSAME( SIDE, 'L' ) ) THEN
241: *
1.8 bertrand 242: * Form H * C or H**T * C
1.1 bertrand 243: *
1.8 bertrand 244: * W( 1:n, 1:k ) = C( 1:k, 1:n )**T
1.1 bertrand 245: *
246: DO 10 J = 1, K
247: CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
248: 10 CONTINUE
249: *
250: * W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
1.8 bertrand 251: * C( m-l+1:m, 1:n )**T * V( 1:k, 1:l )**T
1.1 bertrand 252: *
253: IF( L.GT.0 )
254: $ CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE,
255: $ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
256: *
1.8 bertrand 257: * W( 1:n, 1:k ) = W( 1:n, 1:k ) * T**T or W( 1:m, 1:k ) * T
1.1 bertrand 258: *
259: CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
260: $ LDT, WORK, LDWORK )
261: *
1.8 bertrand 262: * C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )**T
1.1 bertrand 263: *
264: DO 30 J = 1, N
265: DO 20 I = 1, K
266: C( I, J ) = C( I, J ) - WORK( J, I )
267: 20 CONTINUE
268: 30 CONTINUE
269: *
270: * C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
1.8 bertrand 271: * V( 1:k, 1:l )**T * W( 1:n, 1:k )**T
1.1 bertrand 272: *
273: IF( L.GT.0 )
274: $ CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
275: $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
276: *
277: ELSE IF( LSAME( SIDE, 'R' ) ) THEN
278: *
1.8 bertrand 279: * Form C * H or C * H**T
1.1 bertrand 280: *
281: * W( 1:m, 1:k ) = C( 1:m, 1:k )
282: *
283: DO 40 J = 1, K
284: CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
285: 40 CONTINUE
286: *
287: * W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
1.8 bertrand 288: * C( 1:m, n-l+1:n ) * V( 1:k, 1:l )**T
1.1 bertrand 289: *
290: IF( L.GT.0 )
291: $ CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
292: $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
293: *
1.8 bertrand 294: * W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T**T
1.1 bertrand 295: *
296: CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
297: $ LDT, WORK, LDWORK )
298: *
299: * C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
300: *
301: DO 60 J = 1, K
302: DO 50 I = 1, M
303: C( I, J ) = C( I, J ) - WORK( I, J )
304: 50 CONTINUE
305: 60 CONTINUE
306: *
307: * C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
308: * W( 1:m, 1:k ) * V( 1:k, 1:l )
309: *
310: IF( L.GT.0 )
311: $ CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
312: $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
313: *
314: END IF
315: *
316: RETURN
317: *
318: * End of DLARZB
319: *
320: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dlarzb.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack