floraachy
/
OpenBLAS
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge pull request #3946 from martin-frbg/lapack682 

Rewrite ?LAQR5 and S/DHGEQZ , add tests for TRECV3 (Reference-LAPACK PR 682)
This commit is contained in:
Martin Kroeker 2023-03-20 13:48:57 +01:00 committed by GitHub
parent f7b9391119 147e2fbf87
commit 7719dbecde
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 427 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
lapack-netlib/SRC/claqr5.f
View File

@ -533,11 +533,13 @@
* . Mth bulge. Exploit fact that first two elements * . Mth bulge. Exploit fact that first two elements
* . of row are actually zero. ==== * . of row are actually zero. ====
* *
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) T1 = V( 1, M )
H( K+3, K ) = -REFSUM T2 = T1*CONJG( V( 2, M ) )
H( K+3, K+1 ) = -REFSUM*CONJG( V( 2, M ) ) T3 = T1*CONJG( V( 3, M ) )
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM = V( 3, M )*H( K+3, K+2 )
$ REFSUM*CONJG( V( 3, M ) ) 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 * ==== Calculate reflection to move
* . Mth bulge one step. ==== * . Mth bulge one step. ====
@ -572,12 +574,13 @@
$ S( 2*M ), VT ) $ S( 2*M ), VT )
ALPHA = VT( 1 ) ALPHA = VT( 1 )
CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = CONJG( VT( 1 ) )* T1 = CONJG( VT( 1 ) )
$ ( H( K+1, K )+CONJG( VT( 2 ) )* T2 = T1*VT( 2 )
$ H( K+2, K ) ) 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 ) )+ IF( CABS1( H( K+2, K )-REFSUM*T2 )+
$ CABS1( REFSUM*VT( 3 ) ).GT.ULP* $ CABS1( REFSUM*T3 ).GT.ULP*
$ ( CABS1( H( K, K ) )+CABS1( H( K+1, $ ( CABS1( H( K, K ) )+CABS1( H( K+1,
$ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
* *
@ -595,7 +598,7 @@
* . Replace the old reflector with * . Replace the old reflector with
* . the new one. ==== * . 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+2, K ) = ZERO
H( K+3, K ) = ZERO H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 ) V( 1, M ) = VT( 1 )

70
lapack-netlib/SRC/dhgeqz.f
View File

@ -337,9 +337,9 @@
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
$ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
$ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
$ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ T2, T3, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
$ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
$ WR2 $ WABS, WI, WR, WR2
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
DOUBLE PRECISION V( 3 ) DOUBLE PRECISION V( 3 )
@ -1127,25 +1127,27 @@
H( J+2, J-1 ) = ZERO H( J+2, J-1 ) = ZERO
END IF END IF
* *
T2 = TAU*V( 2 )
T3 = TAU*V( 3 )
DO 230 JC = J, ILASTM DO 230 JC = J, ILASTM
TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* TEMP = H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
$ H( J+2, JC ) ) $ H( J+2, JC )
H( J, JC ) = H( J, JC ) - TEMP H( J, JC ) = H( J, JC ) - TEMP*TAU
H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) H( J+1, JC ) = H( J+1, JC ) - TEMP*T2
H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) H( J+2, JC ) = H( J+2, JC ) - TEMP*T3
TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* TEMP2 = T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
$ T( J+2, JC ) ) $ T( J+2, JC )
T( J, JC ) = T( J, JC ) - TEMP2 T( J, JC ) = T( J, JC ) - TEMP2*TAU
T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) T( J+1, JC ) = T( J+1, JC ) - TEMP2*T2
T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) T( J+2, JC ) = T( J+2, JC ) - TEMP2*T3
230 CONTINUE 230 CONTINUE
IF( ILQ ) THEN IF( ILQ ) THEN
DO 240 JR = 1, N DO 240 JR = 1, N
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* TEMP = Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
$ Q( JR, J+2 ) ) $ Q( JR, J+2 )
Q( JR, J ) = Q( JR, J ) - TEMP Q( JR, J ) = Q( JR, J ) - TEMP*TAU
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*T2
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*T3
240 CONTINUE 240 CONTINUE
END IF END IF
* *
@ -1233,27 +1235,29 @@
* *
* Apply transformations from the right. * Apply transformations from the right.
* *
T2 = TAU*V(2)
T3 = TAU*V(3)
DO 260 JR = IFRSTM, MIN( J+3, ILAST ) DO 260 JR = IFRSTM, MIN( J+3, ILAST )
TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* TEMP = H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
$ H( JR, J+2 ) ) $ H( JR, J+2 )
H( JR, J ) = H( JR, J ) - TEMP H( JR, J ) = H( JR, J ) - TEMP*TAU
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) H( JR, J+1 ) = H( JR, J+1 ) - TEMP*T2
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) H( JR, J+2 ) = H( JR, J+2 ) - TEMP*T3
260 CONTINUE 260 CONTINUE
DO 270 JR = IFRSTM, J + 2 DO 270 JR = IFRSTM, J + 2
TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* TEMP = T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
$ T( JR, J+2 ) ) $ T( JR, J+2 )
T( JR, J ) = T( JR, J ) - TEMP T( JR, J ) = T( JR, J ) - TEMP*TAU
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) T( JR, J+1 ) = T( JR, J+1 ) - TEMP*T2
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) T( JR, J+2 ) = T( JR, J+2 ) - TEMP*T3
270 CONTINUE 270 CONTINUE
IF( ILZ ) THEN IF( ILZ ) THEN
DO 280 JR = 1, N DO 280 JR = 1, N
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* TEMP = Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
$ Z( JR, J+2 ) ) $ Z( JR, J+2 )
Z( JR, J ) = Z( JR, J ) - TEMP Z( JR, J ) = Z( JR, J ) - TEMP*TAU
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*T2
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*T3
280 CONTINUE 280 CONTINUE
END IF END IF
T( J+1, J ) = ZERO T( J+1, J ) = ZERO

