LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ cuncsd2by1()

subroutine cuncsd2by1 ( character  JOBU1,
character  JOBU2,
character  JOBV1T,
integer  M,
integer  P,
integer  Q,
complex, dimension(ldx11,*)  X11,
integer  LDX11,
complex, dimension(ldx21,*)  X21,
integer  LDX21,
real, dimension(*)  THETA,
complex, dimension(ldu1,*)  U1,
integer  LDU1,
complex, dimension(ldu2,*)  U2,
integer  LDU2,
complex, dimension(ldv1t,*)  V1T,
integer  LDV1T,
complex, dimension(*)  WORK,
integer  LWORK,
real, dimension(*)  RWORK,
integer  LRWORK,
integer, dimension(*)  IWORK,
integer  INFO 
)

CUNCSD2BY1

Download CUNCSD2BY1 + dependencies [TGZ] [ZIP] [TXT]

Purpose: 
 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:

                                [  I1 0  0 ]
                                [  0  C  0 ]
          [ X11 ]   [ U1 |    ] [  0  0  0 ]
      X = [-----] = [---------] [----------] V1**T .
          [ X21 ]   [    | U2 ] [  0  0  0 ]
                                [  0  S  0 ]
                                [  0  0  I2]

 X11 is P-by-Q. The unitary matrices U1, U2, and V1 are P-by-P,
 (M-P)-by-(M-P), and Q-by-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). I1 is a K1-by-K1 identity matrix and I2 is a
 K2-by-K2 identity matrix, where K1 = MAX(Q+P-M,0), K2 = MAX(Q-P,0).
Parameters
[in]JOBU1
          JOBU1 is CHARACTER
          = 'Y':      U1 is computed;
          otherwise:  U1 is not computed.
[in]JOBU2
          JOBU2 is CHARACTER
          = 'Y':      U2 is computed;
          otherwise:  U2 is not computed.
[in]JOBV1T
          JOBV1T is CHARACTER
          = 'Y':      V1T is computed;
          otherwise:  V1T is not computed.
[in]M
          M is INTEGER
          The number of rows in X.
[in]P
          P is INTEGER
          The number of rows in X11. 0 <= P <= M.
[in]Q
          Q is INTEGER
          The number of columns in X11 and X21. 0 <= Q <= M.
[in,out]X11
          X11 is COMPLEX array, dimension (LDX11,Q)
          On entry, part of the unitary matrix whose CSD is desired.
[in]LDX11
          LDX11 is INTEGER
          The leading dimension of X11. LDX11 >= MAX(1,P).
[in,out]X21
          X21 is COMPLEX array, dimension (LDX21,Q)
          On entry, part of the unitary matrix whose CSD is desired.
[in]LDX21
          LDX21 is INTEGER
          The leading dimension of X21. LDX21 >= MAX(1,M-P).
[out]THETA
          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)) ).
[out]U1
          U1 is COMPLEX array, dimension (P)
          If JOBU1 = 'Y', U1 contains the P-by-P unitary matrix U1.
[in]LDU1
          LDU1 is INTEGER
          The leading dimension of U1. If JOBU1 = 'Y', LDU1 >=
          MAX(1,P).
[out]U2
          U2 is COMPLEX array, dimension (M-P)
          If JOBU2 = 'Y', U2 contains the (M-P)-by-(M-P) unitary
          matrix U2.
[in]LDU2
          LDU2 is INTEGER
          The leading dimension of U2. If JOBU2 = 'Y', LDU2 >=
          MAX(1,M-P).
[out]V1T
          V1T is COMPLEX array, dimension (Q)
          If JOBV1T = 'Y', V1T contains the Q-by-Q matrix unitary
          matrix V1**T.
[in]LDV1T
          LDV1T is INTEGER
          The leading dimension of V1T. If JOBV1T = 'Y', LDV1T >=
          MAX(1,Q).
[out]WORK
          WORK is COMPLEX array, dimension (MAX(1,LWORK))
          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
[in]LWORK
          LWORK is INTEGER
          The dimension of the array WORK.

          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.
[out]RWORK
          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.
[in]LRWORK
          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.
[out]IWORK
          IWORK is INTEGER array, dimension (M-MIN(P,M-P,Q,M-Q))
[out]INFO
          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.
References:
[1] Brian D. Sutton. Computing the complete CS decomposition. Numer. Algorithms, 50(1):33-65, 2009.
Author
Univ. of Tennessee
Univ. of California Berkeley
Univ. of Colorado Denver
NAG Ltd.
Date
June 2016

Definition at line 257 of file cuncsd2by1.f.

257 *
258 * -- LAPACK computational routine (version 3.7.1) --
259 * -- LAPACK is a software package provided by Univ. of Tennessee, --
260 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
261 * June 2016
262 *
263 * .. Scalar Arguments ..
264  CHARACTER jobu1, jobu2, jobv1t
265  INTEGER info, ldu1, ldu2, ldv1t, lwork, ldx11, ldx21,
266  $ m, p, q
267  INTEGER lrwork, lrworkmin, lrworkopt
268 * ..
269 * .. Array Arguments ..
270  REAL rwork(*)
271  REAL theta(*)
272  COMPLEX u1(ldu1,*), u2(ldu2,*), v1t(ldv1t,*), work(*),
273  $ x11(ldx11,*), x21(ldx21,*)
274  INTEGER iwork(*)
275 * ..
276 *
277 * =====================================================================
278 *
279 * .. Parameters ..
280  COMPLEX one, zero
281  parameter( one = (1.0e0,0.0e0), zero = (0.0e0,0.0e0) )
282 * ..
283 * .. Local Scalars ..
284  INTEGER childinfo, i, ib11d, ib11e, ib12d, ib12e,
285  $ ib21d, ib21e, ib22d, ib22e, ibbcsd, iorbdb,
286  $ iorglq, iorgqr, iphi, itaup1, itaup2, itauq1,
287  $ j, lbbcsd, lorbdb, lorglq, lorglqmin,
288  $ lorglqopt, lorgqr, lorgqrmin, lorgqropt,
289  $ lworkmin, lworkopt, r
290  LOGICAL lquery, wantu1, wantu2, wantv1t
291 * ..
292 * .. Local Arrays ..
293  REAL dum( 1 )
294  COMPLEX cdum( 1, 1 )
295 * ..
296 * .. External Subroutines ..
297  EXTERNAL cbbcsd, ccopy, clacpy, clapmr, clapmt, cunbdb1,
298  $ cunbdb2, cunbdb3, cunbdb4, cunglq, cungqr,
299  $ xerbla
300 * ..
301 * .. External Functions ..
302  LOGICAL lsame
303  EXTERNAL lsame
304 * ..
305 * .. Intrinsic Function ..
306  INTRINSIC int, max, min
307 * ..
308 * .. Executable Statements ..
309 *
310 * Test input arguments
311 *
312  info = 0
313  wantu1 = lsame( jobu1, 'Y' )
314  wantu2 = lsame( jobu2, 'Y' )
315  wantv1t = lsame( jobv1t, 'Y' )
316  lquery = lwork .EQ. -1
317 *
318  IF( m .LT. 0 ) THEN
319  info = -4
320  ELSE IF( p .LT. 0 .OR. p .GT. m ) THEN
321  info = -5
322  ELSE IF( q .LT. 0 .OR. q .GT. m ) THEN
323  info = -6
324  ELSE IF( ldx11 .LT. max( 1, p ) ) THEN
325  info = -8
326  ELSE IF( ldx21 .LT. max( 1, m-p ) ) THEN
327  info = -10
328  ELSE IF( wantu1 .AND. ldu1 .LT. max( 1, p ) ) THEN
329  info = -13
330  ELSE IF( wantu2 .AND. ldu2 .LT. max( 1, m - p ) ) THEN
331  info = -15
332  ELSE IF( wantv1t .AND. ldv1t .LT. max( 1, q ) ) THEN
333  info = -17
334  END IF
335 *
336  r = min( p, m-p, q, m-q )
337 *
338 * Compute workspace
339 *
340 * WORK layout:
341 * |-----------------------------------------|
342 * | LWORKOPT (1) |
343 * |-----------------------------------------|
344 * | TAUP1 (MAX(1,P)) |
345 * | TAUP2 (MAX(1,M-P)) |
346 * | TAUQ1 (MAX(1,Q)) |
347 * |-----------------------------------------|
348 * | CUNBDB WORK | CUNGQR WORK | CUNGLQ WORK |
349 * | | | |
350 * | | | |
351 * | | | |
352 * | | | |
353 * |-----------------------------------------|
354 * RWORK layout:
355 * |------------------|
356 * | LRWORKOPT (1) |
357 * |------------------|
358 * | PHI (MAX(1,R-1)) |
359 * |------------------|
360 * | B11D (R) |
361 * | B11E (R-1) |
362 * | B12D (R) |
363 * | B12E (R-1) |
364 * | B21D (R) |
365 * | B21E (R-1) |
366 * | B22D (R) |
367 * | B22E (R-1) |
368 * | CBBCSD RWORK |
369 * |------------------|
370 *
371  IF( info .EQ. 0 ) THEN
372  iphi = 2
373  ib11d = iphi + max( 1, r-1 )
374  ib11e = ib11d + max( 1, r )
375  ib12d = ib11e + max( 1, r - 1 )
376  ib12e = ib12d + max( 1, r )
377  ib21d = ib12e + max( 1, r - 1 )
378  ib21e = ib21d + max( 1, r )
379  ib22d = ib21e + max( 1, r - 1 )
380  ib22e = ib22d + max( 1, r )
381  ibbcsd = ib22e + max( 1, r - 1 )
382  itaup1 = 2
383  itaup2 = itaup1 + max( 1, p )
384  itauq1 = itaup2 + max( 1, m-p )
385  iorbdb = itauq1 + max( 1, q )
386  iorgqr = itauq1 + max( 1, q )
387  iorglq = itauq1 + max( 1, q )
388  lorgqrmin = 1
389  lorgqropt = 1
390  lorglqmin = 1
391  lorglqopt = 1
392  IF( r .EQ. q ) THEN
393  CALL cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,
394  $ dum, cdum, cdum, cdum, work, -1,
395  $ childinfo )
396  lorbdb = int( work(1) )
397  IF( wantu1 .AND. p .GT. 0 ) THEN
398  CALL cungqr( p, p, q, u1, ldu1, cdum, work(1), -1,
399  $ childinfo )
400  lorgqrmin = max( lorgqrmin, p )
401  lorgqropt = max( lorgqropt, int( work(1) ) )
402  ENDIF
403  IF( wantu2 .AND. m-p .GT. 0 ) THEN
404  CALL cungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,
405  $ childinfo )
406  lorgqrmin = max( lorgqrmin, m-p )
407  lorgqropt = max( lorgqropt, int( work(1) ) )
408  END IF
409  IF( wantv1t .AND. q .GT. 0 ) THEN
410  CALL cunglq( q-1, q-1, q-1, v1t, ldv1t,
411  $ cdum, work(1), -1, childinfo )
412  lorglqmin = max( lorglqmin, q-1 )
413  lorglqopt = max( lorglqopt, int( work(1) ) )
414  END IF
415  CALL cbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,
416  $ dum(1), u1, ldu1, u2, ldu2, v1t, ldv1t, cdum,
417  $ 1, dum, dum, dum, dum, dum, dum, dum, dum,
418  $ rwork(1), -1, childinfo )
419  lbbcsd = int( rwork(1) )
420  ELSE IF( r .EQ. p ) THEN
421  CALL cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
422  $ cdum, cdum, cdum, work(1), -1, childinfo )
423  lorbdb = int( work(1) )
424  IF( wantu1 .AND. p .GT. 0 ) THEN
425  CALL cungqr( p-1, p-1, p-1, u1(2,2), ldu1, cdum, work(1),
426  $ -1, childinfo )
427  lorgqrmin = max( lorgqrmin, p-1 )
428  lorgqropt = max( lorgqropt, int( work(1) ) )
429  END IF
430  IF( wantu2 .AND. m-p .GT. 0 ) THEN
431  CALL cungqr( m-p, m-p, q, u2, ldu2, cdum, work(1), -1,
432  $ childinfo )
433  lorgqrmin = max( lorgqrmin, m-p )
434  lorgqropt = max( lorgqropt, int( work(1) ) )
435  END IF
436  IF( wantv1t .AND. q .GT. 0 ) THEN
437  CALL cunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,
438  $ childinfo )
439  lorglqmin = max( lorglqmin, q )
440  lorglqopt = max( lorglqopt, int( work(1) ) )
441  END IF
442  CALL cbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,
443  $ dum, v1t, ldv1t, cdum, 1, u1, ldu1, u2, ldu2,
444  $ dum, dum, dum, dum, dum, dum, dum, dum,
445  $ rwork(1), -1, childinfo )
446  lbbcsd = int( rwork(1) )
447  ELSE IF( r .EQ. m-p ) THEN
448  CALL cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
449  $ cdum, cdum, cdum, work(1), -1, childinfo )
450  lorbdb = int( work(1) )
451  IF( wantu1 .AND. p .GT. 0 ) THEN
452  CALL cungqr( p, p, q, u1, ldu1, cdum, work(1), -1,
453  $ childinfo )
454  lorgqrmin = max( lorgqrmin, p )
455  lorgqropt = max( lorgqropt, int( work(1) ) )
456  END IF
457  IF( wantu2 .AND. m-p .GT. 0 ) THEN
458  CALL cungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2, cdum,
459  $ work(1), -1, childinfo )
460  lorgqrmin = max( lorgqrmin, m-p-1 )
461  lorgqropt = max( lorgqropt, int( work(1) ) )
462  END IF
463  IF( wantv1t .AND. q .GT. 0 ) THEN
464  CALL cunglq( q, q, r, v1t, ldv1t, cdum, work(1), -1,
465  $ childinfo )
466  lorglqmin = max( lorglqmin, q )
467  lorglqopt = max( lorglqopt, int( work(1) ) )
468  END IF
469  CALL cbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,
470  $ theta, dum, cdum, 1, v1t, ldv1t, u2, ldu2, u1,
471  $ ldu1, dum, dum, dum, dum, dum, dum, dum, dum,
472  $ rwork(1), -1, childinfo )
473  lbbcsd = int( rwork(1) )
474  ELSE
475  CALL cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta, dum,
476  $ cdum, cdum, cdum, cdum, work(1), -1, childinfo
477  $ )
478  lorbdb = m + int( work(1) )
479  IF( wantu1 .AND. p .GT. 0 ) THEN
480  CALL cungqr( p, p, m-q, u1, ldu1, cdum, work(1), -1,
481  $ childinfo )
482  lorgqrmin = max( lorgqrmin, p )
483  lorgqropt = max( lorgqropt, int( work(1) ) )
484  END IF
485  IF( wantu2 .AND. m-p .GT. 0 ) THEN
486  CALL cungqr( m-p, m-p, m-q, u2, ldu2, cdum, work(1), -1,
487  $ childinfo )
488  lorgqrmin = max( lorgqrmin, m-p )
489  lorgqropt = max( lorgqropt, int( work(1) ) )
490  END IF
491  IF( wantv1t .AND. q .GT. 0 ) THEN
492  CALL cunglq( q, q, q, v1t, ldv1t, cdum, work(1), -1,
493  $ childinfo )
494  lorglqmin = max( lorglqmin, q )
495  lorglqopt = max( lorglqopt, int( work(1) ) )
496  END IF
497  CALL cbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,
498  $ theta, dum, u2, ldu2, u1, ldu1, cdum, 1, v1t,
499  $ ldv1t, dum, dum, dum, dum, dum, dum, dum, dum,
500  $ rwork(1), -1, childinfo )
501  lbbcsd = int( rwork(1) )
502  END IF
503  lrworkmin = ibbcsd+lbbcsd-1
504  lrworkopt = lrworkmin
505  rwork(1) = lrworkopt
506  lworkmin = max( iorbdb+lorbdb-1,
507  $ iorgqr+lorgqrmin-1,
508  $ iorglq+lorglqmin-1 )
509  lworkopt = max( iorbdb+lorbdb-1,
510  $ iorgqr+lorgqropt-1,
511  $ iorglq+lorglqopt-1 )
512  work(1) = lworkopt
513  IF( lwork .LT. lworkmin .AND. .NOT.lquery ) THEN
514  info = -19
515  END IF
516  END IF
517  IF( info .NE. 0 ) THEN
518  CALL xerbla( 'CUNCSD2BY1', -info )
519  RETURN
520  ELSE IF( lquery ) THEN
521  RETURN
522  END IF
523  lorgqr = lwork-iorgqr+1
524  lorglq = lwork-iorglq+1
525 *
526 * Handle four cases separately: R = Q, R = P, R = M-P, and R = M-Q,
527 * in which R = MIN(P,M-P,Q,M-Q)
528 *
529  IF( r .EQ. q ) THEN
530 *
531 * Case 1: R = Q
532 *
533 * Simultaneously bidiagonalize X11 and X21
534 *
535  CALL cunbdb1( m, p, q, x11, ldx11, x21, ldx21, theta,
536  $ rwork(iphi), work(itaup1), work(itaup2),
537  $ work(itauq1), work(iorbdb), lorbdb, childinfo )
538 *
539 * Accumulate Householder reflectors
540 *
541  IF( wantu1 .AND. p .GT. 0 ) THEN
542  CALL clacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
543  CALL cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),
544  $ lorgqr, childinfo )
545  END IF
546  IF( wantu2 .AND. m-p .GT. 0 ) THEN
547  CALL clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
548  CALL cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),
549  $ work(iorgqr), lorgqr, childinfo )
550  END IF
551  IF( wantv1t .AND. q .GT. 0 ) THEN
552  v1t(1,1) = one
553  DO j = 2, q
554  v1t(1,j) = zero
555  v1t(j,1) = zero
556  END DO
557  CALL clacpy( 'U', q-1, q-1, x21(1,2), ldx21, v1t(2,2),
558  $ ldv1t )
559  CALL cunglq( q-1, q-1, q-1, v1t(2,2), ldv1t, work(itauq1),
560  $ work(iorglq), lorglq, childinfo )
561  END IF
562 *
563 * Simultaneously diagonalize X11 and X21.
564 *
565  CALL cbbcsd( jobu1, jobu2, jobv1t, 'N', 'N', m, p, q, theta,
566  $ rwork(iphi), u1, ldu1, u2, ldu2, v1t, ldv1t, cdum,
567  $ 1, rwork(ib11d), rwork(ib11e), rwork(ib12d),
568  $ rwork(ib12e), rwork(ib21d), rwork(ib21e),
569  $ rwork(ib22d), rwork(ib22e), rwork(ibbcsd), lbbcsd,
570  $ childinfo )
571 *
572 * Permute rows and columns to place zero submatrices in
573 * preferred positions
574 *
575  IF( q .GT. 0 .AND. wantu2 ) THEN
576  DO i = 1, q
577  iwork(i) = m - p - q + i
578  END DO
579  DO i = q + 1, m - p
580  iwork(i) = i - q
581  END DO
582  CALL clapmt( .false., m-p, m-p, u2, ldu2, iwork )
583  END IF
584  ELSE IF( r .EQ. p ) THEN
585 *
586 * Case 2: R = P
587 *
588 * Simultaneously bidiagonalize X11 and X21
589 *
590  CALL cunbdb2( m, p, q, x11, ldx11, x21, ldx21, theta,
591  $ rwork(iphi), work(itaup1), work(itaup2),
592  $ work(itauq1), work(iorbdb), lorbdb, childinfo )
593 *
594 * Accumulate Householder reflectors
595 *
596  IF( wantu1 .AND. p .GT. 0 ) THEN
597  u1(1,1) = one
598  DO j = 2, p
599  u1(1,j) = zero
600  u1(j,1) = zero
601  END DO
602  CALL clacpy( 'L', p-1, p-1, x11(2,1), ldx11, u1(2,2), ldu1 )
603  CALL cungqr( p-1, p-1, p-1, u1(2,2), ldu1, work(itaup1),
604  $ work(iorgqr), lorgqr, childinfo )
605  END IF
606  IF( wantu2 .AND. m-p .GT. 0 ) THEN
607  CALL clacpy( 'L', m-p, q, x21, ldx21, u2, ldu2 )
608  CALL cungqr( m-p, m-p, q, u2, ldu2, work(itaup2),
609  $ work(iorgqr), lorgqr, childinfo )
610  END IF
611  IF( wantv1t .AND. q .GT. 0 ) THEN
612  CALL clacpy( 'U', p, q, x11, ldx11, v1t, ldv1t )
613  CALL cunglq( q, q, r, v1t, ldv1t, work(itauq1),
614  $ work(iorglq), lorglq, childinfo )
615  END IF
616 *
617 * Simultaneously diagonalize X11 and X21.
618 *
619  CALL cbbcsd( jobv1t, 'N', jobu1, jobu2, 'T', m, q, p, theta,
620  $ rwork(iphi), v1t, ldv1t, cdum, 1, u1, ldu1, u2,
621  $ ldu2, rwork(ib11d), rwork(ib11e), rwork(ib12d),
622  $ rwork(ib12e), rwork(ib21d), rwork(ib21e),
623  $ rwork(ib22d), rwork(ib22e), rwork(ibbcsd), lbbcsd,
624  $ childinfo )
625 *
626 * Permute rows and columns to place identity submatrices in
627 * preferred positions
628 *
629  IF( q .GT. 0 .AND. wantu2 ) THEN
630  DO i = 1, q
631  iwork(i) = m - p - q + i
632  END DO
633  DO i = q + 1, m - p
634  iwork(i) = i - q
635  END DO
636  CALL clapmt( .false., m-p, m-p, u2, ldu2, iwork )
637  END IF
638  ELSE IF( r .EQ. m-p ) THEN
639 *
640 * Case 3: R = M-P
641 *
642 * Simultaneously bidiagonalize X11 and X21
643 *
644  CALL cunbdb3( m, p, q, x11, ldx11, x21, ldx21, theta,
645  $ rwork(iphi), work(itaup1), work(itaup2),
646  $ work(itauq1), work(iorbdb), lorbdb, childinfo )
647 *
648 * Accumulate Householder reflectors
649 *
650  IF( wantu1 .AND. p .GT. 0 ) THEN
651  CALL clacpy( 'L', p, q, x11, ldx11, u1, ldu1 )
652  CALL cungqr( p, p, q, u1, ldu1, work(itaup1), work(iorgqr),
653  $ lorgqr, childinfo )
654  END IF
655  IF( wantu2 .AND. m-p .GT. 0 ) THEN
656  u2(1,1) = one
657  DO j = 2, m-p
658  u2(1,j) = zero
659  u2(j,1) = zero
660  END DO
661  CALL clacpy( 'L', m-p-1, m-p-1, x21(2,1), ldx21, u2(2,2),
662  $ ldu2 )
663  CALL cungqr( m-p-1, m-p-1, m-p-1, u2(2,2), ldu2,
664  $ work(itaup2), work(iorgqr), lorgqr, childinfo )
665  END IF
666  IF( wantv1t .AND. q .GT. 0 ) THEN
667  CALL clacpy( 'U', m-p, q, x21, ldx21, v1t, ldv1t )
668  CALL cunglq( q, q, r, v1t, ldv1t, work(itauq1),
669  $ work(iorglq), lorglq, childinfo )
670  END IF
671 *
672 * Simultaneously diagonalize X11 and X21.
673 *
674  CALL cbbcsd( 'N', jobv1t, jobu2, jobu1, 'T', m, m-q, m-p,
675  $ theta, rwork(iphi), cdum, 1, v1t, ldv1t, u2, ldu2,
676  $ u1, ldu1, rwork(ib11d), rwork(ib11e),
677  $ rwork(ib12d), rwork(ib12e), rwork(ib21d),
678  $ rwork(ib21e), rwork(ib22d), rwork(ib22e),
679  $ rwork(ibbcsd), lbbcsd, childinfo )
680 *
681 * Permute rows and columns to place identity submatrices in
682 * preferred positions
683 *
684  IF( q .GT. r ) THEN
685  DO i = 1, r
686  iwork(i) = q - r + i
687  END DO
688  DO i = r + 1, q
689  iwork(i) = i - r
690  END DO
691  IF( wantu1 ) THEN
692  CALL clapmt( .false., p, q, u1, ldu1, iwork )
693  END IF
694  IF( wantv1t ) THEN
695  CALL clapmr( .false., q, q, v1t, ldv1t, iwork )
696  END IF
697  END IF
698  ELSE
699 *
700 * Case 4: R = M-Q
701 *
702 * Simultaneously bidiagonalize X11 and X21
703 *
704  CALL cunbdb4( m, p, q, x11, ldx11, x21, ldx21, theta,
705  $ rwork(iphi), work(itaup1), work(itaup2),
706  $ work(itauq1), work(iorbdb), work(iorbdb+m),
707  $ lorbdb-m, childinfo )
708 *
709 * Accumulate Householder reflectors
710 *
711  IF( wantu1 .AND. p .GT. 0 ) THEN
712  CALL ccopy( p, work(iorbdb), 1, u1, 1 )
713  DO j = 2, p
714  u1(1,j) = zero
715  END DO
716  CALL clacpy( 'L', p-1, m-q-1, x11(2,1), ldx11, u1(2,2),
717  $ ldu1 )
718  CALL cungqr( p, p, m-q, u1, ldu1, work(itaup1),
719  $ work(iorgqr), lorgqr, childinfo )
720  END IF
721  IF( wantu2 .AND. m-p .GT. 0 ) THEN
722  CALL ccopy( m-p, work(iorbdb+p), 1, u2, 1 )
723  DO j = 2, m-p
724  u2(1,j) = zero
725  END DO
726  CALL clacpy( 'L', m-p-1, m-q-1, x21(2,1), ldx21, u2(2,2),
727  $ ldu2 )
728  CALL cungqr( m-p, m-p, m-q, u2, ldu2, work(itaup2),
729  $ work(iorgqr), lorgqr, childinfo )
730  END IF
731  IF( wantv1t .AND. q .GT. 0 ) THEN
732  CALL clacpy( 'U', m-q, q, x21, ldx21, v1t, ldv1t )
733  CALL clacpy( 'U', p-(m-q), q-(m-q), x11(m-q+1,m-q+1), ldx11,
734  $ v1t(m-q+1,m-q+1), ldv1t )
735  CALL clacpy( 'U', -p+q, q-p, x21(m-q+1,p+1), ldx21,
736  $ v1t(p+1,p+1), ldv1t )
737  CALL cunglq( q, q, q, v1t, ldv1t, work(itauq1),
738  $ work(iorglq), lorglq, childinfo )
739  END IF
740 *
741 * Simultaneously diagonalize X11 and X21.
742 *
743  CALL cbbcsd( jobu2, jobu1, 'N', jobv1t, 'N', m, m-p, m-q,
744  $ theta, rwork(iphi), u2, ldu2, u1, ldu1, cdum, 1,
745  $ v1t, ldv1t, rwork(ib11d), rwork(ib11e),
746  $ rwork(ib12d), rwork(ib12e), rwork(ib21d),
747  $ rwork(ib21e), rwork(ib22d), rwork(ib22e),
748  $ rwork(ibbcsd), lbbcsd, childinfo )
749 *
750 * Permute rows and columns to place identity submatrices in
751 * preferred positions
752 *
753  IF( p .GT. r ) THEN
754  DO i = 1, r
755  iwork(i) = p - r + i
756  END DO
757  DO i = r + 1, p
758  iwork(i) = i - r
759  END DO
760  IF( wantu1 ) THEN
761  CALL clapmt( .false., p, p, u1, ldu1, iwork )
762  END IF
763  IF( wantv1t ) THEN
764  CALL clapmr( .false., p, q, v1t, ldv1t, iwork )
765  END IF
766  END IF
767  END IF
768 *
769  RETURN
770 *
771 * End of CUNCSD2BY1
772 *
clapmt
subroutine clapmt(FORWRD, M, N, X, LDX, K)
CLAPMT performs a forward or backward permutation of the columns of a matrix.
Definition: clapmt.f:106
cunbdb3
subroutine cunbdb3(M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO)
CUNBDB3
Definition: cunbdb3.f:204
cbbcsd
subroutine cbbcsd(JOBU1, JOBU2, JOBV1T, JOBV2T, TRANS, M, P, Q, THETA, PHI, U1, LDU1, U2, LDU2, V1T, LDV1T, V2T, LDV2T, B11D, B11E, B12D, B12E, B21D, B21E, B22D, B22E, RWORK, LRWORK, INFO)
CBBCSD
Definition: cbbcsd.f:334
cungqr
subroutine cungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGQR
Definition: cungqr.f:130
clapmr
subroutine clapmr(FORWRD, M, N, X, LDX, K)
CLAPMR rearranges rows of a matrix as specified by a permutation vector.
Definition: clapmr.f:106
cunbdb4
subroutine cunbdb4(M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, TAUP1, TAUP2, TAUQ1, PHANTOM, WORK, LWORK, INFO)
CUNBDB4
Definition: cunbdb4.f:215
xerbla
subroutine xerbla(SRNAME, INFO)
XERBLA
Definition: xerbla.f:62
lsame
logical function lsame(CA, CB)
LSAME
Definition: lsame.f:55
clacpy
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
Definition: clacpy.f:105
cunbdb1
subroutine cunbdb1(M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO)
CUNBDB1
Definition: cunbdb1.f:204
cunbdb2
subroutine cunbdb2(M, P, Q, X11, LDX11, X21, LDX21, THETA, PHI, TAUP1, TAUP2, TAUQ1, WORK, LWORK, INFO)
CUNBDB2
Definition: cunbdb2.f:204
ccopy
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
Definition: ccopy.f:83
cunglq
subroutine cunglq(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
CUNGLQ
Definition: cunglq.f:129
Here is the call graph for this function:
Here is the caller graph for this function: