259 SUBROUTINE cggsvp( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB,
260 $ tola, tolb, k, l, u, ldu, v, ldv, q, ldq,
261 $ iwork, rwork, tau, work, info )
269 CHARACTER jobq, jobu, jobv
270 INTEGER info, k, l, lda, ldb, ldq, ldu, ldv, m, n, p
276 COMPLEX a( lda, * ),
b( ldb, * ), q( ldq, * ),
277 $ tau( * ), u( ldu, * ), v( ldv, * ), work( * )
284 parameter( czero = ( 0.0e+0, 0.0e+0 ),
285 $ cone = ( 1.0e+0, 0.0e+0 ) )
288 LOGICAL forwrd, wantq, wantu, wantv
301 INTRINSIC abs, aimag, max, min, real
307 cabs1( t ) = abs(
REAL( T ) ) + abs( aimag( t ) )
313 wantu =
lsame( jobu,
'U' )
314 wantv =
lsame( jobv,
'V' )
315 wantq =
lsame( jobq,
'Q' )
319 IF( .NOT.( wantu .OR.
lsame( jobu,
'N' ) ) )
THEN
321 ELSE IF( .NOT.( wantv .OR.
lsame( jobv,
'N' ) ) )
THEN
323 ELSE IF( .NOT.( wantq .OR.
lsame( jobq,
'N' ) ) )
THEN
325 ELSE IF( m.LT.0 )
THEN
327 ELSE IF( p.LT.0 )
THEN
329 ELSE IF( n.LT.0 )
THEN
331 ELSE IF( lda.LT.max( 1, m ) )
THEN
333 ELSE IF( ldb.LT.max( 1, p ) )
THEN
335 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) )
THEN
337 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) )
THEN
339 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) )
THEN
343 CALL
xerbla(
'CGGSVP', -info )
353 CALL
cgeqpf( p, n,
b, ldb, iwork, tau, work, rwork, info )
357 CALL
clapmt( forwrd, m, n, a, lda, iwork )
362 DO 20 i = 1, min( p, n )
363 IF( cabs1(
b( i, i ) ).GT.tolb )
371 CALL
claset(
'Full', p, p, czero, czero, v, ldv )
373 $ CALL
clacpy(
'Lower', p-1, n,
b( 2, 1 ), ldb, v( 2, 1 ),
375 CALL
cung2r( p, p, min( p, n ), v, ldv, tau, work, info )
386 $ CALL
claset(
'Full', p-l, n, czero, czero,
b( l+1, 1 ), ldb )
392 CALL
claset(
'Full', n, n, czero, cone, q, ldq )
393 CALL
clapmt( forwrd, n, n, q, ldq, iwork )
396 IF( p.GE.l .AND. n.NE.l )
THEN
400 CALL
cgerq2( l, n,
b, ldb, tau, work, info )
404 CALL
cunmr2(
'Right',
'Conjugate transpose', m, n, l,
b, ldb,
405 $ tau, a, lda, work, info )
410 CALL
cunmr2(
'Right',
'Conjugate transpose', n, n, l,
b,
411 $ ldb, tau, q, ldq, work, info )
416 CALL
claset(
'Full', l, n-l, czero, czero,
b, ldb )
417 DO 60
j = n - l + 1, n
418 DO 50 i =
j - n + l + 1, l
436 CALL
cgeqpf( m, n-l, a, lda, iwork, tau, work, rwork, info )
441 DO 80 i = 1, min( m, n-l )
442 IF( cabs1( a( i, i ) ).GT.tola )
448 CALL
cunm2r(
'Left',
'Conjugate transpose', m, l, min( m, n-l ),
449 $ a, lda, tau, a( 1, n-l+1 ), lda, work, info )
455 CALL
claset(
'Full', m, m, czero, czero, u, ldu )
457 $ CALL
clacpy(
'Lower', m-1, n-l, a( 2, 1 ), lda, u( 2, 1 ),
459 CALL
cung2r( m, m, min( m, n-l ), u, ldu, tau, work, info )
466 CALL
clapmt( forwrd, n, n-l, q, ldq, iwork )
478 $ CALL
claset(
'Full', m-k, n-l, czero, czero, a( k+1, 1 ), lda )
484 CALL
cgerq2( k, n-l, a, lda, tau, work, info )
490 CALL
cunmr2(
'Right',
'Conjugate transpose', n, n-l, k, a,
491 $ lda, tau, q, ldq, work, info )
496 CALL
claset(
'Full', k, n-l-k, czero, czero, a, lda )
497 DO 120
j = n - l - k + 1, n - l
498 DO 110 i =
j - n + l + k + 1, k
509 CALL
cgeqr2( m-k, l, a( k+1, n-l+1 ), lda, tau, work, info )
515 CALL
cunm2r(
'Right',
'No transpose', m, m-k, min( m-k, l ),
516 $ a( k+1, n-l+1 ), lda, tau, u( 1, k+1 ), ldu,
522 DO 140
j = n - l + 1, n
523 DO 130 i =
j - n + k + l + 1, m
subroutine claset(UPLO, M, N, ALPHA, BETA, A, LDA)
CLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values...
subroutine cunmr2(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
CUNMR2 multiplies a general matrix by the unitary matrix from a RQ factorization determined by cgerqf...
subroutine cgerq2(M, N, A, LDA, TAU, WORK, INFO)
CGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm...
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine cgeqr2(M, N, A, LDA, TAU, WORK, INFO)
CGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm...
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
logical function lsame(CA, CB)
LSAME
subroutine clacpy(UPLO, M, N, A, LDA, B, LDB)
CLACPY copies all or part of one two-dimensional array to another.
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real j
subroutine cung2r(M, N, K, A, LDA, TAU, WORK, INFO)
CUNG2R
subroutine clapmt(FORWRD, M, N, X, LDX, K)
CLAPMT performs a forward or backward permutation of the columns of a matrix.
subroutine cgeqpf(M, N, A, LDA, JPVT, TAU, WORK, RWORK, INFO)
CGEQPF
subroutine cunm2r(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, INFO)
CUNM2R multiplies a general matrix by the unitary matrix from a QR factorization determined by cgeqrf...
subroutine cggsvp(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)
CGGSVP