23
lapack-netlib/SRC/dlaqr5.f
View File

@ -558,10 +558,13 @@
* . Mth bulge. Exploit fact that first two elements * . Mth bulge. Exploit fact that first two elements
* . of row are actually zero. ==== * . of row are actually zero. ====
* *
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) T1 = V( 1, M )
H( K+3, K ) = -REFSUM T2 = T1*V( 2, M )
H( K+3, K+1 ) = -REFSUM*V( 2, M ) T3 = T1*V( 3, M )
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*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 * ==== Calculate reflection to move
* . Mth bulge one step. ==== * . Mth bulge one step. ====
@ -597,11 +600,13 @@
$ VT ) $ VT )
ALPHA = VT( 1 ) ALPHA = VT( 1 )
CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* T1 = VT( 1 )
$ H( K+2, K ) ) 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 ) )+ IF( ABS( H( K+2, K )-REFSUM*T2 )+
$ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ABS( REFSUM*T3 ).GT.ULP*
$ ( ABS( H( K, K ) )+ABS( H( K+1, $ ( ABS( H( K, K ) )+ABS( H( K+1,
$ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
* *
@ -619,7 +624,7 @@
* . Replace the old reflector with * . Replace the old reflector with
* . the new one. ==== * . 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+2, K ) = ZERO
H( K+3, K ) = ZERO H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 ) V( 1, M ) = VT( 1 )

70
lapack-netlib/SRC/shgeqz.f
View File

@ -337,9 +337,9 @@
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL, $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
$ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX, $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
$ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1, $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
$ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L, $ T2, T3, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
$ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR, $ U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
$ WR2 $ WABS, WI, WR, WR2
* .. * ..
* .. Local Arrays .. * .. Local Arrays ..
REAL V( 3 ) REAL V( 3 )
@ -1127,25 +1127,27 @@
H( J+2, J-1 ) = ZERO H( J+2, J-1 ) = ZERO
END IF END IF
* *
T2 = TAU * V( 2 )
T3 = TAU * V( 3 )
DO 230 JC = J, ILASTM DO 230 JC = J, ILASTM
TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )* TEMP = H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
$ H( J+2, JC ) ) $ H( J+2, JC )
H( J, JC ) = H( J, JC ) - TEMP H( J, JC ) = H( J, JC ) - TEMP*TAU
H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 ) H( J+1, JC ) = H( J+1, JC ) - TEMP*T2
H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 ) H( J+2, JC ) = H( J+2, JC ) - TEMP*T3
TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )* TEMP2 = T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
$ T( J+2, JC ) ) $ T( J+2, JC )
T( J, JC ) = T( J, JC ) - TEMP2 T( J, JC ) = T( J, JC ) - TEMP2*TAU
T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 ) T( J+1, JC ) = T( J+1, JC ) - TEMP2*T2
T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 ) T( J+2, JC ) = T( J+2, JC ) - TEMP2*T3
230 CONTINUE 230 CONTINUE
IF( ILQ ) THEN IF( ILQ ) THEN
DO 240 JR = 1, N DO 240 JR = 1, N
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )* TEMP = Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
$ Q( JR, J+2 ) ) $ Q( JR, J+2 )
Q( JR, J ) = Q( JR, J ) - TEMP Q( JR, J ) = Q( JR, J ) - TEMP*TAU
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 ) Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*T2
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 ) Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*T3
240 CONTINUE 240 CONTINUE
END IF END IF
* *
@ -1233,27 +1235,29 @@
* *
* Apply transformations from the right. * Apply transformations from the right.
* *
T2 = TAU*V( 2 )
T3 = TAU*V( 3 )
DO 260 JR = IFRSTM, MIN( J+3, ILAST ) DO 260 JR = IFRSTM, MIN( J+3, ILAST )
TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )* TEMP = H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
$ H( JR, J+2 ) ) $ H( JR, J+2 )
H( JR, J ) = H( JR, J ) - TEMP H( JR, J ) = H( JR, J ) - TEMP*TAU
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 ) H( JR, J+1 ) = H( JR, J+1 ) - TEMP*T2
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 ) H( JR, J+2 ) = H( JR, J+2 ) - TEMP*T3
260 CONTINUE 260 CONTINUE
DO 270 JR = IFRSTM, J + 2 DO 270 JR = IFRSTM, J + 2
TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )* TEMP = T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
$ T( JR, J+2 ) ) $ T( JR, J+2 )
T( JR, J ) = T( JR, J ) - TEMP T( JR, J ) = T( JR, J ) - TEMP*TAU
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 ) T( JR, J+1 ) = T( JR, J+1 ) - TEMP*T2
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 ) T( JR, J+2 ) = T( JR, J+2 ) - TEMP*T3
270 CONTINUE 270 CONTINUE
IF( ILZ ) THEN IF( ILZ ) THEN
DO 280 JR = 1, N DO 280 JR = 1, N
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )* TEMP = Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
$ Z( JR, J+2 ) ) $ Z( JR, J+2 )
Z( JR, J ) = Z( JR, J ) - TEMP Z( JR, J ) = Z( JR, J ) - TEMP*TAU
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 ) Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*T2
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 ) Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*T3
280 CONTINUE 280 CONTINUE
END IF END IF
T( J+1, J ) = ZERO T( J+1, J ) = ZERO

