264 SUBROUTINE zggsvp( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
265 $ tola, tolb, k, l, u, ldu, v, ldv, q, ldq,
266 $ iwork, rwork, tau, work, info )
274 CHARACTER JOBQ, JOBU, JOBV
275 INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
276 DOUBLE PRECISION TOLA, TOLB
280 DOUBLE PRECISION RWORK( * )
281 COMPLEX*16 A( lda, * ), B( ldb, * ), Q( ldq, * ),
282 $ tau( * ), u( ldu, * ), v( ldv, * ), work( * )
288 COMPLEX*16 CZERO, CONE
289 parameter ( czero = ( 0.0d+0, 0.0d+0 ),
290 $ cone = ( 1.0d+0, 0.0d+0 ) )
293 LOGICAL FORWRD, WANTQ, WANTU, WANTV
306 INTRINSIC abs, dble, dimag, max, min
309 DOUBLE PRECISION CABS1
312 cabs1( t ) = abs( dble( t ) ) + abs( dimag( t ) )
318 wantu = lsame( jobu,
'U' )
319 wantv = lsame( jobv,
'V' )
320 wantq = lsame( jobq,
'Q' )
324 IF( .NOT.( wantu .OR. lsame( jobu,
'N' ) ) )
THEN
326 ELSE IF( .NOT.( wantv .OR. lsame( jobv,
'N' ) ) )
THEN
328 ELSE IF( .NOT.( wantq .OR. lsame( jobq,
'N' ) ) )
THEN
330 ELSE IF( m.LT.0 )
THEN
332 ELSE IF( p.LT.0 )
THEN
334 ELSE IF( n.LT.0 )
THEN
336 ELSE IF( lda.LT.max( 1, m ) )
THEN
338 ELSE IF( ldb.LT.max( 1, p ) )
THEN
340 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) )
THEN
342 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) )
THEN
344 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) )
THEN
348 CALL xerbla(
'ZGGSVP', -info )
358 CALL zgeqpf( p, n, b, ldb, iwork, tau, work, rwork, info )
362 CALL zlapmt( forwrd, m, n, a, lda, iwork )
367 DO 20 i = 1, min( p, n )
368 IF( cabs1( b( i, i ) ).GT.tolb )
376 CALL zlaset(
'Full', p, p, czero, czero, v, ldv )
378 $
CALL zlacpy(
'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
380 CALL zung2r( p, p, min( p, n ), v, ldv, tau, work, info )
391 $
CALL zlaset(
'Full', p-l, n, czero, czero, b( l+1, 1 ), ldb )
397 CALL zlaset(
'Full', n, n, czero, cone, q, ldq )
398 CALL zlapmt( forwrd, n, n, q, ldq, iwork )
401 IF( p.GE.l .AND. n.NE.l )
THEN
405 CALL zgerq2( l, n, b, ldb, tau, work, info )
409 CALL zunmr2(
'Right',
'Conjugate transpose', m, n, l, b, ldb,
410 $ tau, a, lda, work, info )
415 CALL zunmr2(
'Right',
'Conjugate transpose', n, n, l, b,
416 $ ldb, tau, q, ldq, work, info )
421 CALL zlaset(
'Full', l, n-l, czero, czero, b, ldb )
422 DO 60 j = n - l + 1, n
423 DO 50 i = j - n + l + 1, l
441 CALL zgeqpf( m, n-l, a, lda, iwork, tau, work, rwork, info )
446 DO 80 i = 1, min( m, n-l )
447 IF( cabs1( a( i, i ) ).GT.tola )
453 CALL zunm2r(
'Left',
'Conjugate transpose', m, l, min( m, n-l ),
454 $ a, lda, tau, a( 1, n-l+1 ), lda, work, info )
460 CALL zlaset(
'Full', m, m, czero, czero, u, ldu )
462 $
CALL zlacpy(
'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
464 CALL zung2r( m, m, min( m, n-l ), u, ldu, tau, work, info )
471 CALL zlapmt( forwrd, n, n-l, q, ldq, iwork )
483 $
CALL zlaset(
'Full', m-k, n-l, czero, czero, a( k+1, 1 ), lda )
489 CALL zgerq2( k, n-l, a, lda, tau, work, info )
495 CALL zunmr2(
'Right',
'Conjugate transpose', n, n-l, k, a,
496 $ lda, tau, q, ldq, work, info )
501 CALL zlaset(
'Full', k, n-l-k, czero, czero, a, lda )
502 DO 120 j = n - l - k + 1, n - l
503 DO 110 i = j - n + l + k + 1, k
514 CALL zgeqr2( m-k, l, a( k+1, n-l+1 ), lda, tau, work, info )
520 CALL zunm2r(
'Right',
'No transpose', m, m-k, min( m-k, l ),
521 $ a( k+1, n-l+1 ), lda, tau, u( 1, k+1 ), ldu,
527 DO 140 j = n - l + 1, n
528 DO 130 i = j - n + k + l + 1, m
subroutine zung2r(M, N, K, A, LDA, TAU, WORK, INFO)
ZUNG2R
subroutine zgeqpf(M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO)
ZGEQPF
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zunmr2(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
ZUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf...
subroutine zlaset(UPLO, M, N, ALPHA, BETA, A, LDA)
ZLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine zlapmt(FORWRD, M, N, X, LDX, K)
ZLAPMT performs a forward or backward permutation of the columns of a matrix.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zggsvp(JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, RWORK, TAU, WORK, INFO)
ZGGSVP
subroutine zgeqr2(M, N, A, LDA, TAU, WORK, INFO)
ZGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
subroutine zunm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
ZUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
subroutine zgerq2(M, N, A, LDA, TAU, WORK, INFO)
ZGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm...