365 SUBROUTINE zget23( COMP, ISRT, BALANC, JTYPE, THRESH, ISEED,
366 $ NOUNIT, N, A, LDA, H, W, W1, VL, LDVL, VR,
367 $ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
368 $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
369 $ WORK, LWORK, RWORK, INFO )
379 INTEGER INFO, ISRT, JTYPE, LDA, LDLRE, LDVL, LDVR,
381 DOUBLE PRECISION THRESH
385 DOUBLE PRECISION RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
386 $ rcndv1( * ), rconde( * ), rcondv( * ),
387 $ result( 11 ), rwork( * ), scale( * ),
389 COMPLEX*16 A( lda, * ), H( lda, * ), LRE( ldlre, * ),
390 $ vl( ldvl, * ), vr( ldvr, * ), w( * ), w1( * ),
397 DOUBLE PRECISION ZERO, ONE, TWO
398 parameter( zero = 0.0d0, one = 1.0d0, two = 2.0d0 )
399 DOUBLE PRECISION EPSIN
400 parameter( epsin = 5.9605d-8 )
405 INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
407 DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
408 $ ulp, ulpinv, v, vmax, vmx, vricmp, vrimin,
414 DOUBLE PRECISION RES( 2 )
419 DOUBLE PRECISION DLAMCH, DZNRM2
420 EXTERNAL lsame, dlamch, dznrm2
426 INTRINSIC abs, dble, dimag, max, min
429 DATA sens /
'N',
'V' /
435 nobal = lsame( balanc,
'N' )
436 balok = nobal .OR. lsame( balanc,
'P' ) .OR.
437 $ lsame( balanc,
'S' ) .OR. lsame( balanc,
'B' )
439 IF( isrt.NE.0 .AND. isrt.NE.1 )
THEN 441 ELSE IF( .NOT.balok )
THEN 443 ELSE IF( thresh.LT.zero )
THEN 445 ELSE IF( nounit.LE.0 )
THEN 447 ELSE IF( n.LT.0 )
THEN 449 ELSE IF( lda.LT.1 .OR. lda.LT.n )
THEN 451 ELSE IF( ldvl.LT.1 .OR. ldvl.LT.n )
THEN 453 ELSE IF( ldvr.LT.1 .OR. ldvr.LT.n )
THEN 455 ELSE IF( ldlre.LT.1 .OR. ldlre.LT.n )
THEN 457 ELSE IF( lwork.LT.2*n .OR. ( comp .AND. lwork.LT.2*n+n*n ) )
THEN 462 CALL xerbla(
'ZGET23', -info )
477 ulp = dlamch(
'Precision' )
478 smlnum = dlamch(
'S' )
483 IF( lwork.GE.2*n+n*n )
THEN 490 CALL zlacpy(
'F', n, n, a, lda, h, lda )
491 CALL zgeevx( balanc,
'V',
'V', sense, n, h, lda, w, vl, ldvl, vr,
492 $ ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work,
493 $ lwork, rwork, iinfo )
494 IF( iinfo.NE.0 )
THEN 496 IF( jtype.NE.22 )
THEN 497 WRITE( nounit, fmt = 9998 )
'ZGEEVX1', iinfo, n, jtype,
500 WRITE( nounit, fmt = 9999 )
'ZGEEVX1', iinfo, n, iseed( 1 )
508 CALL zget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work, rwork,
510 result( 1 ) = res( 1 )
514 CALL zget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work, rwork,
516 result( 2 ) = res( 1 )
521 tnrm = dznrm2( n, vr( 1, j ), 1 )
522 result( 3 ) = max( result( 3 ),
523 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
527 vtst = abs( vr( jj, j ) )
530 IF( dimag( vr( jj, j ) ).EQ.zero .AND.
531 $ abs( dble( vr( jj, j ) ) ).GT.vrmx )
532 $ vrmx = abs( dble( vr( jj, j ) ) )
534 IF( vrmx / vmx.LT.one-two*ulp )
535 $ result( 3 ) = ulpinv
541 tnrm = dznrm2( n, vl( 1, j ), 1 )
542 result( 4 ) = max( result( 4 ),
543 $ min( ulpinv, abs( tnrm-one ) / ulp ) )
547 vtst = abs( vl( jj, j ) )
550 IF( dimag( vl( jj, j ) ).EQ.zero .AND.
551 $ abs( dble( vl( jj, j ) ) ).GT.vrmx )
552 $ vrmx = abs( dble( vl( jj, j ) ) )
554 IF( vrmx / vmx.LT.one-two*ulp )
555 $ result( 4 ) = ulpinv
560 DO 200 isens = 1, isensm
562 sense = sens( isens )
566 CALL zlacpy(
'F', n, n, a, lda, h, lda )
567 CALL zgeevx( balanc,
'N',
'N', sense, n, h, lda, w1, cdum, 1,
568 $ cdum, 1, ilo1, ihi1, scale1, abnrm1, rcnde1,
569 $ rcndv1, work, lwork, rwork, iinfo )
570 IF( iinfo.NE.0 )
THEN 572 IF( jtype.NE.22 )
THEN 573 WRITE( nounit, fmt = 9998 )
'ZGEEVX2', iinfo, n, jtype,
576 WRITE( nounit, fmt = 9999 )
'ZGEEVX2', iinfo, n,
586 IF( w( j ).NE.w1( j ) )
587 $ result( 5 ) = ulpinv
592 IF( .NOT.nobal )
THEN 594 IF( scale( j ).NE.scale1( j ) )
595 $ result( 8 ) = ulpinv
598 $ result( 8 ) = ulpinv
600 $ result( 8 ) = ulpinv
601 IF( abnrm.NE.abnrm1 )
602 $ result( 8 ) = ulpinv
607 IF( isens.EQ.2 .AND. n.GT.1 )
THEN 609 IF( rcondv( j ).NE.rcndv1( j ) )
610 $ result( 9 ) = ulpinv
616 CALL zlacpy(
'F', n, n, a, lda, h, lda )
617 CALL zgeevx( balanc,
'N',
'V', sense, n, h, lda, w1, cdum, 1,
618 $ lre, ldlre, ilo1, ihi1, scale1, abnrm1, rcnde1,
619 $ rcndv1, work, lwork, rwork, iinfo )
620 IF( iinfo.NE.0 )
THEN 622 IF( jtype.NE.22 )
THEN 623 WRITE( nounit, fmt = 9998 )
'ZGEEVX3', iinfo, n, jtype,
626 WRITE( nounit, fmt = 9999 )
'ZGEEVX3', iinfo, n,
636 IF( w( j ).NE.w1( j ) )
637 $ result( 5 ) = ulpinv
644 IF( vr( j, jj ).NE.lre( j, jj ) )
645 $ result( 6 ) = ulpinv
651 IF( .NOT.nobal )
THEN 653 IF( scale( j ).NE.scale1( j ) )
654 $ result( 8 ) = ulpinv
657 $ result( 8 ) = ulpinv
659 $ result( 8 ) = ulpinv
660 IF( abnrm.NE.abnrm1 )
661 $ result( 8 ) = ulpinv
666 IF( isens.EQ.2 .AND. n.GT.1 )
THEN 668 IF( rcondv( j ).NE.rcndv1( j ) )
669 $ result( 9 ) = ulpinv
675 CALL zlacpy(
'F', n, n, a, lda, h, lda )
676 CALL zgeevx( balanc,
'V',
'N', sense, n, h, lda, w1, lre,
677 $ ldlre, cdum, 1, ilo1, ihi1, scale1, abnrm1,
678 $ rcnde1, rcndv1, work, lwork, rwork, iinfo )
679 IF( iinfo.NE.0 )
THEN 681 IF( jtype.NE.22 )
THEN 682 WRITE( nounit, fmt = 9998 )
'ZGEEVX4', iinfo, n, jtype,
685 WRITE( nounit, fmt = 9999 )
'ZGEEVX4', iinfo, n,
695 IF( w( j ).NE.w1( j ) )
696 $ result( 5 ) = ulpinv
703 IF( vl( j, jj ).NE.lre( j, jj ) )
704 $ result( 7 ) = ulpinv
710 IF( .NOT.nobal )
THEN 712 IF( scale( j ).NE.scale1( j ) )
713 $ result( 8 ) = ulpinv
716 $ result( 8 ) = ulpinv
718 $ result( 8 ) = ulpinv
719 IF( abnrm.NE.abnrm1 )
720 $ result( 8 ) = ulpinv
725 IF( isens.EQ.2 .AND. n.GT.1 )
THEN 727 IF( rcondv( j ).NE.rcndv1( j ) )
728 $ result( 9 ) = ulpinv
739 CALL zlacpy(
'F', n, n, a, lda, h, lda )
740 CALL zgeevx(
'N',
'V',
'V',
'B', n, h, lda, w, vl, ldvl, vr,
741 $ ldvr, ilo, ihi, scale, abnrm, rconde, rcondv,
742 $ work, lwork, rwork, iinfo )
743 IF( iinfo.NE.0 )
THEN 745 WRITE( nounit, fmt = 9999 )
'ZGEEVX5', iinfo, n, iseed( 1 )
756 vrimin = dble( w( i ) )
758 vrimin = dimag( w( i ) )
762 vricmp = dble( w( j ) )
764 vricmp = dimag( w( j ) )
766 IF( vricmp.LT.vrimin )
THEN 774 vrimin = rconde( kmin )
775 rconde( kmin ) = rconde( i )
777 vrimin = rcondv( kmin )
778 rcondv( kmin ) = rcondv( i )
786 eps = max( epsin, ulp )
787 v = max( dble( n )*eps*abnrm, smlnum )
791 IF( v.GT.rcondv( i )*rconde( i ) )
THEN 794 tol = v / rconde( i )
796 IF( v.GT.rcdvin( i )*rcdein( i ) )
THEN 799 tolin = v / rcdein( i )
801 tol = max( tol, smlnum / eps )
802 tolin = max( tolin, smlnum / eps )
803 IF( eps*( rcdvin( i )-tolin ).GT.rcondv( i )+tol )
THEN 805 ELSE IF( rcdvin( i )-tolin.GT.rcondv( i )+tol )
THEN 806 vmax = ( rcdvin( i )-tolin ) / ( rcondv( i )+tol )
807 ELSE IF( rcdvin( i )+tolin.LT.eps*( rcondv( i )-tol ) )
THEN 809 ELSE IF( rcdvin( i )+tolin.LT.rcondv( i )-tol )
THEN 810 vmax = ( rcondv( i )-tol ) / ( rcdvin( i )+tolin )
814 result( 10 ) = max( result( 10 ), vmax )
822 IF( v.GT.rcondv( i ) )
THEN 825 tol = v / rcondv( i )
827 IF( v.GT.rcdvin( i ) )
THEN 830 tolin = v / rcdvin( i )
832 tol = max( tol, smlnum / eps )
833 tolin = max( tolin, smlnum / eps )
834 IF( eps*( rcdein( i )-tolin ).GT.rconde( i )+tol )
THEN 836 ELSE IF( rcdein( i )-tolin.GT.rconde( i )+tol )
THEN 837 vmax = ( rcdein( i )-tolin ) / ( rconde( i )+tol )
838 ELSE IF( rcdein( i )+tolin.LT.eps*( rconde( i )-tol ) )
THEN 840 ELSE IF( rcdein( i )+tolin.LT.rconde( i )-tol )
THEN 841 vmax = ( rconde( i )-tol ) / ( rcdein( i )+tolin )
845 result( 11 ) = max( result( 11 ), vmax )
851 9999
FORMAT(
' ZGET23: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
852 $ i6,
', INPUT EXAMPLE NUMBER = ', i4 )
853 9998
FORMAT(
' ZGET23: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
854 $ i6,
', JTYPE=', i6,
', BALANC = ', a,
', ISEED=(',
855 $ 3( i5,
',' ), i5,
')' )
subroutine zget22(TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, W, WORK, RWORK, RESULT)
ZGET22
subroutine zlacpy(UPLO, M, N, A, LDA, B, LDB)
ZLACPY copies all or part of one two-dimensional array to another.
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 xerbla(SRNAME, INFO)
XERBLA
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