23
lapack-netlib/SRC/slaqr5.f
View File

@ -558,10 +558,13 @@
* . Mth bulge. Exploit fact that first two elements * . Mth bulge. Exploit fact that first two elements
* . of row are actually zero. ==== * . of row are actually zero. ====
* *
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) T1 = V( 1, M )
H( K+3, K ) = -REFSUM T2 = T1*V( 2, M )
H( K+3, K+1 ) = -REFSUM*V( 2, M ) T3 = T1*V( 3, M )
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*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 * ==== Calculate reflection to move
* . Mth bulge one step. ==== * . Mth bulge one step. ====
@ -597,11 +600,13 @@
$ VT ) $ VT )
ALPHA = VT( 1 ) ALPHA = VT( 1 )
CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )* T1 = VT( 1 )
$ H( K+2, K ) ) 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 ) )+ IF( ABS( H( K+2, K )-REFSUM*T2 )+
$ ABS( REFSUM*VT( 3 ) ).GT.ULP* $ ABS( REFSUM*T3 ).GT.ULP*
$ ( ABS( H( K, K ) )+ABS( H( K+1, $ ( ABS( H( K, K ) )+ABS( H( K+1,
$ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
* *
@ -619,7 +624,7 @@
* . Replace the old reflector with * . Replace the old reflector with
* . the new one. ==== * . 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+2, K ) = ZERO
H( K+3, K ) = ZERO H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 ) V( 1, M ) = VT( 1 )

25
lapack-netlib/SRC/zlaqr5.f
View File

@ -533,11 +533,13 @@
* . Mth bulge. Exploit fact that first two elements * . Mth bulge. Exploit fact that first two elements
* . of row are actually zero. ==== * . of row are actually zero. ====
* *
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 ) T1 = V( 1, M )
H( K+3, K ) = -REFSUM T2 = T1*DCONJG( V( 2, M ) )
H( K+3, K+1 ) = -REFSUM*DCONJG( V( 2, M ) ) T3 = T1*DCONJG( V( 3, M ) )
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM = V( 3, M )*H( K+3, K+2 )
$ REFSUM*DCONJG( V( 3, M ) ) 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 * ==== Calculate reflection to move
* . Mth bulge one step. ==== * . Mth bulge one step. ====
@ -572,12 +574,13 @@
$ S( 2*M ), VT ) $ S( 2*M ), VT )
ALPHA = VT( 1 ) ALPHA = VT( 1 )
CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) ) CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
REFSUM = DCONJG( VT( 1 ) )* T1 = DCONJG( VT( 1 ) )
$ ( H( K+1, K )+DCONJG( VT( 2 ) )* T2 = T1*VT( 2 )
$ H( K+2, K ) ) 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 ) )+ IF( CABS1( H( K+2, K )-REFSUM*T2 )+
$ CABS1( REFSUM*VT( 3 ) ).GT.ULP* $ CABS1( REFSUM*T3 ).GT.ULP*
$ ( CABS1( H( K, K ) )+CABS1( H( K+1, $ ( CABS1( H( K, K ) )+CABS1( H( K+1,
$ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN $ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
* *
@ -595,7 +598,7 @@
* . Replace the old reflector with * . Replace the old reflector with
* . the new one. ==== * . 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+2, K ) = ZERO
H( K+3, K ) = ZERO H( K+3, K ) = ZERO
V( 1, M ) = VT( 1 ) V( 1, M ) = VT( 1 )

81
lapack-netlib/TESTING/EIG/cchkhs.f
View File

@ -21,7 +21,7 @@
* .. Array Arguments .. * .. Array Arguments ..
* LOGICAL DOTYPE( * ), SELECT( * ) * LOGICAL DOTYPE( * ), SELECT( * )
* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) * INTEGER ISEED( 4 ), IWORK( * ), NN( * )
* REAL RESULT( 14 ), RWORK( * ) * REAL RESULT( 16 ), RWORK( * )
* COMPLEX A( LDA, * ), EVECTL( LDU, * ), * COMPLEX A( LDA, * ), EVECTL( LDU, * ),
* $ EVECTR( LDU, * ), EVECTX( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ),
* $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), * $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ),
@ -64,10 +64,15 @@
*> eigenvectors of H. Y is lower triangular, and X is *> eigenvectors of H. Y is lower triangular, and X is
*> upper triangular. *> 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 *> When CCHKHS is called, a number of matrix "sizes" ("n's") and a
*> number of matrix "types" are specified. For each size ("n") *> number of matrix "types" are specified. For each size ("n")
*> and each type of matrix, one matrix will be generated and used *> 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: *> tests will be performed:
*> *>
*> (1) | A - U H U**H | / ( |A| n ulp ) *> (1) | A - U H U**H | / ( |A| n ulp )
@ -98,6 +103,10 @@
*> *>
*> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> (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 *> The "sizes" are specified by an array NN(1:NSIZES); the value of
*> each element NN(j) specifies one size. *> each element NN(j) specifies one size.
*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
@ -331,7 +340,7 @@
*> Workspace. Could be equivalenced to IWORK, but not RWORK. *> Workspace. Could be equivalenced to IWORK, but not RWORK.
*> Modified. *> Modified.
*> *>
*> RESULT - REAL array, dimension (14) *> RESULT - REAL array, dimension (16)
*> The values computed by the fourteen tests described above. *> The values computed by the fourteen tests described above.
*> The values are currently limited to 1/ulp, to avoid *> The values are currently limited to 1/ulp, to avoid
*> overflow. *> overflow.
@ -421,7 +430,7 @@
* .. Array Arguments .. * .. Array Arguments ..
LOGICAL DOTYPE( * ), SELECT( * ) LOGICAL DOTYPE( * ), SELECT( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * ) INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL RESULT( 14 ), RWORK( * ) REAL RESULT( 16 ), RWORK( * )
COMPLEX A( LDA, * ), EVECTL( LDU, * ), COMPLEX A( LDA, * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), EVECTX( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ),
$ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ),
@ -463,8 +472,8 @@
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL CCOPY, CGEHRD, CGEMM, CGET10, CGET22, CHSEIN, EXTERNAL CCOPY, CGEHRD, CGEMM, CGET10, CGET22, CHSEIN,
$ CHSEQR, CHST01, CLACPY, CLASET, CLATME, CLATMR, $ CHSEQR, CHST01, CLACPY, CLASET, CLATME, CLATMR,
$ CLATMS, CTREVC, CUNGHR, CUNMHR, SLABAD, SLAFTS, $ CLATMS, CTREVC, CTREVC3, CUNGHR, CUNMHR,
$ SLASUM, XERBLA $ SLABAD, SLAFTS, SLASUM, XERBLA
* .. * ..
* .. Intrinsic Functions .. * .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT INTRINSIC ABS, MAX, MIN, REAL, SQRT
@ -1067,6 +1076,66 @@
$ RESULT( 14 ) = DUMMA( 3 )*ANINV $ RESULT( 14 ) = DUMMA( 3 )*ANINV
END IF 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 * End of Loop -- Check for RESULT(j) > THRESH
* *
240 CONTINUE 240 CONTINUE

82
lapack-netlib/TESTING/EIG/dchkhs.f
View File

@ -23,7 +23,7 @@
* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) * INTEGER ISEED( 4 ), IWORK( * ), NN( * )
* DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ), * DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ),
* $ EVECTR( LDU, * ), EVECTX( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ),
* $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), * $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ),
* $ T1( LDA, * ), T2( LDA, * ), TAU( * ), * $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
* $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), * $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
* $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), * $ WI1( * ), WI2( * ), WI3( * ), WORK( * ),
@ -49,15 +49,21 @@
*> T is "quasi-triangular", and the eigenvalue vector W. *> T is "quasi-triangular", and the eigenvalue vector W.
*> *>
*> DTREVC computes the left and right eigenvector matrices *> 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 *> DHSEIN computes the left and right eigenvector matrices
*> Y and X for H, using inverse iteration. *> 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 *> When DCHKHS is called, a number of matrix "sizes" ("n's") and a
*> number of matrix "types" are specified. For each size ("n") *> number of matrix "types" are specified. For each size ("n")
*> and each type of matrix, one matrix will be generated and used *> 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: *> tests will be performed:
*> *>
*> (1) | A - U H U**T | / ( |A| n ulp ) *> (1) | A - U H U**T | / ( |A| n ulp )
@ -88,6 +94,10 @@
*> *>
*> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> (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 *> The "sizes" are specified by an array NN(1:NSIZES); the value of
*> each element NN(j) specifies one size. *> each element NN(j) specifies one size.
*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
@ -331,7 +341,7 @@
*> Workspace. *> Workspace.
*> Modified. *> Modified.
*> *>
*> RESULT - DOUBLE PRECISION array, dimension (14) *> RESULT - DOUBLE PRECISION array, dimension (16)
*> The values computed by the fourteen tests described above. *> The values computed by the fourteen tests described above.
*> The values are currently limited to 1/ulp, to avoid *> The values are currently limited to 1/ulp, to avoid
*> overflow. *> overflow.
@ -423,7 +433,7 @@
INTEGER ISEED( 4 ), IWORK( * ), NN( * ) INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ), DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), EVECTX( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ),
$ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ),
$ T1( LDA, * ), T2( LDA, * ), TAU( * ), $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
$ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
$ WI1( * ), WI2( * ), WI3( * ), WORK( * ), $ WI1( * ), WI2( * ), WI3( * ), WORK( * ),
@ -461,7 +471,7 @@
EXTERNAL DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN, EXTERNAL DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN,
$ DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET, $ DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET,
$ DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR, $ DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR,
$ DTREVC, XERBLA $ DTREVC, DTREVC3, XERBLA
* .. * ..
* .. Intrinsic Functions .. * .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT INTRINSIC ABS, DBLE, MAX, MIN, SQRT
@ -561,7 +571,7 @@
* *
* Initialize RESULT * Initialize RESULT
* *
DO 30 J = 1, 14 DO 30 J = 1, 16
RESULT( J ) = ZERO RESULT( J ) = ZERO
30 CONTINUE 30 CONTINUE
* *
@ -1108,6 +1118,64 @@
$ RESULT( 14 ) = DUMMA( 3 )*ANINV $ RESULT( 14 ) = DUMMA( 3 )*ANINV
END IF 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 * End of Loop -- Check for RESULT(j) > THRESH
* *
250 CONTINUE 250 CONTINUE

