373 SUBROUTINE sget23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N,
374 $ A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, VR,
375 $ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
376 $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
377 $ WORK, LWORK, IWORK, INFO )
386 INTEGER INFO, JTYPE, LDA, LDLRE, LDVL, LDVR, LWORK, N,
391 INTEGER ISEED( 4 ), IWORK( * )
392 REAL A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
393 $ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
394 $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
395 $ result( 11 ), scale( * ), scale1( * ),
396 $ vl( ldvl, * ), vr( ldvr, * ), wi( * ),
397 $ wi1( * ), work( * ), wr( * ), wr1( * )
405 PARAMETER ( ZERO = 0.0e0, one = 1.0e0, two = 2.0e0 )
407 PARAMETER ( = 5.9605e-8 )
412 INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
414 REAL ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
415 $ ulp, ulpinv, v, vimin, vmax, vmx, vrmin, vrmx,
420 REAL DUM( 1 ), RES( 2 )
424 REAL SLAMCH, SLAPY2, SNRM2
425 EXTERNAL LSAME, SLAMCH, SLAPY2, SNRM2
431 INTRINSIC abs,
max,
min, real
434 DATA sens /
'N', 'v
' /
440 NOBAL = LSAME( BALANC, 'n
' )
441.OR.
BALOK = NOBAL LSAME( BALANC, 'p.OR.
' )
442 $ LSAME( BALANC, 's.OR.
' ) LSAME( BALANC, 'b
' )
444.NOT.
IF( BALOK ) THEN
446.LT.
ELSE IF( THRESHZERO ) THEN
448.LE.
ELSE IF( NOUNIT0 ) THEN
450.LT.
ELSE IF( N0 ) THEN
452.LT..OR..LT.
ELSE IF( LDA1 LDAN ) THEN
454.LT..OR..LT.
ELSE IF( LDVL1 LDVLN ) THEN
456.LT..OR..LT.
ELSE IF( LDVR1 LDVRN ) THEN
458.LT..OR..LT.
ELSE IF( LDLRE1 LDLREN ) THEN
460.LT..OR..AND..LT.
ELSE IF( LWORK3*N ( COMP LWORK6*N+N*N ) ) THEN
465 CALL XERBLA( 'sget23', -INFO )
480 ULP = SLAMCH( 'precision
' )
481 SMLNUM = SLAMCH( 's
' )
486.GE.
IF( LWORK6*N+N*N ) THEN
493 CALL SLACPY( 'f
', N, N, A, LDA, H, LDA )
494 CALL SGEEVX( BALANC, 'v',
'V', sense, n, h, lda, wr, wi, vl, ldvl,
495 $ vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv,
496 $ work, lwork, iwork, iinfo )
497 IF( iinfo.NE.0 )
THEN
499 IF( jtype.NE.22 )
THEN
500 WRITE( nounit, fmt = 9998 )'sgeevx1
', IINFO, N, JTYPE,
503 WRITE( NOUNIT, FMT = 9999 )'sgeevx1
', IINFO, N, ISEED( 1 )
511 CALL SGET22( 'n
', 'n
', 'n
', N, A, LDA, VR, LDVR, WR, WI, WORK,
513 RESULT( 1 ) = RES( 1 )
517 CALL SGET22( 't
', 'n
', 't
', N, A, LDA, VL, LDVL, WR, WI, WORK,
519 RESULT( 2 ) = RES( 1 )
525.EQ.
IF( WI( J )ZERO ) THEN
526 TNRM = SNRM2( N, VR( 1, J ), 1 )
527.GT.
ELSE IF( WI( J )ZERO ) THEN
528 TNRM = SLAPY2( SNRM2( N, VR( 1, J ), 1 ),
529 $ SNRM2( N, VR( 1, J+1 ), 1 ) )
531 RESULT( 3 ) = MAX( RESULT( 3 ),
532 $ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
533.GT.
IF( WI( J )ZERO ) THEN
537 VTST = SLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
540.EQ..AND..GT.
IF( VR( JJ, J+1 )ZERO ABS( VR( JJ, J ) )
541 $ VRMX )VRMX = ABS( VR( JJ, J ) )
543.LT.
IF( VRMX / VMXONE-TWO*ULP )
544 $ RESULT( 3 ) = ULPINV
552.EQ.
IF( WI( J )ZERO ) THEN
553 TNRM = SNRM2( N, VL( 1, J ), 1 )
554.GT.
ELSE IF( WI( J )ZERO ) THEN
555 TNRM = SLAPY2( SNRM2( N, VL( 1, J ), 1 ),
556 $ SNRM2( N, VL( 1, J+1 ), 1 ) )
558 RESULT( 4 ) = MAX( RESULT( 4 ),
559 $ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
560.GT.
IF( WI( J )ZERO ) THEN
564 VTST = SLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
567.EQ..AND..GT.
IF( VL( JJ, J+1 )ZERO ABS( VL( JJ, J ) )
568 $ VRMX )VRMX = ABS( VL( JJ, J ) )
570.LT.
IF( VRMX / VMXONE-TWO*ULP )
571 $ RESULT( 4 ) = ULPINV
577 DO 200 ISENS = 1, ISENSM
579 SENSE = SENS( ISENS )
583 CALL SLACPY( 'f
', N, N, A, LDA, H, LDA )
584 CALL SGEEVX( BALANC, 'n
', 'n
', SENSE, N, H, LDA, WR1, WI1, DUM,
585 $ 1, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
586 $ RCNDV1, WORK, LWORK, IWORK, IINFO )
587.NE.
IF( IINFO0 ) THEN
589.NE.
IF( JTYPE22 ) THEN
590 WRITE( NOUNIT, FMT = 9998 )'sgeevx2
', IINFO, N, JTYPE,
593 WRITE( NOUNIT, FMT = 9999 )'sgeevx2
', IINFO, N,
603.NE..OR..NE.
IF( WR( J )WR1( J ) WI( J )WI1( J ) )
604 $ RESULT( 5 ) = ULPINV
609.NOT.
IF( NOBAL ) THEN
611.NE.
IF( SCALE( J )SCALE1( J ) )
612 $ RESULT( 8 ) = ULPINV
615 $ RESULT( 8 ) = ULPINV
617 $ RESULT( 8 ) = ULPINV
618.NE.
IF( ABNRMABNRM1 )
619 $ RESULT( 8 ) = ULPINV
624.EQ..AND..GT.
IF( ISENS2 N1 ) THEN
626.NE.
IF( RCONDV( J )RCNDV1( J ) )
627 $ RESULT( 9 ) = ULPINV
633 CALL SLACPY( 'f
', N, N, A, LDA, H, LDA )
634 CALL SGEEVX( BALANC, 'n
', 'v
', SENSE, N, H, LDA, WR1, WI1, DUM,
635 $ 1, LRE, LDLRE, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
636 $ RCNDV1, WORK, LWORK, IWORK, IINFO )
637.NE.
IF( IINFO0 ) THEN
639.NE.
IF( JTYPE22 ) THEN
640 WRITE( NOUNIT, FMT = 9998 )'sgeevx3
', IINFO, N, JTYPE,
643 WRITE( NOUNIT, FMT = 9999 )'sgeevx3
', IINFO, N,
653.NE..OR..NE.
IF( WR( J )WR1( J ) WI( J )WI1( J ) )
654 $ RESULT( 5 ) = ULPINV
661.NE.
IF( VR( J, JJ )LRE( J, JJ ) )
662 $ RESULT( 6 ) = ULPINV
668.NOT.
IF( NOBAL ) THEN
670.NE.
IF( SCALE( J )SCALE1( J ) )
671 $ RESULT( 8 ) = ULPINV
674 $ RESULT( 8 ) = ULPINV
676 $ RESULT( 8 ) = ULPINV
677.NE.
IF( ABNRMABNRM1 )
678 $ RESULT( 8 ) = ULPINV
683.EQ..AND..GT.
IF( ISENS2 N1 ) THEN
685.NE.
IF( RCONDV( J )RCNDV1( J ) )
686 $ RESULT( 9 ) = ULPINV
692 CALL SLACPY( 'f
', N, N, A, LDA, H, LDA )
693 CALL SGEEVX( BALANC, 'v
', 'n
', SENSE, N, H, LDA, WR1, WI1, LRE,
694 $ LDLRE, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
695 $ RCNDV1, WORK, LWORK, IWORK, IINFO )
696.NE.
IF( IINFO0 ) THEN
698.NE.
IF( JTYPE22 ) THEN
699 WRITE( NOUNIT, FMT = 9998 )'sgeevx4
', IINFO, N, JTYPE,
702 WRITE( NOUNIT, FMT = 9999 )'sgeevx4
', IINFO, N,
712.NE..OR..NE.
IF( WR( J )WR1( J ) WI( J )WI1( J ) )
713 $ RESULT( 5 ) = ULPINV
720.NE.
IF( VL( J, JJ )LRE( J, JJ ) )
721 $ RESULT( 7 ) = ULPINV
727.NOT.
IF( NOBAL ) THEN
729.NE.
IF( SCALE( J )SCALE1( J ) )
730 $ RESULT( 8 ) = ULPINV
733 $ RESULT( 8 ) = ULPINV
735 $ RESULT( 8 ) = ULPINV
736.NE.
IF( ABNRMABNRM1 )
737 $ RESULT( 8 ) = ULPINV
742.EQ..AND..GT.
IF( ISENS2 N1 ) THEN
744.NE.
IF( RCONDV( J )RCNDV1( J ) )
745 $ RESULT( 9 ) = ULPINV
756 CALL SLACPY( 'f
', N, N, A, LDA, H, LDA )
757 CALL SGEEVX( 'n
', 'v
', 'v
', 'b
', N, H, LDA, WR, WI, VL, LDVL,
758 $ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
759 $ WORK, LWORK, IWORK, IINFO )
760.NE.
IF( IINFO0 ) THEN
762 WRITE( NOUNIT, FMT = 9999 )'sgeevx5
', IINFO, N, ISEED( 1 )
775.LT.
IF( WR( J )VRMIN ) THEN
785 VRMIN = RCONDE( KMIN )
786 RCONDE( KMIN ) = RCONDE( I )
788 VRMIN = RCONDV( KMIN )
789 RCONDV( KMIN ) = RCONDV( I )
797 EPS = MAX( EPSIN, ULP )
798 V = MAX( REAL( N )*EPS*ABNRM, SMLNUM )
802.GT.
IF( VRCONDV( I )*RCONDE( I ) ) THEN
805 TOL = V / RCONDE( I )
807.GT.
IF( VRCDVIN( I )*RCDEIN( I ) ) THEN
810 TOLIN = V / RCDEIN( I )
812 TOL = MAX( TOL, SMLNUM / EPS )
813 TOLIN = MAX( TOLIN, SMLNUM / EPS )
814.GT.
IF( EPS*( RCDVIN( I )-TOLIN )RCONDV( I )+TOL ) THEN
816.GT.
ELSE IF( RCDVIN( I )-TOLINRCONDV( I )+TOL ) THEN
817 VMAX = ( RCDVIN( I )-TOLIN ) / ( RCONDV( I )+TOL )
818.LT.
ELSE IF( RCDVIN( I )+TOLINEPS*( RCONDV( I )-TOL ) ) THEN
820.LT.
ELSE IF( RCDVIN( I )+TOLINRCONDV( I )-TOL ) THEN
821 VMAX = ( RCONDV( I )-TOL ) / ( RCDVIN( I )+TOLIN )
825 RESULT( 10 ) = MAX( RESULT( 10 ), VMAX )
833.GT.
IF( VRCONDV( I ) ) THEN
836 TOL = V / RCONDV( I )
838.GT.
IF( VRCDVIN( I ) ) THEN
841 TOLIN = V / RCDVIN( I )
843 TOL = MAX( TOL, SMLNUM / EPS )
844 TOLIN = MAX( TOLIN, SMLNUM / EPS )
845.GT.
IF( EPS*( RCDEIN( I )-TOLIN )RCONDE( I )+TOL ) THEN
847.GT.
ELSE IF( RCDEIN( I )-TOLINRCONDE( I )+TOL ) THEN
848 VMAX = ( RCDEIN( I )-TOLIN ) / ( RCONDE( I )+TOL )
849.LT.
ELSE IF( RCDEIN( I )+TOLINEPS*( RCONDE( I )-TOL ) ) THEN
851.LT.
ELSE IF( RCDEIN( I )+TOLINRCONDE( I )-TOL ) THEN
852 VMAX = ( RCONDE( I )-TOL ) / ( RCDEIN( I )+TOLIN )
856 RESULT( 11 ) = MAX( RESULT( 11 ), VMAX )
862 9999 FORMAT( ' sget23:
', A, ' returned info=
', I6, '.
', / 9X, 'n=
',
863 $ I6, ', input example number =
', I4 )
864 9998 FORMAT( ' sget23:
', A, ' returned info=
', I6, '.
', / 9X, 'n=
',
865 $ I6, ', jtype=
', I6, ', balanc =
', A, ', iseed=(
',
866 $ 3( I5, ',
' ), I5, ')
' )
subroutine sgeevx(balanc, jobvl, jobvr, sense, n, a, lda, wr, wi, vl, ldvl, vr, ldvr, ilo, ihi, scale, abnrm, rconde, rcondv, work, lwork, iwork, info)
SGEEVX computes the eigenvalues and, optionally, the left and/or right eigenvectors for GE matrices
subroutine sget23(comp, balanc, jtype, thresh, iseed, nounit, n, a, lda, h, wr, wi, wr1, wi1, vl, ldvl, vr, ldvr, lre, ldlre, rcondv, rcndv1, rcdvin, rconde, rcnde1, rcdein, scale, scale1, result, work, lwork, iwork, info)
SGET23