363 SUBROUTINE zget23( COMP, ISRT, BALANC, JTYPE, THRESH, ISEED,
364 $ NOUNIT, N, A, LDA, H, W, W1, VL, LDVL, VR,
365 $ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
366 $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
367 $ WORK, LWORK, RWORK, INFO )
376 INTEGER INFO, ISRT, JTYPE, LDA, LDLRE, LDVL, LDVR,
378 DOUBLE PRECISION THRESH
382 DOUBLE PRECISION RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
383 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
384 $ RESULT( 11 ), RWORK( * ), SCALE( * ),
386 COMPLEX*16 A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
387 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
394 DOUBLE PRECISION ZERO, ONE, TWO
395 PARAMETER ( ZERO = 0.0d0, one = 1.0d0, two = 2.0d0 )
396 DOUBLE PRECISION EPSIN
397 PARAMETER ( EPSIN = 5.9605d-8 )
402 INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
404 DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
405 $ ulp, ulpinv, v, vmax, vmx, vricmp, vrimin,
411 DOUBLE PRECISION RES( 2 )
416 DOUBLE PRECISION DLAMCH, DZNRM2
417 EXTERNAL LSAME, DLAMCH, DZNRM2
423 INTRINSIC abs, dble, dimag, max, min
426 DATA sens /
'N',
'V' /
432 nobal = lsame( balanc,
'N' )
433 balok = nobal .OR. lsame( balanc,
'P' ) .OR.
434 $ lsame( balanc,
'S' ) .OR. lsame( balanc,
'B' )
436 IF( isrt.NE.0 .AND. isrt.NE.1 )
THEN
438 ELSE IF( .NOT.balok )
THEN
440 ELSE IF( thresh.LT.zero )
THEN
442 ELSE IF( nounit.LE.0 )
THEN
444 ELSE IF( n.LT.0 )
THEN
446 ELSE IF( lda.LT.1 .OR. lda.LT.n )
THEN
448 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.n )
THEN
450 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.n )
THEN
452 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.n )
THEN
454 ELSE IF( lwork.LT.2*n .OR. ( comp .AND. lwork.LT.2*n+n*n ) )
THEN
459 CALL xerbla(
'ZGET23', -info )
474 ulp = dlamch(
'Precision' )
475 smlnum = dlamch(
'S' )
480 IF( lwork.GE.2*n+n*n )
THEN
487 CALL zlacpy(
'F', n, n, a, lda, h, lda )
488 CALL zgeevx( balanc,
'V',
'V', sense, n, h, lda, w, vl, ldvl, vr,
489 $ ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work,
490 $ lwork, rwork, iinfo )
491 IF( iinfo.NE.0 )
THEN
493 IF( jtype.NE.22 )
THEN
494 WRITE( nounit, fmt = 9998 )
'ZGEEVX1', iinfo, n, jtype,
497 WRITE( nounit, fmt = 9999 )
'ZGEEVX1', iinfo, n, iseed( 1 )
505 CALL zget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work, rwork,
507 result( 1 ) = res( 1 )
511 CALL zget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work, rwork,
513 result( 2 ) = res( 1 )
518 tnrm = dznrm2( n, vr( 1, j ), 1 )
519 result( 3 ) = max( result( 3 ),
520 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
524 vtst = abs( vr( jj, j ) )
527 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
528 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
529 $ vrmx = abs( dble( vr( jj, j ) ) )
531 IF( vrmx / vmx.LT.one-two*ulp )
532 $ result( 3 ) = ulpinv
538 tnrm = dznrm2( n, vl( 1, j ), 1 )
539 result( 4 ) = max( result( 4 ),
540 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
544 vtst = abs( vl( jj, j ) )
547 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
548 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
549 $ vrmx = abs( dble( vl( jj, j ) ) )
551 IF( vrmx / vmx.LT.one-two*ulp )
552 $ result( 4 ) = ulpinv
557 DO 200 isens = 1, isensm
559 sense = sens( isens )
563 CALL zlacpy(
'F', n, n, a, lda, h, lda )
564 CALL zgeevx( balanc,
'N',
'N', sense, n, h, lda, w1, cdum, 1,
565 $ cdum, 1, ilo1, ihi1, scale1, abnrm1, rcnde1,
566 $ rcndv1, work, lwork, rwork, iinfo )
567 IF( iinfo.NE.0 )
THEN
569 IF( jtype.NE.22 )
THEN
570 WRITE( nounit, fmt = 9998 )
'ZGEEVX2', iinfo, n, jtype,
573 WRITE( nounit, fmt = 9999 )
'ZGEEVX2', iinfo, n,
583 IF( w( j ).NE.w1( j ) )
584 $ result( 5 ) = ulpinv
589 IF( .NOT.nobal )
THEN
591 IF( scale( j ).NE.scale1( j ) )
592 $ result( 8 ) = ulpinv
595 $ result( 8 ) = ulpinv
597 $ result( 8 ) = ulpinv
598 IF( abnrm.NE.abnrm1 )
599 $ result( 8 ) = ulpinv
604 IF( isens.EQ.2 .AND. n.GT.1 )
THEN
606 IF( rcondv( j ).NE.rcndv1( j ) )
607 $ result( 9 ) = ulpinv
613 CALL zlacpy(
'F', n, n, a, lda, h, lda )
614 CALL zgeevx( balanc,
'N',
'V', sense, n, h, lda, w1, cdum, 1,
615 $ lre, ldlre, ilo1, ihi1, scale1, abnrm1, rcnde1,
616 $ rcndv1, work, lwork, rwork, iinfo )
617 IF( iinfo.NE.0 )
THEN
619 IF( jtype.NE.22 )
THEN
620 WRITE( nounit, fmt = 9998 )
'ZGEEVX3', iinfo, n, jtype,
623 WRITE( nounit, fmt = 9999 )
'ZGEEVX3', iinfo, n,
633 IF( w( j ).NE.w1( j ) )
634 $ result( 5 ) = ulpinv
641 IF( vr( j, jj ).NE.lre( j, jj ) )
642 $ result( 6 ) = ulpinv
648 IF( .NOT.nobal )
THEN
650 IF( scale( j ).NE.scale1( j ) )
651 $ result( 8 ) = ulpinv
654 $ result( 8 ) = ulpinv
656 $ result( 8 ) = ulpinv
657 IF( abnrm.NE.abnrm1 )
658 $ result( 8 ) = ulpinv
663 IF( isens.EQ.2 .AND. n.GT.1 )
THEN
665 IF( rcondv( j ).NE.rcndv1( j ) )
666 $ result( 9 ) = ulpinv
672 CALL zlacpy(
'F', n, n, a, lda, h, lda )
673 CALL zgeevx( balanc,
'V',
'N', sense, n, h, lda, w1, lre,
674 $ ldlre, cdum, 1, ilo1, ihi1, scale1, abnrm1,
675 $ rcnde1, rcndv1, work, lwork, rwork, iinfo )
676 IF( iinfo.NE.0 )
THEN
678 IF( jtype.NE.22 )
THEN
679 WRITE( nounit, fmt = 9998 )
'ZGEEVX4', iinfo, n, jtype,
682 WRITE( nounit, fmt = 9999 )
'ZGEEVX4', iinfo, n,
692 IF( w( j ).NE.w1( j ) )
693 $ result( 5 ) = ulpinv
700 IF( vl( j, jj ).NE.lre( j, jj ) )
701 $ result( 7 ) = ulpinv
707 IF( .NOT.nobal )
THEN
709 IF( scale( j ).NE.scale1( j ) )
710 $ result( 8 ) = ulpinv
713 $ result( 8 ) = ulpinv
715 $ result( 8 ) = ulpinv
716 IF( abnrm.NE.abnrm1 )
717 $ result( 8 ) = ulpinv
722 IF( isens.EQ.2 .AND. n.GT.1 )
THEN
724 IF( rcondv( j ).NE.rcndv1( j ) )
725 $ result( 9 ) = ulpinv
736 CALL zlacpy(
'F', n, n, a, lda, h, lda )
737 CALL zgeevx(
'N',
'V',
'V',
'B', n, h, lda, w, vl, ldvl, vr,
738 $ ldvr, ilo, ihi, scale, abnrm, rconde, rcondv,
739 $ work, lwork, rwork, iinfo )
740 IF( iinfo.NE.0 )
THEN
742 WRITE( nounit, fmt = 9999 )
'ZGEEVX5', iinfo, n, iseed( 1 )
753 vrimin = dble( w( i ) )
755 vrimin = dimag( w( i ) )
759 vricmp = dble( w( j ) )
761 vricmp = dimag( w( j ) )
763 IF( vricmp.LT.vrimin )
THEN
771 vrimin = rconde( kmin )
772 rconde( kmin ) = rconde( i )
774 vrimin = rcondv( kmin )
775 rcondv( kmin ) = rcondv( i )
783 eps = max( epsin, ulp )
784 v = max( dble( n )*eps*abnrm, smlnum )
788 IF( v.GT.rcondv( i )*rconde( i ) )
THEN
791 tol = v / rconde( i )
793 IF( v.GT.rcdvin( i )*rcdein( i ) )
THEN
796 tolin = v / rcdein( i )
798 tol = max( tol, smlnum / eps )
799 tolin = max( tolin, smlnum / eps )
800 IF( eps*( rcdvin( i )-tolin ).GT.rcondv( i )+tol )
THEN
802 ELSE IF( rcdvin( i )-tolin.GT.rcondv( i )+tol )
THEN
803 vmax = ( rcdvin( i )-tolin ) / ( rcondv( i )+tol )
804 ELSE IF( rcdvin( i )+tolin.LT.eps*( rcondv( i )-tol ) )
THEN
806 ELSE IF( rcdvin( i )+tolin.LT.rcondv( i )-tol )
THEN
807 vmax = ( rcondv( i )-tol ) / ( rcdvin( i )+tolin )
811 result( 10 ) = max( result( 10 ), vmax )
819 IF( v.GT.rcondv( i ) )
THEN
822 tol = v / rcondv( i )
824 IF( v.GT.rcdvin( i ) )
THEN
827 tolin = v / rcdvin( i )
829 tol = max( tol, smlnum / eps )
830 tolin = max( tolin, smlnum / eps )
831 IF( eps*( rcdein( i )-tolin ).GT.rconde( i )+tol )
THEN
833 ELSE IF( rcdein( i )-tolin.GT.rconde( i )+tol )
THEN
834 vmax = ( rcdein( i )-tolin ) / ( rconde( i )+tol )
835 ELSE IF( rcdein( i )+tolin.LT.eps*( rconde( i )-tol ) )
THEN
837 ELSE IF( rcdein( i )+tolin.LT.rconde( i )-tol )
THEN
838 vmax = ( rconde( i )-tol ) / ( rcdein( i )+tolin )
842 result( 11 ) = max( result( 11 ), vmax )
848 9999
FORMAT(
' ZGET23: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
849 $ i6,
', INPUT EXAMPLE NUMBER = ', i4 )
850 9998
FORMAT(
' ZGET23: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
851 $ i6,
', JTYPE=', i6,
', BALANC = ', a,
', ISEED=(',
852 $ 3( i5,
',' ), i5,
')' )
subroutine xerbla(srname, info)
subroutine zgeevx(balanc, jobvl, jobvr, sense, n, a, lda, w, vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, rwork, info)
ZGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
subroutine zlacpy(uplo, m, n, a, lda, b, ldb)
ZLACPY copies all or part of one two-dimensional array to another.
subroutine zget22(transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
ZGET22
subroutine zget23(comp, isrt, balanc, jtype, thresh, iseed, nounit, n, a, lda, h, w, w1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, lwork, rwork, info)
ZGET23