79
lapack-netlib/TESTING/EIG/schkhs.f
View File

@ -23,7 +23,7 @@
* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) * INTEGER ISEED( 4 ), IWORK( * ), NN( * )
* REAL A( LDA, * ), EVECTL( LDU, * ), * REAL A( LDA, * ), EVECTL( LDU, * ),
* $ EVECTR( LDU, * ), EVECTX( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ),
* $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), * $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ),
* $ T1( LDA, * ), T2( LDA, * ), TAU( * ), * $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
* $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), * $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
* $ WI1( * ), WI2( * ), WI3( * ), WORK( * ), * $ WI1( * ), WI2( * ), WI3( * ), WORK( * ),
@ -54,10 +54,15 @@
*> SHSEIN computes the left and right eigenvector matrices *> SHSEIN computes the left and right eigenvector matrices
*> Y and X for H, using inverse iteration. *> 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 *> When SCHKHS is called, a number of matrix "sizes" ("n's") and a
*> number of matrix "types" are specified. For each size ("n") *> number of matrix "types" are specified. For each size ("n")
*> and each type of matrix, one matrix will be generated and used *> 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: *> tests will be performed:
*> *>
*> (1) | A - U H U**T | / ( |A| n ulp ) *> (1) | A - U H U**T | / ( |A| n ulp )
@ -88,6 +93,10 @@
*> *>
*> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> (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 *> The "sizes" are specified by an array NN(1:NSIZES); the value of
*> each element NN(j) specifies one size. *> each element NN(j) specifies one size.
*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
@ -331,7 +340,7 @@
*> Workspace. *> Workspace.
*> Modified. *> Modified.
*> *>
*> RESULT - REAL array, dimension (14) *> RESULT - REAL array, dimension (16)
*> The values computed by the fourteen tests described above. *> The values computed by the fourteen tests described above.
*> The values are currently limited to 1/ulp, to avoid *> The values are currently limited to 1/ulp, to avoid
*> overflow. *> overflow.
@ -423,7 +432,7 @@
INTEGER ISEED( 4 ), IWORK( * ), NN( * ) INTEGER ISEED( 4 ), IWORK( * ), NN( * )
REAL A( LDA, * ), EVECTL( LDU, * ), REAL A( LDA, * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), EVECTX( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ),
$ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ), $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 16 ),
$ T1( LDA, * ), T2( LDA, * ), TAU( * ), $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
$ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ), $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
$ WI1( * ), WI2( * ), WI3( * ), WORK( * ), $ WI1( * ), WI2( * ), WI3( * ), WORK( * ),
@ -461,7 +470,7 @@
EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN, EXTERNAL SCOPY, SGEHRD, SGEMM, SGET10, SGET22, SHSEIN,
$ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET, $ SHSEQR, SHST01, SLABAD, SLACPY, SLAFTS, SLASET,
$ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR, $ SLASUM, SLATME, SLATMR, SLATMS, SORGHR, SORMHR,
$ STREVC, XERBLA $ STREVC, STREVC3, XERBLA
* .. * ..
* .. Intrinsic Functions .. * .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, REAL, SQRT INTRINSIC ABS, MAX, MIN, REAL, SQRT
@ -561,7 +570,7 @@
* *
* Initialize RESULT * Initialize RESULT
* *
DO 30 J = 1, 14 DO 30 J = 1, 16
RESULT( J ) = ZERO RESULT( J ) = ZERO
30 CONTINUE 30 CONTINUE
* *
@ -1108,6 +1117,64 @@
$ RESULT( 14 ) = DUMMA( 3 )*ANINV $ RESULT( 14 ) = DUMMA( 3 )*ANINV
END IF 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 * End of Loop -- Check for RESULT(j) > THRESH
* *
250 CONTINUE 250 CONTINUE

