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,
')' )