224 SUBROUTINE zgegs( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA,
225 $ vsl, ldvsl, vsr, ldvsr, work, lwork, rwork,
234 CHARACTER jobvsl, jobvsr
235 INTEGER info, lda, ldb, ldvsl, ldvsr, lwork, n
238 DOUBLE PRECISION rwork( * )
239 COMPLEX*16 a( lda, * ), alpha( * ),
b( ldb, * ),
240 $ beta( * ), vsl( ldvsl, * ), vsr( ldvsr, * ),
247 DOUBLE PRECISION zero, one
248 parameter( zero = 0.0d0, one = 1.0d0 )
249 COMPLEX*16 czero, cone
250 parameter( czero = ( 0.0d0, 0.0d0 ),
251 $ cone = ( 1.0d0, 0.0d0 ) )
254 LOGICAL ilascl, ilbscl, ilvsl, ilvsr, lquery
255 INTEGER icols, ihi, iinfo, ijobvl, ijobvr, ileft, ilo,
256 $ iright, irows, irwork, itau, iwork, lopt,
257 $ lwkmin, lwkopt, nb, nb1, nb2, nb3
258 DOUBLE PRECISION anrm, anrmto, bignum, bnrm, bnrmto, eps,
278 IF(
lsame( jobvsl,
'N' ) )
THEN
281 ELSE IF(
lsame( jobvsl,
'V' ) )
THEN
289 IF(
lsame( jobvsr,
'N' ) )
THEN
292 ELSE IF(
lsame( jobvsr,
'V' ) )
THEN
302 lwkmin = max( 2*n, 1 )
305 lquery = ( lwork.EQ.-1 )
307 IF( ijobvl.LE.0 )
THEN
309 ELSE IF( ijobvr.LE.0 )
THEN
311 ELSE IF( n.LT.0 )
THEN
313 ELSE IF( lda.LT.max( 1, n ) )
THEN
315 ELSE IF( ldb.LT.max( 1, n ) )
THEN
317 ELSE IF( ldvsl.LT.1 .OR. ( ilvsl .AND. ldvsl.LT.n ) )
THEN
319 ELSE IF( ldvsr.LT.1 .OR. ( ilvsr .AND. ldvsr.LT.n ) )
THEN
321 ELSE IF( lwork.LT.lwkmin .AND. .NOT.lquery )
THEN
326 nb1 =
ilaenv( 1,
'ZGEQRF',
' ', n, n, -1, -1 )
327 nb2 =
ilaenv( 1,
'ZUNMQR',
' ', n, n, n, -1 )
328 nb3 =
ilaenv( 1,
'ZUNGQR',
' ', n, n, n, -1 )
329 nb = max( nb1, nb2, nb3 )
335 CALL
xerbla(
'ZGEGS ', -info )
337 ELSE IF( lquery )
THEN
350 smlnum = n*safmin / eps
351 bignum = one / smlnum
355 anrm =
zlange(
'M', n, n, a, lda, rwork )
357 IF( anrm.GT.zero .AND. anrm.LT.smlnum )
THEN
360 ELSE IF( anrm.GT.bignum )
THEN
366 CALL
zlascl(
'G', -1, -1, anrm, anrmto, n, n, a, lda, iinfo )
367 IF( iinfo.NE.0 )
THEN
375 bnrm =
zlange(
'M', n, n,
b, ldb, rwork )
377 IF( bnrm.GT.zero .AND. bnrm.LT.smlnum )
THEN
380 ELSE IF( bnrm.GT.bignum )
THEN
386 CALL
zlascl(
'G', -1, -1, bnrm, bnrmto, n, n,
b, ldb, iinfo )
387 IF( iinfo.NE.0 )
THEN
399 CALL
zggbal(
'P', n, a, lda,
b, ldb, ilo, ihi, rwork( ileft ),
400 $ rwork( iright ), rwork( irwork ), iinfo )
401 IF( iinfo.NE.0 )
THEN
408 irows = ihi + 1 - ilo
412 CALL
zgeqrf( irows, icols,
b( ilo, ilo ), ldb, work( itau ),
413 $ work( iwork ), lwork+1-iwork, iinfo )
415 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
416 IF( iinfo.NE.0 )
THEN
421 CALL
zunmqr(
'L',
'C', irows, icols, irows,
b( ilo, ilo ), ldb,
422 $ work( itau ), a( ilo, ilo ), lda, work( iwork ),
423 $ lwork+1-iwork, iinfo )
425 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
426 IF( iinfo.NE.0 )
THEN
432 CALL
zlaset(
'Full', n, n, czero, cone, vsl, ldvsl )
433 CALL
zlacpy(
'L', irows-1, irows-1,
b( ilo+1, ilo ), ldb,
434 $ vsl( ilo+1, ilo ), ldvsl )
435 CALL
zungqr( irows, irows, irows, vsl( ilo, ilo ), ldvsl,
436 $ work( itau ), work( iwork ), lwork+1-iwork,
439 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
440 IF( iinfo.NE.0 )
THEN
447 $ CALL
zlaset(
'Full', n, n, czero, cone, vsr, ldvsr )
451 CALL
zgghrd( jobvsl, jobvsr, n, ilo, ihi, a, lda,
b, ldb, vsl,
452 $ ldvsl, vsr, ldvsr, iinfo )
453 IF( iinfo.NE.0 )
THEN
461 CALL
zhgeqz(
'S', jobvsl, jobvsr, n, ilo, ihi, a, lda,
b, ldb,
462 $ alpha, beta, vsl, ldvsl, vsr, ldvsr, work( iwork ),
463 $ lwork+1-iwork, rwork( irwork ), iinfo )
465 $ lwkopt = max( lwkopt, int( work( iwork ) )+iwork-1 )
466 IF( iinfo.NE.0 )
THEN
467 IF( iinfo.GT.0 .AND. iinfo.LE.n )
THEN
469 ELSE IF( iinfo.GT.n .AND. iinfo.LE.2*n )
THEN
480 CALL
zggbak(
'P',
'L', n, ilo, ihi, rwork( ileft ),
481 $ rwork( iright ), n, vsl, ldvsl, iinfo )
482 IF( iinfo.NE.0 )
THEN
488 CALL
zggbak(
'P',
'R', n, ilo, ihi, rwork( ileft ),
489 $ rwork( iright ), n, vsr, ldvsr, iinfo )
490 IF( iinfo.NE.0 )
THEN
499 CALL
zlascl(
'U', -1, -1, anrmto, anrm, n, n, a, lda, iinfo )
500 IF( iinfo.NE.0 )
THEN
504 CALL
zlascl(
'G', -1, -1, anrmto, anrm, n, 1, alpha, n, iinfo )
505 IF( iinfo.NE.0 )
THEN
512 CALL
zlascl(
'U', -1, -1, bnrmto, bnrm, n, n,
b, ldb, iinfo )
513 IF( iinfo.NE.0 )
THEN
517 CALL
zlascl(
'G', -1, -1, bnrmto, bnrm, n, 1, beta, n, iinfo )
518 IF( iinfo.NE.0 )
THEN
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zhgeqz(JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, ALPHA, BETA, Q, LDQ, Z, LDZ, WORK, LWORK, RWORK, INFO)
ZHGEQZ
subroutine zungqr(M, N, K, A, LDA, TAU, WORK, LWORK, INFO)
ZUNGQR
subroutine xerbla(SRNAME, INFO)
XERBLA
subroutine zggbak(JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V, LDV, INFO)
ZGGBAK
set ue cd $ADTTMP cat<< EOF > tmp f Program LinearEquations Implicit none Real b(3) integer i
subroutine zgghrd(COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q, LDQ, Z, LDZ, INFO)
ZGGHRD
subroutine zlascl(TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO)
ZLASCL multiplies a general rectangular matrix by a real scalar defined as cto/cfrom.
logical function lsame(CA, CB)
LSAME
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 zgeqrf(M, N, A, LDA, TAU, WORK, LWORK, INFO)
ZGEQRF VARIANT: left-looking Level 3 BLAS of the algorithm.
double precision function zlange(NORM, M, N, A, LDA, WORK)
ZLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value ...
subroutine zgegs(JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHA, BETA, VSL, LDVSL, VSR, LDVSR, WORK, LWORK, RWORK, INFO)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices ...
double precision function dlamch(CMACH)
DLAMCH
subroutine zunmqr(SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK, LWORK, INFO)
ZUNMQR
integer function ilaenv(ISPEC, NAME, OPTS, N1, N2, N3, N4)
subroutine zggbal(JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE, WORK, INFO)
ZGGBAL