1*> \brief \b SORBDB3
2*
3*  =========== DOCUMENTATION ===========
4*
5* Online html documentation available at
6*            http://www.netlib.org/lapack/explore-html/
7*
8*> \htmlonly
9*> Download SORBDB3 + dependencies
10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb3.f">
11*> [TGZ]</a>
12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb3.f">
13*> [ZIP]</a>
14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb3.f">
15*> [TXT]</a>
16*> \endhtmlonly
17*
18*  Definition:
19*  ===========
20*
21*       SUBROUTINE SORBDB3( 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*       REAL               PHI(*), THETA(*)
29*       REAL               TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
30*      $                   X11(LDX11,*), X21(LDX21,*)
31*       ..
32*
33*
34*> \par Purpose:
35*  =============
36*>
37*>\verbatim
38*>
39*> SORBDB3 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. M-P must be no larger than P,
49*> Q, or M-Q. Routines SORBDB1, SORBDB2, and SORBDB4 handle cases in
50*> which M-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 (M-P)-by-(M-P) bidiagonal matrices represented
57*> implicitly by 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 <= M. M-P <= min(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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 REAL 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 realOTHERcomputational
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 SORCSD for details.
187*>
188*>  P1, P2, and Q1 are represented as products of elementary reflectors.
189*>  See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
190*>  and SORGLQ.
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 SORBDB3( 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      REAL               PHI(*), THETA(*)
212      REAL               TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
213     $                   X11(LDX11,*), X21(LDX21,*)
214*     ..
215*
216*  ====================================================================
217*
218*     .. Parameters ..
219      REAL               ONE
220      PARAMETER          ( ONE = 1.0E0 )
221*     ..
222*     .. Local Scalars ..
223      REAL               C, S
224      INTEGER            CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
225     $                   LWORKMIN, LWORKOPT
226      LOGICAL            LQUERY
227*     ..
228*     .. External Subroutines ..
229      EXTERNAL           SLARF, SLARFGP, SORBDB5, SROT, XERBLA
230*     ..
231*     .. External Functions ..
232      REAL               SNRM2
233      EXTERNAL           SNRM2
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( 2*P .LT. M .OR. P .GT. M ) THEN
248         INFO = -2
249      ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-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, M-P-1, 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( 'SORBDB3', -INFO )
273         RETURN
274      ELSE IF( LQUERY ) THEN
275         RETURN
276      END IF
277*
278*     Reduce rows 1, ..., M-P of X11 and X21
279*
280      DO I = 1, M-P
281*
282         IF( I .GT. 1 ) THEN
283            CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
284         END IF
285*
286         CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
287         S = X21(I,I)
288         X21(I,I) = ONE
289         CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
290     $               X11(I,I), LDX11, WORK(ILARF) )
291         CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
292     $               X21(I+1,I), LDX21, WORK(ILARF) )
293         C = SQRT( SNRM2( P-I+1, X11(I,I), 1 )**2
294     $           + SNRM2( M-P-I, X21(I+1,I), 1 )**2 )
295         THETA(I) = ATAN2( S, C )
296*
297         CALL SORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
298     $                 X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
299     $                 WORK(IORBDB5), LORBDB5, CHILDINFO )
300         CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
301         IF( I .LT. M-P ) THEN
302            CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
303            PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
304            C = COS( PHI(I) )
305            S = SIN( PHI(I) )
306            X21(I+1,I) = ONE
307            CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
308     $                  X21(I+1,I+1), LDX21, WORK(ILARF) )
309         END IF
310         X11(I,I) = ONE
311         CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
312     $               LDX11, WORK(ILARF) )
313*
314      END DO
315*
316*     Reduce the bottom-right portion of X11 to the identity matrix
317*
318      DO I = M-P + 1, Q
319         CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
320         X11(I,I) = ONE
321         CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
322     $               LDX11, WORK(ILARF) )
323      END DO
324*
325      RETURN
326*
327*     End of SORBDB3
328*
329      END
330
331