79
lapack-netlib/TESTING/EIG/zchkhs.f
View File

@ -21,7 +21,7 @@
* .. Array Arguments .. * .. Array Arguments ..
* LOGICAL DOTYPE( * ), SELECT( * ) * LOGICAL DOTYPE( * ), SELECT( * )
* INTEGER ISEED( 4 ), IWORK( * ), NN( * ) * INTEGER ISEED( 4 ), IWORK( * ), NN( * )
* DOUBLE PRECISION RESULT( 14 ), RWORK( * ) * DOUBLE PRECISION RESULT( 16 ), RWORK( * )
* COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ), * COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ),
* $ EVECTR( LDU, * ), EVECTX( LDU, * ), * $ EVECTR( LDU, * ), EVECTX( LDU, * ),
* $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), * $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ),
@ -64,10 +64,15 @@
*> eigenvectors of H. Y is lower triangular, and X is *> eigenvectors of H. Y is lower triangular, and X is
*> upper triangular. *> 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 *> When ZCHKHS is called, a number of matrix "sizes" ("n's") and a
*> number of matrix "types" are specified. For each size ("n") *> number of matrix "types" are specified. For each size ("n")
*> and each type of matrix, one matrix will be generated and used *> 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: *> tests will be performed:
*> *>
*> (1) | A - U H U**H | / ( |A| n ulp ) *> (1) | A - U H U**H | / ( |A| n ulp )
@ -98,6 +103,10 @@
*> *>
*> (14) | Y**H A - W**H Y | / ( |A| |Y| ulp ) *> (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 *> The "sizes" are specified by an array NN(1:NSIZES); the value of
*> each element NN(j) specifies one size. *> each element NN(j) specifies one size.
*> The "types" are specified by a logical array DOTYPE( 1:NTYPES ); *> The "types" are specified by a logical array DOTYPE( 1:NTYPES );
@ -331,7 +340,7 @@
*> Workspace. Could be equivalenced to IWORK, but not RWORK. *> Workspace. Could be equivalenced to IWORK, but not RWORK.
*> Modified. *> Modified.
*> *>
*> RESULT - DOUBLE PRECISION array, dimension (14) *> RESULT - DOUBLE PRECISION array, dimension (16)
*> The values computed by the fourteen tests described above. *> The values computed by the fourteen tests described above.
*> The values are currently limited to 1/ulp, to avoid *> The values are currently limited to 1/ulp, to avoid
*> overflow. *> overflow.
@ -421,7 +430,7 @@
* .. Array Arguments .. * .. Array Arguments ..
LOGICAL DOTYPE( * ), SELECT( * ) LOGICAL DOTYPE( * ), SELECT( * )
INTEGER ISEED( 4 ), IWORK( * ), NN( * ) INTEGER ISEED( 4 ), IWORK( * ), NN( * )
DOUBLE PRECISION RESULT( 14 ), RWORK( * ) DOUBLE PRECISION RESULT( 16 ), RWORK( * )
COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ), COMPLEX*16 A( LDA, * ), EVECTL( LDU, * ),
$ EVECTR( LDU, * ), EVECTX( LDU, * ), $ EVECTR( LDU, * ), EVECTX( LDU, * ),
$ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ), $ EVECTY( LDU, * ), H( LDA, * ), T1( LDA, * ),
@ -464,7 +473,7 @@
EXTERNAL DLABAD, DLAFTS, DLASUM, XERBLA, ZCOPY, ZGEHRD, EXTERNAL DLABAD, DLAFTS, DLASUM, XERBLA, ZCOPY, ZGEHRD,
$ ZGEMM, ZGET10, ZGET22, ZHSEIN, ZHSEQR, ZHST01, $ ZGEMM, ZGET10, ZGET22, ZHSEIN, ZHSEQR, ZHST01,
$ ZLACPY, ZLASET, ZLATME, ZLATMR, ZLATMS, ZTREVC, $ ZLACPY, ZLASET, ZLATME, ZLATMR, ZLATMS, ZTREVC,
$ ZUNGHR, ZUNMHR $ ZTREVC3, ZUNGHR, ZUNMHR
* .. * ..
* .. Intrinsic Functions .. * .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, MAX, MIN, SQRT INTRINSIC ABS, DBLE, MAX, MIN, SQRT
@ -1067,6 +1076,66 @@
$ RESULT( 14 ) = DUMMA( 3 )*ANINV $ RESULT( 14 ) = DUMMA( 3 )*ANINV
END IF 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 * End of Loop -- Check for RESULT(j) > THRESH
* *
240 CONTINUE 240 CONTINUE