Commit Brian Sutton new CS Decomposition routines.

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.

40 files changed, 11624 insertions, 195 deletions

diff --git a/SRC/CMakeLists.txt b/SRC/CMakeLists.txt
index b0bac95d..e0935de2 100644
--- a/SRC/CMakeLists.txt
+++ b/SRC/CMakeLists.txt
@@ -146,7 +146,8 @@ set(SLASRC
    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
   )
@@ -223,7 +224,8 @@ set(CLASRC
    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)
 
@@ -300,7 +302,8 @@ set(DLASRC
    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 )
 
@@ -379,7 +382,8 @@ set(ZLASRC
    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)
 
diff --git a/SRC/Makefile b/SRC/Makefile
index 531f55ae..0679f3de 100644
--- a/SRC/Makefile
+++ b/SRC/Makefile
@@ -152,7 +152,8 @@ SLASRC = \
    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
 
@@ -230,7 +231,8 @@ CLASRC = \
    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
 
@@ -309,7 +311,8 @@ DLASRC = \
    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
 
@@ -390,7 +393,8 @@ ZLASRC = \
    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
 
diff --git a/SRC/cunbdb1.f b/SRC/cunbdb1.f
new file mode 100644
index 00000000..fea26b21
--- /dev/null
+++ b/SRC/cunbdb1.f
@@ -0,0 +1,327 @@
+*> \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
+
diff --git a/SRC/cunbdb2.f b/SRC/cunbdb2.f
new file mode 100644
index 00000000..cec00f93
--- /dev/null
+++ b/SRC/cunbdb2.f
@@ -0,0 +1,337 @@
+*> \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
+
diff --git a/SRC/cunbdb3.f b/SRC/cunbdb3.f
new file mode 100644
index 00000000..5451ef00
--- /dev/null
+++ b/SRC/cunbdb3.f
@@ -0,0 +1,336 @@
+*> \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
+
diff --git a/SRC/cunbdb4.f b/SRC/cunbdb4.f
new file mode 100644
index 00000000..bc948a30
--- /dev/null
+++ b/SRC/cunbdb4.f
@@ -0,0 +1,385 @@
+*> \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
+
diff --git a/SRC/cunbdb5.f b/SRC/cunbdb5.f
new file mode 100644
index 00000000..d3a7d153
--- /dev/null
+++ b/SRC/cunbdb5.f
@@ -0,0 +1,274 @@
+*> \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
+
diff --git a/SRC/cunbdb6.f b/SRC/cunbdb6.f
new file mode 100644
index 00000000..943e5224
--- /dev/null
+++ b/SRC/cunbdb6.f
@@ -0,0 +1,313 @@
+*> \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
+
diff --git a/SRC/cuncsd2by1.f b/SRC/cuncsd2by1.f
new file mode 100644
index 00000000..172ff7ac
--- /dev/null
+++ b/SRC/cuncsd2by1.f
@@ -0,0 +1,757 @@
+*> \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
+
diff --git a/SRC/dorbdb1.f b/SRC/dorbdb1.f
new file mode 100644
index 00000000..b5675f71
--- /dev/null
+++ b/SRC/dorbdb1.f
@@ -0,0 +1,324 @@
+*> \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
+
diff --git a/SRC/dorbdb2.f b/SRC/dorbdb2.f
new file mode 100644
index 00000000..3cf82cf4
--- /dev/null
+++ b/SRC/dorbdb2.f
@@ -0,0 +1,333 @@
+*> \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
+
diff --git a/SRC/dorbdb3.f b/SRC/dorbdb3.f
new file mode 100644
index 00000000..03be504f
--- /dev/null
+++ b/SRC/dorbdb3.f
@@ -0,0 +1,332 @@
+*> \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
+
diff --git a/SRC/dorbdb4.f b/SRC/dorbdb4.f
new file mode 100644
index 00000000..8c723605
--- /dev/null
+++ b/SRC/dorbdb4.f
@@ -0,0 +1,378 @@
+*> \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
+
diff --git a/SRC/dorbdb5.f b/SRC/dorbdb5.f
new file mode 100644
index 00000000..8fd8e6e3
--- /dev/null
+++ b/SRC/dorbdb5.f
@@ -0,0 +1,274 @@
+*> \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
+
diff --git a/SRC/dorbdb6.f b/SRC/dorbdb6.f
new file mode 100644
index 00000000..59fd863b
--- /dev/null
+++ b/SRC/dorbdb6.f
@@ -0,0 +1,312 @@
+*> \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
+
diff --git a/SRC/dorcsd2by1.f b/SRC/dorcsd2by1.f
new file mode 100644
index 00000000..916b1759
--- /dev/null
+++ b/SRC/dorcsd2by1.f
@@ -0,0 +1,715 @@
+*> \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
+
diff --git a/SRC/sorbdb1.f b/SRC/sorbdb1.f
new file mode 100644
index 00000000..b1f5f462
--- /dev/null
+++ b/SRC/sorbdb1.f
@@ -0,0 +1,324 @@
+*> \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
+
diff --git a/SRC/sorbdb2.f b/SRC/sorbdb2.f
new file mode 100644
index 00000000..582540e3
--- /dev/null
+++ b/SRC/sorbdb2.f
@@ -0,0 +1,332 @@
+*> \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
+
diff --git a/SRC/sorbdb3.f b/SRC/sorbdb3.f
new file mode 100644
index 00000000..ea52f4db
--- /dev/null
+++ b/SRC/sorbdb3.f
@@ -0,0 +1,333 @@
+*> \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
+
diff --git a/SRC/sorbdb4.f b/SRC/sorbdb4.f
new file mode 100644
index 00000000..9ed16a71
--- /dev/null
+++ b/SRC/sorbdb4.f
@@ -0,0 +1,379 @@
+*> \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
+
diff --git a/SRC/sorbdb5.f b/SRC/sorbdb5.f
new file mode 100644
index 00000000..a0b6672c
--- /dev/null
+++ b/SRC/sorbdb5.f
@@ -0,0 +1,274 @@
+*> \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
+
diff --git a/SRC/sorbdb6.f b/SRC/sorbdb6.f
new file mode 100644
index 00000000..900316ee
--- /dev/null
+++ b/SRC/sorbdb6.f
@@ -0,0 +1,312 @@
+*> \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
+
diff --git a/SRC/sorcsd2by1.f b/SRC/sorcsd2by1.f
new file mode 100644
index 00000000..b7b3b8a3
--- /dev/null
+++ b/SRC/sorcsd2by1.f
@@ -0,0 +1,711 @@
+*> \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
+
diff --git a/SRC/zunbdb1.f b/SRC/zunbdb1.f
new file mode 100644
index 00000000..4125450c
--- /dev/null
+++ b/SRC/zunbdb1.f
@@ -0,0 +1,328 @@
+*> \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
+
diff --git a/SRC/zunbdb2.f b/SRC/zunbdb2.f
new file mode 100644
index 00000000..89104f65
--- /dev/null
+++ b/SRC/zunbdb2.f
@@ -0,0 +1,336 @@
+*> \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
+
diff --git a/SRC/zunbdb3.f b/SRC/zunbdb3.f
new file mode 100644
index 00000000..37a5c89f
--- /dev/null
+++ b/SRC/zunbdb3.f
@@ -0,0 +1,336 @@
+*> \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
+
diff --git a/SRC/zunbdb4.f b/SRC/zunbdb4.f
new file mode 100644
index 00000000..91ed9d05
--- /dev/null
+++ b/SRC/zunbdb4.f
@@ -0,0 +1,385 @@
+*> \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
+
diff --git a/SRC/zunbdb5.f b/SRC/zunbdb5.f
new file mode 100644
index 00000000..f777324b
--- /dev/null
+++ b/SRC/zunbdb5.f
@@ -0,0 +1,274 @@
+*> \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
+
diff --git a/SRC/zunbdb6.f b/SRC/zunbdb6.f
new file mode 100644
index 00000000..931710d0
--- /dev/null
+++ b/SRC/zunbdb6.f
@@ -0,0 +1,313 @@
+*> \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
+
diff --git a/SRC/zuncsd2by1.f b/SRC/zuncsd2by1.f
new file mode 100644
index 00000000..c2e228e2
--- /dev/null
+++ b/SRC/zuncsd2by1.f
@@ -0,0 +1,756 @@
+*> \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
+
diff --git a/TESTING/EIG/alahdg.f b/TESTING/EIG/alahdg.f
index 1431d8ee..51959416 100644
--- a/TESTING/EIG/alahdg.f
+++ b/TESTING/EIG/alahdg.f
@@ -209,14 +209,23 @@
 *
 *        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 )
