378 SUBROUTINE ctgsja( JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B,
379 $ ldb, tola, tolb, alpha, beta, u, ldu, v, ldv,
380 $ q, ldq, work, ncycle, info )
388 CHARACTER JOBQ, JOBU, JOBV
389 INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
394 REAL ALPHA( * ), BETA( * )
395 COMPLEX A( lda, * ), B( ldb, * ), Q( ldq, * ),
396 $ u( ldu, * ), v( ldv, * ), work( * )
403 parameter( maxit = 40 )
405 parameter( zero = 0.0e+0, one = 1.0e+0 )
407 parameter( czero = ( 0.0e+0, 0.0e+0 ),
408 $ cone = ( 1.0e+0, 0.0e+0 ) )
412 LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
414 REAL A1, A3, B1, B3, CSQ, CSU, CSV, ERROR, GAMMA,
416 COMPLEX A2, B2, SNQ, SNU, SNV
427 INTRINSIC abs, conjg, max, min, real
433 initu = lsame( jobu,
'I' )
434 wantu = initu .OR. lsame( jobu,
'U' )
436 initv = lsame( jobv,
'I' )
437 wantv = initv .OR. lsame( jobv,
'V' )
439 initq = lsame( jobq,
'I' )
440 wantq = initq .OR. lsame( jobq,
'Q' )
443 IF( .NOT.( initu .OR. wantu .OR. lsame( jobu,
'N' ) ) )
THEN
445 ELSE IF( .NOT.( initv .OR. wantv .OR. lsame( jobv,
'N' ) ) )
THEN
447 ELSE IF( .NOT.( initq .OR. wantq .OR. lsame( jobq,
'N' ) ) )
THEN
449 ELSE IF( m.LT.0 )
THEN
451 ELSE IF( p.LT.0 )
THEN
453 ELSE IF( n.LT.0 )
THEN
455 ELSE IF( lda.LT.max( 1, m ) )
THEN
457 ELSE IF( ldb.LT.max( 1, p ) )
THEN
459 ELSE IF( ldu.LT.1 .OR. ( wantu .AND. ldu.LT.m ) )
THEN
461 ELSE IF( ldv.LT.1 .OR. ( wantv .AND. ldv.LT.p ) )
THEN
463 ELSE IF( ldq.LT.1 .OR. ( wantq .AND. ldq.LT.n ) )
THEN
467 CALL
xerbla(
'CTGSJA', -info )
474 $ CALL
claset(
'Full', m, m, czero, cone, u, ldu )
476 $ CALL
claset(
'Full', p, p, czero, cone, v, ldv )
478 $ CALL
claset(
'Full', n, n, czero, cone, q, ldq )
483 DO 40 kcycle = 1, maxit
494 $ a1 =
REAL( A( K+I, N-L+I ) )
496 $ a3 =
REAL( A( K+J, N-L+J ) )
498 b1 =
REAL( B( I, N-L+I ) )
499 b3 =
REAL( B( J, N-L+J ) )
503 $ a2 = a( k+i, n-l+j )
507 $ a2 = a( k+j, n-l+i )
511 CALL
clags2( upper, a1, a2, a3, b1, b2, b3, csu, snu,
512 $ csv, snv, csq, snq )
517 $ CALL
crot( l, a( k+j, n-l+1 ), lda, a( k+i, n-l+1 ),
518 $ lda, csu, conjg( snu ) )
522 CALL
crot( l, b( j, n-l+1 ), ldb, b( i, n-l+1 ), ldb,
523 $ csv, conjg( snv ) )
528 CALL
crot( min( k+l, m ), a( 1, n-l+j ), 1,
529 $ a( 1, n-l+i ), 1, csq, snq )
531 CALL
crot( l, b( 1, n-l+j ), 1, b( 1, n-l+i ), 1, csq,
536 $ a( k+i, n-l+j ) = czero
537 b( i, n-l+j ) = czero
540 $ a( k+j, n-l+i ) = czero
541 b( j, n-l+i ) = czero
547 $ a( k+i, n-l+i ) =
REAL( A( K+I, N-L+I ) )
549 $ a( k+j, n-l+j ) =
REAL( A( K+J, N-L+J ) )
550 b( i, n-l+i ) =
REAL( B( I, N-L+I ) )
551 b( j, n-l+j ) =
REAL( B( J, N-L+J ) )
555 IF( wantu .AND. k+j.LE.m )
556 $ CALL
crot( m, u( 1, k+j ), 1, u( 1, k+i ), 1, csu,
560 $ CALL
crot( p, v( 1, j ), 1, v( 1, i ), 1, csv, snv )
563 $ CALL
crot( n, q( 1, n-l+j ), 1, q( 1, n-l+i ), 1, csq,
569 IF( .NOT.upper )
THEN
578 DO 30 i = 1, min( l, m-k )
579 CALL
ccopy( l-i+1, a( k+i, n-l+i ), lda, work, 1 )
580 CALL
ccopy( l-i+1, b( i, n-l+i ), ldb, work( l+1 ), 1 )
581 CALL
clapll( l-i+1, work, 1, work( l+1 ), 1, ssmin )
582 error = max( error, ssmin )
585 IF( abs( error ).LE.min( tola, tolb ) )
609 DO 70 i = 1, min( l, m-k )
611 a1 =
REAL( A( K+I, N-L+I ) )
612 b1 =
REAL( B( I, N-L+I ) )
614 IF( a1.NE.zero )
THEN
617 IF( gamma.LT.zero )
THEN
618 CALL
csscal( l-i+1, -one, b( i, n-l+i ), ldb )
620 $ CALL
csscal( p, -one, v( 1, i ), 1 )
623 CALL
slartg( abs( gamma ), one, beta( k+i ), alpha( k+i ),
626 IF( alpha( k+i ).GE.beta( k+i ) )
THEN
627 CALL
csscal( l-i+1, one / alpha( k+i ), a( k+i, n-l+i ),
630 CALL
csscal( l-i+1, one / beta( k+i ), b( i, n-l+i ),
632 CALL
ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),
639 CALL
ccopy( l-i+1, b( i, n-l+i ), ldb, a( k+i, n-l+i ),
646 DO 80 i = m + 1, k + l
652 DO 90 i = k + l + 1, n
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 crot(N, CX, INCX, CY, INCY, C, S)
CROT applies a plane rotation with real cosine and complex sine to a pair of complex vectors...
subroutine clags2(UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV, SNV, CSQ, SNQ)
CLAGS2
subroutine ctgsja(JOBU, JOBV, JOBQ, M, P, N, K, L, A, LDA, B, LDB, TOLA, TOLB, ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, NCYCLE, INFO)
CTGSJA
subroutine clapll(N, X, INCX, Y, INCY, SSMIN)
CLAPLL measures the linear dependence of two vectors.
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine ccopy(N, CX, INCX, CY, INCY)
CCOPY
subroutine csscal(N, SA, CX, INCX)
CSSCAL
subroutine slartg(F, G, CS, SN, R)
SLARTG generates a plane rotation with real cosine and real sine.