Browse Source
Merge pull request #3946 from martin-frbg/lapack682
Rewrite ?LAQR5 and S/DHGEQZ , add tests for TRECV3 (Reference-LAPACK PR 682)tags/v0.3.22^2
Martin Kroeker
GitHub
2 years ago
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
10 changed files with 427 additions and 130 deletions
Unified View
Diff Options
-
+14 -11lapack-netlib/SRC/claqr5.f
-
+37 -33lapack-netlib/SRC/dhgeqz.f
-
+14 -9lapack-netlib/SRC/dlaqr5.f
-
+37 -33lapack-netlib/SRC/shgeqz.f
-
+14 -9lapack-netlib/SRC/slaqr5.f
-
+14 -11lapack-netlib/SRC/zlaqr5.f
-
+75 -6lapack-netlib/TESTING/EIG/cchkhs.f
-
+75 -7lapack-netlib/TESTING/EIG/dchkhs.f
-
+73 -6lapack-netlib/TESTING/EIG/schkhs.f
-
+74 -5lapack-netlib/TESTING/EIG/zchkhs.f
+ 14
- 11
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 ) | |||||
| 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 | * ==== 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 ) )* | |||||
| $ ( 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, | $ ( 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 ) | ||||
+ 37
- 33
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, | |||||
| $ 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 .. | * .. 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 280 CONTINUE | ||||
| END IF | END IF | ||||
| T( J+1, J ) = ZERO | T( J+1, J ) = ZERO | ||||
+ 14
- 9
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 ) | |||||
| 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 | * ==== 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 )* | |||||
| $ 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, | $ ( 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 ) | ||||
+ 37
- 33
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, | |||||
| $ 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 .. | * .. 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 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 )* | |||||
| $ 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 | 280 CONTINUE | ||||
| END IF | END IF | ||||
| T( J+1, J ) = ZERO | T( J+1, J ) = ZERO | ||||
+ 14
- 9
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 ) | |||||
| 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 | * ==== 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 )* | |||||
| $ 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, | $ ( 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 ) | ||||
+ 14
- 11
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 ) | |||||
| 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 | * ==== 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 ) )* | |||||
| $ ( 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, | $ ( 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 ) | ||||
+ 75
- 6
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, | |||||
| $ SLASUM, XERBLA | |||||
| $ CLATMS, CTREVC, CTREVC3, CUNGHR, CUNMHR, | |||||
| $ 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 | ||||
+ 75
- 7
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 | ||||
+ 73
- 6
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 | ||||
+ 74
- 5
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 | ||||