@@ -291,18 +300,29 @@
 *
 *     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
diff --git a/TESTING/EIG/cckcsd.f b/TESTING/EIG/cckcsd.f
index c6cb13b0..a4146c74 100644
--- a/TESTING/EIG/cckcsd.f
+++ b/TESTING/EIG/cckcsd.f
@@ -205,13 +205,16 @@
 *
 *     .. 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
@@ -231,8 +234,8 @@
       INTRINSIC          ABS, MIN
 *     ..
 *     .. External Functions ..
-      REAL               SLARND
-      EXTERNAL           SLARND
+      REAL               SLARAN, SLARND
+      EXTERNAL           SLARAN, SLARND
 *     ..
 *     .. Executable Statements ..
 *
@@ -286,7 +289,7 @@
      $                                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)
@@ -298,9 +301,18 @@
                   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,
diff --git a/TESTING/EIG/ccsdts.f b/TESTING/EIG/ccsdts.f
index da6ac6b7..34ab56cc 100644
--- a/TESTING/EIG/ccsdts.f
+++ b/TESTING/EIG/ccsdts.f
@@ -17,7 +17,7 @@
 *       ..
 *       .. 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, * )
@@ -47,6 +47,21 @@
 *>                             [  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:
@@ -171,8 +186,9 @@
 *>
 *> \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 )
