Annotation of rpl/lapack/lapack/dtpmqrt.f, revision 1.9
1.1 bertrand 1: *> \brief \b DTPMQRT
2: *
3: * =========== DOCUMENTATION ===========
4: *
1.8 bertrand 5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
1.1 bertrand 7: *
8: *> \htmlonly
1.8 bertrand 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">
1.1 bertrand 15: *> [TXT]</a>
1.8 bertrand 16: *> \endhtmlonly
1.1 bertrand 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 )
1.8 bertrand 23: *
1.1 bertrand 24: * .. Scalar Arguments ..
25: * CHARACTER SIDE, TRANS
26: * INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT
27: * ..
28: * .. Array Arguments ..
1.8 bertrand 29: * DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
1.1 bertrand 30: * $ T( LDT, * ), WORK( * )
31: * ..
1.8 bertrand 32: *
1.1 bertrand 33: *
34: *> \par Purpose:
35: * =============
36: *>
37: *> \verbatim
38: *>
1.8 bertrand 39: *> DTPMQRT applies a real orthogonal matrix Q obtained from a
1.1 bertrand 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;
1.6 bertrand 58: *> = 'T': Transpose, apply Q**T.
1.1 bertrand 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
1.8 bertrand 72: *>
1.1 bertrand 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
1.8 bertrand 83: *> The order of the trapezoidal part of V.
1.1 bertrand 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 (LDA,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
1.8 bertrand 127: *> (LDA,N) if SIDE = 'L' or
1.1 bertrand 128: *> (LDA,K) if SIDE = 'R'
129: *> On entry, the K-by-N or M-by-K matrix A.
1.8 bertrand 130: *> On exit, A is overwritten by the corresponding block of
1.1 bertrand 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
1.8 bertrand 137: *> The leading dimension of the array A.
1.1 bertrand 138: *> If SIDE = 'L', LDC >= max(1,K);
1.8 bertrand 139: *> If SIDE = 'R', LDC >= max(1,M).
1.1 bertrand 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
1.8 bertrand 153: *> The leading dimension of the array B.
1.1 bertrand 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: *
1.8 bertrand 173: *> \author Univ. of Tennessee
174: *> \author Univ. of California Berkeley
175: *> \author Univ. of Colorado Denver
176: *> \author NAG Ltd.
1.1 bertrand 177: *
1.8 bertrand 178: *> \date December 2016
1.1 bertrand 179: *
180: *> \ingroup doubleOTHERcomputational
181: *
182: *> \par Further Details:
183: * =====================
184: *>
185: *> \verbatim
186: *>
187: *> The columns of the pentagonal matrix V contain the elementary reflectors
1.8 bertrand 188: *> H(1), H(2), ..., H(K); V is composed of a rectangular block V1 and a
1.1 bertrand 189: *> trapezoidal block V2:
190: *>
191: *> V = [V1]
192: *> [V2].
193: *>
1.8 bertrand 194: *> The size of the trapezoidal block V2 is determined by the parameter L,
1.1 bertrand 195: *> where 0 <= L <= K; V2 is upper trapezoidal, consisting of the first L
196: *> rows of a K-by-K upper triangular matrix. If L=K, V2 is upper triangular;
197: *> if L=0, there is no trapezoidal block, hence V = V1 is rectangular.
198: *>
1.8 bertrand 199: *> If SIDE = 'L': C = [A] where A is K-by-N, B is M-by-N and V is M-by-K.
200: *> [B]
201: *>
1.1 bertrand 202: *> If SIDE = 'R': C = [A B] where A is M-by-K, B is M-by-N and V is N-by-K.
203: *>
204: *> The real orthogonal matrix Q is formed from V and T.
205: *>
206: *> If TRANS='N' and SIDE='L', C is on exit replaced with Q * C.
207: *>
208: *> If TRANS='T' and SIDE='L', C is on exit replaced with Q**T * C.
209: *>
210: *> If TRANS='N' and SIDE='R', C is on exit replaced with C * Q.
211: *>
212: *> If TRANS='T' and SIDE='R', C is on exit replaced with C * Q**T.
213: *> \endverbatim
214: *>
215: * =====================================================================
216: SUBROUTINE DTPMQRT( SIDE, TRANS, M, N, K, L, NB, V, LDV, T, LDT,
217: $ A, LDA, B, LDB, WORK, INFO )
218: *
1.8 bertrand 219: * -- LAPACK computational routine (version 3.7.0) --
1.1 bertrand 220: * -- LAPACK is a software package provided by Univ. of Tennessee, --
221: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
1.8 bertrand 222: * December 2016
1.1 bertrand 223: *
224: * .. Scalar Arguments ..
225: CHARACTER SIDE, TRANS
226: INTEGER INFO, K, LDV, LDA, LDB, M, N, L, NB, LDT
227: * ..
228: * .. Array Arguments ..
1.8 bertrand 229: DOUBLE PRECISION V( LDV, * ), A( LDA, * ), B( LDB, * ),
1.1 bertrand 230: $ T( LDT, * ), WORK( * )
231: * ..
232: *
233: * =====================================================================
234: *
235: * ..
236: * .. Local Scalars ..
237: LOGICAL LEFT, RIGHT, TRAN, NOTRAN
1.4 bertrand 238: INTEGER I, IB, MB, LB, KF, LDAQ, LDVQ
1.1 bertrand 239: * ..
240: * .. External Functions ..
241: LOGICAL LSAME
242: EXTERNAL LSAME
243: * ..
244: * .. External Subroutines ..
1.8 bertrand 245: EXTERNAL XERBLA
1.1 bertrand 246: * ..
247: * .. Intrinsic Functions ..
248: INTRINSIC MAX, MIN
249: * ..
250: * .. Executable Statements ..
251: *
252: * .. Test the input arguments ..
253: *
254: INFO = 0
255: LEFT = LSAME( SIDE, 'L' )
256: RIGHT = LSAME( SIDE, 'R' )
257: TRAN = LSAME( TRANS, 'T' )
258: NOTRAN = LSAME( TRANS, 'N' )
1.8 bertrand 259: *
1.4 bertrand 260: IF ( LEFT ) THEN
261: LDVQ = MAX( 1, M )
262: LDAQ = MAX( 1, K )
1.1 bertrand 263: ELSE IF ( RIGHT ) THEN
1.4 bertrand 264: LDVQ = MAX( 1, N )
265: LDAQ = MAX( 1, M )
1.1 bertrand 266: END IF
267: IF( .NOT.LEFT .AND. .NOT.RIGHT ) THEN
268: INFO = -1
269: ELSE IF( .NOT.TRAN .AND. .NOT.NOTRAN ) THEN
270: INFO = -2
271: ELSE IF( M.LT.0 ) THEN
272: INFO = -3
273: ELSE IF( N.LT.0 ) THEN
274: INFO = -4
275: ELSE IF( K.LT.0 ) THEN
276: INFO = -5
277: ELSE IF( L.LT.0 .OR. L.GT.K ) THEN
1.8 bertrand 278: INFO = -6
1.4 bertrand 279: ELSE IF( NB.LT.1 .OR. (NB.GT.K .AND. K.GT.0) ) THEN
1.1 bertrand 280: INFO = -7
1.4 bertrand 281: ELSE IF( LDV.LT.LDVQ ) THEN
1.1 bertrand 282: INFO = -9
283: ELSE IF( LDT.LT.NB ) THEN
284: INFO = -11
1.4 bertrand 285: ELSE IF( LDA.LT.LDAQ ) THEN
1.1 bertrand 286: INFO = -13
287: ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
288: INFO = -15
289: END IF
290: *
291: IF( INFO.NE.0 ) THEN
292: CALL XERBLA( 'DTPMQRT', -INFO )
293: RETURN
294: END IF
295: *
296: * .. Quick return if possible ..
297: *
298: IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) RETURN
299: *
300: IF( LEFT .AND. TRAN ) THEN
301: *
302: DO I = 1, K, NB
303: IB = MIN( NB, K-I+1 )
304: MB = MIN( M-L+I+IB-1, M )
305: IF( I.GE.L ) THEN
306: LB = 0
307: ELSE
308: LB = MB-M+L-I+1
309: END IF
1.8 bertrand 310: CALL DTPRFB( 'L', 'T', 'F', 'C', MB, N, IB, LB,
311: $ V( 1, I ), LDV, T( 1, I ), LDT,
1.1 bertrand 312: $ A( I, 1 ), LDA, B, LDB, WORK, IB )
313: END DO
1.8 bertrand 314: *
1.1 bertrand 315: ELSE IF( RIGHT .AND. NOTRAN ) THEN
316: *
317: DO I = 1, K, NB
318: IB = MIN( NB, K-I+1 )
319: MB = MIN( N-L+I+IB-1, N )
320: IF( I.GE.L ) THEN
321: LB = 0
322: ELSE
323: LB = MB-N+L-I+1
324: END IF
1.8 bertrand 325: CALL DTPRFB( 'R', 'N', 'F', 'C', M, MB, IB, LB,
326: $ V( 1, I ), LDV, T( 1, I ), LDT,
1.1 bertrand 327: $ A( 1, I ), LDA, B, LDB, WORK, M )
328: END DO
329: *
330: ELSE IF( LEFT .AND. NOTRAN ) THEN
331: *
332: KF = ((K-1)/NB)*NB+1
333: DO I = KF, 1, -NB
1.8 bertrand 334: IB = MIN( NB, K-I+1 )
1.1 bertrand 335: MB = MIN( M-L+I+IB-1, M )
336: IF( I.GE.L ) THEN
337: LB = 0
338: ELSE
339: LB = MB-M+L-I+1
1.8 bertrand 340: END IF
1.1 bertrand 341: CALL DTPRFB( 'L', 'N', 'F', 'C', MB, N, IB, LB,
1.8 bertrand 342: $ V( 1, I ), LDV, T( 1, I ), LDT,
1.1 bertrand 343: $ A( I, 1 ), LDA, B, LDB, WORK, IB )
344: END DO
345: *
346: ELSE IF( RIGHT .AND. TRAN ) THEN
347: *
348: KF = ((K-1)/NB)*NB+1
349: DO I = KF, 1, -NB
1.8 bertrand 350: IB = MIN( NB, K-I+1 )
1.1 bertrand 351: MB = MIN( N-L+I+IB-1, N )
352: IF( I.GE.L ) THEN
353: LB = 0
354: ELSE
355: LB = MB-N+L-I+1
356: END IF
357: CALL DTPRFB( 'R', 'T', 'F', 'C', M, MB, IB, LB,
1.8 bertrand 358: $ V( 1, I ), LDV, T( 1, I ), LDT,
1.1 bertrand 359: $ A( 1, I ), LDA, B, LDB, WORK, M )
360: END DO
361: *
362: END IF
363: *
364: RETURN
365: *
366: * End of DTPMQRT
367: *
368: 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