310 SUBROUTINE ztgsna( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
311 $ ldvl, vr, ldvr, s, dif, mm, m, work, lwork,
320 CHARACTER howmny, job
321 INTEGER info, lda, ldb, ldvl, ldvr, lwork, m, mm, n
326 DOUBLE PRECISION dif( * ), s( * )
327 COMPLEX*16 a( lda, * ),
b( ldb, * ), vl( ldvl, * ),
328 $ vr( ldvr, * ), work( * )
334 DOUBLE PRECISION zero, one
336 parameter( zero = 0.0d+0, one = 1.0d+0, idifjb = 3 )
339 LOGICAL lquery, somcon, wantbh, wantdf, wants
340 INTEGER i, ierr, ifst, ilst, k, ks, lwmin, n1, n2
341 DOUBLE PRECISION bignum, cond, eps, lnrm, rnrm, scale, smlnum
342 COMPLEX*16 yhax, yhbx
345 COMPLEX*16 dummy( 1 ), dummy1( 1 )
357 INTRINSIC abs, dcmplx, max
363 wantbh =
lsame( job,
'B' )
364 wants =
lsame( job,
'E' ) .OR. wantbh
365 wantdf =
lsame( job,
'V' ) .OR. wantbh
367 somcon =
lsame( howmny,
'S' )
370 lquery = ( lwork.EQ.-1 )
372 IF( .NOT.wants .AND. .NOT.wantdf )
THEN
374 ELSE IF( .NOT.
lsame( howmny,
'A' ) .AND. .NOT.somcon )
THEN
376 ELSE IF( n.LT.0 )
THEN
378 ELSE IF( lda.LT.max( 1, n ) )
THEN
380 ELSE IF( ldb.LT.max( 1, n ) )
THEN
382 ELSE IF( wants .AND. ldvl.LT.n )
THEN
384 ELSE IF( wants .AND. ldvr.LT.n )
THEN
403 ELSE IF(
lsame( job,
'V' ) .OR.
lsame( job,
'B' ) )
THEN
412 ELSE IF( lwork.LT.lwmin .AND. .NOT.lquery )
THEN
418 CALL
xerbla(
'ZTGSNA', -info )
420 ELSE IF( lquery )
THEN
432 smlnum =
dlamch(
'S' ) / eps
433 bignum = one / smlnum
434 CALL
dlabad( smlnum, bignum )
442 IF( .NOT.
SELECT( k ) )
453 rnrm =
dznrm2( n, vr( 1, ks ), 1 )
454 lnrm =
dznrm2( n, vl( 1, ks ), 1 )
455 CALL
zgemv(
'N', n, n, dcmplx( one, zero ), a, lda,
456 $ vr( 1, ks ), 1, dcmplx( zero, zero ), work, 1 )
457 yhax =
zdotc( n, work, 1, vl( 1, ks ), 1 )
458 CALL
zgemv(
'N', n, n, dcmplx( one, zero ),
b, ldb,
459 $ vr( 1, ks ), 1, dcmplx( zero, zero ), work, 1 )
460 yhbx =
zdotc( n, work, 1, vl( 1, ks ), 1 )
461 cond =
dlapy2( abs( yhax ), abs( yhbx ) )
462 IF( cond.EQ.zero )
THEN
465 s( ks ) = cond / ( rnrm*lnrm )
471 dif( ks ) =
dlapy2( abs( a( 1, 1 ) ), abs(
b( 1, 1 ) ) )
480 CALL
zlacpy(
'Full', n, n, a, lda, work, n )
481 CALL
zlacpy(
'Full', n, n,
b, ldb, work( n*n+1 ), n )
485 CALL
ztgexc( .false., .false., n, work, n, work( n*n+1 ),
486 $ n, dummy, 1, dummy1, 1, ifst, ilst, ierr )
504 CALL
ztgsyl(
'N', idifjb, n2, n1, work( n*n1+n1+1 ),
505 $ n, work, n, work( n1+1 ), n,
506 $ work( n*n1+n1+i ), n, work( i ), n,
507 $ work( n1+i ), n, scale, dif( ks ), dummy,
LOGICAL function lsame(CA, CB)
LSAME
subroutine zgemv(TRANS, M, N, ALPHA, A, LDA, X, INCX, BETA, Y, INCY)
ZGEMV
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine ztgsna(JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL, LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK, IWORK, INFO)
ZTGSNA
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine dlabad(SMALL, LARGE)
DLABAD
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
DOUBLE PRECISION function dznrm2(N, X, INCX)
DZNRM2
subroutine ztgexc(WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z, LDZ, IFST, ILST, INFO)
ZTGEXC
subroutine ztgsyl(TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D, LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK, IWORK, INFO)
ZTGSYL
DOUBLE PRECISION function dlamch(CMACH)
DLAMCH
COMPLEX *16 function zdotc(N, ZX, INCX, ZY, INCY)
ZDOTC
DOUBLE PRECISION function dlapy2(X, Y)
DLAPY2 returns sqrt(x2+y2).