@@ -184,6 +200,15 @@
 *>          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
 *
@@ -214,7 +239,7 @@
 *     ..
 *     .. 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, * )
@@ -238,15 +263,18 @@
       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 )
@@ -269,86 +297,88 @@
      $             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
@@ -397,14 +427,126 @@
 *
 *     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
@@ -414,4 +556,3 @@
 *     End of CCSDTS
 *
       END
-
diff --git a/TESTING/EIG/dckcsd.f b/TESTING/EIG/dckcsd.f
index 94892b79..219ebafc 100644
--- a/TESTING/EIG/dckcsd.f
+++ b/TESTING/EIG/dckcsd.f
@@ -205,13 +205,14 @@
 *
 *     .. 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
@@ -231,8 +232,8 @@
       INTRINSIC          ABS, MIN
 *     ..
 *     .. External Functions ..
-      DOUBLE PRECISION   DLARND
-      EXTERNAL           DLARND
+      DOUBLE PRECISION   DLARAN, DLARND
+      EXTERNAL           DLARAN, DLARND
 *     ..
 *     .. Executable Statements ..
 *
@@ -286,7 +287,7 @@
      $                                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)
@@ -298,9 +299,18 @@
                   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,
diff --git a/TESTING/EIG/dcsdts.f b/TESTING/EIG/dcsdts.f
index de0e3a93..528092a1 100644
--- a/TESTING/EIG/dcsdts.f
+++ b/TESTING/EIG/dcsdts.f
@@ -17,7 +17,7 @@
 *       ..
 *       .. 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, * )
@@ -43,10 +43,25 @@
 *>                             [  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:
@@ -171,8 +186,9 @@
 *>
 *> \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 )
@@ -184,6 +200,15 @@
 *>          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
 *
@@ -214,7 +239,7 @@
 *     ..
 *     .. 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, * )
@@ -238,15 +263,19 @@
       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 )
@@ -269,85 +298,87 @@
      $             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
@@ -396,14 +427,125 @@
 *
 *     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
diff --git a/TESTING/EIG/sckcsd.f b/TESTING/EIG/sckcsd.f
index fe5de85a..20ba3d66 100644
--- a/TESTING/EIG/sckcsd.f
+++ b/TESTING/EIG/sckcsd.f
@@ -205,13 +205,14 @@
 *
 *     .. 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
@@ -231,8 +232,8 @@
       INTRINSIC          ABS, MIN
 *     ..
 *     .. External Functions ..
-      REAL               SLARND
-      EXTERNAL           SLARND
+      REAL               SLARAN, SLARND
+      EXTERNAL           SLARAN, SLARND
 *     ..
 *     .. Executable Statements ..
 *
@@ -286,7 +287,7 @@
      $                                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)
@@ -298,9 +299,18 @@
                   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,
diff --git a/TESTING/EIG/scsdts.f b/TESTING/EIG/scsdts.f
index 74b32ead..a326f356 100644
--- a/TESTING/EIG/scsdts.f
+++ b/TESTING/EIG/scsdts.f
@@ -17,7 +17,7 @@
 *       ..
 *       .. 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, * )
@@ -47,6 +47,21 @@
 *>                             [  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:
@@ -171,8 +186,9 @@
 *>
 *> \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 )
@@ -184,6 +200,15 @@
 *>          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
 *
@@ -214,7 +239,7 @@
 *     ..
 *     .. 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, * )
@@ -238,15 +263,19 @@
       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 )
@@ -269,85 +298,87 @@
      $             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
@@ -396,14 +427,125 @@
 *
 *     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
diff --git a/TESTING/EIG/zckcsd.f b/TESTING/EIG/zckcsd.f
index 5385131c..99ed5bd5 100644
--- a/TESTING/EIG/zckcsd.f
+++ b/TESTING/EIG/zckcsd.f
@@ -205,13 +205,16 @@
 *
 *     .. 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
@@ -231,8 +234,8 @@
       INTRINSIC          ABS, MIN
 *     ..
 *     .. External Functions ..
-      DOUBLE PRECISION   DLARND
-      EXTERNAL           DLARND
+      DOUBLE PRECISION   DLARAN, DLARND
+      EXTERNAL           DLARAN, DLARND
 *     ..
 *     .. Executable Statements ..
 *
@@ -286,7 +289,7 @@
      $                                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)
@@ -298,9 +301,18 @@
                   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,
diff --git a/TESTING/EIG/zcsdts.f b/TESTING/EIG/zcsdts.f
index 9d8ba2b5..044fa76f 100644
--- a/TESTING/EIG/zcsdts.f
+++ b/TESTING/EIG/zcsdts.f
@@ -17,7 +17,7 @@
 *       ..
 *       .. 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, * )
@@ -47,6 +47,21 @@
 *>                             [  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:
@@ -171,8 +186,9 @@
 *>
 *> \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 )
@@ -184,6 +200,15 @@
 *>          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
 *
@@ -214,7 +239,7 @@
 *     ..
 *     .. 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, * )
@@ -238,15 +263,18 @@
       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 )
@@ -269,86 +297,88 @@
      $             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
@@ -397,14 +427,126 @@
 *
 *     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
diff --git a/TESTING/csd.in b/TESTING/csd.in
index b146d395..a0a2e545 100644
--- a/TESTING/csd.in
+++ b/TESTING/csd.in
@@ -3,7 +3,7 @@ CSD:  Data file for testing CS decomposition routines
 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