From 22d172188ce2c1cab440ea4568b5a061a46e557b Mon Sep 17 00:00:00 2001 From: Angelika Schwarz Date: Sun, 19 Jun 2022 22:51:43 +0100 Subject: [PATCH 1/3] Add missing numerical tests for TREVC3 At least some tests, though there are still code paths that are not covered * input sizes defined in nep.in are small * RWORK in [CZ]TREVC3 is de factor defined as N-vector from the input file and limits the blocked computation --- TESTING/EIG/cchkhs.f | 81 +++++++++++++++++++++++++++++++++++++++---- TESTING/EIG/dchkhs.f | 82 ++++++++++++++++++++++++++++++++++++++++---- TESTING/EIG/schkhs.f | 79 ++++++++++++++++++++++++++++++++++++++---- TESTING/EIG/zchkhs.f | 79 +++++++++++++++++++++++++++++++++++++++--- 4 files changed, 297 insertions(+), 24 deletions(-) diff --git a/TESTING/EIG/cchkhs.f b/TESTING/EIG/cchkhs.f index 65f1fc82d4..6c6430d5f8 100644 --- a/TESTING/EIG/cchkhs.f +++ b/TESTING/EIG/cchkhs.f @@ -21,7 +21,7 @@ * .. Array Arguments .. * LOGICAL DOTYPE( * ), SELECT( * ) * INTEGER ISEED( 4 ), IWORK( * ), NN( * ) -* REAL RESULT( 14 ), RWORK( * ) +* REAL RESULT( 16 ), RWORK( * ) * COMPLEX A( LDA, * ), EVECTL( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ), * $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), @@ -64,10 +64,15 @@ *> eigenvectors of H. Y is lower triangular, and X is *> upper triangular. *> +*> CTREVC3 computes left and right eigenvector matrices +*> from a Schur matrix T and backtransforms them with Z +*> to eigenvector matrices L and R for A. L and R are +*> GE matrices. +*> *> When CCHKHS is called, a number of matrix "sizes" ("n's") and a *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, one matrix will be generated and used -*> to test the nonsymmetric eigenroutines. For each matrix, 14 +*> to test the nonsymmetric eigenroutines. For each matrix, 16 *> tests will be performed: *> *> (1) | A - U H U**H | / ( |A| n ulp ) @@ -98,6 +103,10 @@ *> *> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> +*> (15) | AR - RW | / ( |A| |R| ulp ) +*> +*> (16) | LA - WL | / ( |A| |L| ulp ) +*> *> The "sizes" are specified by an array NN(1:NSIZES); the value of *> each element NN(j) specifies one size. *> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); @@ -331,7 +340,7 @@ *> Workspace. Could be equivalenced to IWORK, but not RWORK. *> Modified. *> -*> RESULT - REAL array, dimension (14) +*> RESULT - REAL array, dimension (16) *> The values computed by the fourteen tests described above. *> The values are currently limited to 1/ulp, to avoid *> overflow. @@ -421,7 +430,7 @@ SUBROUTINE CCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Array Arguments .. LOGICAL DOTYPE( * ), SELECT( * ) INTEGER ISEED( 4 ), IWORK( * ), NN( * ) - REAL RESULT( 14 ), RWORK( * ) + REAL RESULT( 16 ), RWORK( * ) COMPLEX A( LDA, * ), EVECTL( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ), $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), @@ -463,8 +472,8 @@ SUBROUTINE CCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. External Subroutines .. EXTERNAL CCOPY, CGEHRD, CGEMM, CGET10, CGET22, CHSEIN, $ CHSEQR, CHST01, CLACPY, CLASET, CLATME, CLATMR, - $ CLATMS, CTREVC, CUNGHR, CUNMHR, SLABAD, SLAFTS, - $ SLASUM, XERBLA + $ CLATMS, CTREVC, CTREVC3, CUNGHR, CUNMHR, + $ SLABAD, SLAFTS, SLASUM, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT @@ -1067,6 +1076,66 @@ SUBROUTINE CCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RESULT( 14 ) = DUMMA( 3 )*ANINV END IF * +* Compute Left and Right Eigenvectors of A +* +* Compute a Right eigenvector matrix: +* + NTEST = 15 + RESULT( 15 ) = ULPINV +* + CALL CLACPY( ' ', N, N, UZ, LDU, EVECTR, LDU ) +* + CALL CTREVC3( 'Right', 'Back', SELECT, N, T1, LDA, CDUMMA, + $ LDU, EVECTR, LDU, N, IN, WORK, NWORK, RWORK, + $ N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CTREVC3(R,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 15: | AR - RW | / ( |A| |R| ulp ) +* +* (from Schur decomposition) +* + CALL CGET22( 'N', 'N', 'N', N, A, LDA, EVECTR, LDU, W1, + $ WORK, RWORK, DUMMA( 1 ) ) + RESULT( 15 ) = DUMMA( 1 ) + IF( DUMMA( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'CTREVC3', + $ DUMMA( 2 ), N, JTYPE, IOLDSD + END IF +* +* Compute a Left eigenvector matrix: +* + NTEST = 16 + RESULT( 16 ) = ULPINV +* + CALL CLACPY( ' ', N, N, UZ, LDU, EVECTL, LDU ) +* + CALL CTREVC3( 'Left', 'Back', SELECT, N, T1, LDA, EVECTL, + $ LDU, CDUMMA, LDU, N, IN, WORK, NWORK, RWORK, + $ N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'CTREVC3(L,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 16: | LA - WL | / ( |A| |L| ulp ) +* +* (from Schur decomposition) +* + CALL CGET22( 'Conj', 'N', 'Conj', N, A, LDA, EVECTL, LDU, + $ W1, WORK, RWORK, DUMMA( 3 ) ) + RESULT( 16 ) = DUMMA( 3 ) + IF( DUMMA( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'CTREVC3', DUMMA( 4 ), + $ N, JTYPE, IOLDSD + END IF +* * End of Loop -- Check for RESULT(j) > THRESH * 240 CONTINUE diff --git a/TESTING/EIG/dchkhs.f b/TESTING/EIG/dchkhs.f index 2e57498965..79ba960086 100644 --- a/TESTING/EIG/dchkhs.f +++ b/TESTING/EIG/dchkhs.f @@ -23,7 +23,7 @@ * INTEGER ISEED( 4 ), IWORK( * ), NN( * ) * DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ), -* $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), +* $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ), * $ T1( LDA, * ), T2( LDA, * ), TAU( * ), * $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), * $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), @@ -49,15 +49,21 @@ *> T is "quasi-triangular", and the eigenvalue vector W. *> *> DTREVC computes the left and right eigenvector matrices -*> L and R for T. +*> L and R for T. L is lower quasi-triangular, and R is +*> upper quasi-triangular. *> *> DHSEIN computes the left and right eigenvector matrices *> Y and X for H, using inverse iteration. *> +*> DTREVC3 computes left and right eigenvector matrices +*> from a Schur matrix T and backtransforms them with Z +*> to eigenvector matrices L and R for A. L and R are +*> GE matrices. +*> *> When DCHKHS is called, a number of matrix "sizes" ("n's") and a *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, one matrix will be generated and used -*> to test the nonsymmetric eigenroutines. For each matrix, 14 +*> to test the nonsymmetric eigenroutines. For each matrix, 16 *> tests will be performed: *> *> (1) | A - U H U**T | / ( |A| n ulp ) @@ -88,6 +94,10 @@ *> *> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> +*> (15) | AR - RW | / ( |A| |R| ulp ) +*> +*> (16) | LA - WL | / ( |A| |L| ulp ) +*> *> The "sizes" are specified by an array NN(1:NSIZES); the value of *> each element NN(j) specifies one size. *> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); @@ -331,7 +341,7 @@ *> Workspace. *> Modified. *> -*> RESULT - DOUBLE PRECISION array, dimension (14) +*> RESULT - DOUBLE PRECISION array, dimension (16) *> The values computed by the fourteen tests described above. *> The values are currently limited to 1/ulp, to avoid *> overflow. @@ -423,7 +433,7 @@ SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, INTEGER ISEED( 4 ), IWORK( * ), NN( * ) DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ), - $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), + $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ), $ T1( LDA, * ), T2( LDA, * ), TAU( * ), $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), @@ -461,7 +471,7 @@ SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN, $ DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET, $ DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR, - $ DTREVC, XERBLA + $ DTREVC, DTREVC3, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT @@ -561,7 +571,7 @@ SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Initialize RESULT * - DO 30 J = 1, 14 + DO 30 J = 1, 16 RESULT( J ) = ZERO 30 CONTINUE * @@ -1108,6 +1118,64 @@ SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RESULT( 14 ) = DUMMA( 3 )*ANINV END IF * +* Compute Left and Right Eigenvectors of A +* +* Compute a Right eigenvector matrix: +* + NTEST = 15 + RESULT( 15 ) = ULPINV +* + CALL DLACPY( ' ', N, N, UZ, LDU, EVECTR, LDU ) +* + CALL DTREVC3( 'Right', 'Back', SELECT, N, T1, LDA, DUMMA, + $ LDU, EVECTR, LDU, N, IN, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DTREVC3(R,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 15: | AR - RW | / ( |A| |R| ulp ) +* +* (from Schur decomposition) +* + CALL DGET22( 'N', 'N', 'N', N, A, LDA, EVECTR, LDU, WR1, + $ WI1, WORK, DUMMA( 1 ) ) + RESULT( 15 ) = DUMMA( 1 ) + IF( DUMMA( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'DTREVC3', + $ DUMMA( 2 ), N, JTYPE, IOLDSD + END IF +* +* Compute a Left eigenvector matrix: +* + NTEST = 16 + RESULT( 16 ) = ULPINV +* + CALL DLACPY( ' ', N, N, UZ, LDU, EVECTL, LDU ) +* + CALL DTREVC3( 'Left', 'Back', SELECT, N, T1, LDA, EVECTL, + $ LDU, DUMMA, LDU, N, IN, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DTREVC3(L,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 16: | LA - WL | / ( |A| |L| ulp ) +* +* (from Schur decomposition) +* + CALL DGET22( 'Trans', 'N', 'Conj', N, A, LDA, EVECTL, LDU, + $ WR1, WI1, WORK, DUMMA( 3 ) ) + RESULT( 16 ) = DUMMA( 3 ) + IF( DUMMA( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'DTREVC3', DUMMA( 4 ), + $ N, JTYPE, IOLDSD + END IF +* * End of Loop -- Check for RESULT(j) > THRESH * 250 CONTINUE diff --git a/TESTING/EIG/schkhs.f b/TESTING/EIG/schkhs.f index ab0e901383..bf8eb1b409 100644 --- a/TESTING/EIG/schkhs.f +++ b/TESTING/EIG/schkhs.f @@ -23,7 +23,7 @@ * INTEGER ISEED( 4 ), IWORK( * ), NN( * ) * REAL A( LDA, * ), EVECTL( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ), -* $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), +* $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ), * $ T1( LDA, * ), T2( LDA, * ), TAU( * ), * $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), * $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), @@ -54,10 +54,15 @@ *> SHSEIN computes the left and right eigenvector matrices *> Y and X for H, using inverse iteration. *> +*> STREVC3 computes left and right eigenvector matrices +*> from a Schur matrix T and backtransforms them with Z +*> to eigenvector matrices L and R for A. L and R are +*> GE matrices. +*> *> When SCHKHS is called, a number of matrix "sizes" ("n's") and a *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, one matrix will be generated and used -*> to test the nonsymmetric eigenroutines. For each matrix, 14 +*> to test the nonsymmetric eigenroutines. For each matrix, 16 *> tests will be performed: *> *> (1) | A - U H U**T | / ( |A| n ulp ) @@ -88,6 +93,10 @@ *> *> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> +*> (15) | AR - RW | / ( |A| |R| ulp ) +*> +*> (16) | LA - WL | / ( |A| |L| ulp ) +*> *> The "sizes" are specified by an array NN(1:NSIZES); the value of *> each element NN(j) specifies one size. *> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); @@ -331,7 +340,7 @@ *> Workspace. *> Modified. *> -*> RESULT - REAL array, dimension (14) +*> RESULT - REAL array, dimension (16) *> The values computed by the fourteen tests described above. *> The values are currently limited to 1/ulp, to avoid *> overflow. @@ -423,7 +432,7 @@ SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, INTEGER ISEED( 4 ), IWORK( * ), NN( * ) REAL A( LDA, * ), EVECTL( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ), - $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), + $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ), $ T1( LDA, * ), T2( LDA, * ), TAU( * ), $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), @@ -461,7 +470,7 @@ SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN, $ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET, $ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR, - $ STREVC, XERBLA + $ STREVC, STREVC3, XERBLA * .. * .. Intrinsic Functions .. INTRINSIC ABS, MAX, MIN, REAL, SQRT @@ -561,7 +570,7 @@ SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Initialize RESULT * - DO 30 J = 1, 14 + DO 30 J = 1, 16 RESULT( J ) = ZERO 30 CONTINUE * @@ -1108,6 +1117,64 @@ SUBROUTINE SCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RESULT( 14 ) = DUMMA( 3 )*ANINV END IF * +* Compute Left and Right Eigenvectors of A +* +* Compute a Right eigenvector matrix: +* + NTEST = 15 + RESULT( 15 ) = ULPINV +* + CALL SLACPY( ' ', N, N, UZ, LDU, EVECTR, LDU ) +* + CALL STREVC3( 'Right', 'Back', SELECT, N, T1, LDA, DUMMA, + $ LDU, EVECTR, LDU, N, IN, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'STREVC3(R,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 15: | AR - RW | / ( |A| |R| ulp ) +* +* (from Schur decomposition) +* + CALL SGET22( 'N', 'N', 'N', N, A, LDA, EVECTR, LDU, WR1, + $ WI1, WORK, DUMMA( 1 ) ) + RESULT( 15 ) = DUMMA( 1 ) + IF( DUMMA( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'STREVC3', + $ DUMMA( 2 ), N, JTYPE, IOLDSD + END IF +* +* Compute a Left eigenvector matrix: +* + NTEST = 16 + RESULT( 16 ) = ULPINV +* + CALL SLACPY( ' ', N, N, UZ, LDU, EVECTL, LDU ) +* + CALL STREVC3( 'Left', 'Back', SELECT, N, T1, LDA, EVECTL, + $ LDU, DUMMA, LDU, N, IN, WORK, NWORK, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'STREVC3(L,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 16: | LA - WL | / ( |A| |L| ulp ) +* +* (from Schur decomposition) +* + CALL SGET22( 'Trans', 'N', 'Conj', N, A, LDA, EVECTL, LDU, + $ WR1, WI1, WORK, DUMMA( 3 ) ) + RESULT( 16 ) = DUMMA( 3 ) + IF( DUMMA( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'STREVC3', DUMMA( 4 ), + $ N, JTYPE, IOLDSD + END IF +* * End of Loop -- Check for RESULT(j) > THRESH * 250 CONTINUE diff --git a/TESTING/EIG/zchkhs.f b/TESTING/EIG/zchkhs.f index 52962a0414..f5ae9b7f3c 100644 --- a/TESTING/EIG/zchkhs.f +++ b/TESTING/EIG/zchkhs.f @@ -21,7 +21,7 @@ * .. Array Arguments .. * LOGICAL DOTYPE( * ), SELECT( * ) * INTEGER ISEED( 4 ), IWORK( * ), NN( * ) -* DOUBLE PRECISION RESULT( 14 ), RWORK( * ) +* DOUBLE PRECISION RESULT( 16 ), RWORK( * ) * COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ), * $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), @@ -64,10 +64,15 @@ *> eigenvectors of H. Y is lower triangular, and X is *> upper triangular. *> +*> ZTREVC3 computes left and right eigenvector matrices +*> from a Schur matrix T and backtransforms them with Z +*> to eigenvector matrices L and R for A. L and R are +*> GE matrices. +*> *> When ZCHKHS is called, a number of matrix "sizes" ("n's") and a *> number of matrix "types" are specified. For each size ("n") *> and each type of matrix, one matrix will be generated and used -*> to test the nonsymmetric eigenroutines. For each matrix, 14 +*> to test the nonsymmetric eigenroutines. For each matrix, 16 *> tests will be performed: *> *> (1) | A - U H U**H | / ( |A| n ulp ) @@ -98,6 +103,10 @@ *> *> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> +*> (15) | AR - RW | / ( |A| |R| ulp ) +*> +*> (16) | LA - WL | / ( |A| |L| ulp ) +*> *> The "sizes" are specified by an array NN(1:NSIZES); the value of *> each element NN(j) specifies one size. *> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); @@ -331,7 +340,7 @@ *> Workspace. Could be equivalenced to IWORK, but not RWORK. *> Modified. *> -*> RESULT - DOUBLE PRECISION array, dimension (14) +*> RESULT - DOUBLE PRECISION array, dimension (16) *> The values computed by the fourteen tests described above. *> The values are currently limited to 1/ulp, to avoid *> overflow. @@ -421,7 +430,7 @@ SUBROUTINE ZCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Array Arguments .. LOGICAL DOTYPE( * ), SELECT( * ) INTEGER ISEED( 4 ), IWORK( * ), NN( * ) - DOUBLE PRECISION RESULT( 14 ), RWORK( * ) + DOUBLE PRECISION RESULT( 16 ), RWORK( * ) COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ), $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), @@ -464,7 +473,7 @@ SUBROUTINE ZCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, EXTERNAL DLABAD, DLAFTS, DLASUM, XERBLA, ZCOPY, ZGEHRD, $ ZGEMM, ZGET10, ZGET22, ZHSEIN, ZHSEQR, ZHST01, $ ZLACPY, ZLASET, ZLATME, ZLATMR, ZLATMS, ZTREVC, - $ ZUNGHR, ZUNMHR + $ ZTREVC3, ZUNGHR, ZUNMHR * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, MAX, MIN, SQRT @@ -1067,6 +1076,66 @@ SUBROUTINE ZCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ RESULT( 14 ) = DUMMA( 3 )*ANINV END IF * +* Compute Left and Right Eigenvectors of A +* +* Compute a Right eigenvector matrix: +* + NTEST = 15 + RESULT( 15 ) = ULPINV +* + CALL ZLACPY( ' ', N, N, UZ, LDU, EVECTR, LDU ) +* + CALL ZTREVC3( 'Right', 'Back', SELECT, N, T1, LDA, CDUMMA, + $ LDU, EVECTR, LDU, N, IN, WORK, NWORK, RWORK, + $ N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZTREVC3(R,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 15: | AR - RW | / ( |A| |R| ulp ) +* +* (from Schur decomposition) +* + CALL ZGET22( 'N', 'N', 'N', N, A, LDA, EVECTR, LDU, W1, + $ WORK, RWORK, DUMMA( 1 ) ) + RESULT( 15 ) = DUMMA( 1 ) + IF( DUMMA( 2 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Right', 'ZTREVC3', + $ DUMMA( 2 ), N, JTYPE, IOLDSD + END IF +* +* Compute a Left eigenvector matrix: +* + NTEST = 16 + RESULT( 16 ) = ULPINV +* + CALL ZLACPY( ' ', N, N, UZ, LDU, EVECTL, LDU ) +* + CALL ZTREVC3( 'Left', 'Back', SELECT, N, T1, LDA, EVECTL, + $ LDU, CDUMMA, LDU, N, IN, WORK, NWORK, RWORK, + $ N, IINFO ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'ZTREVC3(L,B)', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + GO TO 250 + END IF +* +* Test 16: | LA - WL | / ( |A| |L| ulp ) +* +* (from Schur decomposition) +* + CALL ZGET22( 'Conj', 'N', 'Conj', N, A, LDA, EVECTL, LDU, + $ W1, WORK, RWORK, DUMMA( 3 ) ) + RESULT( 16 ) = DUMMA( 3 ) + IF( DUMMA( 4 ).GT.THRESH ) THEN + WRITE( NOUNIT, FMT = 9998 )'Left', 'ZTREVC3', DUMMA( 4 ), + $ N, JTYPE, IOLDSD + END IF +* * End of Loop -- Check for RESULT(j) > THRESH * 240 CONTINUE From 9f9295f5729931a00dc5c3b93da3c8541584ab82 Mon Sep 17 00:00:00 2001 From: Angelika Schwarz Date: Sun, 3 Jul 2022 20:40:54 +0100 Subject: [PATCH 2/3] standardize style in laqr5 --- SRC/claqr5.f | 25 ++++++++++++++----------- SRC/dlaqr5.f | 23 ++++++++++++++--------- SRC/slaqr5.f | 23 ++++++++++++++--------- SRC/zlaqr5.f | 25 ++++++++++++++----------- 4 files changed, 56 insertions(+), 40 deletions(-) diff --git a/SRC/claqr5.f b/SRC/claqr5.f index 0a01cc2265..4e6f43a73d 100644 --- a/SRC/claqr5.f +++ b/SRC/claqr5.f @@ -533,11 +533,13 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, * . Mth bulge. Exploit fact that first two elements * . of row are actually zero. ==== * - REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) - H( K+3, K ) = -REFSUM - H( K+3, K+1 ) = -REFSUM*CONJG( V( 2, M ) ) - H( K+3, K+2 ) = H( K+3, K+2 ) - - $ REFSUM*CONJG( V( 3, M ) ) + T1 = V( 1, M ) + T2 = T1*CONJG( V( 2, M ) ) + T3 = T1*CONJG( V( 3, M ) ) + REFSUM = V( 3, M )*H( K+3, K+2 ) + H( K+3, K ) = -REFSUM*T1 + H( K+3, K+1 ) = -REFSUM*T2 + H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3 * * ==== Calculate reflection to move * . Mth bulge one step. ==== @@ -572,12 +574,13 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, $ S( 2*M ), VT ) ALPHA = VT( 1 ) CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = CONJG( VT( 1 ) )* - $ ( H( K+1, K )+CONJG( VT( 2 ) )* - $ H( K+2, K ) ) + T1 = CONJG( VT( 1 ) ) + T2 = T1*VT( 2 ) + T3 = T1*VT( 3 ) + REFSUM = H( K+1, K )+CONJG( VT( 2 ) )*H( K+2, K ) * - IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ - $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* + IF( CABS1( H( K+2, K )-REFSUM*T2 )+ + $ CABS1( REFSUM*T3 ).GT.ULP* $ ( CABS1( H( K, K ) )+CABS1( H( K+1, $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN * @@ -595,7 +598,7 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, * . Replace the old reflector with * . the new one. ==== * - H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM*T1 H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) diff --git a/SRC/dlaqr5.f b/SRC/dlaqr5.f index 43b4ac72a3..cc94b12223 100644 --- a/SRC/dlaqr5.f +++ b/SRC/dlaqr5.f @@ -558,10 +558,13 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * . Mth bulge. Exploit fact that first two elements * . of row are actually zero. ==== * - REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) - H( K+3, K ) = -REFSUM - H( K+3, K+1 ) = -REFSUM*V( 2, M ) - H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*V( 3, M ) + T1 = V( 1, M ) + T2 = T1*V( 2, M ) + T3 = T1*V( 3, M ) + REFSUM = V( 3, M )*H( K+3, K+2 ) + H( K+3, K ) = -REFSUM*T1 + H( K+3, K+1 ) = -REFSUM*T2 + H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3 * * ==== Calculate reflection to move * . Mth bulge one step. ==== @@ -597,11 +600,13 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, $ VT ) ALPHA = VT( 1 ) CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* - $ H( K+2, K ) ) + T1 = VT( 1 ) + T2 = T1*VT( 2 ) + T3 = T1*VT( 3 ) + REFSUM = H( K+1, K ) + VT( 2 )*H( K+2, K ) * - IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ - $ ABS( REFSUM*VT( 3 ) ).GT.ULP* + IF( ABS( H( K+2, K )-REFSUM*T2 )+ + $ ABS( REFSUM*T3 ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * @@ -619,7 +624,7 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * . Replace the old reflector with * . the new one. ==== * - H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM*T1 H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) diff --git a/SRC/slaqr5.f b/SRC/slaqr5.f index a4f805674d..b10e597542 100644 --- a/SRC/slaqr5.f +++ b/SRC/slaqr5.f @@ -558,10 +558,13 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * . Mth bulge. Exploit fact that first two elements * . of row are actually zero. ==== * - REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) - H( K+3, K ) = -REFSUM - H( K+3, K+1 ) = -REFSUM*V( 2, M ) - H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*V( 3, M ) + T1 = V( 1, M ) + T2 = T1*V( 2, M ) + T3 = T1*V( 3, M ) + REFSUM = V( 3, M )*H( K+3, K+2 ) + H( K+3, K ) = -REFSUM*T1 + H( K+3, K+1 ) = -REFSUM*T2 + H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3 * * ==== Calculate reflection to move * . Mth bulge one step. ==== @@ -597,11 +600,13 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, $ VT ) ALPHA = VT( 1 ) CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* - $ H( K+2, K ) ) + T1 = VT( 1 ) + T2 = T1*VT( 2 ) + T3 = T2*VT( 3 ) + REFSUM = H( K+1, K )+VT( 2 )*H( K+2, K ) * - IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+ - $ ABS( REFSUM*VT( 3 ) ).GT.ULP* + IF( ABS( H( K+2, K )-REFSUM*T2 )+ + $ ABS( REFSUM*T3 ).GT.ULP* $ ( ABS( H( K, K ) )+ABS( H( K+1, $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN * @@ -619,7 +624,7 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, * . Replace the old reflector with * . the new one. ==== * - H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM*T1 H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) diff --git a/SRC/zlaqr5.f b/SRC/zlaqr5.f index 4fa5ee5b06..d8c521349e 100644 --- a/SRC/zlaqr5.f +++ b/SRC/zlaqr5.f @@ -533,11 +533,13 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, * . Mth bulge. Exploit fact that first two elements * . of row are actually zero. ==== * - REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) - H( K+3, K ) = -REFSUM - H( K+3, K+1 ) = -REFSUM*DCONJG( V( 2, M ) ) - H( K+3, K+2 ) = H( K+3, K+2 ) - - $ REFSUM*DCONJG( V( 3, M ) ) + T1 = V( 1, M ) + T2 = T1*DCONJG( V( 2, M ) ) + T3 = T1*DCONJG( V( 3, M ) ) + REFSUM = V( 3, M )*H( K+3, K+2 ) + H( K+3, K ) = -REFSUM*T1 + H( K+3, K+1 ) = -REFSUM*T2 + H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3 * * ==== Calculate reflection to move * . Mth bulge one step. ==== @@ -572,12 +574,13 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, $ S( 2*M ), VT ) ALPHA = VT( 1 ) CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) - REFSUM = DCONJG( VT( 1 ) )* - $ ( H( K+1, K )+DCONJG( VT( 2 ) )* - $ H( K+2, K ) ) + T1 = DCONJG( VT( 1 ) ) + T2 = T1*VT( 2 ) + T3 = T1*VT( 3 ) + REFSUM = H( K+1, K )+DCONJG( VT( 2 ) )*H( K+2, K ) * - IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+ - $ CABS1( REFSUM*VT( 3 ) ).GT.ULP* + IF( CABS1( H( K+2, K )-REFSUM*T2 )+ + $ CABS1( REFSUM*T3 ).GT.ULP* $ ( CABS1( H( K, K ) )+CABS1( H( K+1, $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN * @@ -595,7 +598,7 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S, * . Replace the old reflector with * . the new one. ==== * - H( K+1, K ) = H( K+1, K ) - REFSUM + H( K+1, K ) = H( K+1, K ) - REFSUM*T1 H( K+2, K ) = ZERO H( K+3, K ) = ZERO V( 1, M ) = VT( 1 ) From 0a6cd431891bbb9cef57e461e023ac7f0c9e5d8e Mon Sep 17 00:00:00 2001 From: Angelika Schwarz Date: Tue, 5 Jul 2022 19:34:23 +0100 Subject: [PATCH 3/3] Rewrite [ds]hgeqz to use FMA with Householder reflectors --- SRC/dhgeqz.f | 70 +++++++++++++++++++++++++++------------------------- SRC/shgeqz.f | 70 +++++++++++++++++++++++++++------------------------- 2 files changed, 74 insertions(+), 66 deletions(-) diff --git a/SRC/dhgeqz.f b/SRC/dhgeqz.f index 3fe2a083c8..5f69563eeb 100644 --- a/SRC/dhgeqz.f +++ b/SRC/dhgeqz.f @@ -337,9 +337,9 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, - $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, - $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, - $ WR2 + $ T2, T3, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, + $ U12, U12L, U2, ULP, VS, W11, W12, W21, W22, + $ WABS, WI, WR, WR2 * .. * .. Local Arrays .. DOUBLE PRECISION V( 3 ) @@ -1132,25 +1132,27 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, H( J+2, J-1 ) = ZERO END IF * + T2 = TAU*V( 2 ) + T3 = TAU*V( 3 ) DO 230 JC = J, ILASTM - TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* - $ H( J+2, JC ) ) - H( J, JC ) = H( J, JC ) - TEMP - H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) - H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* - $ T( J+2, JC ) ) - T( J, JC ) = T( J, JC ) - TEMP2 - T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) - T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) + TEMP = H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) + H( J, JC ) = H( J, JC ) - TEMP*TAU + H( J+1, JC ) = H( J+1, JC ) - TEMP*T2 + H( J+2, JC ) = H( J+2, JC ) - TEMP*T3 + TEMP2 = T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) + T( J, JC ) = T( J, JC ) - TEMP2*TAU + T( J+1, JC ) = T( J+1, JC ) - TEMP2*T2 + T( J+2, JC ) = T( J+2, JC ) - TEMP2*T3 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N - TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* - $ Q( JR, J+2 ) ) - Q( JR, J ) = Q( JR, J ) - TEMP - Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) - Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) + TEMP = Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* + $ Q( JR, J+2 ) + Q( JR, J ) = Q( JR, J ) - TEMP*TAU + Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*T2 + Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*T3 240 CONTINUE END IF * @@ -1238,27 +1240,29 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * * Apply transformations from the right. * + T2 = TAU*V(2) + T3 = TAU*V(3) DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* - $ H( JR, J+2 ) ) - H( JR, J ) = H( JR, J ) - TEMP - H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) - H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) + TEMP = H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) + H( JR, J ) = H( JR, J ) - TEMP*TAU + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*T2 + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*T3 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* - $ T( JR, J+2 ) ) - T( JR, J ) = T( JR, J ) - TEMP - T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) - T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) + TEMP = T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) + T( JR, J ) = T( JR, J ) - TEMP*TAU + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*T2 + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*T3 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N - TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* - $ Z( JR, J+2 ) ) - Z( JR, J ) = Z( JR, J ) - TEMP - Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) - Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) + TEMP = Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* + $ Z( JR, J+2 ) + Z( JR, J ) = Z( JR, J ) - TEMP*TAU + Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*T2 + Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*T3 280 CONTINUE END IF T( J+1, J ) = ZERO diff --git a/SRC/shgeqz.f b/SRC/shgeqz.f index 79a9c60925..635bb8b20c 100644 --- a/SRC/shgeqz.f +++ b/SRC/shgeqz.f @@ -337,9 +337,9 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, - $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, - $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, - $ WR2 + $ T2, T3, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, + $ U12, U12L, U2, ULP, VS, W11, W12, W21, W22, + $ WABS, WI, WR, WR2 * .. * .. Local Arrays .. REAL V( 3 ) @@ -1132,25 +1132,27 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, H( J+2, J-1 ) = ZERO END IF * + T2 = TAU * V( 2 ) + T3 = TAU * V( 3 ) DO 230 JC = J, ILASTM - TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* - $ H( J+2, JC ) ) - H( J, JC ) = H( J, JC ) - TEMP - H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) - H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) - TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* - $ T( J+2, JC ) ) - T( J, JC ) = T( J, JC ) - TEMP2 - T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) - T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) + TEMP = H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* + $ H( J+2, JC ) + H( J, JC ) = H( J, JC ) - TEMP*TAU + H( J+1, JC ) = H( J+1, JC ) - TEMP*T2 + H( J+2, JC ) = H( J+2, JC ) - TEMP*T3 + TEMP2 = T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* + $ T( J+2, JC ) + T( J, JC ) = T( J, JC ) - TEMP2*TAU + T( J+1, JC ) = T( J+1, JC ) - TEMP2*T2 + T( J+2, JC ) = T( J+2, JC ) - TEMP2*T3 230 CONTINUE IF( ILQ ) THEN DO 240 JR = 1, N - TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* - $ Q( JR, J+2 ) ) - Q( JR, J ) = Q( JR, J ) - TEMP - Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) - Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) + TEMP = Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* + $ Q( JR, J+2 ) + Q( JR, J ) = Q( JR, J ) - TEMP*TAU + Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*T2 + Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*T3 240 CONTINUE END IF * @@ -1238,27 +1240,29 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT, * * Apply transformations from the right. * + T2 = TAU*V( 2 ) + T3 = TAU*V( 3 ) DO 260 JR = IFRSTM, MIN( J+3, ILAST ) - TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* - $ H( JR, J+2 ) ) - H( JR, J ) = H( JR, J ) - TEMP - H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) - H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) + TEMP = H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* + $ H( JR, J+2 ) + H( JR, J ) = H( JR, J ) - TEMP*TAU + H( JR, J+1 ) = H( JR, J+1 ) - TEMP*T2 + H( JR, J+2 ) = H( JR, J+2 ) - TEMP*T3 260 CONTINUE DO 270 JR = IFRSTM, J + 2 - TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* - $ T( JR, J+2 ) ) - T( JR, J ) = T( JR, J ) - TEMP - T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) - T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) + TEMP = T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* + $ T( JR, J+2 ) + T( JR, J ) = T( JR, J ) - TEMP*TAU + T( JR, J+1 ) = T( JR, J+1 ) - TEMP*T2 + T( JR, J+2 ) = T( JR, J+2 ) - TEMP*T3 270 CONTINUE IF( ILZ ) THEN DO 280 JR = 1, N - TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* - $ Z( JR, J+2 ) ) - Z( JR, J ) = Z( JR, J ) - TEMP - Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) - Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) + TEMP = Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* + $ Z( JR, J+2 ) + Z( JR, J ) = Z( JR, J ) - TEMP*TAU + Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*T2 + Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*T3 280 CONTINUE END IF T( J+1, J ) = ZERO