All the routines from the SRC folder have been updated to integrate the current Doxygen layout.
Everything seems to be fine, all tests passed without problem.
stfttr.f stpttf.f stpttr.f strttf.f strttp.f
sgejsv.f sgesvj.f sgsvj0.f sgsvj1.f
sgeequb.f ssyequb.f spoequb.f sgbequb.f
- sbbcsd.f slapmr.f sorbdb.f sorcsd.f
+ sbbcsd.f slapmr.f sorbdb.f sorbdb1.f sorbdb2.f sorbdb3.f sorbdb4.f
+ sorbdb5.f sorbdb6.f sorcsd.f sorcsd2by1.f
sgeqrt.f sgeqrt2.f sgeqrt3.f sgemqrt.f
stpqrt.f stpqrt2.f stpmqrt.f stprfb.f
)
chfrk.f ctfttp.f clanhf.f cpftrf.f cpftri.f cpftrs.f ctfsm.f ctftri.f
ctfttr.f ctpttf.f ctpttr.f ctrttf.f ctrttp.f
cgeequb.f cgbequb.f csyequb.f cpoequb.f cheequb.f
- cbbcsd.f clapmr.f cunbdb.f cuncsd.f
+ cbbcsd.f clapmr.f cunbdb.f cunbdb1.f cunbdb2.f cunbdb3.f cunbdb4.f
+ cunbdb5.f cunbdb6.f cuncsd.f cuncsd2by1.f
cgeqrt.f cgeqrt2.f cgeqrt3.f cgemqrt.f
ctpqrt.f ctpqrt2.f ctpmqrt.f ctprfb.f)
dtfttr.f dtpttf.f dtpttr.f dtrttf.f dtrttp.f
dgejsv.f dgesvj.f dgsvj0.f dgsvj1.f
dgeequb.f dsyequb.f dpoequb.f dgbequb.f
- dbbcsd.f dlapmr.f dorbdb.f dorcsd.f
+ dbbcsd.f dlapmr.f dorbdb.f dorbdb1.f dorbdb2.f dorbdb3.f dorbdb4.f
+ dorbdb5.f dorbdb6.f dorcsd.f dorcsd2by1.f
dgeqrt.f dgeqrt2.f dgeqrt3.f dgemqrt.f
dtpqrt.f dtpqrt2.f dtpmqrt.f dtprfb.f )
zhfrk.f ztfttp.f zlanhf.f zpftrf.f zpftri.f zpftrs.f ztfsm.f ztftri.f
ztfttr.f ztpttf.f ztpttr.f ztrttf.f ztrttp.f
zgeequb.f zgbequb.f zsyequb.f zpoequb.f zheequb.f
- zbbcsd.f zlapmr.f zunbdb.f zuncsd.f
+ zbbcsd.f zlapmr.f zunbdb.f zunbdb1.f zunbdb2.f zunbdb3.f zunbdb4.f
+ zunbdb5.f zunbdb6.f zuncsd.f zuncsd2by1.f
zgeqrt.f zgeqrt2.f zgeqrt3.f zgemqrt.f
ztpqrt.f ztpqrt2.f ztpmqrt.f ztprfb.f)
stfttr.o stpttf.o stpttr.o strttf.o strttp.o \
sgejsv.o sgesvj.o sgsvj0.o sgsvj1.o \
sgeequb.o ssyequb.o spoequb.o sgbequb.o \
- sbbcsd.o slapmr.o sorbdb.o sorcsd.o \
+ sbbcsd.o slapmr.o sorbdb.o sorbdb1.o sorbdb2.o sorbdb3.o sorbdb4.o \
+ sorbdb5.o sorbdb6.o sorcsd.o sorcsd2by1.o \
sgeqrt.o sgeqrt2.o sgeqrt3.o sgemqrt.o \
stpqrt.o stpqrt2.o stpmqrt.o stprfb.o
chfrk.o ctfttp.o clanhf.o cpftrf.o cpftri.o cpftrs.o ctfsm.o ctftri.o \
ctfttr.o ctpttf.o ctpttr.o ctrttf.o ctrttp.o \
cgeequb.o cgbequb.o csyequb.o cpoequb.o cheequb.o \
- cbbcsd.o clapmr.o cunbdb.o cuncsd.o \
+ cbbcsd.o clapmr.o cunbdb.o cunbdb1.o cunbdb2.o cunbdb3.o cunbdb4.o \
+ cunbdb5.o cunbdb6.o cuncsd.o cuncsd2by1.o \
cgeqrt.o cgeqrt2.o cgeqrt3.o cgemqrt.o \
ctpqrt.o ctpqrt2.o ctpmqrt.o ctprfb.o
dtfttr.o dtpttf.o dtpttr.o dtrttf.o dtrttp.o \
dgejsv.o dgesvj.o dgsvj0.o dgsvj1.o \
dgeequb.o dsyequb.o dpoequb.o dgbequb.o \
- dbbcsd.o dlapmr.o dorbdb.o dorcsd.o \
+ dbbcsd.o dlapmr.o dorbdb.o dorbdb1.o dorbdb2.o dorbdb3.o dorbdb4.o \
+ dorbdb5.o dorbdb6.o dorcsd.o dorcsd2by1.o \
dgeqrt.o dgeqrt2.o dgeqrt3.o dgemqrt.o \
dtpqrt.o dtpqrt2.o dtpmqrt.o dtprfb.o
zhfrk.o ztfttp.o zlanhf.o zpftrf.o zpftri.o zpftrs.o ztfsm.o ztftri.o \
ztfttr.o ztpttf.o ztpttr.o ztrttf.o ztrttp.o \
zgeequb.o zgbequb.o zsyequb.o zpoequb.o zheequb.o \
- zbbcsd.o zlapmr.o zunbdb.o zuncsd.o \
+ zbbcsd.o zlapmr.o zunbdb.o zunbdb1.o zunbdb2.o zunbdb3.o zunbdb4.o \
+ zunbdb5.o zunbdb6.o zuncsd.o zuncsd2by1.o \
zgeqrt.o zgeqrt2.o zgeqrt3.o zgemqrt.o \
ztpqrt.o ztpqrt2.o ztpmqrt.o ztprfb.o
--- /dev/null
+*> \brief \b CUNBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines CUNBDB2, CUNBDB3, and CUNBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = (1.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
+ EXTERNAL CLACGV
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( REAL( X21(I,I) ), REAL( X11(I,I) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL CSROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
+ $ S )
+ CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
+ CALL CLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = REAL( X21(I,I+1) )
+ X21(I,I+1) = ONE
+ CALL CLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I, X21(I,I+1), LDX21 )
+ C = SQRT( SCNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL CUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB1
+*
+ END
+
--- /dev/null
+*> \brief \b CUNBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb2.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines CUNBDB1, CUNBDB3, and CUNBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX NEGONE, ONE
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0),
+ $ ONE = (1.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
+ $ S )
+ END IF
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = REAL( X11(I,I) )
+ X11(I,I) = ONE
+ CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SCNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL CUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL CSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL CLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( REAL( X11(I+1,I) ), REAL( X21(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL CLARF( 'L', P-I, Q-I, X11(I+1,I), 1, CONJG(TAUP1(I)),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL CLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL CLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, CONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB2
+*
+ END
+
--- /dev/null
+*> \brief \b CUNBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines CUNBDB1, CUNBDB2, and CUNBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE
+ PARAMETER ( ONE = (1.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL CSROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
+ $ S )
+ END IF
+*
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = REAL( X21(I,I) )
+ X21(I,I) = ONE
+ CALL CLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ C = SQRT( SCNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL CUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL CLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( REAL( X21(I+1,I) ), REAL( X11(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL CLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, CONJG(TAUP2(I)),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL CLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I, X11(I,I), 1, CONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB3
+*
+ END
+
--- /dev/null
+*> \brief \b CUNBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB4 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb4.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb4.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb4.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines CUNBDB1, CUNBDB2, and CUNBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is COMPLEX array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or CUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See CUNCSD2BY1 for details on generating P1, P2, and Q1 using CUNGQR
+*> and CUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.4.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ COMPLEX PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
+ $ ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL CLARF, CLARFGP, CUNBDB5, CSROT, CSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL CUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL CSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL CLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL CLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( REAL( PHANTOM(1) ), REAL( PHANTOM(P+1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL CLARF( 'L', P, Q, PHANTOM(1), 1, CONJG(TAUP1(1)), X11,
+ $ LDX11, WORK(ILARF) )
+ CALL CLARF( 'L', M-P, Q, PHANTOM(P+1), 1, CONJG(TAUP2(1)),
+ $ X21, LDX21, WORK(ILARF) )
+ ELSE
+ CALL CUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL CSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL CLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL CLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( REAL( X11(I,I-1) ), REAL( X21(I,I-1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL CLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ CONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ CONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL CSROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL CLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = REAL( X21(I,I) )
+ X21(I,I) = ONE
+ CALL CLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X21(I,I), LDX21 )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( SCNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SCNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL CLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL CLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL CLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X11(I,I), LDX11 )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ CALL CLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL CLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL CLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB4
+*
+ END
+
--- /dev/null
+*> \brief \b CUNBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB5 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb5.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb5.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb5.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE CUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL CUNBDB6, XERBLA
+* ..
+* .. External Functions ..
+ REAL SCNRM2
+ EXTERNAL SCNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SCNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SCNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of CUNBDB5
+*
+ END
+
--- /dev/null
+*> \brief \b CUNBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNBDB6 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cunbdb6.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cunbdb6.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cunbdb6.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE CUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0,
+ $ REALZERO = 0.0E0 )
+ COMPLEX NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0E0,0.0E0), ONE = (1.0E0,0.0E0),
+ $ ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL CGEMV, CLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL CLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL CGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL CGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL CGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL CGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL CLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of CUNBDB6
+*
+ END
+
--- /dev/null
+*> \brief \b CUNCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download CUNCSD2BY1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/cuncsd2by1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/cuncsd2by1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/cuncsd2by1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+* REAL RWORK(*)
+* REAL THETA(*)
+* COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> CUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX array, dimension (LDX11,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX array, dimension (LDX21,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is COMPLEX array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is COMPLEX array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is COMPLEX array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is COMPLEX array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*> \verbatim
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is REAL array, dimension (MAX(1,LRWORK))
+*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LRWORK
+*> \verbatim
+*> LRWORK is INTEGER
+*> The dimension of the array RWORK.
+*>
+*> If LRWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the RWORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LRWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: CBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*
+*> \par References:
+*> ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complexOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE CUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+ INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+ REAL RWORK(*)
+ REAL THETA(*)
+ COMPLEX U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL CBBCSD, CCOPY, CLACPY, CLAPMR, CLAPMT, CUNBDB1,
+ $ CUNBDB2, CUNBDB3, CUNBDB4, CUNGLQ, CUNGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-----------------------------------------|
+* | LWORKOPT (1) |
+* |-----------------------------------------|
+* | TAUP1 (MAX(1,P)) |
+* | TAUP2 (MAX(1,M-P)) |
+* | TAUQ1 (MAX(1,Q)) |
+* |-----------------------------------------|
+* | CUNBDB WORK | CUNGQR WORK | CUNGLQ WORK |
+* | | | |
+* | | | |
+* | | | |
+* | | | |
+* |-----------------------------------------|
+* RWORK layout:
+* |------------------|
+* | LRWORKOPT (1) |
+* |------------------|
+* | PHI (MAX(1,R-1)) |
+* |------------------|
+* | B11D (R) |
+* | B11E (R-1) |
+* | B12D (R) |
+* | B12E (R-1) |
+* | B21D (R) |
+* | B21E (R-1) |
+* | B22D (R) |
+* | B22E (R-1) |
+* | CBBCSD RWORK |
+* |------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + R
+ IB12D = IB11E + R - 1
+ IB12E = IB12D + R
+ IB21D = IB12E + R - 1
+ IB21E = IB21D + R
+ IB22D = IB21E + R - 1
+ IB22E = IB22D + R
+ IBBCSD = IB22E + R - 1
+ ITAUP1 = 2
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL CUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE
+ CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL CUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ END IF
+ LRWORKMIN = IBBCSD+LBBCSD-1
+ LRWORKOPT = LRWORKMIN
+ RWORK(1) = LRWORKOPT
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'CUNCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL CLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL CUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL CLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL CUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL CLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL CUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL CLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL CLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL CLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL CUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL CLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL CUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL CLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL CUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2,
+ $ U1, LDU1, RWORK(IB11D), RWORK(IB11E),
+ $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D),
+ $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E),
+ $ RWORK(IBBCSD), LBBCSD, CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL CLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL CLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL CUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL CCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL CLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL CUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL CCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL CLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL CUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL CLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL CLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL CLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL CUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL CBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL CLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL CLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of CUNCSD2BY1
+*
+ END
+
--- /dev/null
+*> \brief \b DORBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines DORBDB2, DORBDB3, and DORBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( X21(I,I), X11(I,I) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL DROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
+ CALL DLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = X21(I,I+1)
+ X21(I,I+1) = ONE
+ CALL DLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ C = SQRT( DNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL DORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of DORBDB1
+*
+ END
+
--- /dev/null
+*> \brief \b DORBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb2.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines DORBDB1, DORBDB3, and DORBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION NEGONE, ONE
+ PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
+ END IF
+ CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = X11(I,I)
+ X11(I,I) = ONE
+ CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL DORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL DSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL DLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL DLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL DLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL DLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of DORBDB2
+*
+ END
+
--- /dev/null
+*> \brief \b DORBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines DORBDB1, DORBDB2, and DORBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL DROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
+ END IF
+*
+ CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = X21(I,I)
+ X21(I,I) = ONE
+ CALL DLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ C = SQRT( DNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL DORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL DLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL DLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL DLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of DORBDB3
+*
+ END
+
--- /dev/null
+*> \brief \b DORBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB4 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb4.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb4.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb4.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines DORBDB1, DORBDB2, and DORBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is DOUBLE PRECISION array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is DOUBLE PRECISION array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is DOUBLE PRECISION array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is DOUBLE PRECISION array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or DORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See DORCSD2BY1 for details on generating P1, P2, and Q1 using DORGQR
+*> and DORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ DOUBLE PRECISION PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFGP, DORBDB5, DROT, DSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL DORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL DSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL DLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL DLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL DLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
+ $ WORK(ILARF) )
+ CALL DLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
+ $ LDX21, WORK(ILARF) )
+ ELSE
+ CALL DORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL DSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL DLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL DLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL DLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL DROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL DLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = X21(I,I)
+ X21(I,I) = ONE
+ CALL DLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( DNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL DLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL DLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL DLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL DLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL DLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of DORBDB4
+*
+ END
+
--- /dev/null
+*> \brief \b DORBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB5 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb5.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb5.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb5.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is DOUBLE PRECISION array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is DOUBLE PRECISION array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE DORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORBDB6, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DNRM2
+ EXTERNAL DNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( DNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of DORBDB5
+*
+ END
+
--- /dev/null
+*> \brief \b DORBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORBDB6 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorbdb6.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorbdb6.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorbdb6.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> DORBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is DOUBLE PRECISION array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is DOUBLE PRECISION array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is DOUBLE PRECISION array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is DOUBLE PRECISION array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE DORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0,
+ $ REALZERO = 0.0D0 )
+ DOUBLE PRECISION NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL DLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL DGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL DGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL DGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL DGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL DLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of DORBDB6
+*
+ END
+
--- /dev/null
+*> \brief \b DORCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download DORCSD2BY1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dorcsd2by1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dorcsd2by1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dorcsd2by1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION THETA(*)
+* DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*> Purpose:
+*> ========
+*>
+*> DORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is DOUBLE PRECISION array, dimension (LDX11,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is DOUBLE PRECISION array, dimension (LDX21,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is DOUBLE PRECISION array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is DOUBLE PRECISION array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is DOUBLE PRECISION array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: DBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup doubleOTHERcomputational
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*> \endverbatim
+*>
+* =====================================================================
+ SUBROUTINE DORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK computational routine (3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION THETA(*)
+ DOUBLE PRECISION U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBBCSD, DCOPY, DLACPY, DLAPMR, DLAPMT, DORBDB1,
+ $ DORBDB2, DORBDB3, DORBDB4, DORGLQ, DORGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-------------------------------------------------------|
+* | LWORKOPT (1) |
+* |-------------------------------------------------------|
+* | PHI (MAX(1,R-1)) |
+* |-------------------------------------------------------|
+* | TAUP1 (MAX(1,P)) | B11D (R) |
+* | TAUP2 (MAX(1,M-P)) | B11E (R-1) |
+* | TAUQ1 (MAX(1,Q)) | B12D (R) |
+* |-----------------------------------------| B12E (R-1) |
+* | DORBDB WORK | DORGQR WORK | DORGLQ WORK | B21D (R) |
+* | | | | B21E (R-1) |
+* | | | | B22D (R) |
+* | | | | B22E (R-1) |
+* | | | | DBBCSD WORK |
+* |-------------------------------------------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + R
+ IB12D = IB11E + R - 1
+ IB12E = IB12D + R
+ IB21D = IB12E + R - 1
+ IB21E = IB21D + R
+ IB22D = IB21E + R - 1
+ IB22E = IB22D + R
+ IBBCSD = IB22E + R - 1
+ ITAUP1 = IPHI + MAX( 1, R-1 )
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL DORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE
+ CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL DORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL DORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ END IF
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1,
+ $ IBBCSD+LBBCSD-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1,
+ $ IBBCSD+LBBCSD-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'DORCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL DLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL DORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL DLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL DORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL DLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL DORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL DLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL DLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL DLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL DORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL DLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL DORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL DLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL DORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1,
+ $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL DLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL DLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL DORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL DCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL DLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL DORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL DCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL DLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL DORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL DLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL DLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL DLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL DORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL DBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL DLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL DLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DORCSD2BY1
+*
+ END
+
--- /dev/null
+*> \brief \b SORBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines SORBDB2, SORBDB3, and SORBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( X21(I,I), X11(I,I) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL SROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C, S )
+ CALL SLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = X21(I,I+1)
+ X21(I,I+1) = ONE
+ CALL SLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ C = SQRT( SNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL SORBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of SORBDB1
+*
+ END
+
--- /dev/null
+*> \brief \b SORBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb2.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines SORBDB1, SORBDB3, and SORBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL NEGONE, ONE
+ PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C, S )
+ END IF
+ CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = X11(I,I)
+ X11(I,I) = ONE
+ CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL SORBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL SSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL SLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( X11(I+1,I), X21(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL SLARF( 'L', P-I, Q-I, X11(I+1,I), 1, TAUP1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL SLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL SLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, TAUP2(I),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of SORBDB2
+*
+ END
+
--- /dev/null
+*> \brief \b SORBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines SORBDB1, SORBDB2, and SORBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL SROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C, S )
+ END IF
+*
+ CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = X21(I,I)
+ X21(I,I) = ONE
+ CALL SLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ C = SQRT( SNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL SORBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL SLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( X21(I+1,I), X11(I,I) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL SLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1, TAUP2(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL SLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I, X11(I,I), 1, TAUP1(I), X11(I,I+1),
+ $ LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of SORBDB3
+*
+ END
+
--- /dev/null
+*> \brief \b SORBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB4 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb4.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb4.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb4.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* REAL PHI(*), THETA(*)
+* REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines SORBDB1, SORBDB2, and SORBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The orthogonal matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is REAL array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is REAL array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is REAL array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is REAL array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is REAL array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or SORCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See SORCSD2BY1 for details on generating P1, P2, and Q1 using SORGQR
+*> and SORGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ REAL PHI(*), THETA(*)
+ REAL PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFGP, SORBDB5, SROT, SSCAL, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL SORBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL SSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL SLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL SLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( PHANTOM(1), PHANTOM(P+1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL SLARF( 'L', P, Q, PHANTOM(1), 1, TAUP1(1), X11, LDX11,
+ $ WORK(ILARF) )
+ CALL SLARF( 'L', M-P, Q, PHANTOM(P+1), 1, TAUP2(1), X21,
+ $ LDX21, WORK(ILARF) )
+ ELSE
+ CALL SORBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL SSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL SLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL SLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( X11(I,I-1), X21(I,I-1) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL SLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1, TAUP1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1, TAUP2(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL SROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL SLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = X21(I,I)
+ X21(I,I) = ONE
+ CALL SLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( SNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + SNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL SLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL SLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL SLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL SLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL SLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of SORBDB4
+*
+ END
+
--- /dev/null
+*> \brief \b SORBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB5 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb5.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb5.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb5.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is REAL array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is REAL array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is REAL array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is REAL array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE SORBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORBDB6, XERBLA
+* ..
+* .. External Functions ..
+ REAL SNRM2
+ EXTERNAL SNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( SNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( SNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. SNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of SORBDB5
+*
+ END
+
--- /dev/null
+*> \brief \b SORBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORBDB6 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorbdb6.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorbdb6.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorbdb6.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is REAL array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is REAL array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is REAL array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is REAL array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE SORBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ REAL Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01E0, REALONE = 1.0E0,
+ $ REALZERO = 0.0E0 )
+ REAL NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = -1.0E0, ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL SLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL SGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL SGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL SGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL SGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL SLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of SORBDB6
+*
+ END
+
--- /dev/null
+*> \brief \b SORCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download SORCSD2BY1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/sorcsd2by1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/sorcsd2by1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/sorcsd2by1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* ..
+* .. Array Arguments ..
+* REAL THETA(*)
+* REAL U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> SORCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The orthogonal matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is REAL array, dimension (LDX11,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is REAL array, dimension (LDX21,Q)
+*> On entry, part of the orthogonal matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is REAL array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is REAL array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P orthogonal matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is REAL array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) orthogonal
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is REAL array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix orthogonal
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is REAL array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: SBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*>
+*> \par Reference:
+* ===============
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup realOTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE SORCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+* ..
+* .. Array Arguments ..
+ REAL THETA(*)
+ REAL U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBBCSD, SCOPY, SLACPY, SLAPMR, SLAPMT, SORBDB1,
+ $ SORBDB2, SORBDB3, SORBDB4, SORGLQ, SORGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-------------------------------------------------------|
+* | LWORKOPT (1) |
+* |-------------------------------------------------------|
+* | PHI (MAX(1,R-1)) |
+* |-------------------------------------------------------|
+* | TAUP1 (MAX(1,P)) | B11D (R) |
+* | TAUP2 (MAX(1,M-P)) | B11E (R-1) |
+* | TAUQ1 (MAX(1,Q)) | B12D (R) |
+* |-----------------------------------------| B12E (R-1) |
+* | SORBDB WORK | SORGQR WORK | SORGLQ WORK | B21D (R) |
+* | | | | B21E (R-1) |
+* | | | | B22D (R) |
+* | | | | B22E (R-1) |
+* | | | | SBBCSD WORK |
+* |-------------------------------------------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + R
+ IB12D = IB11E + R - 1
+ IB12E = IB12D + R
+ IB21D = IB12E + R - 1
+ IB21E = IB21D + R
+ IB22D = IB21E + R - 1
+ IB22E = IB22D + R
+ IBBCSD = IB22E + R - 1
+ ITAUP1 = IPHI + MAX( 1, R-1 )
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL SORGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ ELSE
+ CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL SORGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL SORGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( WORK(1) )
+ END IF
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1,
+ $ IBBCSD+LBBCSD-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1,
+ $ IBBCSD+LBBCSD-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'SORCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL SLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL SORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL SLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL SLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL SORGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ WORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL SLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL SLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL SORGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL SLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL SORGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL SLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ WORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL SLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL SLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL SORGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL SLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL SORGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL SLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL SORGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, WORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2, U1,
+ $ LDU1, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL SLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL SLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL SORBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ WORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL SCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL SLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL SORGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL SCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL SLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL SORGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL SLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL SLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL SLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL SORGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL SBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, WORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, WORK(IB11D), WORK(IB11E), WORK(IB12D),
+ $ WORK(IB12E), WORK(IB21D), WORK(IB21E),
+ $ WORK(IB22D), WORK(IB22E), WORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL SLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL SLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SORCSD2BY1
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNBDB1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunbdb1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunbdb1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunbdb1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB1 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. Q must be no larger than P,
+*> M-P, or M-Q. Routines ZUNBDB2, ZUNBDB3, and ZUNBDB4 handle cases in
+*> which Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are Q-by-Q bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <=
+*> MIN(P,M-P,M-Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*>
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = (1.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA
+ EXTERNAL ZLACGV
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. Q .OR. M-P .LT. Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. M-Q .LT. Q ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-2
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., Q of X11 and X21
+*
+ DO I = 1, Q
+*
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ THETA(I) = ATAN2( DBLE( X21(I,I) ), DBLE( X11(I,I) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I) = ONE
+ X21(I,I) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ IF( I .LT. Q ) THEN
+ CALL ZDROT( Q-I, X11(I,I+1), LDX11, X21(I,I+1), LDX21, C,
+ $ S )
+ CALL ZLACGV( Q-I, X21(I,I+1), LDX21 )
+ CALL ZLARFGP( Q-I, X21(I,I+1), X21(I,I+2), LDX21, TAUQ1(I) )
+ S = DBLE( X21(I,I+1) )
+ X21(I,I+1) = ONE
+ CALL ZLARF( 'R', P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I, Q-I, X21(I,I+1), LDX21, TAUQ1(I),
+ $ X21(I+1,I+1), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I, X21(I,I+1), LDX21 )
+ C = SQRT( DZNRM2( P-I, X11(I+1,I+1), 1, X11(I+1,I+1),
+ $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I+1), 1, X21(I+1,I+1),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ CALL ZUNBDB5( P-I, M-P-I, Q-I-1, X11(I+1,I+1), 1,
+ $ X21(I+1,I+1), 1, X11(I+1,I+2), LDX11,
+ $ X21(I+1,I+2), LDX21, WORK(IORBDB5), LORBDB5,
+ $ CHILDINFO )
+ END IF
+*
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB1
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNBDB2
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB2 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunbdb2.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunbdb2.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunbdb2.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB2 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. P must be no larger than M-P,
+*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB3, and ZUNBDB4 handle cases in
+*> which P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are P-by-P bidiagonal matrices represented implicitly by
+*> angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= min(M-P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 NEGONE, ONE
+ PARAMETER ( NEGONE = (-1.0D0,0.0D0),
+ $ ONE = (1.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. 0 .OR. P .GT. M-P ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. 0 .OR. Q .LT. P .OR. M-Q .LT. P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P-1, M-P, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB2', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., P of X11 and X21
+*
+ DO I = 1, P
+*
+ IF( I .GT. 1 ) THEN
+ CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I-1,I), LDX21, C,
+ $ S )
+ END IF
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ C = DBLE( X11(I,I) )
+ X11(I,I) = ONE
+ CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I+1, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(I,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DZNRM2( M-P-I+1, X21(I,I), 1, X21(I,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL ZUNBDB5( P-I, M-P-I+1, Q-I, X11(I+1,I), 1, X21(I,I), 1,
+ $ X11(I+1,I+1), LDX11, X21(I,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL ZSCAL( P-I, NEGONE, X11(I+1,I), 1 )
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ IF( I .LT. P ) THEN
+ CALL ZLARFGP( P-I, X11(I+1,I), X11(I+2,I), 1, TAUP1(I) )
+ PHI(I) = ATAN2( DBLE( X11(I+1,I) ), DBLE( X21(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X11(I+1,I) = ONE
+ CALL ZLARF( 'L', P-I, Q-I, X11(I+1,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I+1,I+1), LDX11, WORK(ILARF) )
+ END IF
+ X21(I,I) = ONE
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X21 to the identity matrix
+*
+ DO I = P + 1, Q
+ CALL ZLARFGP( M-P-I+1, X21(I,I), X21(I+1,I), 1, TAUP2(I) )
+ X21(I,I) = ONE
+ CALL ZLARF( 'L', M-P-I+1, Q-I, X21(I,I), 1, DCONJG(TAUP2(I)),
+ $ X21(I,I+1), LDX21, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB2
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNBDB3
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB3 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunbdb3.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunbdb3.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunbdb3.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB3 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-P must be no larger than P,
+*> Q, or M-Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB4 handle cases in
+*> which M-P is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-P)-by-(M-P) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M. M-P <= min(P,Q,M-Q).
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 TAUP1(*), TAUP2(*), TAUQ1(*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE
+ PARAMETER ( ONE = (1.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, LLARF, LORBDB5,
+ $ LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( 2*P .LT. M .OR. P .GT. M ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-P .OR. M-Q .LT. M-P ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( P, M-P-1, Q-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q-1
+ LWORKOPT = MAX( ILARF+LLARF-1, IORBDB5+LORBDB5-1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce rows 1, ..., M-P of X11 and X21
+*
+ DO I = 1, M-P
+*
+ IF( I .GT. 1 ) THEN
+ CALL ZDROT( Q-I+1, X11(I-1,I), LDX11, X21(I,I), LDX11, C,
+ $ S )
+ END IF
+*
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ S = DBLE( X21(I,I) )
+ X21(I,I) = ONE
+ CALL ZLARF( 'R', P-I+1, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ C = SQRT( DZNRM2( P-I+1, X11(I,I), 1, X11(I,I),
+ $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I), 1 )**2 )
+ THETA(I) = ATAN2( S, C )
+*
+ CALL ZUNBDB5( P-I+1, M-P-I, Q-I, X11(I,I), 1, X21(I+1,I), 1,
+ $ X11(I,I+1), LDX11, X21(I+1,I+1), LDX21,
+ $ WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ IF( I .LT. M-P ) THEN
+ CALL ZLARFGP( M-P-I, X21(I+1,I), X21(I+2,I), 1, TAUP2(I) )
+ PHI(I) = ATAN2( DBLE( X21(I+1,I) ), DBLE( X11(I,I) ) )
+ C = COS( PHI(I) )
+ S = SIN( PHI(I) )
+ X21(I+1,I) = ONE
+ CALL ZLARF( 'L', M-P-I, Q-I, X21(I+1,I), 1,
+ $ DCONJG(TAUP2(I)), X21(I+1,I+1), LDX21,
+ $ WORK(ILARF) )
+ END IF
+ X11(I,I) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to the identity matrix
+*
+ DO I = M-P + 1, Q
+ CALL ZLARFGP( P-I+1, X11(I,I), X11(I+1,I), 1, TAUP1(I) )
+ X11(I,I) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I, X11(I,I), 1, DCONJG(TAUP1(I)),
+ $ X11(I,I+1), LDX11, WORK(ILARF) )
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB3
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNBDB4
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB4 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunbdb4.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunbdb4.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunbdb4.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+* TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION PHI(*), THETA(*)
+* COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+* $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB4 simultaneously bidiagonalizes the blocks of a tall and skinny
+*> matrix X with orthonomal columns:
+*>
+*> [ B11 ]
+*> [ X11 ] [ P1 | ] [ 0 ]
+*> [-----] = [---------] [-----] Q1**T .
+*> [ X21 ] [ | P2 ] [ B21 ]
+*> [ 0 ]
+*>
+*> X11 is P-by-Q, and X21 is (M-P)-by-Q. M-Q must be no larger than P,
+*> M-P, or Q. Routines ZUNBDB1, ZUNBDB2, and ZUNBDB3 handle cases in
+*> which M-Q is not the minimum dimension.
+*>
+*> The unitary matrices P1, P2, and Q1 are P-by-P, (M-P)-by-(M-P),
+*> and (M-Q)-by-(M-Q), respectively. They are represented implicitly by
+*> Householder vectors.
+*>
+*> B11 and B12 are (M-Q)-by-(M-Q) bidiagonal matrices represented
+*> implicitly by angles THETA, PHI.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows X11 plus the number of rows in X21.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M and
+*> M-Q <= min(P,M-P,Q).
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, the top block of the matrix X to be reduced. On
+*> exit, the columns of tril(X11) specify reflectors for P1 and
+*> the rows of triu(X11,1) specify reflectors for Q1.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= P.
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, the bottom block of the matrix X to be reduced. On
+*> exit, the columns of tril(X21) specify reflectors for P2.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= M-P.
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is DOUBLE PRECISION array, dimension (Q)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] PHI
+*> \verbatim
+*> PHI is DOUBLE PRECISION array, dimension (Q-1)
+*> The entries of the bidiagonal blocks B11, B21 are defined by
+*> THETA and PHI. See Further Details.
+*> \endverbatim
+*>
+*> \param[out] TAUP1
+*> \verbatim
+*> TAUP1 is COMPLEX*16 array, dimension (P)
+*> The scalar factors of the elementary reflectors that define
+*> P1.
+*> \endverbatim
+*>
+*> \param[out] TAUP2
+*> \verbatim
+*> TAUP2 is COMPLEX*16 array, dimension (M-P)
+*> The scalar factors of the elementary reflectors that define
+*> P2.
+*> \endverbatim
+*>
+*> \param[out] TAUQ1
+*> \verbatim
+*> TAUQ1 is COMPLEX*16 array, dimension (Q)
+*> The scalar factors of the elementary reflectors that define
+*> Q1.
+*> \endverbatim
+*>
+*> \param[out] PHANTOM
+*> \verbatim
+*> PHANTOM is COMPLEX*16 array, dimension (M)
+*> The routine computes an M-by-1 column vector Y that is
+*> orthogonal to the columns of [ X11; X21 ]. PHANTOM(1:P) and
+*> PHANTOM(P+1:M) contain Householder vectors for Y(1:P) and
+*> Y(P+1:M), respectively.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= M-Q.
+*>
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the WORK array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+*> \par Further Details:
+* =====================
+*>
+*> \verbatim
+*>
+*> The upper-bidiagonal blocks B11, B21 are represented implicitly by
+*> angles THETA(1), ..., THETA(Q) and PHI(1), ..., PHI(Q-1). Every entry
+*> in each bidiagonal band is a product of a sine or cosine of a THETA
+*> with a sine or cosine of a PHI. See [1] or ZUNCSD for details.
+*>
+*> P1, P2, and Q1 are represented as products of elementary reflectors.
+*> See ZUNCSD2BY1 for details on generating P1, P2, and Q1 using ZUNGQR
+*> and ZUNGLQ.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*>
+* =====================================================================
+ SUBROUTINE ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI,
+ $ TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LWORK, M, P, Q, LDX11, LDX21
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION PHI(*), THETA(*)
+ COMPLEX*16 PHANTOM(*), TAUP1(*), TAUP2(*), TAUQ1(*),
+ $ WORK(*), X11(LDX11,*), X21(LDX21,*)
+* ..
+*
+* ====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0),
+ $ ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION C, S
+ INTEGER CHILDINFO, I, ILARF, IORBDB5, J, LLARF,
+ $ LORBDB5, LWORKMIN, LWORKOPT
+ LOGICAL LQUERY
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZLARF, ZLARFGP, ZUNBDB5, ZDROT, ZSCAL, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC ATAN2, COS, MAX, SIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( P .LT. M-Q .OR. M-P .LT. M-Q ) THEN
+ INFO = -2
+ ELSE IF( Q .LT. M-Q .OR. Q .GT. M ) THEN
+ INFO = -3
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -5
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+*
+ IF( INFO .EQ. 0 ) THEN
+ ILARF = 2
+ LLARF = MAX( Q-1, P-1, M-P-1 )
+ IORBDB5 = 2
+ LORBDB5 = Q
+ LWORKOPT = ILARF + LLARF - 1
+ LWORKOPT = MAX( LWORKOPT, IORBDB5 + LORBDB5 - 1 )
+ LWORKMIN = LWORKOPT
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB4', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Reduce columns 1, ..., M-Q of X11 and X21
+*
+ DO I = 1, M-Q
+*
+ IF( I .EQ. 1 ) THEN
+ DO J = 1, M
+ PHANTOM(J) = ZERO
+ END DO
+ CALL ZUNBDB5( P, M-P, Q, PHANTOM(1), 1, PHANTOM(P+1), 1,
+ $ X11, LDX11, X21, LDX21, WORK(IORBDB5),
+ $ LORBDB5, CHILDINFO )
+ CALL ZSCAL( P, NEGONE, PHANTOM(1), 1 )
+ CALL ZLARFGP( P, PHANTOM(1), PHANTOM(2), 1, TAUP1(1) )
+ CALL ZLARFGP( M-P, PHANTOM(P+1), PHANTOM(P+2), 1, TAUP2(1) )
+ THETA(I) = ATAN2( DBLE( PHANTOM(1) ), DBLE( PHANTOM(P+1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ PHANTOM(1) = ONE
+ PHANTOM(P+1) = ONE
+ CALL ZLARF( 'L', P, Q, PHANTOM(1), 1, DCONJG(TAUP1(1)), X11,
+ $ LDX11, WORK(ILARF) )
+ CALL ZLARF( 'L', M-P, Q, PHANTOM(P+1), 1, DCONJG(TAUP2(1)),
+ $ X21, LDX21, WORK(ILARF) )
+ ELSE
+ CALL ZUNBDB5( P-I+1, M-P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ X21(I,I-1), 1, X11(I,I), LDX11, X21(I,I),
+ $ LDX21, WORK(IORBDB5), LORBDB5, CHILDINFO )
+ CALL ZSCAL( P-I+1, NEGONE, X11(I,I-1), 1 )
+ CALL ZLARFGP( P-I+1, X11(I,I-1), X11(I+1,I-1), 1, TAUP1(I) )
+ CALL ZLARFGP( M-P-I+1, X21(I,I-1), X21(I+1,I-1), 1,
+ $ TAUP2(I) )
+ THETA(I) = ATAN2( DBLE( X11(I,I-1) ), DBLE( X21(I,I-1) ) )
+ C = COS( THETA(I) )
+ S = SIN( THETA(I) )
+ X11(I,I-1) = ONE
+ X21(I,I-1) = ONE
+ CALL ZLARF( 'L', P-I+1, Q-I+1, X11(I,I-1), 1,
+ $ DCONJG(TAUP1(I)), X11(I,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'L', M-P-I+1, Q-I+1, X21(I,I-1), 1,
+ $ DCONJG(TAUP2(I)), X21(I,I), LDX21, WORK(ILARF) )
+ END IF
+*
+ CALL ZDROT( Q-I+1, X11(I,I), LDX11, X21(I,I), LDX21, S, -C )
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ CALL ZLARFGP( Q-I+1, X21(I,I), X21(I,I+1), LDX21, TAUQ1(I) )
+ C = DBLE( X21(I,I) )
+ X21(I,I) = ONE
+ CALL ZLARF( 'R', P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', M-P-I, Q-I+1, X21(I,I), LDX21, TAUQ1(I),
+ $ X21(I+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X21(I,I), LDX21 )
+ IF( I .LT. M-Q ) THEN
+ S = SQRT( DZNRM2( P-I, X11(I+1,I), 1, X11(I+1,I),
+ $ 1 )**2 + DZNRM2( M-P-I, X21(I+1,I), 1, X21(I+1,I),
+ $ 1 )**2 )
+ PHI(I) = ATAN2( S, C )
+ END IF
+*
+ END DO
+*
+* Reduce the bottom-right portion of X11 to [ I 0 ]
+*
+ DO I = M - Q + 1, P
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ CALL ZLARFGP( Q-I+1, X11(I,I), X11(I,I+1), LDX11, TAUQ1(I) )
+ X11(I,I) = ONE
+ CALL ZLARF( 'R', P-I, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X11(I+1,I), LDX11, WORK(ILARF) )
+ CALL ZLARF( 'R', Q-P, Q-I+1, X11(I,I), LDX11, TAUQ1(I),
+ $ X21(M-Q+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X11(I,I), LDX11 )
+ END DO
+*
+* Reduce the bottom-right portion of X21 to [ 0 I ]
+*
+ DO I = P + 1, Q
+ CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ CALL ZLARFGP( Q-I+1, X21(M-Q+I-P,I), X21(M-Q+I-P,I+1), LDX21,
+ $ TAUQ1(I) )
+ X21(M-Q+I-P,I) = ONE
+ CALL ZLARF( 'R', Q-I, Q-I+1, X21(M-Q+I-P,I), LDX21, TAUQ1(I),
+ $ X21(M-Q+I-P+1,I), LDX21, WORK(ILARF) )
+ CALL ZLACGV( Q-I+1, X21(M-Q+I-P,I), LDX21 )
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB4
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNBDB5
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB5 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunbdb5.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunbdb5.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunbdb5.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB5 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then some other vector from the orthogonal complement
+*> is returned. This vector is chosen in an arbitrary but deterministic
+*> way.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX*16 array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX*16 array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX*16 array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX*16 array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ZUNBDB5( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZUNBDB6, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DZNRM2
+ EXTERNAL DZNRM2
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB5', -INFO )
+ RETURN
+ END IF
+*
+* Project X onto the orthogonal complement of Q
+*
+ CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2, LDQ2,
+ $ WORK, LWORK, CHILDINFO )
+*
+* If the projection is nonzero, then return
+*
+ IF( DZNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+*
+* Project each standard basis vector e_1,...,e_M1 in turn, stopping
+* when a nonzero projection is found
+*
+ DO I = 1, M1
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ X1(I) = ONE
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DZNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+* Project each standard basis vector e_(M1+1),...,e_(M1+M2) in turn,
+* stopping when a nonzero projection is found
+*
+ DO I = 1, M2
+ DO J = 1, M1
+ X1(J) = ZERO
+ END DO
+ DO J = 1, M2
+ X2(J) = ZERO
+ END DO
+ X2(I) = ONE
+ CALL ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, CHILDINFO )
+ IF( DZNRM2(M1,X1,INCX1) .NE. ZERO
+ $ .OR. DZNRM2(M2,X2,INCX2) .NE. ZERO ) THEN
+ RETURN
+ END IF
+ END DO
+*
+ RETURN
+*
+* End of ZUNBDB5
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNBDB6
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNBDB6 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zunbdb6.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zunbdb6.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zunbdb6.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+* LDQ2, WORK, LWORK, INFO )
+*
+* .. Scalar Arguments ..
+* INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+* $ N
+* ..
+* .. Array Arguments ..
+* COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNBDB6 orthogonalizes the column vector
+*> X = [ X1 ]
+*> [ X2 ]
+*> with respect to the columns of
+*> Q = [ Q1 ] .
+*> [ Q2 ]
+*> The columns of Q must be orthonormal.
+*>
+*> If the projection is zero according to Kahan's "twice is enough"
+*> criterion, then the zero vector is returned.
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] M1
+*> \verbatim
+*> M1 is INTEGER
+*> The dimension of X1 and the number of rows in Q1. 0 <= M1.
+*> \endverbatim
+*>
+*> \param[in] M2
+*> \verbatim
+*> M2 is INTEGER
+*> The dimension of X2 and the number of rows in Q2. 0 <= M2.
+*> \endverbatim
+*>
+*> \param[in] N
+*> \verbatim
+*> N is INTEGER
+*> The number of columns in Q1 and Q2. 0 <= N.
+*> \endverbatim
+*>
+*> \param[in,out] X1
+*> \verbatim
+*> X1 is COMPLEX*16 array, dimension (M1)
+*> On entry, the top part of the vector to be orthogonalized.
+*> On exit, the top part of the projected vector.
+*> \endverbatim
+*>
+*> \param[in] INCX1
+*> \verbatim
+*> INCX1 is INTEGER
+*> Increment for entries of X1.
+*> \endverbatim
+*>
+*> \param[in,out] X2
+*> \verbatim
+*> X2 is COMPLEX*16 array, dimension (M2)
+*> On entry, the bottom part of the vector to be
+*> orthogonalized. On exit, the bottom part of the projected
+*> vector.
+*> \endverbatim
+*>
+*> \param[in] INCX2
+*> \verbatim
+*> INCX2 is INTEGER
+*> Increment for entries of X2.
+*> \endverbatim
+*>
+*> \param[in] Q1
+*> \verbatim
+*> Q1 is COMPLEX*16 array, dimension (LDQ1, N)
+*> The top part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ1
+*> \verbatim
+*> LDQ1 is INTEGER
+*> The leading dimension of Q1. LDQ1 >= M1.
+*> \endverbatim
+*>
+*> \param[in] Q2
+*> \verbatim
+*> Q2 is COMPLEX*16 array, dimension (LDQ2, N)
+*> The bottom part of the orthonormal basis matrix.
+*> \endverbatim
+*>
+*> \param[in] LDQ2
+*> \verbatim
+*> LDQ2 is INTEGER
+*> The leading dimension of Q2. LDQ2 >= M2.
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (LWORK)
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK. LWORK >= N.
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> \endverbatim
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ZUNBDB6( M1, M2, N, X1, INCX1, X2, INCX2, Q1, LDQ1, Q2,
+ $ LDQ2, WORK, LWORK, INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ INTEGER INCX1, INCX2, INFO, LDQ1, LDQ2, LWORK, M1, M2,
+ $ N
+* ..
+* .. Array Arguments ..
+ COMPLEX*16 Q1(LDQ1,*), Q2(LDQ2,*), WORK(*), X1(*), X2(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ALPHASQ, REALONE, REALZERO
+ PARAMETER ( ALPHASQ = 0.01D0, REALONE = 1.0D0,
+ $ REALZERO = 0.0D0 )
+ COMPLEX*16 NEGONE, ONE, ZERO
+ PARAMETER ( NEGONE = (-1.0D0,0.0D0), ONE = (1.0D0,0.0D0),
+ $ ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION NORMSQ1, NORMSQ2, SCL1, SCL2, SSQ1, SSQ2
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZGEMV, ZLASSQ, XERBLA
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ IF( M1 .LT. 0 ) THEN
+ INFO = -1
+ ELSE IF( M2 .LT. 0 ) THEN
+ INFO = -2
+ ELSE IF( N .LT. 0 ) THEN
+ INFO = -3
+ ELSE IF( INCX1 .LT. 1 ) THEN
+ INFO = -5
+ ELSE IF( INCX2 .LT. 1 ) THEN
+ INFO = -7
+ ELSE IF( LDQ1 .LT. MAX( 1, M1 ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ2 .LT. MAX( 1, M2 ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK .LT. N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNBDB6', -INFO )
+ RETURN
+ END IF
+*
+* First, project X onto the orthogonal complement of Q's column
+* space
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL ZLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ1 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL ZGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL ZGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL ZGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL ZGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL ZLASSQ( M2, X2, INCX2, SCL2, SSQ2 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If projection is sufficiently large in norm, then stop.
+* If projection is zero, then stop.
+* Otherwise, project again.
+*
+ IF( NORMSQ2 .GE. ALPHASQ*NORMSQ1 ) THEN
+ RETURN
+ END IF
+*
+ IF( NORMSQ2 .EQ. ZERO ) THEN
+ RETURN
+ END IF
+*
+ NORMSQ1 = NORMSQ2
+*
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+*
+ IF( M1 .EQ. 0 ) THEN
+ DO I = 1, N
+ WORK(I) = ZERO
+ END DO
+ ELSE
+ CALL ZGEMV( 'C', M1, N, ONE, Q1, LDQ1, X1, INCX1, ZERO, WORK,
+ $ 1 )
+ END IF
+*
+ CALL ZGEMV( 'C', M2, N, ONE, Q2, LDQ2, X2, INCX2, ONE, WORK, 1 )
+*
+ CALL ZGEMV( 'N', M1, N, NEGONE, Q1, LDQ1, WORK, 1, ONE, X1,
+ $ INCX1 )
+ CALL ZGEMV( 'N', M2, N, NEGONE, Q2, LDQ2, WORK, 1, ONE, X2,
+ $ INCX2 )
+*
+ SCL1 = REALZERO
+ SSQ1 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ SCL2 = REALZERO
+ SSQ2 = REALONE
+ CALL ZLASSQ( M1, X1, INCX1, SCL1, SSQ1 )
+ NORMSQ2 = SCL1**2*SSQ1 + SCL2**2*SSQ2
+*
+* If second projection is sufficiently large in norm, then do
+* nothing more. Alternatively, if it shrunk significantly, then
+* truncate it to zero.
+*
+ IF( NORMSQ2 .LT. ALPHASQ*NORMSQ1 ) THEN
+ DO I = 1, M1
+ X1(I) = ZERO
+ END DO
+ DO I = 1, M2
+ X2(I) = ZERO
+ END DO
+ END IF
+*
+ RETURN
+*
+* End of ZUNBDB6
+*
+ END
+
--- /dev/null
+*> \brief \b ZUNCSD2BY1
+*
+* =========== DOCUMENTATION ===========
+*
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
+*
+*> \htmlonly
+*> Download ZUNCSD2BY1 + dependencies
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zuncsd2by1.f">
+*> [TGZ]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zuncsd2by1.f">
+*> [ZIP]</a>
+*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zuncsd2by1.f">
+*> [TXT]</a>
+*> \endhtmlonly
+*
+* Definition:
+* ===========
+*
+* SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+* X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+* LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+* INFO )
+*
+* .. Scalar Arguments ..
+* CHARACTER JOBU1, JOBU2, JOBV1T
+* INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+* $ M, P, Q
+* INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+* DOUBLE PRECISION RWORK(*)
+* DOUBLE PRECISION THETA(*)
+* COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+* $ X11(LDX11,*), X21(LDX21,*)
+* INTEGER IWORK(*)
+* ..
+*
+*
+*> \par Purpose:
+*> =============
+*>
+*>\verbatim
+*>
+*> ZUNCSD2BY1 computes the CS decomposition of an M-by-Q matrix X with
+*> orthonormal columns that has been partitioned into a 2-by-1 block
+*> structure:
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ X11 ] [ U1 | ] [ 0 0 0 ]
+*> X = [-----] = [---------] [----------] V1**T .
+*> [ X21 ] [ | U2 ] [ 0 0 0 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
+*>
+*> X11 is P-by-Q. The unitary matrices U1, U2, V1, and V2 are P-by-P,
+*> (M-P)-by-(M-P), Q-by-Q, and (M-Q)-by-(M-Q), respectively. C and S are
+*> R-by-R nonnegative diagonal matrices satisfying C^2 + S^2 = I, in
+*> which R = MIN(P,M-P,Q,M-Q).
+*>
+*>\endverbatim
+*
+* Arguments:
+* ==========
+*
+*> \param[in] JOBU1
+*> \verbatim
+*> JOBU1 is CHARACTER
+*> = 'Y': U1 is computed;
+*> otherwise: U1 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBU2
+*> \verbatim
+*> JOBU2 is CHARACTER
+*> = 'Y': U2 is computed;
+*> otherwise: U2 is not computed.
+*> \endverbatim
+*>
+*> \param[in] JOBV1T
+*> \verbatim
+*> JOBV1T is CHARACTER
+*> = 'Y': V1T is computed;
+*> otherwise: V1T is not computed.
+*> \endverbatim
+*>
+*> \param[in] M
+*> \verbatim
+*> M is INTEGER
+*> The number of rows and columns in X.
+*> \endverbatim
+*>
+*> \param[in] P
+*> \verbatim
+*> P is INTEGER
+*> The number of rows in X11 and X12. 0 <= P <= M.
+*> \endverbatim
+*>
+*> \param[in] Q
+*> \verbatim
+*> Q is INTEGER
+*> The number of columns in X11 and X21. 0 <= Q <= M.
+*> \endverbatim
+*>
+*> \param[in,out] X11
+*> \verbatim
+*> X11 is COMPLEX*16 array, dimension (LDX11,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX11
+*> \verbatim
+*> LDX11 is INTEGER
+*> The leading dimension of X11. LDX11 >= MAX(1,P).
+*> \endverbatim
+*>
+*> \param[in,out] X21
+*> \verbatim
+*> X21 is COMPLEX*16 array, dimension (LDX21,Q)
+*> On entry, part of the unitary matrix whose CSD is
+*> desired.
+*> \endverbatim
+*>
+*> \param[in] LDX21
+*> \verbatim
+*> LDX21 is INTEGER
+*> The leading dimension of X21. LDX21 >= MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] THETA
+*> \verbatim
+*> THETA is COMPLEX*16 array, dimension (R), in which R =
+*> MIN(P,M-P,Q,M-Q).
+*> C = DIAG( COS(THETA(1)), ... , COS(THETA(R)) ) and
+*> S = DIAG( SIN(THETA(1)), ... , SIN(THETA(R)) ).
+*> \endverbatim
+*>
+*> \param[out] U1
+*> \verbatim
+*> U1 is COMPLEX*16 array, dimension (P)
+*> If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
+*> \endverbatim
+*>
+*> \param[in] LDU1
+*> \verbatim
+*> LDU1 is INTEGER
+*> The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
+*> MAX(1,P).
+*> \endverbatim
+*>
+*> \param[out] U2
+*> \verbatim
+*> U2 is COMPLEX*16 array, dimension (M-P)
+*> If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
+*> matrix U2.
+*> \endverbatim
+*>
+*> \param[in] LDU2
+*> \verbatim
+*> LDU2 is INTEGER
+*> The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
+*> MAX(1,M-P).
+*> \endverbatim
+*>
+*> \param[out] V1T
+*> \verbatim
+*> V1T is COMPLEX*16 array, dimension (Q)
+*> If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
+*> matrix V1**T.
+*> \endverbatim
+*>
+*> \param[in] LDV1T
+*> \verbatim
+*> LDV1T is INTEGER
+*> The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
+*> MAX(1,Q).
+*> \endverbatim
+*>
+*> \param[out] WORK
+*> \verbatim
+*> WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
+*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*> If INFO > 0 on exit, WORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LWORK
+*> \verbatim
+*> LWORK is INTEGER
+*> The dimension of the array WORK.
+*> \endverbatim
+*> \verbatim
+*> If LWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the WORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LWORK is issued by XERBLA.
+*> \endverbatim
+*>
+*> \param[out] RWORK
+*> \verbatim
+*> RWORK is DOUBLE PRECISION array, dimension (MAX(1,LRWORK))
+*> On exit, if INFO = 0, RWORK(1) returns the optimal LRWORK.
+*> If INFO > 0 on exit, RWORK(2:R) contains the values PHI(1),
+*> ..., PHI(R-1) that, together with THETA(1), ..., THETA(R),
+*> define the matrix in intermediate bidiagonal-block form
+*> remaining after nonconvergence. INFO specifies the number
+*> of nonzero PHI's.
+*> \endverbatim
+*>
+*> \param[in] LRWORK
+*> \verbatim
+*> LRWORK is INTEGER
+*> The dimension of the array RWORK.
+*>
+*> If LRWORK = -1, then a workspace query is assumed; the routine
+*> only calculates the optimal size of the RWORK array, returns
+*> this value as the first entry of the work array, and no error
+*> message related to LRWORK is issued by XERBLA.
+*> \param[out] IWORK
+*> \verbatim
+*> IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
+*> \endverbatim
+*> \endverbatim
+*>
+*> \param[out] INFO
+*> \verbatim
+*> INFO is INTEGER
+*> = 0: successful exit.
+*> < 0: if INFO = -i, the i-th argument had an illegal value.
+*> > 0: ZBBCSD did not converge. See the description of WORK
+*> above for details.
+*> \endverbatim
+*
+*> \par References:
+* ================
+*>
+*> [1] Brian D. Sutton. Computing the complete CS decomposition. Numer.
+*> Algorithms, 50(1):33-65, 2009.
+*
+* Authors:
+* ========
+*
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
+*
+*> \date July 2012
+*
+*> \ingroup complex16OTHERcomputational
+*
+* =====================================================================
+ SUBROUTINE ZUNCSD2BY1( JOBU1, JOBU2, JOBV1T, M, P, Q, X11, LDX11,
+ $ X21, LDX21, THETA, U1, LDU1, U2, LDU2, V1T,
+ $ LDV1T, WORK, LWORK, RWORK, LRWORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK computational routine (version 3.5.0) --
+* -- LAPACK is a software package provided by Univ. of Tennessee, --
+* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
+* July 2012
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU1, JOBU2, JOBV1T
+ INTEGER INFO, LDU1, LDU2, LDV1T, LWORK, LDX11, LDX21,
+ $ M, P, Q
+ INTEGER LRWORK, LRWORKMIN, LRWORKOPT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION RWORK(*)
+ DOUBLE PRECISION THETA(*)
+ COMPLEX*16 U1(LDU1,*), U2(LDU2,*), V1T(LDV1T,*), WORK(*),
+ $ X11(LDX11,*), X21(LDX21,*)
+ INTEGER IWORK(*)
+* ..
+*
+* =====================================================================
+*
+* .. Parameters ..
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) )
+* ..
+* .. Local Scalars ..
+ INTEGER CHILDINFO, I, IB11D, IB11E, IB12D, IB12E,
+ $ IB21D, IB21E, IB22D, IB22E, IBBCSD, IORBDB,
+ $ IORGLQ, IORGQR, IPHI, ITAUP1, ITAUP2, ITAUQ1,
+ $ J, LBBCSD, LORBDB, LORGLQ, LORGLQMIN,
+ $ LORGLQOPT, LORGQR, LORGQRMIN, LORGQROPT,
+ $ LWORKMIN, LWORKOPT, R
+ LOGICAL LQUERY, WANTU1, WANTU2, WANTV1T
+* ..
+* .. External Subroutines ..
+ EXTERNAL ZBBCSD, ZCOPY, ZLACPY, ZLAPMR, ZLAPMT, ZUNBDB1,
+ $ ZUNBDB2, ZUNBDB3, ZUNBDB4, ZUNGLQ, ZUNGQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Function ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+*
+ INFO = 0
+ WANTU1 = LSAME( JOBU1, 'Y' )
+ WANTU2 = LSAME( JOBU2, 'Y' )
+ WANTV1T = LSAME( JOBV1T, 'Y' )
+ LQUERY = LWORK .EQ. -1
+*
+ IF( M .LT. 0 ) THEN
+ INFO = -4
+ ELSE IF( P .LT. 0 .OR. P .GT. M ) THEN
+ INFO = -5
+ ELSE IF( Q .LT. 0 .OR. Q .GT. M ) THEN
+ INFO = -6
+ ELSE IF( LDX11 .LT. MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LDX21 .LT. MAX( 1, M-P ) ) THEN
+ INFO = -10
+ ELSE IF( WANTU1 .AND. LDU1 .LT. P ) THEN
+ INFO = -13
+ ELSE IF( WANTU2 .AND. LDU2 .LT. M - P ) THEN
+ INFO = -15
+ ELSE IF( WANTV1T .AND. LDV1T .LT. Q ) THEN
+ INFO = -17
+ END IF
+*
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Compute workspace
+*
+* WORK layout:
+* |-----------------------------------------|
+* | LWORKOPT (1) |
+* |-----------------------------------------|
+* | TAUP1 (MAX(1,P)) |
+* | TAUP2 (MAX(1,M-P)) |
+* | TAUQ1 (MAX(1,Q)) |
+* |-----------------------------------------|
+* | ZUNBDB WORK | ZUNGQR WORK | ZUNGLQ WORK |
+* | | | |
+* | | | |
+* | | | |
+* | | | |
+* |-----------------------------------------|
+* RWORK layout:
+* |------------------|
+* | LRWORKOPT (1) |
+* |------------------|
+* | PHI (MAX(1,R-1)) |
+* |------------------|
+* | B11D (R) |
+* | B11E (R-1) |
+* | B12D (R) |
+* | B12E (R-1) |
+* | B21D (R) |
+* | B21E (R-1) |
+* | B22D (R) |
+* | B22E (R-1) |
+* | ZBBCSD RWORK |
+* |------------------|
+*
+ IF( INFO .EQ. 0 ) THEN
+ IPHI = 2
+ IB11D = IPHI + MAX( 1, R-1 )
+ IB11E = IB11D + R
+ IB12D = IB11E + R - 1
+ IB12E = IB12D + R
+ IB21D = IB12E + R - 1
+ IB21E = IB21D + R
+ IB22D = IB21E + R - 1
+ IB22E = IB22D + R
+ IBBCSD = IB22E + R - 1
+ ITAUP1 = 2
+ ITAUP2 = ITAUP1 + MAX( 1, P )
+ ITAUQ1 = ITAUP2 + MAX( 1, M-P )
+ IORBDB = ITAUQ1 + MAX( 1, Q )
+ IORGQR = ITAUQ1 + MAX( 1, Q )
+ IORGLQ = ITAUQ1 + MAX( 1, Q )
+ IF( R .EQ. Q ) THEN
+ CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK, -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( MAX(0,Q-1), MAX(0,Q-1), MAX(0,Q-1), V1T, LDV1T,
+ $ 0, WORK(1), -1, CHILDINFO )
+ LORGLQMIN = MAX( 1, Q-1 )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ 0, U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. P ) THEN
+ CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P-1 .GE. M-P ) THEN
+ CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, 0, WORK(1),
+ $ -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, P-1 )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ 0, V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2, 0, 0,
+ $ 0, 0, 0, 0, 0, 0, RWORK(1), -1, CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE IF( R .EQ. M-P ) THEN
+ CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = INT( WORK(1) )
+ IF( P .GE. M-P-1 ) THEN
+ CALL ZUNGQR( P, P, Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2, 0,
+ $ WORK(1), -1, CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P-1 )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, 0, 0, 1, V1T, LDV1T, U2, LDU2, U1, LDU1,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ ELSE
+ CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA, 0, 0,
+ $ 0, 0, 0, WORK(1), -1, CHILDINFO )
+ LORBDB = M + INT( WORK(1) )
+ IF( P .GE. M-P ) THEN
+ CALL ZUNGQR( P, P, M-Q, U1, LDU1, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, P )
+ LORGQROPT = INT( WORK(1) )
+ ELSE
+ CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGQRMIN = MAX( 1, M-P )
+ LORGQROPT = INT( WORK(1) )
+ END IF
+ CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, 0, WORK(1), -1,
+ $ CHILDINFO )
+ LORGLQMIN = MAX( 1, Q )
+ LORGLQOPT = INT( WORK(1) )
+ CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, 0, U2, LDU2, U1, LDU1, 0, 1, V1T, LDV1T,
+ $ 0, 0, 0, 0, 0, 0, 0, 0, RWORK(1), -1,
+ $ CHILDINFO )
+ LBBCSD = INT( RWORK(1) )
+ END IF
+ LRWORKMIN = IBBCSD+LBBCSD-1
+ LRWORKOPT = LRWORKMIN
+ RWORK(1) = LRWORKOPT
+ LWORKMIN = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQRMIN-1,
+ $ IORGLQ+LORGLQMIN-1 )
+ LWORKOPT = MAX( IORBDB+LORBDB-1,
+ $ IORGQR+LORGQROPT-1,
+ $ IORGLQ+LORGLQOPT-1 )
+ WORK(1) = LWORKOPT
+ IF( LWORK .LT. LWORKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+ IF( INFO .NE. 0 ) THEN
+ CALL XERBLA( 'ZUNCSD2BY1', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+ LORGQR = LWORK-IORGQR+1
+ LORGLQ = LWORK-IORGLQ+1
+*
+* Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
+* in which R = MIN(P,M-P,Q,M-Q)
+*
+ IF( R .EQ. Q ) THEN
+*
+* Case 1: R = Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB1( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL ZUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ V1T(1,1) = ONE
+ DO J = 2, Q
+ V1T(1,J) = ZERO
+ V1T(J,1) = ZERO
+ END DO
+ CALL ZLACPY( 'U', Q-1, Q-1, X21(1,2), LDX21, V1T(2,2),
+ $ LDV1T )
+ CALL ZUNGLQ( Q-1, Q-1, Q-1, V1T(2,2), LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( JOBU1, JOBU2, JOBV1T, 'N', 'N', M, P, Q, THETA,
+ $ RWORK(IPHI), U1, LDU1, U2, LDU2, V1T, LDV1T, 0, 1,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place zero submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL ZLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. P ) THEN
+*
+* Case 2: R = P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB2( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ U1(1,1) = ONE
+ DO J = 2, P
+ U1(1,J) = ZERO
+ U1(J,1) = ZERO
+ END DO
+ CALL ZLACPY( 'L', P-1, P-1, X11(2,1), LDX11, U1(2,2), LDU1 )
+ CALL ZUNGQR( P-1, P-1, P-1, U1(2,2), LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', M-P, Q, X21, LDX21, U2, LDU2 )
+ CALL ZUNGQR( M-P, M-P, Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL ZLACPY( 'U', P, Q, X11, LDX11, V1T, LDV1T )
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( JOBV1T, 'N', JOBU1, JOBU2, 'T', M, Q, P, THETA,
+ $ RWORK(IPHI), V1T, LDV1T, 0, 1, U1, LDU1, U2, LDU2,
+ $ RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. 0 .AND. WANTU2 ) THEN
+ DO I = 1, Q
+ IWORK(I) = M - P - Q + I
+ END DO
+ DO I = Q + 1, M - P
+ IWORK(I) = I - Q
+ END DO
+ CALL ZLAPMT( .FALSE., M-P, M-P, U2, LDU2, IWORK )
+ END IF
+ ELSE IF( R .EQ. M-P ) THEN
+*
+* Case 3: R = M-P
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB3( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), LORBDB, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL ZLACPY( 'L', P, Q, X11, LDX11, U1, LDU1 )
+ CALL ZUNGQR( P, P, Q, U1, LDU1, WORK(ITAUP1), WORK(IORGQR),
+ $ LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ U2(1,1) = ONE
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ U2(J,1) = ZERO
+ END DO
+ CALL ZLACPY( 'L', M-P-1, M-P-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL ZUNGQR( M-P-1, M-P-1, M-P-1, U2(2,2), LDU2,
+ $ WORK(ITAUP2), WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL ZLACPY( 'U', M-P, Q, X21, LDX21, V1T, LDV1T )
+ CALL ZUNGLQ( Q, Q, R, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( 'N', JOBV1T, JOBU2, JOBU1, 'T', M, M-Q, M-P,
+ $ THETA, RWORK(IPHI), 0, 1, V1T, LDV1T, U2, LDU2,
+ $ U1, LDU1, RWORK(IB11D), RWORK(IB11E),
+ $ RWORK(IB12D), RWORK(IB12E), RWORK(IB21D),
+ $ RWORK(IB21E), RWORK(IB22D), RWORK(IB22E),
+ $ RWORK(IBBCSD), LBBCSD, CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( Q .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = Q - R + I
+ END DO
+ DO I = R + 1, Q
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL ZLAPMT( .FALSE., P, Q, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL ZLAPMR( .FALSE., Q, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ ELSE
+*
+* Case 4: R = M-Q
+*
+* Simultaneously bidiagonalize X11 and X21
+*
+ CALL ZUNBDB4( M, P, Q, X11, LDX11, X21, LDX21, THETA,
+ $ RWORK(IPHI), WORK(ITAUP1), WORK(ITAUP2),
+ $ WORK(ITAUQ1), WORK(IORBDB), WORK(IORBDB+M),
+ $ LORBDB-M, CHILDINFO )
+*
+* Accumulate Householder reflectors
+*
+ IF( WANTU1 .AND. P .GT. 0 ) THEN
+ CALL ZCOPY( P, WORK(IORBDB), 1, U1, 1 )
+ DO J = 2, P
+ U1(1,J) = ZERO
+ END DO
+ CALL ZLACPY( 'L', P-1, M-Q-1, X11(2,1), LDX11, U1(2,2),
+ $ LDU1 )
+ CALL ZUNGQR( P, P, M-Q, U1, LDU1, WORK(ITAUP1),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTU2 .AND. M-P .GT. 0 ) THEN
+ CALL ZCOPY( M-P, WORK(IORBDB+P), 1, U2, 1 )
+ DO J = 2, M-P
+ U2(1,J) = ZERO
+ END DO
+ CALL ZLACPY( 'L', M-P-1, M-Q-1, X21(2,1), LDX21, U2(2,2),
+ $ LDU2 )
+ CALL ZUNGQR( M-P, M-P, M-Q, U2, LDU2, WORK(ITAUP2),
+ $ WORK(IORGQR), LORGQR, CHILDINFO )
+ END IF
+ IF( WANTV1T .AND. Q .GT. 0 ) THEN
+ CALL ZLACPY( 'U', M-Q, Q, X21, LDX21, V1T, LDV1T )
+ CALL ZLACPY( 'U', P-(M-Q), Q-(M-Q), X11(M-Q+1,M-Q+1), LDX11,
+ $ V1T(M-Q+1,M-Q+1), LDV1T )
+ CALL ZLACPY( 'U', -P+Q, Q-P, X21(M-Q+1,P+1), LDX21,
+ $ V1T(P+1,P+1), LDV1T )
+ CALL ZUNGLQ( Q, Q, Q, V1T, LDV1T, WORK(ITAUQ1),
+ $ WORK(IORGLQ), LORGLQ, CHILDINFO )
+ END IF
+*
+* Simultaneously diagonalize X11 and X21.
+*
+ CALL ZBBCSD( JOBU2, JOBU1, 'N', JOBV1T, 'N', M, M-P, M-Q,
+ $ THETA, RWORK(IPHI), U2, LDU2, U1, LDU1, 0, 1, V1T,
+ $ LDV1T, RWORK(IB11D), RWORK(IB11E), RWORK(IB12D),
+ $ RWORK(IB12E), RWORK(IB21D), RWORK(IB21E),
+ $ RWORK(IB22D), RWORK(IB22E), RWORK(IBBCSD), LBBCSD,
+ $ CHILDINFO )
+*
+* Permute rows and columns to place identity submatrices in
+* preferred positions
+*
+ IF( P .GT. R ) THEN
+ DO I = 1, R
+ IWORK(I) = P - R + I
+ END DO
+ DO I = R + 1, P
+ IWORK(I) = I - R
+ END DO
+ IF( WANTU1 ) THEN
+ CALL ZLAPMT( .FALSE., P, P, U1, LDU1, IWORK )
+ END IF
+ IF( WANTV1T ) THEN
+ CALL ZLAPMR( .FALSE., P, Q, V1T, LDV1T, IWORK )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of ZUNCSD2BY1
+*
+ END
+
*
* CSD
*
- WRITE( IOUNIT, FMT = 9920 )1
- WRITE( IOUNIT, FMT = 9921 )2
- WRITE( IOUNIT, FMT = 9922 )3
- WRITE( IOUNIT, FMT = 9923 )4
- WRITE( IOUNIT, FMT = 9924 )5
- WRITE( IOUNIT, FMT = 9925 )6
- WRITE( IOUNIT, FMT = 9926 )7
- WRITE( IOUNIT, FMT = 9927 )8
+ WRITE( IOUNIT, FMT = 9910 )
+ WRITE( IOUNIT, FMT = 9911 )1
+ WRITE( IOUNIT, FMT = 9912 )2
+ WRITE( IOUNIT, FMT = 9913 )3
+ WRITE( IOUNIT, FMT = 9914 )4
+ WRITE( IOUNIT, FMT = 9915 )5
+ WRITE( IOUNIT, FMT = 9916 )6
+ WRITE( IOUNIT, FMT = 9917 )7
+ WRITE( IOUNIT, FMT = 9918 )8
+ WRITE( IOUNIT, FMT = 9919 )9
+ WRITE( IOUNIT, FMT = 9920 )
+ WRITE( IOUNIT, FMT = 9921 )10
+ WRITE( IOUNIT, FMT = 9922 )11
+ WRITE( IOUNIT, FMT = 9923 )12
+ WRITE( IOUNIT, FMT = 9924 )13
+ WRITE( IOUNIT, FMT = 9925 )14
+ WRITE( IOUNIT, FMT = 9926 )15
END IF
*
9999 FORMAT( 1X, A )
*
* CSD test ratio
*
- 9920 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)',
+ 9910 FORMAT( 3X, '2-by-2 CSD' )
+ 9911 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)',
$ ' * max(norm(I-X''*X),EPS) )' )
- 9921 FORMAT( 3X, I2, ': norm( U1'' * X12 * V2-(-S)) / ( max( P,',
+ 9912 FORMAT( 3X, I2, ': norm( U1'' * X12 * V2-(-S)) / ( max( P,',
$ 'M-Q) * max(norm(I-X''*X),EPS) )' )
- 9922 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max(M-P,',
+ 9913 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max(M-P,',
$ ' Q) * max(norm(I-X''*X),EPS) )' )
- 9923 FORMAT( 3X, I2, ': norm( U2'' * X22 * V2 - C ) / ( max(M-P,',
+ 9914 FORMAT( 3X, I2, ': norm( U2'' * X22 * V2 - C ) / ( max(M-P,',
$ 'M-Q) * max(norm(I-X''*X),EPS) )' )
- 9924 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' )
- 9925 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' )
- 9926 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' )
- 9927 FORMAT( 3X, I2, ': norm( I - V2''*V2 ) / ( (M-Q) * EPS )' )
+ 9915 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' )
+ 9916 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' )
+ 9917 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' )
+ 9918 FORMAT( 3X, I2, ': norm( I - V2''*V2 ) / ( (M-Q) * EPS )' )
+ 9919 FORMAT( 3X, I2, ': principal angle ordering ( 0 or ULP )' )
+ 9920 FORMAT( 3X, '2-by-1 CSD' )
+ 9921 FORMAT( 3X, I2, ': norm( U1'' * X11 * V1 - C ) / ( max( P, Q)',
+ $ ' * max(norm(I-X''*X),EPS) )' )
+ 9922 FORMAT( 3X, I2, ': norm( U2'' * X21 * V1 - S ) / ( max( M-P,',
+ $ 'Q) * max(norm(I-X''*X),EPS) )' )
+ 9923 FORMAT( 3X, I2, ': norm( I - U1''*U1 ) / ( P * EPS )' )
+ 9924 FORMAT( 3X, I2, ': norm( I - U2''*U2 ) / ( (M-P) * EPS )' )
+ 9925 FORMAT( 3X, I2, ': norm( I - V1''*V1 ) / ( Q * EPS )' )
+ 9926 FORMAT( 3X, I2, ': principal angle ordering ( 0 or ULP )' )
RETURN
*
* End of ALAHDG
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- REAL GAPDIGIT, ORTH, PIOVER2, TEN
+ PARAMETER ( NTYPES = 4 )
+ REAL GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN
PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4,
$ PIOVER2 = 1.57079632679489662E0,
- $ TEN = 10.0D0 )
+ $ REALONE = 1.0E0, REALZERO = 0.0E0,
+ $ TEN = 10.0E0 )
+ COMPLEX ONE, ZERO
+ PARAMETER ( ONE = (1.0E0,0.0E0), ZERO = (0.0E0,0.0E0) )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- REAL SLARND
- EXTERNAL SLARND
+ REAL SLARAN, SLARND
+ EXTERNAL SLARAN, SLARND
* ..
* .. Executable Statements ..
*
$ ORTH*SLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT)
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL CLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL CLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( SLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL CSROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX),
+ $ 1, REALZERO, REALONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL CCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* REAL RESULT( 9 ), RWORK( * ), THETA( * )
+* REAL RESULT( 15 ), RWORK( * ), THETA( * )
* COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also SORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is REAL array, dimension (9)
+*> RESULT is REAL array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- REAL RESULT( 9 ), RWORK( * ), THETA( * )
+ REAL RESULT( 15 ), RWORK( * ), THETA( * )
COMPLEX U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
EXTERNAL SLAMCH, CLANGE, CLANHE
* ..
* .. External Subroutines ..
- EXTERNAL CGEMM, CLACPY, CLASET, CUNCSD, CHERK
+ EXTERNAL CGEMM, CHERK, CLACPY, CLASET, CUNCSD, CUNCSD2BY1
* ..
* .. Intrinsic Functions ..
- INTRINSIC REAL, MAX, MIN
+ INTRINSIC CMPLX, COS, MAX, MIN, REAL, SIN
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL CLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL CHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE,
$ X, LDX, REALONE, WORK, LDX )
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, RWORK, 17*(R+2), IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL CLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)),
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)),
$ 0.0E0 )
END DO
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ CMPLX( SIN(THETA(R-I+1)), 0.0E0 )
END DO
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ CMPLX( SIN(THETA(R-I+1)), 0.0E0 )
END DO
*
CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ CMPLX( COS(THETA(I)), 0.0E0 )
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = CLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = CLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = CLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = CLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = CLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = CLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = CLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = CLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL CHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE,
+ $ X, LDX, REALONE, WORK, LDX )
+ IF (M.GT.0) THEN
+ EPS2 = MAX( ULP,
+ $ CLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix X to the array XF.
+*
+ CALL CLACPY( 'Full', M, Q, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL CUNCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, RWORK, 17*(R+2), IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL CGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - CMPLX( COS(THETA(I)),
+ $ 0.0E0 )
+ END DO
+*
+ CALL CGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL CGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ CMPLX( SIN(THETA(R-I+1)), 0.0E0 )
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = CLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = CLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL CLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL CHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE,
+ $ U1, LDU1, REALONE, WORK, LDU1 )
+*
+* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = CLANHE( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL CLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL CHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE,
+ $ U2, LDU2, REALONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = CLANHE( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL CLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL CHERK( 'Upper', 'No transpose', Q, Q, -REALONE,
+ $ V1T, LDV1T, REALONE, WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = CLANHE( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
IF( I.GT.1) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
* End of CCSDTS
*
END
-
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, TEN
- PARAMETER ( GAPDIGIT = 18.0D0, ORTH = 1.0D-12,
+ PARAMETER ( NTYPES = 4 )
+ DOUBLE PRECISION GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO
+ PARAMETER ( GAPDIGIT = 18.0D0, ONE = 1.0D0,
+ $ ORTH = 1.0D-12,
$ PIOVER2 = 1.57079632679489662D0,
- $ TEN = 10.0D0 )
+ $ TEN = 10.0D0, ZERO = 0.0D0 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- DOUBLE PRECISION DLARND
- EXTERNAL DLARND
+ DOUBLE PRECISION DLARAN, DLARND
+ EXTERNAL DLARAN, DLARND
* ..
* .. Executable Statements ..
*
$ ORTH*DLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT)
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL DLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL DLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( DLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL DROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1,
+ $ ZERO, ONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL DCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+* DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
* DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
*> [ I 0 0 | 0 0 0 ]
*> [ 0 C 0 | 0 -S 0 ]
*> [ 0 0 0 | 0 0 -I ]
-*> = [---------------------] = [ D11 D12 ] .
+*> = [---------------------] = [ D11 D12 ] ,
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also DORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is DOUBLE PRECISION array, dimension (9)
+*> RESULT is DOUBLE PRECISION array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+ DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
DOUBLE PRECISION U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
EXTERNAL DLAMCH, DLANGE, DLANSY
* ..
* .. External Subroutines ..
- EXTERNAL DGEMM, DLACPY, DLASET, DORCSD, DSYRK
+ EXTERNAL DGEMM, DLACPY, DLASET, DORCSD, DORCSD2BY1,
+ $ DSYRK
* ..
* .. Intrinsic Functions ..
- INTRINSIC DBLE, MAX, MIN
+ INTRINSIC COS, DBLE, MAX, MIN, SIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL DSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX,
$ ONE, WORK, LDX )
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL DLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
END DO
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ SIN(THETA(R-I+1))
END DO
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ SIN(THETA(R-I+1))
END DO
*
CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ COS(THETA(I))
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = DLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = DLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = DLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = DLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / DBLE(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = DLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = DLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = DLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / DBLE(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1 ) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL DSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX,
+ $ ONE, WORK, LDX )
+ IF( M.GT.0 ) THEN
+ EPS2 = MAX( ULP,
+ $ DLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix [ X11; X21 ] to the array XF.
+*
+ CALL DLACPY( 'Full', M, Q, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL DORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL DGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL DGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ END DO
+*
+ CALL DGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL DGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ SIN(THETA(R-I+1))
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = DLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / DBLE(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = DLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / DBLE(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL DSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1,
+ $ ONE, WORK, LDU1 )
+*
+* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / DBLE(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL DLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL DSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2,
+ $ LDU2, ONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / DBLE(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL DLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL DSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE,
+ $ WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / DBLE(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
- IF( I.GT.1) THEN
+ IF( I.GT.1 ) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- REAL GAPDIGIT, ORTH, PIOVER2, TEN
- PARAMETER ( GAPDIGIT = 10.0E0, ORTH = 1.0E-4,
+ PARAMETER ( NTYPES = 4 )
+ REAL GAPDIGIT, ONE, ORTH, PIOVER2, TEN, ZERO
+ PARAMETER ( GAPDIGIT = 10.0E0, ONE = 1.0E0,
+ $ ORTH = 1.0E-4,
$ PIOVER2 = 1.57079632679489662E0,
- $ TEN = 10.0D0 )
+ $ TEN = 10.0E0, ZERO = 0.0E0 )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- REAL SLARND
- EXTERNAL SLARND
+ REAL SLARAN, SLARND
+ EXTERNAL SLARAN, SLARND
* ..
* .. Executable Statements ..
*
$ ORTH*SLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-SLARND(1,ISEED)*GAPDIGIT)
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL SLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL SLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( SLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL SROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX), 1,
+ $ ZERO, ONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL SCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* REAL RESULT( 9 ), RWORK( * ), THETA( * )
+* REAL RESULT( 15 ), RWORK( * ), THETA( * )
* REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also SORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is REAL array, dimension (9)
+*> RESULT is REAL array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- REAL RESULT( 9 ), RWORK( * ), THETA( * )
+ REAL RESULT( 15 ), RWORK( * ), THETA( * )
REAL U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
EXTERNAL SLAMCH, SLANGE, SLANSY
* ..
* .. External Subroutines ..
- EXTERNAL SGEMM, SLACPY, SLASET, SORCSD, SSYRK
+ EXTERNAL SGEMM, SLACPY, SLASET, SORCSD, SORCSD2BY1,
+ $ SSYRK
* ..
* .. Intrinsic Functions ..
- INTRINSIC REAL, MAX, MIN
+ INTRINSIC COS, MAX, MIN, REAL, SIN
* ..
* .. Executable Statements ..
*
ULP = SLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL SLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL SSYRK( 'Upper', 'Conjugate transpose', M, M, -ONE, X, LDX,
$ ONE, WORK, LDX )
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL SLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
END DO
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ SIN(THETA(R-I+1))
END DO
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ SIN(THETA(R-I+1))
END DO
*
CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ COS(THETA(I))
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = SLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = SLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = SLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = SLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = SLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = SLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = SLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = SLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1 ) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL SLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL SSYRK( 'Upper', 'Conjugate transpose', Q, M, -ONE, X, LDX,
+ $ ONE, WORK, LDX )
+ IF (M.GT.0) THEN
+ EPS2 = MAX( ULP,
+ $ SLANGE( '1', Q, Q, WORK, LDX, RWORK ) / REAL( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix [X11;X21] to the array XF.
+*
+ CALL SLACPY( 'Full', M, Q, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL SORCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL SGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL SGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - COS(THETA(I))
+ END DO
+*
+ CALL SGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL SGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ SIN(THETA(R-I+1))
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = SLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = SLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL SLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL SSYRK( 'Upper', 'Conjugate transpose', P, P, -ONE, U1, LDU1,
+ $ ONE, WORK, LDU1 )
+*
+* Compute norm( I - U1'*U1 ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = SLANSY( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL SLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL SSYRK( 'Upper', 'Conjugate transpose', M-P, M-P, -ONE, U2,
+ $ LDU2, ONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = SLANSY( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL SLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL SSYRK( 'Upper', 'No transpose', Q, Q, -ONE, V1T, LDV1T, ONE,
+ $ WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = SLANSY( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
- IF( I.GT.1) THEN
+ IF( I.GT.1 ) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
*
* .. Parameters ..
INTEGER NTESTS
- PARAMETER ( NTESTS = 9 )
+ PARAMETER ( NTESTS = 15 )
INTEGER NTYPES
- PARAMETER ( NTYPES = 3 )
- DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, TEN
+ PARAMETER ( NTYPES = 4 )
+ DOUBLE PRECISION GAPDIGIT, ORTH, PIOVER2, REALONE, REALZERO, TEN
PARAMETER ( GAPDIGIT = 18.0D0, ORTH = 1.0D-12,
$ PIOVER2 = 1.57079632679489662D0,
+ $ REALONE = 1.0D0, REALZERO = 0.0D0,
$ TEN = 10.0D0 )
+ COMPLEX*16 ONE, ZERO
+ PARAMETER ( ONE = (1.0D0,0.0D0), ZERO = (0.0D0,0.0D0) )
* ..
* .. Local Scalars ..
LOGICAL FIRSTT
INTRINSIC ABS, MIN
* ..
* .. External Functions ..
- DOUBLE PRECISION DLARND
- EXTERNAL DLARND
+ DOUBLE PRECISION DLARAN, DLARND
+ EXTERNAL DLARAN, DLARND
* ..
* .. Executable Statements ..
*
$ ORTH*DLARND(2,ISEED)
END DO
END DO
- ELSE
+ ELSE IF( IMAT.EQ.3 ) THEN
R = MIN( P, M-P, Q, M-Q )
DO I = 1, R+1
THETA(I) = TEN**(-DLARND(1,ISEED)*GAPDIGIT)
THETA(I) = PIOVER2 * THETA(I) / THETA(R+1)
END DO
CALL ZLACSG( M, P, Q, THETA, ISEED, X, LDX, WORK )
+ ELSE
+ CALL ZLASET( 'F', M, M, ZERO, ONE, X, LDX )
+ DO I = 1, M
+ J = INT( DLARAN( ISEED ) * M ) + 1
+ IF( J .NE. I ) THEN
+ CALL ZDROT( M, X(1+(I-1)*LDX), 1, X(1+(J-1)*LDX),
+ $ 1, REALZERO, REALONE )
+ END IF
+ END DO
END IF
*
- NT = 9
+ NT = 15
*
CALL ZCSDTS( M, P, Q, X, XF, LDX, U1, LDU1, U2, LDU2, V1T,
$ LDV1T, V2T, LDV2T, THETA, IWORK, WORK, LWORK,
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
-* DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+* DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
* COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
* $ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
* $ XF( LDX, * )
*> [ 0 0 0 | I 0 0 ] [ D21 D22 ]
*> [ 0 S 0 | 0 C 0 ]
*> [ 0 0 I | 0 0 0 ]
+*>
+*> and also SORCSD2BY1, which, given
+*> Q
+*> [ X11 ] P ,
+*> [ X21 ] M-P
+*>
+*> computes the 2-by-1 CSD
+*>
+*> [ I 0 0 ]
+*> [ 0 C 0 ]
+*> [ 0 0 0 ]
+*> [ U1 ]**T * [ X11 ] * V1 = [----------] = [ D11 ] ,
+*> [ U2 ] [ X21 ] [ 0 0 0 ] [ D21 ]
+*> [ 0 S 0 ]
+*> [ 0 0 I ]
*> \endverbatim
*
* Arguments:
*>
*> \param[out] RESULT
*> \verbatim
-*> RESULT is DOUBLE PRECISION array, dimension (9)
+*> RESULT is DOUBLE PRECISION array, dimension (15)
*> The test ratios:
+*> First, the 2-by-2 CSD:
*> RESULT(1) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
*> RESULT(2) = norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 )
*> RESULT(3) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
*> RESULT(9) = 0 if THETA is in increasing order and
*> all angles are in [0,pi/2];
*> = ULPINV otherwise.
+*> Then, the 2-by-1 CSD:
+*> RESULT(10) = norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 )
+*> RESULT(11) = norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 )
+*> RESULT(12) = norm( I - U1'*U1 ) / ( MAX(1,P)*ULP )
+*> RESULT(13) = norm( I - U2'*U2 ) / ( MAX(1,M-P)*ULP )
+*> RESULT(14) = norm( I - V1T'*V1T ) / ( MAX(1,Q)*ULP )
+*> RESULT(15) = 0 if THETA is in increasing order and
+*> all angles are in [0,pi/2];
+*> = ULPINV otherwise.
*> ( EPS2 = MAX( norm( I - X'*X ) / M, ULP ). )
*> \endverbatim
*
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
- DOUBLE PRECISION RESULT( 9 ), RWORK( * ), THETA( * )
+ DOUBLE PRECISION RESULT( 15 ), RWORK( * ), THETA( * )
COMPLEX*16 U1( LDU1, * ), U2( LDU2, * ), V1T( LDV1T, * ),
$ V2T( LDV2T, * ), WORK( LWORK ), X( LDX, * ),
$ XF( LDX, * )
EXTERNAL DLAMCH, ZLANGE, ZLANHE
* ..
* .. External Subroutines ..
- EXTERNAL ZGEMM, ZLACPY, ZLASET, ZUNCSD, ZHERK
+ EXTERNAL ZGEMM, ZHERK, ZLACPY, ZLASET, ZUNCSD, ZUNCSD2BY1
* ..
* .. Intrinsic Functions ..
- INTRINSIC REAL, MAX, MIN
+ INTRINSIC COS, DBLE, DCMPLX, MAX, MIN, REAL, SIN
* ..
* .. Executable Statements ..
*
ULP = DLAMCH( 'Precision' )
ULPINV = REALONE / ULP
+*
+* The first half of the routine checks the 2-by-2 CSD
+*
CALL ZLASET( 'Full', M, M, ZERO, ONE, WORK, LDX )
CALL ZHERK( 'Upper', 'Conjugate transpose', M, M, -REALONE,
$ X, LDX, REALONE, WORK, LDX )
$ THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T,
$ WORK, LWORK, RWORK, 17*(R+2), IWORK, INFO )
*
-* Compute X := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+* Compute XF := diag(U1,U2)'*X*diag(V1,V2) - [D11 D12; D21 D22]
+*
+ CALL ZLACPY( 'Full', M, M, X, LDX, XF, LDX )
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
- $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF, LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
- $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+ $ U1, LDU1, WORK, LDX, ZERO, XF, LDX )
*
DO I = 1, MIN(P,Q)-R
- X(I,I) = X(I,I) - ONE
+ XF(I,I) = XF(I,I) - ONE
END DO
DO I = 1, R
- X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
- $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)),
+ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ XF(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)),
$ 0.0D0 )
END DO
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, M-Q, M-Q,
- $ ONE, X(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, M-Q, P,
- $ ONE, U1, LDU1, WORK, LDX, ZERO, X(1,Q+1), LDX )
+ $ ONE, U1, LDU1, WORK, LDX, ZERO, XF(1,Q+1), LDX )
*
DO I = 1, MIN(P,M-Q)-R
- X(P-I+1,M-I+1) = X(P-I+1,M-I+1) + ONE
+ XF(P-I+1,M-I+1) = XF(P-I+1,M-I+1) + ONE
END DO
DO I = 1, R
- X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
- $ X(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
+ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) =
+ $ XF(P-(MIN(P,M-Q)-R)+1-I,M-(MIN(P,M-Q)-R)+1-I) +
$ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 )
END DO
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
- $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+ $ XF(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,1), LDX )
*
DO I = 1, MIN(M-P,Q)-R
- X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ XF(M-I+1,Q-I+1) = XF(M-I+1,Q-I+1) - ONE
END DO
DO I = 1, R
- X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
- $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ XF(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
$ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 )
END DO
*
CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, M-Q, M-Q,
- $ ONE, X(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
+ $ ONE, XF(P+1,Q+1), LDX, V2T, LDV2T, ZERO, WORK, LDX )
*
CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, M-Q, M-P,
- $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,Q+1), LDX )
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, XF(P+1,Q+1), LDX )
*
DO I = 1, MIN(M-P,M-Q)-R
- X(P+I,Q+I) = X(P+I,Q+I) - ONE
+ XF(P+I,Q+I) = XF(P+I,Q+I) - ONE
END DO
DO I = 1, R
- X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
- $ X(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
+ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) =
+ $ XF(P+(MIN(M-P,M-Q)-R)+I,Q+(MIN(M-P,M-Q)-R)+I) -
$ DCMPLX( COS(THETA(I)), 0.0D0 )
END DO
*
* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', P, Q, X, LDX, RWORK )
+ RESID = ZLANGE( '1', P, Q, XF, LDX, RWORK )
RESULT( 1 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
*
* Compute norm( U1'*X12*V2 - D12 ) / ( MAX(1,P,M-Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', P, M-Q, X(1,Q+1), LDX, RWORK )
+ RESID = ZLANGE( '1', P, M-Q, XF(1,Q+1), LDX, RWORK )
RESULT( 2 ) = ( RESID / REAL(MAX(1,P,M-Q)) ) / EPS2
*
* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESID = ZLANGE( '1', M-P, Q, XF(P+1,1), LDX, RWORK )
RESULT( 3 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
*
* Compute norm( U2'*X22*V2 - D22 ) / ( MAX(1,M-P,M-Q)*EPS2 ) .
*
- RESID = ZLANGE( '1', M-P, M-Q, X(P+1,Q+1), LDX, RWORK )
+ RESID = ZLANGE( '1', M-P, M-Q, XF(P+1,Q+1), LDX, RWORK )
RESULT( 4 ) = ( RESID / REAL(MAX(1,M-P,M-Q)) ) / EPS2
*
* Compute I - U1'*U1
*
* Check sorting
*
- RESULT(9) = REALZERO
+ RESULT( 9 ) = REALZERO
+ DO I = 1, R
+ IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ IF( I.GT.1) THEN
+ IF ( THETA(I).LT.THETA(I-1) ) THEN
+ RESULT( 9 ) = ULPINV
+ END IF
+ END IF
+ END DO
+*
+* The second half of the routine checks the 2-by-1 CSD
+*
+ CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDX )
+ CALL ZHERK( 'Upper', 'Conjugate transpose', Q, M, -REALONE,
+ $ X, LDX, REALONE, WORK, LDX )
+ IF (M.GT.0) THEN
+ EPS2 = MAX( ULP,
+ $ ZLANGE( '1', Q, Q, WORK, LDX, RWORK ) / DBLE( M ) )
+ ELSE
+ EPS2 = ULP
+ END IF
+ R = MIN( P, M-P, Q, M-Q )
+*
+* Copy the matrix X to the array XF.
+*
+ CALL ZLACPY( 'Full', M, M, X, LDX, XF, LDX )
+*
+* Compute the CSD
+*
+ CALL ZUNCSD2BY1( 'Y', 'Y', 'Y', M, P, Q, XF(1,1), LDX, XF(P+1,1),
+ $ LDX, THETA, U1, LDU1, U2, LDU2, V1T, LDV1T, WORK,
+ $ LWORK, RWORK, 17*(R+2), IWORK, INFO )
+*
+* Compute [X11;X21] := diag(U1,U2)'*[X11;X21]*V1 - [D11;D21]
+*
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', P, Q, Q, ONE,
+ $ X, LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL ZGEMM( 'Conjugate transpose', 'No transpose', P, Q, P, ONE,
+ $ U1, LDU1, WORK, LDX, ZERO, X, LDX )
+*
+ DO I = 1, MIN(P,Q)-R
+ X(I,I) = X(I,I) - ONE
+ END DO
+ DO I = 1, R
+ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) =
+ $ X(MIN(P,Q)-R+I,MIN(P,Q)-R+I) - DCMPLX( COS(THETA(I)),
+ $ 0.0D0 )
+ END DO
+*
+ CALL ZGEMM( 'No transpose', 'Conjugate transpose', M-P, Q, Q, ONE,
+ $ X(P+1,1), LDX, V1T, LDV1T, ZERO, WORK, LDX )
+*
+ CALL ZGEMM( 'Conjugate transpose', 'No transpose', M-P, Q, M-P,
+ $ ONE, U2, LDU2, WORK, LDX, ZERO, X(P+1,1), LDX )
+*
+ DO I = 1, MIN(M-P,Q)-R
+ X(M-I+1,Q-I+1) = X(M-I+1,Q-I+1) - ONE
+ END DO
+ DO I = 1, R
+ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) =
+ $ X(M-(MIN(M-P,Q)-R)+1-I,Q-(MIN(M-P,Q)-R)+1-I) -
+ $ DCMPLX( SIN(THETA(R-I+1)), 0.0D0 )
+ END DO
+*
+* Compute norm( U1'*X11*V1 - D11 ) / ( MAX(1,P,Q)*EPS2 ) .
+*
+ RESID = ZLANGE( '1', P, Q, X, LDX, RWORK )
+ RESULT( 10 ) = ( RESID / REAL(MAX(1,P,Q)) ) / EPS2
+*
+* Compute norm( U2'*X21*V1 - D21 ) / ( MAX(1,M-P,Q)*EPS2 ) .
+*
+ RESID = ZLANGE( '1', M-P, Q, X(P+1,1), LDX, RWORK )
+ RESULT( 11 ) = ( RESID / REAL(MAX(1,M-P,Q)) ) / EPS2
+*
+* Compute I - U1'*U1
+*
+ CALL ZLASET( 'Full', P, P, ZERO, ONE, WORK, LDU1 )
+ CALL ZHERK( 'Upper', 'Conjugate transpose', P, P, -REALONE,
+ $ U1, LDU1, REALONE, WORK, LDU1 )
+*
+* Compute norm( I - U'*U ) / ( MAX(1,P) * ULP ) .
+*
+ RESID = ZLANHE( '1', 'Upper', P, WORK, LDU1, RWORK )
+ RESULT( 12 ) = ( RESID / REAL(MAX(1,P)) ) / ULP
+*
+* Compute I - U2'*U2
+*
+ CALL ZLASET( 'Full', M-P, M-P, ZERO, ONE, WORK, LDU2 )
+ CALL ZHERK( 'Upper', 'Conjugate transpose', M-P, M-P, -REALONE,
+ $ U2, LDU2, REALONE, WORK, LDU2 )
+*
+* Compute norm( I - U2'*U2 ) / ( MAX(1,M-P) * ULP ) .
+*
+ RESID = ZLANHE( '1', 'Upper', M-P, WORK, LDU2, RWORK )
+ RESULT( 13 ) = ( RESID / REAL(MAX(1,M-P)) ) / ULP
+*
+* Compute I - V1T*V1T'
+*
+ CALL ZLASET( 'Full', Q, Q, ZERO, ONE, WORK, LDV1T )
+ CALL ZHERK( 'Upper', 'No transpose', Q, Q, -REALONE,
+ $ V1T, LDV1T, REALONE, WORK, LDV1T )
+*
+* Compute norm( I - V1T*V1T' ) / ( MAX(1,Q) * ULP ) .
+*
+ RESID = ZLANHE( '1', 'Upper', Q, WORK, LDV1T, RWORK )
+ RESULT( 14 ) = ( RESID / REAL(MAX(1,Q)) ) / ULP
+*
+* Check sorting
+*
+ RESULT( 15 ) = REALZERO
DO I = 1, R
IF( THETA(I).LT.REALZERO .OR. THETA(I).GT.PIOVER2 ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
IF( I.GT.1) THEN
IF ( THETA(I).LT.THETA(I-1) ) THEN
- RESULT(9) = ULPINV
+ RESULT( 15 ) = ULPINV
END IF
END IF
END DO
0 10 10 10 10 21 24 30 22 32 55 Values of M (row and column dimension of unitary matrix)
0 4 4 0 10 9 10 20 12 12 40 Values of P (row dimension of top-left block)
0 0 10 4 4 15 12 8 20 8 20 Values of Q (column dimension of top-left block)
-10.0 Threshold value of test ratio
+30.0 Threshold value of test ratio
T Put T to test the error exits
1 Code to interpret the seed
-CSD 3 List types on next line if 0 < NTYPES < 3
+CSD 4 List types on next line if 0 < NTYPES < 3
projects / platform / upstream / lapack.git / commitdiff