1: *> \brief \b DTPMQRT
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
9: *> Download DTPMQRT + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dtpmqrt.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dtpmqrt.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dtpmqrt.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
22: * A, LDA, B, LDB, WORK, INFO )
23: *
24: * .. Scalar Arguments ..
25: * CHARACTER SIDE, TRANS
26: * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT
27: * ..
28: * .. Array Arguments ..
29: * DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
30: * $ T( LDT, * ), WORK( * )
31: * ..
32: *
33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
39: *> DTPMQRT applies a real orthogonal matrix Q obtained from a
40: *> "triangular-pentagonal" real block reflector H to a general
41: *> real matrix C, which consists of two blocks A and B.
42: *> \endverbatim
43: *
44: * Arguments:
45: * ==========
46: *
47: *> \param[in] SIDE
48: *> \verbatim
49: *> SIDE is CHARACTER*1
50: *> = 'L': apply Q or Q**T from the Left;
51: *> = 'R': apply Q or Q**T from the Right.
52: *> \endverbatim
53: *>
54: *> \param[in] TRANS
55: *> \verbatim
56: *> TRANS is CHARACTER*1
57: *> = 'N': No transpose, apply Q;
58: *> = 'T': Transpose, apply Q**T.
59: *> \endverbatim
60: *>
61: *> \param[in] M
62: *> \verbatim
63: *> M is INTEGER
64: *> The number of rows of the matrix B. M >= 0.
65: *> \endverbatim
66: *>
67: *> \param[in] N
68: *> \verbatim
69: *> N is INTEGER
70: *> The number of columns of the matrix B. N >= 0.
71: *> \endverbatim
72: *>
73: *> \param[in] K
74: *> \verbatim
75: *> K is INTEGER
76: *> The number of elementary reflectors whose product defines
77: *> the matrix Q.
78: *> \endverbatim
79: *>
80: *> \param[in] L
81: *> \verbatim
82: *> L is INTEGER
83: *> The order of the trapezoidal part of V.
84: *> K >= L >= 0. See Further Details.
85: *> \endverbatim
86: *>
87: *> \param[in] NB
88: *> \verbatim
89: *> NB is INTEGER
90: *> The block size used for the storage of T. K >= NB >= 1.
91: *> This must be the same value of NB used to generate T
92: *> in CTPQRT.
93: *> \endverbatim
94: *>
95: *> \param[in] V
96: *> \verbatim
97: *> V is DOUBLE PRECISION array, dimension (LDV,K)
98: *> The i-th column must contain the vector which defines the
99: *> elementary reflector H(i), for i = 1,2,...,k, as returned by
100: *> CTPQRT in B. See Further Details.
101: *> \endverbatim
102: *>
103: *> \param[in] LDV
104: *> \verbatim
105: *> LDV is INTEGER
106: *> The leading dimension of the array V.
107: *> If SIDE = 'L', LDV >= max(1,M);
108: *> if SIDE = 'R', LDV >= max(1,N).
109: *> \endverbatim
110: *>
111: *> \param[in] T
112: *> \verbatim
113: *> T is DOUBLE PRECISION array, dimension (LDT,K)
114: *> The upper triangular factors of the block reflectors
115: *> as returned by CTPQRT, stored as a NB-by-K matrix.
116: *> \endverbatim
117: *>
118: *> \param[in] LDT
119: *> \verbatim
120: *> LDT is INTEGER
121: *> The leading dimension of the array T. LDT >= NB.
122: *> \endverbatim
123: *>
124: *> \param[in,out] A
125: *> \verbatim
126: *> A is DOUBLE PRECISION array, dimension
127: *> (LDA,N) if SIDE = 'L' or
128: *> (LDA,K) if SIDE = 'R'
129: *> On entry, the K-by-N or M-by-K matrix A.
130: *> On exit, A is overwritten by the corresponding block of
131: *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details.
132: *> \endverbatim
133: *>
134: *> \param[in] LDA
135: *> \verbatim
136: *> LDA is INTEGER
137: *> The leading dimension of the array A.
138: *> If SIDE = 'L', LDC >= max(1,K);
139: *> If SIDE = 'R', LDC >= max(1,M).
140: *> \endverbatim
141: *>
142: *> \param[in,out] B
143: *> \verbatim
144: *> B is DOUBLE PRECISION array, dimension (LDB,N)
145: *> On entry, the M-by-N matrix B.
146: *> On exit, B is overwritten by the corresponding block of
147: *> Q*C or Q**T*C or C*Q or C*Q**T. See Further Details.
148: *> \endverbatim
149: *>
150: *> \param[in] LDB
151: *> \verbatim
152: *> LDB is INTEGER
153: *> The leading dimension of the array B.
154: *> LDB >= max(1,M).
155: *> \endverbatim
156: *>
157: *> \param[out] WORK
158: *> \verbatim
159: *> WORK is DOUBLE PRECISION array. The dimension of WORK is
160: *> N*NB if SIDE = 'L', or M*NB if SIDE = 'R'.
161: *> \endverbatim
162: *>
163: *> \param[out] INFO
164: *> \verbatim
165: *> INFO is INTEGER
166: *> = 0: successful exit
167: *> < 0: if INFO = -i, the i-th argument had an illegal value
168: *> \endverbatim
169: *
170: * Authors:
171: * ========
172: *
173: *> \author Univ. of Tennessee
174: *> \author Univ. of California Berkeley
175: *> \author Univ. of Colorado Denver
176: *> \author NAG Ltd.
177: *
178: *> \ingroup doubleOTHERcomputational
179: *
180: *> \par Further Details:
181: * =====================
182: *>
183: *> \verbatim
184: *>
185: *> The columns of the pentagonal matrix V contain the elementary reflectors
186: *> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
187: *> trapezoidal block V2:
188: *>
189: *> V = [V1]
190: *> [V2].
191: *>
192: *> The size of the trapezoidal block V2 is determined by the parameter L,
193: *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L
194: *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular;
195: *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
196: *>
197: *> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K.
198: *> [B]
199: *>
200: *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K.
201: *>
202: *> The real orthogonal matrix Q is formed from V and T.
203: *>
204: *> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
205: *>
206: *> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C.
207: *>
208: *> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
209: *>
210: *> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T.
211: *> \endverbatim
212: *>
213: * =====================================================================
214: SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
215: $ A, LDA, B, LDB, WORK, INFO )
216: *
217: * -- LAPACK computational routine --
218: * -- LAPACK is a software package provided by Univ. of Tennessee, --
219: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
220: *
221: * .. Scalar Arguments ..
222: CHARACTER SIDE, TRANS
223: INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT
224: * ..
225: * .. Array Arguments ..
226: DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
227: $ T( LDT, * ), WORK( * )
228: * ..
229: *
230: * =====================================================================
231: *
232: * ..
233: * .. Local Scalars ..
234: LOGICAL LEFT, RIGHT, TRAN, NOTRAN
235: INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
236: * ..
237: * .. External Functions ..
238: LOGICAL LSAME
239: EXTERNAL LSAME
240: * ..
241: * .. External Subroutines ..
242: EXTERNAL DTPRFB, XERBLA
243: * ..
244: * .. Intrinsic Functions ..
245: INTRINSIC MAX, MIN
246: * ..
247: * .. Executable Statements ..
248: *
249: * .. Test the input arguments ..
250: *
251: INFO = 0
252: LEFT = LSAME( SIDE, 'L' )
253: RIGHT = LSAME( SIDE, 'R' )
254: TRAN = LSAME( TRANS, 'T' )
255: NOTRAN = LSAME( TRANS, 'N' )
256: *
257: IF ( LEFT ) THEN
258: LDVQ = MAX( 1, M )
259: LDAQ = MAX( 1, K )
260: ELSE IF ( RIGHT ) THEN
261: LDVQ = MAX( 1, N )
262: LDAQ = MAX( 1, M )
263: END IF
264: IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
265: INFO = -1
266: ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
267: INFO = -2
268: ELSE IF( M.LT.0 ) THEN
269: INFO = -3
270: ELSE IF( N.LT.0 ) THEN
271: INFO = -4
272: ELSE IF( K.LT.0 ) THEN
273: INFO = -5
274: ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
275: INFO = -6
276: ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
277: INFO = -7
278: ELSE IF( LDV.LT.LDVQ ) THEN
279: INFO = -9
280: ELSE IF( LDT.LT.NB ) THEN
281: INFO = -11
282: ELSE IF( LDA.LT.LDAQ ) THEN
283: INFO = -13
284: ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
285: INFO = -15
286: END IF
287: *
288: IF( INFO.NE.0 ) THEN
289: CALL XERBLA( 'DTPMQRT', -INFO )
290: RETURN
291: END IF
292: *
293: * .. Quick return if possible ..
294: *
295: IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
296: *
297: IF( LEFT .AND. TRAN ) THEN
298: *
299: DO I = 1, K, NB
300: IB = MIN( NB, K-I+1 )
301: MB = MIN( M-L+I+IB-1, M )
302: IF( I.GE.L ) THEN
303: LB = 0
304: ELSE
305: LB = MB-M+L-I+1
306: END IF
307: CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB,
308: $ V( 1, I ), LDV, T( 1, I ), LDT,
309: $ A( I, 1 ), LDA, B, LDB, WORK, IB )
310: END DO
311: *
312: ELSE IF( RIGHT .AND. NOTRAN ) THEN
313: *
314: DO I = 1, K, NB
315: IB = MIN( NB, K-I+1 )
316: MB = MIN( N-L+I+IB-1, N )
317: IF( I.GE.L ) THEN
318: LB = 0
319: ELSE
320: LB = MB-N+L-I+1
321: END IF
322: CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB,
323: $ V( 1, I ), LDV, T( 1, I ), LDT,
324: $ A( 1, I ), LDA, B, LDB, WORK, M )
325: END DO
326: *
327: ELSE IF( LEFT .AND. NOTRAN ) THEN
328: *
329: KF = ((K-1)/NB)*NB+1
330: DO I = KF, 1, -NB
331: IB = MIN( NB, K-I+1 )
332: MB = MIN( M-L+I+IB-1, M )
333: IF( I.GE.L ) THEN
334: LB = 0
335: ELSE
336: LB = MB-M+L-I+1
337: END IF
338: CALL DTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB,
339: $ V( 1, I ), LDV, T( 1, I ), LDT,
340: $ A( I, 1 ), LDA, B, LDB, WORK, IB )
341: END DO
342: *
343: ELSE IF( RIGHT .AND. TRAN ) THEN
344: *
345: KF = ((K-1)/NB)*NB+1
346: DO I = KF, 1, -NB
347: IB = MIN( NB, K-I+1 )
348: MB = MIN( N-L+I+IB-1, N )
349: IF( I.GE.L ) THEN
350: LB = 0
351: ELSE
352: LB = MB-N+L-I+1
353: END IF
354: CALL DTPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB,
355: $ V( 1, I ), LDV, T( 1, I ), LDT,
356: $ A( 1, I ), LDA, B, LDB, WORK, M )
357: END DO
358: *
359: END IF
360: *
361: RETURN
362: *
363: * End of DTPMQRT
364: *
365: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dtpmqrt.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack