363 SUBROUTINE cget23( 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,
382 REAL RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
383 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
384 $ RESULT( 11 ), RWORK( * ), SCALE( * ),
386 COMPLEX A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
387 $ VL( LDVL, * ), VR( LDVR, * ), W( * ), W1( * ),
395 PARAMETER ( ZERO = 0.0e0, one = 1.0e0, two = 2.0e0 )
397 PARAMETER ( EPSIN = 5.9605e-8 )
402 INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
404 REAL ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
405 $ ulp, ulpinv, v, vmax, vmx, vricmp, vrimin,
417 EXTERNAL LSAME, SCNRM2, SLAMCH
423 INTRINSIC abs, aimag, max, min, real
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(
'CGET23', -info )
474 ulp = slamch(
'Precision' )
475 smlnum = slamch(
'S' )
480 IF( lwork.GE.2*n+n*n )
THEN
487 CALL clacpy(
'F', n, n, a, lda, h, lda )
488 CALL cgeevx( 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 )
'CGEEVX1', iinfo, n, jtype,
497 WRITE( nounit, fmt = 9999 )
'CGEEVX1', iinfo, n, iseed( 1 )
505 CALL cget22(
'N',
'N',
'N', n, a, lda, vr, ldvr, w, work, rwork,
507 result( 1 ) = res( 1 )
511 CALL cget22(
'C',
'N',
'C', n, a, lda, vl, ldvl, w, work, rwork,
513 result( 2 ) = res( 1 )
518 tnrm = scnrm2( 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( aimag( vr( jj, j ) ).EQ.zero .AND.
528 $ abs( real( vr( jj, j ) ) ).GT.vrmx )
529 $ vrmx = abs( real( vr( jj, j ) ) )
531 IF( vrmx / vmx.LT.one-two*ulp )
532 $ result( 3 ) = ulpinv
538 tnrm = scnrm2( 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( aimag( vl( jj, j ) ).EQ.zero .AND.
548 $ abs( real( vl( jj, j ) ) ).GT.vrmx )
549 $ vrmx = abs( real( 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 clacpy(
'F', n, n, a, lda, h, lda )
564 CALL cgeevx( 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 )
'CGEEVX2', iinfo, n, jtype,
573 WRITE( nounit, fmt = 9999 )
'CGEEVX2', 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 clacpy(
'F', n, n, a, lda, h, lda )
614 CALL cgeevx( 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 )
'CGEEVX3', iinfo, n, jtype,
623 WRITE( nounit, fmt = 9999 )
'CGEEVX3', 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 clacpy(
'F', n, n, a, lda, h, lda )
673 CALL cgeevx( 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 )
'CGEEVX4', iinfo, n, jtype,
682 WRITE( nounit, fmt = 9999 )
'CGEEVX4', 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 clacpy(
'F', n, n, a, lda, h, lda )
737 CALL cgeevx(
'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 )
'CGEEVX5', iinfo, n, iseed( 1 )
753 vrimin = real( w( i ) )
755 vrimin = aimag( w( i ) )
759 vricmp = real( w( j ) )
761 vricmp = aimag( 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( real( 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(
' CGET23: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
849 $ i6,
', INPUT EXAMPLE NUMBER = ', i4 )
850 9998
FORMAT(
' CGET23: ', a,
' returned INFO=', i6,
'.', / 9x,
'N=',
851 $ i6,
', JTYPE=', i6,
', BALANC = ', a,
', ISEED=(',
852 $ 3( i5,
',' ), i5,
')' )
subroutine xerbla(srname, info)
subroutine cget22(transa, transe, transw, n, a, lda, e, lde, w, work, rwork, result)
CGET22
subroutine cget23(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)
CGET23
subroutine cgeevx(balanc, jobvl, jobvr, sense, n, a, lda, w, vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, rwork, info)
CGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
subroutine clacpy(uplo, m, n, a, lda, b, ldb)
CLACPY copies all or part of one two-dimensional array to another.