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
439