diff --git a/TESTING/EIG/cdrgev.f b/TESTING/EIG/cdrgev.f index b9ff39dce..fe7a55da8 100644 --- a/TESTING/EIG/cdrgev.f +++ b/TESTING/EIG/cdrgev.f @@ -428,14 +428,18 @@ SUBROUTINE CDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS, $ NMATS, NMAX, NTESTT REAL SAFMAX, SAFMIN, ULP, ULPINV COMPLEX CTEMP + + real wtol, atst, btst, rtst + * .. * .. Local Arrays .. + complex EVAL(LDA), EVAL1(LDA) LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -484,6 +488,7 @@ SUBROUTINE CDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. * .. Executable Statements .. * + * Check for errors * INFO = 0 @@ -778,10 +783,51 @@ SUBROUTINE CDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take different path through code +* than eigenvalues only. IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. - $ BETA1( J ) )RESULT( 5 ) = ULPINV + $ BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical, examine +* differences more closely and compare to a tolerance. + IF( EVAL_5 ) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N +* Compute eigenvalues to extent possible + IF (BETA(J).NE.CZERO) THEN + EVAL(J) = ALPHA(J)/BETA(J) + ELSE + EVAL(J) = CMPLX(SAFMAX) + ENDIF + IF (BETA1(J).NE.CZERO) THEN + EVAL1(J) = ALPHA1(J)/BETA1(J) + ELSE + EVAL1(J) = CMPLX(SAFMAX) + ENDIF + 121 CONTINUE + + DO 122 J = 1, N +* Compare eigenvalues. + RTST = CABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE + CABS(EVAL(J)) ) + IF ( RTST .GT. WTOL) THEN +* Compare alphas and betas directly. Don't record an error +* if relative alpha/beta diffs are both small. + ATST = CABS(ALPHA(J)-ALPHA1(J))/ + $ (ONE + CABS(ALPHA(J)) ) + BTST = CABS(BETA(J)-BETA1(J))/ + $ (ONE + CABS(BETA(J)) ) + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN +* If error detected, set RESULT(5) as original code did + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/cdrgev3.f b/TESTING/EIG/cdrgev3.f index 07b7a1f96..282da5757 100644 --- a/TESTING/EIG/cdrgev3.f +++ b/TESTING/EIG/cdrgev3.f @@ -428,14 +428,17 @@ SUBROUTINE CDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS, $ NMATS, NMAX, NTESTT REAL SAFMAX, SAFMIN, ULP, ULPINV COMPLEX CTEMP + + real wtol, atst, btst, rtst * .. * .. Local Arrays .. + complex EVAL(LDA), EVAL1(LDA) LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -484,6 +487,7 @@ SUBROUTINE CDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. * .. Executable Statements .. * + * Check for errors * INFO = 0 @@ -786,10 +790,51 @@ SUBROUTINE CDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take a different path through code +* than eigenvalues only. IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. - $ BETA1( J ) ) RESULT( 5 ) = ULPINV + $ BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical, examine +* differences more closely and compare to a tolerance. + IF( EVAL_5 ) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N +* Compute eigenvalues to extent possible + IF (BETA(J).NE.CZERO) THEN + EVAL(J) = ALPHA(J)/BETA(J) + ELSE + EVAL(J) = CMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.CZERO) THEN + EVAL1(J) = ALPHA1(J)/BETA1(J) + ELSE + EVAL1(J) = CMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE + + DO 122 J = 1, N +* Compare eigenvalues + RTST = CABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE + CABS(EVAL(J)) ) + IF ( RTST .GT. WTOL) THEN +* Compare alphas and betas directly. Don't record +* an error if relative alpha/beta diffs are both small. + ATST = CABS(ALPHA(J)-ALPHA1(J))/ + $ (ONE + CABS(ALPHA(J)) ) + BTST = CABS(BETA(J)-BETA1(J))/ + $ (ONE + CABS(BETA(J)) ) +* If error detected, set RESULT(5) as original code did. + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do the test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/cdrvev.f b/TESTING/EIG/cdrvev.f index 6957f9911..46f39a045 100644 --- a/TESTING/EIG/cdrvev.f +++ b/TESTING/EIG/cdrvev.f @@ -422,13 +422,14 @@ SUBROUTINE CDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 21 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN,EVAL_5 CHARACTER*3 PATH INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE, $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, $ NNWORK, NTEST, NTESTF, NTESTT REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM, $ ULP, ULPINV, UNFL, VMX, VRMX, VTST + REAL TEMP, TEMPR, TEMPI, WTOL * .. * .. Local Arrays .. INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ), @@ -798,10 +799,23 @@ SUBROUTINE CDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do Test (5) * + EVAL_5 = .FALSE. DO 150 J = 1, N IF( W( J ).NE.W1( J ) ) - $ RESULT( 5 ) = ULPINV + $ EVAL_5 = .TRUE. 150 CONTINUE + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 300 J = 1, N + TEMP = (CABS(W(J)-W1(J))) / (1+CABS(W1(J))) + TEMPR = (ABS(REAL(W(J))-REAL(W1(J))))/(1+CABS(W1(J))) + TEMPI = (ABS(AIMAG(W(J))-AIMAG(W1(J))))/(1+CABS(W1(J))) + IF ( (TEMP.GT.WTOL).OR.(TEMPR.GT.WTOL).OR. + $ (TEMPI.GT.WTOL) ) THEN + RESULT( 5 ) = ULPINV + ENDIF + 300 CONTINUE + ENDIF * * Compute eigenvalues and right eigenvectors, and test them * diff --git a/TESTING/EIG/ddrgev.f b/TESTING/EIG/ddrgev.f index bafd8c2d2..5786082a7 100644 --- a/TESTING/EIG/ddrgev.f +++ b/TESTING/EIG/ddrgev.f @@ -434,13 +434,18 @@ SUBROUTINE DDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS, $ NMAX, NTESTT DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV + + double precision wtol, atst, btst, rtst + * .. * .. Local Arrays .. + complex*16 CALPHA(LDA), CALPH1(LDA) + complex*16 EVAL(LDA), EVAL1(LDA) INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -776,11 +781,53 @@ SUBROUTINE DDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take different path through +* code than eigenvalues only. IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. - $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 5 ) - $ = ULPINV + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical, +* examine differences more closely and compare to a tolerance. + IF( EVAL_5 ) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N + CALPHA(J) = DCMPLX( ALPHAR(J), ALPHAI(J) ) + CALPH1(J) = DCMPLX( ALPHR1(J), ALPHI1(J) ) +* Compute eigenvalues to extent possible + IF (BETA(J).NE.ZERO) THEN + EVAL(J) = CALPHA(J)/BETA(J) + ELSE + EVAL(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.ZERO) THEN + EVAL1(J) = CALPH1(J)/BETA1(J) + ELSE + EVAL1(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE +* + DO 122 J = 1,N +* Compare eigenvalues + RTST = CDABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE+CDABS(EVAL(J)) ) + IF ( RTST .GT. WTOL) THEN +* Compare alphas and betas directly. Don't record an error +* if relative alpha and beta diffs are both small. + ATST = CDABS(CALPHA(J)-CALPH1(J))/ + $ (ONE + CDABS(CALPHA(J)) ) + BTST = DABS(BETA(J)-BETA1(J))/ + $ (ONE + DABS(BETA(J)) ) +* If error detected, set RESULT(5) as original code did + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do the test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/ddrgev3.f b/TESTING/EIG/ddrgev3.f index ac6944634..7020fdfcc 100644 --- a/TESTING/EIG/ddrgev3.f +++ b/TESTING/EIG/ddrgev3.f @@ -434,13 +434,17 @@ SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 27 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS, $ NMAX, NTESTT DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV + + double precision wtol, atst, btst, rtst * .. * .. Local Arrays .. + complex*16 CALPHA(LDA), CALPH1(LDA) + complex*16 EVAL(LDA), EVAL1(LDA) INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -455,7 +459,7 @@ SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL ILAENV, DLAMCH, DLARND * .. * .. External Subroutines .. - EXTERNAL ALASVM, DGET52, DGGEV3, DLACPY, DLARFG, DLASET, + EXTERNAL ALASVM, DGET52, DGGEV3, DLACPY, DLARFG, DLASET $ DLATM4, DORM2R, XERBLA * .. * .. Intrinsic Functions .. @@ -484,6 +488,7 @@ SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 10*0 / * .. * .. Executable Statements .. + * * Check for errors * @@ -811,11 +816,53 @@ SUBROUTINE DDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take a different path through +* code than eigenvalues only IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. - $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 5 ) - $ = ULPINV + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical +* examine differences more closely and compare to a tolerance. + IF ( EVAL_5 ) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N + CALPHA(J) = DCMPLX( ALPHAR(J), ALPHAI(J) ) + CALPH1(J) = DCMPLX( ALPHR1(J), ALPHI1(J) ) +* Compute eigenvalues to extent possible + IF (BETA(J).NE.ZERO) THEN + EVAL(J) = CALPHA(J)/BETA(J) + ELSE + EVAL(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.ZERO) THEN + EVAL1(J) = CALPH1(J)/BETA1(J) + ELSE + EVAL1(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE + + DO 122 J = 1, N +* Compare eigenvalues + RTST = CDABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE + CDABS(EVAL(J)) ) + IF ( RTST .GT. WTOL) THEN +C compare alphas and betas directly. +C Don't record an error if relative alpha/beta diffs are both small. + ATST = CDABS(CALPHA(J)-CALPH1(J))/ + $ ( ONE + CDABS(CALPHA(J)) ) + BTST = DABS(BETA(J)-BETA1(J))/ + $ ( ONE + DABS(BETA(J)) ) +* If error, set RESULT(5) as original code did. + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do the test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/ddrvev.f b/TESTING/EIG/ddrvev.f index 402022a82..926b5f647 100644 --- a/TESTING/EIG/ddrvev.f +++ b/TESTING/EIG/ddrvev.f @@ -432,13 +432,14 @@ SUBROUTINE DDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 21 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 CHARACTER*3 PATH INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE, $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK, $ NTEST, NTESTF, NTESTT DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM, $ ULP, ULPINV, UNFL, VMX, VRMX, VTST + $ , TEMPR, TEMPI, WTOL * .. * .. Local Arrays .. CHARACTER ADUMMA( 1 ) @@ -826,10 +827,21 @@ SUBROUTINE DDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do Test (5) * + EVAL_5 = .FALSE. DO 150 J = 1, N IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) ) - $ RESULT( 5 ) = ULPINV + $ EVAL_5 = .TRUE. 150 CONTINUE + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 300 J = 1, N + TEMPR = (DABS(WR(J)-WR1(J))) / (1+DABS(WR1(J))) + TEMPI = (DABS(WI(J)-WI1(J))) / (1+DABS(WI1(J))) + IF ((TEMPR.GT.WTOL) .OR. (TEMPI.GT.WTOL) ) THEN + RESULT( 5 ) = ULPINV + ENDIF + 300 CONTINUE + ENDIF * * Compute eigenvalues and right eigenvectors, and test them * diff --git a/TESTING/EIG/dget23.f b/TESTING/EIG/dget23.f index 215166904..763e12951 100644 --- a/TESTING/EIG/dget23.f +++ b/TESTING/EIG/dget23.f @@ -407,13 +407,13 @@ SUBROUTINE DGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, PARAMETER ( EPSIN = 5.9605D-8 ) * .. * .. Local Scalars .. - LOGICAL BALOK, NOBAL + LOGICAL BALOK, NOBAL, EVAL_5 CHARACTER SENSE INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM, $ J, JJ, KMIN DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN, $ ULP, ULPINV, V, VIMIN, VMAX, VMX, VRMIN, VRMX, - $ VTST + $ VTST, TEMPR, TEMPI, WTOL * .. * .. Local Arrays .. CHARACTER SENS( 2 ) @@ -599,10 +599,21 @@ SUBROUTINE DGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, * * Do Test (5) * + EVAL_5 = .FALSE. DO 60 J = 1, N IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) ) - $ RESULT( 5 ) = ULPINV + $ EVAL_5 = .TRUE. 60 CONTINUE + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 300 J = 1, N + TEMPR = (DABS(WR(J)-WR1(J))) / (1+DABS(WR1(J))) + TEMPI = (DABS(WI(J)-WI1(J))) / (1+DABS(WI1(J))) + IF ( (TEMPR.GT.WTOL) .OR. (TEMPI.GT.WTOL) ) THEN + RESULT( 5 ) = ULPINV + ENDIF + 300 CONTINUE + ENDIF * * Do Test (8) * diff --git a/TESTING/EIG/sdrgev.f b/TESTING/EIG/sdrgev.f index db1c1b3e7..04fa6a702 100644 --- a/TESTING/EIG/sdrgev.f +++ b/TESTING/EIG/sdrgev.f @@ -423,6 +423,7 @@ SUBROUTINE SDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ BETA( * ), BETA1( * ), Q( LDQ, * ), $ QE( LDQE, * ), RESULT( * ), S( LDA, * ), $ T( LDA, * ), WORK( * ), Z( LDQ, * ) + * .. * * ===================================================================== @@ -434,13 +435,16 @@ SUBROUTINE SDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS, $ NMAX, NTESTT + REAL WTOL, ATST, BTST, RTST REAL SAFMAX, SAFMIN, ULP, ULPINV * .. * .. Local Arrays .. + COMPLEX CALPHA(LDA), CALPH1(LDA) + COMPLEX EVAL(LDA), EVAL1(LDA) INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -485,6 +489,7 @@ SUBROUTINE SDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. * .. Executable Statements .. * + * Check for errors * INFO = 0 @@ -776,11 +781,56 @@ SUBROUTINE SDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take different path through +* code than eigenvalues only. IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE. - $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) ) - $ RESULT( 5 ) = ULPINV + $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical +* examine differences more closely and compare to a tolerance. + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N + CALPHA(J) = CMPLX( ALPHAR(J), ALPHAI(J) ) + CALPH1(J) = CMPLX( ALPHR1(J), ALPHI1(J) ) +* Compute eigenvalues to extent possible + IF (BETA(J).NE.ZERO) THEN + EVAL(J) = CALPHA(J)/BETA(J) + ELSE + EVAL(J) = CMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.ZERO) THEN + EVAL1(J) = CALPH1(J)/BETA1(J) + ELSE + EVAL1(J) = CMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE +* + DO 122 J = 1,N +* Compare eigenvalues. + RTST = CABS( EVAL(J)-EVAL1(J) )/ + $ (ONE+CABS(EVAL(J)) ) + IF (RTST.GT.WTOL) THEN +* Compare alphas and betas directly. +* Don't record an error if relative alpha and beta +* differences are both small. + ATST = CABS(CALPHA(J)-CALPH1(J))/ + $ ( ONE + CABS(CALPHA(J)) ) + + BTST = ABS(BETA(J)-BETA1(J))/ + $ ( ONE + ABS(BETA(J)) ) + + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN +* If error detected, set RESULT(5) as original code did. + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do the test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/sdrgev3.f b/TESTING/EIG/sdrgev3.f index 9012c615a..6fb26d3a4 100644 --- a/TESTING/EIG/sdrgev3.f +++ b/TESTING/EIG/sdrgev3.f @@ -434,13 +434,16 @@ SUBROUTINE SDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS, $ NMAX, NTESTT REAL SAFMAX, SAFMIN, ULP, ULPINV + real wtol, atst, btst, rtst * .. * .. Local Arrays .. + complex CALPHA(LDA), CALPH1(LDA) + complex EVAL(LDA), EVAL1(LDA) INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ), $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -784,12 +787,54 @@ SUBROUTINE SDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take different path through +* code than eigenvalues only. IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. $ BETA( J ).NE. BETA1( J ) ) THEN - RESULT( 5 ) = ULPINV + EVAL_5 = .TRUE. END IF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical, examine +* differences more closely and compare to a tolerance. + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N + CALPHA(J) = CMPLX( ALPHAR(J), ALPHAI(J) ) + CALPH1(J) = CMPLX( ALPHR1(J), ALPHI1(J) ) +* compute eigenvalues to extent possible + IF (BETA(J).NE.ZERO) THEN + EVAL(J) = CALPHA(J)/BETA(J) + ELSE + EVAL(J) = CMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.ZERO) THEN + EVAL1(J) = CALPH1(J)/BETA1(J) + ELSE + EVAL1(J) = CMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE +* + DO 122 J = 1,N +* Compare eigenvalues + RTST = CABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE + CABS(EVAL(J)) ) + IF (RTST.GT.WTOL) THEN +* Compare alphas and betas directly. Don't record an +* error if relative alpha and beta diffs are both small. + ATST = CABS(CALPHA(J)-CALPH1(J))/ + $ ( ONE + CABS(CALPHA(J)) ) + BTST = ABS(BETA(J)-BETA1(J))/ + $ ( ONE + ABS(BETA(J)) ) + + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN +* If error, set RESULT(5) as original code did. + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do the test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/sdrvev.f b/TESTING/EIG/sdrvev.f index f6d233551..dfa9b0940 100644 --- a/TESTING/EIG/sdrvev.f +++ b/TESTING/EIG/sdrvev.f @@ -432,13 +432,14 @@ SUBROUTINE SDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 21 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 CHARACTER*3 PATH INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE, $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, $ NNWORK, NTEST, NTESTF, NTESTT REAL ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM, $ ULP, ULPINV, UNFL, VMX, VRMX, VTST + $ , TEMPR, TEMPI, WTOL * .. * .. Local Arrays .. CHARACTER ADUMMA( 1 ) @@ -826,10 +827,21 @@ SUBROUTINE SDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do Test (5) * + EVAL_5 = .FALSE. DO 150 J = 1, N IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) ) - $ RESULT( 5 ) = ULPINV + $ EVAL_5 = .TRUE. 150 CONTINUE + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 300 J = 1, N + TEMPR = (ABS(WR(J)-WR1(J))) / (1+ABS(WR1(J))) + TEMPI = (ABS(WI(J)-WI1(J))) / (1+ABS(WI1(J))) + IF ( (TEMPR.GT.WTOL) .OR. (TEMPI.GT.WTOL) ) THEN + RESULT( 5 ) = ULPINV + ENDIF + 300 CONTINUE + ENDIF * * Compute eigenvalues and right eigenvectors, and test them * diff --git a/TESTING/EIG/sget23.f b/TESTING/EIG/sget23.f index 827578181..f770191dc 100644 --- a/TESTING/EIG/sget23.f +++ b/TESTING/EIG/sget23.f @@ -407,13 +407,13 @@ SUBROUTINE SGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, PARAMETER ( EPSIN = 5.9605E-8 ) * .. * .. Local Scalars .. - LOGICAL BALOK, NOBAL + LOGICAL BALOK, NOBAL, EVAL_5 CHARACTER SENSE INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM, $ J, JJ, KMIN REAL ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN, $ ULP, ULPINV, V, VIMIN, VMAX, VMX, VRMIN, VRMX, - $ VTST + $ VTST, TEMPR, TEMPI, WTOL * .. * .. Local Arrays .. CHARACTER SENS( 2 ) @@ -599,10 +599,22 @@ SUBROUTINE SGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N, * * Do Test (5) * + EVAL_5 = .FALSE. DO 60 J = 1, N IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) ) - $ RESULT( 5 ) = ULPINV + $ EVAL_5 = .TRUE. 60 CONTINUE + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 300 J = 1, N + TEMPR = (ABS(WR(J)-WR1(J))) / (1+ABS(WR1(J))) + TEMPI = (ABS(WI(J)-WI1(J))) / (1+ABS(WI1(J))) + IF ((TEMPR.GT.WTOL) .OR. (TEMPI.GT.WTOL) ) THEN + RESULT( 5 ) = ULPINV + ENDIF + 300 CONTINUE + ENDIF + * * Do Test (8) * diff --git a/TESTING/EIG/zdrgev.f b/TESTING/EIG/zdrgev.f index 7adf9ba8f..48e6effb3 100644 --- a/TESTING/EIG/zdrgev.f +++ b/TESTING/EIG/zdrgev.f @@ -428,14 +428,16 @@ SUBROUTINE ZDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS, $ NMATS, NMAX, NTESTT DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV COMPLEX*16 CTEMP + double precision wtol, atst, btst, rtst * .. * .. Local Arrays .. + complex*16 eval(LDA),eval1(lda) LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -778,10 +780,51 @@ SUBROUTINE ZDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take different path through +* code than eigenvalues only. IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. - $ BETA1( J ) )RESULT( 5 ) = ULPINV + $ BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical, examine +* differences more closely and compare to a tolerance. + IF( EVAL_5 ) THEN + WTOL = THRESH*ULP + DO 121 J = 1, N +* Compute eigenvalues to extent possible + IF (BETA(J).NE.CZERO) THEN + EVAL(J) = ALPHA(J)/BETA(J) + ELSE + EVAL(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.CZERO) THEN + EVAL1(J) = ALPHA1(J)/BETA1(J) + ELSE + EVAL1(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE + + DO 122 J = 1, N +* Compare eigenvalues + RTST = CDABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE+ CDABS(EVAL(J)) ) + IF ( RTST .GT. WTOL) THEN +* Compare alphas and betas directly. Don't record an +* error if relative alpha and beta diffs are both small. + ATST = CDABS(ALPHA(J)-ALPHA1(J))/ + $ (ONE + CDABS(ALPHA(J)) ) + BTST = CDABS(BETA(J)-BETA1(J))/ + $ (ONE + CDABS(BETA(J)) ) + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN +* If error detected, set RESULT(5) as original code did. + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF * * Do test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/zdrgev3.f b/TESTING/EIG/zdrgev3.f index f44591319..ffdcda76c 100644 --- a/TESTING/EIG/zdrgev3.f +++ b/TESTING/EIG/zdrgev3.f @@ -428,14 +428,16 @@ SUBROUTINE ZDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 26 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE, $ MAXWRK, MINWRK, MTYPES, N, N1, NB, NERRS, $ NMATS, NMAX, NTESTT DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV COMPLEX*16 CTEMP + double precision wtol, atst, btst, rtst * .. * .. Local Arrays .. + complex*16 eval(LDA),eval1(lda) LOGICAL LASIGN( MAXTYP ), LBSIGN( MAXTYP ) INTEGER IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ), $ KATYPE( MAXTYP ), KAZERO( MAXTYP ), @@ -786,10 +788,52 @@ SUBROUTINE ZDRGEV3( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 190 END IF * + EVAL_5 = .FALSE. DO 120 J = 1, N +* eigenvalues+eigenvectors may take different path through code +* than eigenvalues only. IF( ALPHA( J ).NE.ALPHA1( J ) .OR. BETA( J ).NE. - $ BETA1( J ) )RESULT( 5 ) = ULPINV + $ BETA1( J ) ) THEN + EVAL_5 = .TRUE. + ENDIF 120 CONTINUE +* If alpha,alpaha1 or beta,beta1 were not identical, examine +* differences more closely and compare to a tolerance. + IF( EVAL_5 ) THEN + WTOL = ULP*THRESH + DO 121 J = 1, N +* Compute eigenvalues to extent possible + IF (BETA(J).NE.CZERO) THEN + EVAL(J) = ALPHA(J)/BETA(J) + ELSE + EVAL(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + IF (BETA1(J).NE.CZERO) THEN + EVAL1(J) = ALPHA1(J)/BETA1(J) + ELSE + EVAL1(J) = DCMPLX(SAFMAX,SAFMAX) + ENDIF + 121 CONTINUE +* + DO 122 J = 1, N +* Compare eigenvalues. + RTST = CDABS( EVAL(J)-EVAL1(J) )/ + $ ( ONE+ CDABS(EVAL(J)) ) + IF ( RTST .GT. WTOL) THEN +* Compare alphas and betas directly. Don't record an +* error if relative alpha/beta diffs are both small. + ATST = CDABS(ALPHA(J)-ALPHA1(J))/ + $ (ONE + CDABS(ALPHA(J)) ) + BTST = CDABS(BETA(J)-BETA1(J))/ + $ (ONE + CDABS(BETA(J)) ) +* If error detected, set RESULT(5) as original code did + IF(ATST.GT.WTOL .OR. BTST.GT.WTOL) THEN + RESULT( 5 ) = ULPINV + ENDIF + ENDIF + 122 CONTINUE + ENDIF + * * Do test (6): Compute eigenvalues and left eigenvectors, * and test them diff --git a/TESTING/EIG/zdrvev.f b/TESTING/EIG/zdrvev.f index ca410f437..c1b3f4ff8 100644 --- a/TESTING/EIG/zdrvev.f +++ b/TESTING/EIG/zdrvev.f @@ -422,13 +422,14 @@ SUBROUTINE ZDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, PARAMETER ( MAXTYP = 21 ) * .. * .. Local Scalars .. - LOGICAL BADNN + LOGICAL BADNN, EVAL_5 CHARACTER*3 PATH INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE, $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK, $ NTEST, NTESTF, NTESTT DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM, $ ULP, ULPINV, UNFL, VMX, VRMX, VTST + $ , TEMP, TEMPR, TEMPI, WTOL * .. * .. Local Arrays .. INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ), @@ -798,10 +799,23 @@ SUBROUTINE ZDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do Test (5) * + EVAL_5 = .FALSE. DO 150 J = 1, N IF( W( J ).NE.W1( J ) ) - $ RESULT( 5 ) = ULPINV + $ EVAL_5 = .TRUE. 150 CONTINUE + IF (EVAL_5) THEN + WTOL = THRESH*ULP + DO 300 J = 1, N + TEMP = (ZABS(W(J)-W1(J))) / (1+ZABS(W1(J))) + TEMPR = (DABS(DREAL(W(J))-DREAL(W1(J))))/(1+ZABS(W1(J))) + TEMPI = (DABS(DIMAG(W(J))-DIMAG(W1(J))))/(1+ZABS(W1(J))) + IF ( (TEMP.GT.WTOL).OR.(TEMPR.GT.WTOL).OR. + $ (TEMPI.GT.WTOL) ) THEN + RESULT( 5 ) = ULPINV + ENDIF + 300 CONTINUE + ENDIF * * Compute eigenvalues and right eigenvectors, and test them *