253 SUBROUTINE sggsvp( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
254 $ tola, tolb, k, l, u, ldu, v, ldv, q, ldq,
255 $ iwork, tau, work, info )
263 CHARACTER JOBQ, JOBU, JOBV
264 INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
269 REAL A( lda, * ), B( ldb, * ), Q( ldq, * ),
270 $ tau( * ), u( ldu, * ), v( ldv, * ), work( * )
277 parameter( zero = 0.0e+0, one = 1.0e+0 )
280 LOGICAL FORWRD, WANTQ, WANTU, WANTV
292 INTRINSIC abs, max, min
298 wantu = lsame( jobu,
'U' )
299 wantv = lsame( jobv,
'V' )
300 wantq = lsame( jobq,
'Q' )
304 IF( .NOT.( wantu .OR. lsame( jobu,
'N' ) ) )
THEN
306 ELSE IF( .NOT.( wantv .OR. lsame( jobv,
'N' ) ) )
THEN
308 ELSE IF( .NOT.( wantq .OR. lsame( jobq,
'N' ) ) )
THEN
310 ELSE IF( m.LT.0 )
THEN
312 ELSE IF( p.LT.0 )
THEN
314 ELSE IF( n.LT.0 )
THEN
316 ELSE IF( lda.LT.max( 1, m ) )
THEN
318 ELSE IF( ldb.LT.max( 1, p ) )
THEN
320 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) )
THEN
322 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) )
THEN
324 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) )
THEN
328 CALL xerbla(
'SGGSVP', -info )
338 CALL sgeqpf( p, n, b, ldb, iwork, tau, work, info )
342 CALL slapmt( forwrd, m, n, a, lda, iwork )
347 DO 20 i = 1, min( p, n )
348 IF( abs( b( i, i ) ).GT.tolb )
356 CALL slaset(
'Full', p, p, zero, zero, v, ldv )
358 $
CALL slacpy(
'Lower', p-1, n, b( 2, 1 ), ldb, v( 2, 1 ),
360 CALL sorg2r( p, p, min( p, n ), v, ldv, tau, work, info )
371 $
CALL slaset(
'Full', p-l, n, zero, zero, b( l+1, 1 ), ldb )
377 CALL slaset(
'Full', n, n, zero, one, q, ldq )
378 CALL slapmt( forwrd, n, n, q, ldq, iwork )
381 IF( p.GE.l .AND. n.NE.l )
THEN
385 CALL sgerq2( l, n, b, ldb, tau, work, info )
389 CALL sormr2(
'Right',
'Transpose', m, n, l, b, ldb, tau, a,
396 CALL sormr2(
'Right',
'Transpose', n, n, l, b, ldb, tau, q,
402 CALL slaset(
'Full', l, n-l, zero, zero, b, ldb )
403 DO 60 j = n - l + 1, n
404 DO 50 i = j - n + l + 1, l
422 CALL sgeqpf( m, n-l, a, lda, iwork, tau, work, info )
427 DO 80 i = 1, min( m, n-l )
428 IF( abs( a( i, i ) ).GT.tola )
434 CALL sorm2r(
'Left',
'Transpose', m, l, min( m, n-l ), a, lda,
435 $ tau, a( 1, n-l+1 ), lda, work, info )
441 CALL slaset(
'Full', m, m, zero, zero, u, ldu )
443 $
CALL slacpy(
'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
445 CALL sorg2r( m, m, min( m, n-l ), u, ldu, tau, work, info )
452 CALL slapmt( forwrd, n, n-l, q, ldq, iwork )
464 $
CALL slaset(
'Full', m-k, n-l, zero, zero, a( k+1, 1 ), lda )
470 CALL sgerq2( k, n-l, a, lda, tau, work, info )
476 CALL sormr2(
'Right',
'Transpose', n, n-l, k, a, lda, tau,
477 $ q, ldq, work, info )
482 CALL slaset(
'Full', k, n-l-k, zero, zero, a, lda )
483 DO 120 j = n - l - k + 1, n - l
484 DO 110 i = j - n + l + k + 1, k
495 CALL sgeqr2( m-k, l, a( k+1, n-l+1 ), lda, tau, work, info )
501 CALL sorm2r(
'Right',
'No transpose', m, m-k, min( m-k, l ),
502 $ a( k+1, n-l+1 ), lda, tau, u( 1, k+1 ), ldu,
508 DO 140 j = n - l + 1, n
509 DO 130 i = j - n + k + l + 1, m
subroutine slaset(UPLO, M, N, ALPHA, BETA, A, LDA)
SLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine sormr2(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
SORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sge...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine sorg2r(M, N, K, A, LDA, TAU, WORK, INFO)
SORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf ...
subroutine slacpy(UPLO, M, N, A, LDA, B, LDB)
SLACPY copies all or part of one two-dimensional array to another.
subroutine slapmt(FORWRD, M, N, X, LDX, K)
SLAPMT performs a forward or backward permutation of the columns of a matrix.
subroutine sorm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
SORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sge...
subroutine sgeqpf(M, N, A, LDA, JPVT, TAU, WORK, INFO)
SGEQPF
subroutine sgerq2(M, N, A, LDA, TAU, WORK, INFO)
SGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm...
subroutine sggsvp(JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA, TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, TAU, WORK, INFO)
SGGSVP
subroutine sgeqr2(M, N, A, LDA, TAU, WORK, INFO)
SGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...