LAPACK  3.7.1
LAPACK: Linear Algebra PACKage

◆ zuncsd2by1()

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

ZUNCSD2BY1

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

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

                                [  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*16 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*16 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 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)) ).
[out]U1
          U1 is COMPLEX*16 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*16 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*16 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*16 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 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.
[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:  ZBBCSD 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
July 2012

Definition at line 256 of file zuncsd2by1.f.

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