1*> \brief \b DORBDB2
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download DORBDB2 + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb2.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb2.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb2.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
22*                           TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
23*
24*       .. Scalar Arguments ..
25*       INTEGER            INFO, LWORK, M, P, Q, LDX11, LDX21
26*       ..
27*       .. Array Arguments ..
28*       DOUBLE PRECISION   PHI(*), THETA(*)
29*       DOUBLE PRECISION   TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
30*      $                   X11(LDX11,*), X21(LDX21,*)
31*       ..
32*
33*
34*> \par Purpose:
35*  =============
36*>
37*>\verbatim
38*>
39*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
40*> matrix X with orthonomal columns:
41*>
42*>                            [ B11 ]
43*>      [ X11 ]   [ P1 |    ] [  0  ]
44*>      [-----] = [---------] [-----] Q1**T .
45*>      [ X21 ]   [    | P2 ] [ B21 ]
46*>                            [  0  ]
47*>
48*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
49*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in
50*> which P is not the minimum dimension.
51*>
52*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
53*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
54*> Householder vectors.
55*>
56*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
57*> angles THETA, PHI.
58*>
59*>\endverbatim
60*
61*  Arguments:
62*  ==========
63*
64*> \param[in] M
65*> \verbatim
66*>          M is INTEGER
67*>           The number of rows X11 plus the number of rows in X21.
68*> \endverbatim
69*>
70*> \param[in] P
71*> \verbatim
72*>          P is INTEGER
73*>           The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
74*> \endverbatim
75*>
76*> \param[in] Q
77*> \verbatim
78*>          Q is INTEGER
79*>           The number of columns in X11 and X21. 0 <= Q <= M.
80*> \endverbatim
81*>
82*> \param[in,out] X11
83*> \verbatim
84*>          X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
85*>           On entry, the top block of the matrix X to be reduced. On
86*>           exit, the columns of tril(X11) specify reflectors for P1 and
87*>           the rows of triu(X11,1) specify reflectors for Q1.
88*> \endverbatim
89*>
90*> \param[in] LDX11
91*> \verbatim
92*>          LDX11 is INTEGER
93*>           The leading dimension of X11. LDX11 >= P.
94*> \endverbatim
95*>
96*> \param[in,out] X21
97*> \verbatim
98*>          X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
99*>           On entry, the bottom block of the matrix X to be reduced. On
100*>           exit, the columns of tril(X21) specify reflectors for P2.
101*> \endverbatim
102*>
103*> \param[in] LDX21
104*> \verbatim
105*>          LDX21 is INTEGER
106*>           The leading dimension of X21. LDX21 >= M-P.
107*> \endverbatim
108*>
109*> \param[out] THETA
110*> \verbatim
111*>          THETA is DOUBLE PRECISION array, dimension (Q)
112*>           The entries of the bidiagonal blocks B11, B21 are defined by
113*>           THETA and PHI. See Further Details.
114*> \endverbatim
115*>
116*> \param[out] PHI
117*> \verbatim
118*>          PHI is DOUBLE PRECISION array, dimension (Q-1)
119*>           The entries of the bidiagonal blocks B11, B21 are defined by
120*>           THETA and PHI. See Further Details.
121*> \endverbatim
122*>
123*> \param[out] TAUP1
124*> \verbatim
125*>          TAUP1 is DOUBLE PRECISION array, dimension (P)
126*>           The scalar factors of the elementary reflectors that define
127*>           P1.
128*> \endverbatim
129*>
130*> \param[out] TAUP2
131*> \verbatim
132*>          TAUP2 is DOUBLE PRECISION array, dimension (M-P)
133*>           The scalar factors of the elementary reflectors that define
134*>           P2.
135*> \endverbatim
136*>
137*> \param[out] TAUQ1
138*> \verbatim
139*>          TAUQ1 is DOUBLE PRECISION array, dimension (Q)
140*>           The scalar factors of the elementary reflectors that define
141*>           Q1.
142*> \endverbatim
143*>
144*> \param[out] WORK
145*> \verbatim
146*>          WORK is DOUBLE PRECISION array, dimension (LWORK)
147*> \endverbatim
148*>
149*> \param[in] LWORK
150*> \verbatim
151*>          LWORK is INTEGER
152*>           The dimension of the array WORK. LWORK >= M-Q.
153*>
154*>           If LWORK = -1, then a workspace query is assumed; the routine
155*>           only calculates the optimal size of the WORK array, returns
156*>           this value as the first entry of the WORK array, and no error
157*>           message related to LWORK is issued by XERBLA.
158*> \endverbatim
159*>
160*> \param[out] INFO
161*> \verbatim
162*>          INFO is INTEGER
163*>           = 0:  successful exit.
164*>           < 0:  if INFO = -i, the i-th argument had an illegal value.
165*> \endverbatim
166*>
167*
168*  Authors:
169*  ========
170*
171*> \author Univ. of Tennessee
172*> \author Univ. of California Berkeley
173*> \author Univ. of Colorado Denver
174*> \author NAG Ltd.
175*
176*> \ingroup doubleOTHERcomputational
177*
178*> \par Further Details:
179*  =====================
180*>
181*> \verbatim
182*>
183*>  The upper-bidiagonal blocks B11, B21 are represented implicitly by
184*>  angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
185*>  in each bidiagonal band is a product of a sine or cosine of a THETA
186*>  with a sine or cosine of a PHI. See [1] or DORCSD for details.
187*>
188*>  P1, P2, and Q1 are represented as products of elementary reflectors.
189*>  See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
190*>  and DORGLQ.
191*> \endverbatim
192*
193*> \par References:
194*  ================
195*>
196*>  [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
197*>      Algorithms, 50(1):33-65, 2009.
198*>
199*  =====================================================================
200      SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
201     $                    TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
202*
203*  -- LAPACK computational routine --
204*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
205*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
206*
207*     .. Scalar Arguments ..
208      INTEGER            INFO, LWORK, M, P, Q, LDX11, LDX21
209*     ..
210*     .. Array Arguments ..
211      DOUBLE PRECISION   PHI(*), THETA(*)
212      DOUBLE PRECISION   TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
213     $                   X11(LDX11,*), X21(LDX21,*)
214*     ..
215*
216*  ====================================================================
217*
218*     .. Parameters ..
219      DOUBLE PRECISION   NEGONE, ONE
220      PARAMETER          ( NEGONE = -1.0D0, ONE = 1.0D0 )
221*     ..
222*     .. Local Scalars ..
223      DOUBLE PRECISION   C, S
224      INTEGER            CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
225     $                   LWORKMIN, LWORKOPT
226      LOGICAL            LQUERY
227*     ..
228*     .. External Subroutines ..
229      EXTERNAL           DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
230*     ..
231*     .. External Functions ..
232      DOUBLE PRECISION   DNRM2
233      EXTERNAL           DNRM2
234*     ..
235*     .. Intrinsic Function ..
236      INTRINSIC          ATAN2, COS, MAX, SIN, SQRT
237*     ..
238*     .. Executable Statements ..
239*
240*     Test input arguments
241*
242      INFO = 0
243      LQUERY = LWORK .EQ. -1
244*
245      IF( M .LT. 0 ) THEN
246         INFO = -1
247      ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
248         INFO = -2
249      ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
250         INFO = -3
251      ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
252         INFO = -5
253      ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
254         INFO = -7
255      END IF
256*
257*     Compute workspace
258*
259      IF( INFO .EQ. 0 ) THEN
260         ILARF = 2
261         LLARF = MAX( P-1, M-P, Q-1 )
262         IORBDB5 = 2
263         LORBDB5 = Q-1
264         LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
265         LWORKMIN = LWORKOPT
266         WORK(1) = LWORKOPT
267         IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
268           INFO = -14
269         END IF
270      END IF
271      IF( INFO .NE. 0 ) THEN
272         CALL XERBLA( 'DORBDB2', -INFO )
273         RETURN
274      ELSE IF( LQUERY ) THEN
275         RETURN
276      END IF
277*
278*     Reduce rows 1, ..., P of X11 and X21
279*
280      DO I = 1, P
281*
282         IF( I .GT. 1 ) THEN
283            CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
284         END IF
285         CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
286         C = X11(I,I)
287         X11(I,I) = ONE
288         CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
289     $               X11(I+1,I), LDX11, WORK(ILARF) )
290         CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
291     $               X21(I,I), LDX21, WORK(ILARF) )
292         S = SQRT( DNRM2( P-I, X11(I+1,I), 1 )**2
293     $           + DNRM2( M-P-I+1, X21(I,I), 1 )**2 )
294         THETA(I) = ATAN2( S, C )
295*
296         CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
297     $                 X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
298     $                 WORK(IORBDB5), LORBDB5, CHILDINFO )
299         CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 )
300         CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
301         IF( I .LT. P ) THEN
302            CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
303            PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
304            C = COS( PHI(I) )
305            S = SIN( PHI(I) )
306            X11(I+1,I) = ONE
307            CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
308     $                  X11(I+1,I+1), LDX11, WORK(ILARF) )
309         END IF
310         X21(I,I) = ONE
311         CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
312     $               X21(I,I+1), LDX21, WORK(ILARF) )
313*
314      END DO
315*
316*     Reduce the bottom-right portion of X21 to the identity matrix
317*
318      DO I = P + 1, Q
319         CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
320         X21(I,I) = ONE
321         CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
322     $               X21(I,I+1), LDX21, WORK(ILARF) )
323      END DO
324*
325      RETURN
326*
327*     End of DORBDB2
328*
329      END
330
331