1: *> \brief \b DORHR_COL
2: *
3: * =========== DOCUMENTATION ===========
4: *
5: * Online html documentation available at
6: * http://www.netlib.org/lapack/explore-html/
7: *
8: *> \htmlonly
9: *> Download DORHR_COL + dependencies
10: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorhr_col.f">
11: *> [TGZ]</a>
12: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorhr_col.f">
13: *> [ZIP]</a>
14: *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorhr_col.f">
15: *> [TXT]</a>
16: *> \endhtmlonly
17: *
18: * Definition:
19: * ===========
20: *
21: * SUBROUTINE DORHR_COL( M, N, NB, A, LDA, T, LDT, D, INFO )
22: *
23: * .. Scalar Arguments ..
24: * INTEGER INFO, LDA, LDT, M, N, NB
25: * ..
26: * .. Array Arguments ..
27: * DOUBLE PRECISION A( LDA, * ), D( * ), T( LDT, * )
28: * ..
29: *
30: *> \par Purpose:
31: * =============
32: *>
33: *> \verbatim
34: *>
35: *> DORHR_COL takes an M-by-N real matrix Q_in with orthonormal columns
36: *> as input, stored in A, and performs Householder Reconstruction (HR),
37: *> i.e. reconstructs Householder vectors V(i) implicitly representing
38: *> another M-by-N matrix Q_out, with the property that Q_in = Q_out*S,
39: *> where S is an N-by-N diagonal matrix with diagonal entries
40: *> equal to +1 or -1. The Householder vectors (columns V(i) of V) are
41: *> stored in A on output, and the diagonal entries of S are stored in D.
42: *> Block reflectors are also returned in T
43: *> (same output format as DGEQRT).
44: *> \endverbatim
45: *
46: * Arguments:
47: * ==========
48: *
49: *> \param[in] M
50: *> \verbatim
51: *> M is INTEGER
52: *> The number of rows of the matrix A. M >= 0.
53: *> \endverbatim
54: *>
55: *> \param[in] N
56: *> \verbatim
57: *> N is INTEGER
58: *> The number of columns of the matrix A. M >= N >= 0.
59: *> \endverbatim
60: *>
61: *> \param[in] NB
62: *> \verbatim
63: *> NB is INTEGER
64: *> The column block size to be used in the reconstruction
65: *> of Householder column vector blocks in the array A and
66: *> corresponding block reflectors in the array T. NB >= 1.
67: *> (Note that if NB > N, then N is used instead of NB
68: *> as the column block size.)
69: *> \endverbatim
70: *>
71: *> \param[in,out] A
72: *> \verbatim
73: *> A is DOUBLE PRECISION array, dimension (LDA,N)
74: *>
75: *> On entry:
76: *>
77: *> The array A contains an M-by-N orthonormal matrix Q_in,
78: *> i.e the columns of A are orthogonal unit vectors.
79: *>
80: *> On exit:
81: *>
82: *> The elements below the diagonal of A represent the unit
83: *> lower-trapezoidal matrix V of Householder column vectors
84: *> V(i). The unit diagonal entries of V are not stored
85: *> (same format as the output below the diagonal in A from
86: *> DGEQRT). The matrix T and the matrix V stored on output
87: *> in A implicitly define Q_out.
88: *>
89: *> The elements above the diagonal contain the factor U
90: *> of the "modified" LU-decomposition:
91: *> Q_in - ( S ) = V * U
92: *> ( 0 )
93: *> where 0 is a (M-N)-by-(M-N) zero matrix.
94: *> \endverbatim
95: *>
96: *> \param[in] LDA
97: *> \verbatim
98: *> LDA is INTEGER
99: *> The leading dimension of the array A. LDA >= max(1,M).
100: *> \endverbatim
101: *>
102: *> \param[out] T
103: *> \verbatim
104: *> T is DOUBLE PRECISION array,
105: *> dimension (LDT, N)
106: *>
107: *> Let NOCB = Number_of_output_col_blocks
108: *> = CEIL(N/NB)
109: *>
110: *> On exit, T(1:NB, 1:N) contains NOCB upper-triangular
111: *> block reflectors used to define Q_out stored in compact
112: *> form as a sequence of upper-triangular NB-by-NB column
113: *> blocks (same format as the output T in DGEQRT).
114: *> The matrix T and the matrix V stored on output in A
115: *> implicitly define Q_out. NOTE: The lower triangles
116: *> below the upper-triangular blocks will be filled with
117: *> zeros. See Further Details.
118: *> \endverbatim
119: *>
120: *> \param[in] LDT
121: *> \verbatim
122: *> LDT is INTEGER
123: *> The leading dimension of the array T.
124: *> LDT >= max(1,min(NB,N)).
125: *> \endverbatim
126: *>
127: *> \param[out] D
128: *> \verbatim
129: *> D is DOUBLE PRECISION array, dimension min(M,N).
130: *> The elements can be only plus or minus one.
131: *>
132: *> D(i) is constructed as D(i) = -SIGN(Q_in_i(i,i)), where
133: *> 1 <= i <= min(M,N), and Q_in_i is Q_in after performing
134: *> i-1 steps of “modified” Gaussian elimination.
135: *> See Further Details.
136: *> \endverbatim
137: *>
138: *> \param[out] INFO
139: *> \verbatim
140: *> INFO is INTEGER
141: *> = 0: successful exit
142: *> < 0: if INFO = -i, the i-th argument had an illegal value
143: *> \endverbatim
144: *>
145: *> \par Further Details:
146: * =====================
147: *>
148: *> \verbatim
149: *>
150: *> The computed M-by-M orthogonal factor Q_out is defined implicitly as
151: *> a product of orthogonal matrices Q_out(i). Each Q_out(i) is stored in
152: *> the compact WY-representation format in the corresponding blocks of
153: *> matrices V (stored in A) and T.
154: *>
155: *> The M-by-N unit lower-trapezoidal matrix V stored in the M-by-N
156: *> matrix A contains the column vectors V(i) in NB-size column
157: *> blocks VB(j). For example, VB(1) contains the columns
158: *> V(1), V(2), ... V(NB). NOTE: The unit entries on
159: *> the diagonal of Y are not stored in A.
160: *>
161: *> The number of column blocks is
162: *>
163: *> NOCB = Number_of_output_col_blocks = CEIL(N/NB)
164: *>
165: *> where each block is of order NB except for the last block, which
166: *> is of order LAST_NB = N - (NOCB-1)*NB.
167: *>
168: *> For example, if M=6, N=5 and NB=2, the matrix V is
169: *>
170: *>
171: *> V = ( VB(1), VB(2), VB(3) ) =
172: *>
173: *> = ( 1 )
174: *> ( v21 1 )
175: *> ( v31 v32 1 )
176: *> ( v41 v42 v43 1 )
177: *> ( v51 v52 v53 v54 1 )
178: *> ( v61 v62 v63 v54 v65 )
179: *>
180: *>
181: *> For each of the column blocks VB(i), an upper-triangular block
182: *> reflector TB(i) is computed. These blocks are stored as
183: *> a sequence of upper-triangular column blocks in the NB-by-N
184: *> matrix T. The size of each TB(i) block is NB-by-NB, except
185: *> for the last block, whose size is LAST_NB-by-LAST_NB.
186: *>
187: *> For example, if M=6, N=5 and NB=2, the matrix T is
188: *>
189: *> T = ( TB(1), TB(2), TB(3) ) =
190: *>
191: *> = ( t11 t12 t13 t14 t15 )
192: *> ( t22 t24 )
193: *>
194: *>
195: *> The M-by-M factor Q_out is given as a product of NOCB
196: *> orthogonal M-by-M matrices Q_out(i).
197: *>
198: *> Q_out = Q_out(1) * Q_out(2) * ... * Q_out(NOCB),
199: *>
200: *> where each matrix Q_out(i) is given by the WY-representation
201: *> using corresponding blocks from the matrices V and T:
202: *>
203: *> Q_out(i) = I - VB(i) * TB(i) * (VB(i))**T,
204: *>
205: *> where I is the identity matrix. Here is the formula with matrix
206: *> dimensions:
207: *>
208: *> Q(i){M-by-M} = I{M-by-M} -
209: *> VB(i){M-by-INB} * TB(i){INB-by-INB} * (VB(i))**T {INB-by-M},
210: *>
211: *> where INB = NB, except for the last block NOCB
212: *> for which INB=LAST_NB.
213: *>
214: *> =====
215: *> NOTE:
216: *> =====
217: *>
218: *> If Q_in is the result of doing a QR factorization
219: *> B = Q_in * R_in, then:
220: *>
221: *> B = (Q_out*S) * R_in = Q_out * (S * R_in) = Q_out * R_out.
222: *>
223: *> So if one wants to interpret Q_out as the result
224: *> of the QR factorization of B, then the corresponding R_out
225: *> should be equal to R_out = S * R_in, i.e. some rows of R_in
226: *> should be multiplied by -1.
227: *>
228: *> For the details of the algorithm, see [1].
229: *>
230: *> [1] "Reconstructing Householder vectors from tall-skinny QR",
231: *> G. Ballard, J. Demmel, L. Grigori, M. Jacquelin, H.D. Nguyen,
232: *> E. Solomonik, J. Parallel Distrib. Comput.,
233: *> vol. 85, pp. 3-31, 2015.
234: *> \endverbatim
235: *>
236: * Authors:
237: * ========
238: *
239: *> \author Univ. of Tennessee
240: *> \author Univ. of California Berkeley
241: *> \author Univ. of Colorado Denver
242: *> \author NAG Ltd.
243: *
244: *> \ingroup doubleOTHERcomputational
245: *
246: *> \par Contributors:
247: * ==================
248: *>
249: *> \verbatim
250: *>
251: *> November 2019, Igor Kozachenko,
252: *> Computer Science Division,
253: *> University of California, Berkeley
254: *>
255: *> \endverbatim
256: *
257: * =====================================================================
258: SUBROUTINE DORHR_COL( M, N, NB, A, LDA, T, LDT, D, INFO )
259: IMPLICIT NONE
260: *
261: * -- LAPACK computational routine --
262: * -- LAPACK is a software package provided by Univ. of Tennessee, --
263: * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
264: *
265: * .. Scalar Arguments ..
266: INTEGER INFO, LDA, LDT, M, N, NB
267: * ..
268: * .. Array Arguments ..
269: DOUBLE PRECISION A( LDA, * ), D( * ), T( LDT, * )
270: * ..
271: *
272: * =====================================================================
273: *
274: * .. Parameters ..
275: DOUBLE PRECISION ONE, ZERO
276: PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
277: * ..
278: * .. Local Scalars ..
279: INTEGER I, IINFO, J, JB, JBTEMP1, JBTEMP2, JNB,
280: $ NPLUSONE
281: * ..
282: * .. External Subroutines ..
283: EXTERNAL DCOPY, DLAORHR_COL_GETRFNP, DSCAL, DTRSM,
284: $ XERBLA
285: * ..
286: * .. Intrinsic Functions ..
287: INTRINSIC MAX, MIN
288: * ..
289: * .. Executable Statements ..
290: *
291: * Test the input parameters
292: *
293: INFO = 0
294: IF( M.LT.0 ) THEN
295: INFO = -1
296: ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
297: INFO = -2
298: ELSE IF( NB.LT.1 ) THEN
299: INFO = -3
300: ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
301: INFO = -5
302: ELSE IF( LDT.LT.MAX( 1, MIN( NB, N ) ) ) THEN
303: INFO = -7
304: END IF
305: *
306: * Handle error in the input parameters.
307: *
308: IF( INFO.NE.0 ) THEN
309: CALL XERBLA( 'DORHR_COL', -INFO )
310: RETURN
311: END IF
312: *
313: * Quick return if possible
314: *
315: IF( MIN( M, N ).EQ.0 ) THEN
316: RETURN
317: END IF
318: *
319: * On input, the M-by-N matrix A contains the orthogonal
320: * M-by-N matrix Q_in.
321: *
322: * (1) Compute the unit lower-trapezoidal V (ones on the diagonal
323: * are not stored) by performing the "modified" LU-decomposition.
324: *
325: * Q_in - ( S ) = V * U = ( V1 ) * U,
326: * ( 0 ) ( V2 )
327: *
328: * where 0 is an (M-N)-by-N zero matrix.
329: *
330: * (1-1) Factor V1 and U.
331:
332: CALL DLAORHR_COL_GETRFNP( N, N, A, LDA, D, IINFO )
333: *
334: * (1-2) Solve for V2.
335: *
336: IF( M.GT.N ) THEN
337: CALL DTRSM( 'R', 'U', 'N', 'N', M-N, N, ONE, A, LDA,
338: $ A( N+1, 1 ), LDA )
339: END IF
340: *
341: * (2) Reconstruct the block reflector T stored in T(1:NB, 1:N)
342: * as a sequence of upper-triangular blocks with NB-size column
343: * blocking.
344: *
345: * Loop over the column blocks of size NB of the array A(1:M,1:N)
346: * and the array T(1:NB,1:N), JB is the column index of a column
347: * block, JNB is the column block size at each step JB.
348: *
349: NPLUSONE = N + 1
350: DO JB = 1, N, NB
351: *
352: * (2-0) Determine the column block size JNB.
353: *
354: JNB = MIN( NPLUSONE-JB, NB )
355: *
356: * (2-1) Copy the upper-triangular part of the current JNB-by-JNB
357: * diagonal block U(JB) (of the N-by-N matrix U) stored
358: * in A(JB:JB+JNB-1,JB:JB+JNB-1) into the upper-triangular part
359: * of the current JNB-by-JNB block T(1:JNB,JB:JB+JNB-1)
360: * column-by-column, total JNB*(JNB+1)/2 elements.
361: *
362: JBTEMP1 = JB - 1
363: DO J = JB, JB+JNB-1
364: CALL DCOPY( J-JBTEMP1, A( JB, J ), 1, T( 1, J ), 1 )
365: END DO
366: *
367: * (2-2) Perform on the upper-triangular part of the current
368: * JNB-by-JNB diagonal block U(JB) (of the N-by-N matrix U) stored
369: * in T(1:JNB,JB:JB+JNB-1) the following operation in place:
370: * (-1)*U(JB)*S(JB), i.e the result will be stored in the upper-
371: * triangular part of T(1:JNB,JB:JB+JNB-1). This multiplication
372: * of the JNB-by-JNB diagonal block U(JB) by the JNB-by-JNB
373: * diagonal block S(JB) of the N-by-N sign matrix S from the
374: * right means changing the sign of each J-th column of the block
375: * U(JB) according to the sign of the diagonal element of the block
376: * S(JB), i.e. S(J,J) that is stored in the array element D(J).
377: *
378: DO J = JB, JB+JNB-1
379: IF( D( J ).EQ.ONE ) THEN
380: CALL DSCAL( J-JBTEMP1, -ONE, T( 1, J ), 1 )
381: END IF
382: END DO
383: *
384: * (2-3) Perform the triangular solve for the current block
385: * matrix X(JB):
386: *
387: * X(JB) * (A(JB)**T) = B(JB), where:
388: *
389: * A(JB)**T is a JNB-by-JNB unit upper-triangular
390: * coefficient block, and A(JB)=V1(JB), which
391: * is a JNB-by-JNB unit lower-triangular block
392: * stored in A(JB:JB+JNB-1,JB:JB+JNB-1).
393: * The N-by-N matrix V1 is the upper part
394: * of the M-by-N lower-trapezoidal matrix V
395: * stored in A(1:M,1:N);
396: *
397: * B(JB) is a JNB-by-JNB upper-triangular right-hand
398: * side block, B(JB) = (-1)*U(JB)*S(JB), and
399: * B(JB) is stored in T(1:JNB,JB:JB+JNB-1);
400: *
401: * X(JB) is a JNB-by-JNB upper-triangular solution
402: * block, X(JB) is the upper-triangular block
403: * reflector T(JB), and X(JB) is stored
404: * in T(1:JNB,JB:JB+JNB-1).
405: *
406: * In other words, we perform the triangular solve for the
407: * upper-triangular block T(JB):
408: *
409: * T(JB) * (V1(JB)**T) = (-1)*U(JB)*S(JB).
410: *
411: * Even though the blocks X(JB) and B(JB) are upper-
412: * triangular, the routine DTRSM will access all JNB**2
413: * elements of the square T(1:JNB,JB:JB+JNB-1). Therefore,
414: * we need to set to zero the elements of the block
415: * T(1:JNB,JB:JB+JNB-1) below the diagonal before the call
416: * to DTRSM.
417: *
418: * (2-3a) Set the elements to zero.
419: *
420: JBTEMP2 = JB - 2
421: DO J = JB, JB+JNB-2
422: DO I = J-JBTEMP2, NB
423: T( I, J ) = ZERO
424: END DO
425: END DO
426: *
427: * (2-3b) Perform the triangular solve.
428: *
429: CALL DTRSM( 'R', 'L', 'T', 'U', JNB, JNB, ONE,
430: $ A( JB, JB ), LDA, T( 1, JB ), LDT )
431: *
432: END DO
433: *
434: RETURN
435: *
436: * End of DORHR_COL
437: *
438: END
CVSweb interface <joel.bertrand@systella.fr>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to dorhr_col.f CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [local] / rpl / lapack / lapack