Skip to content

Commit 7719dbe

Browse files
martin-frbgmartin-frbg
authored
Merge pull request #3946 from martin-frbg/lapack682
Rewrite ?LAQR5 and S/DHGEQZ , add tests for TRECV3 (Reference-LAPACK PR 682)
2 parents f7b9391 + 147e2fb commit 7719dbe

File tree

10 files changed

+427
-130
lines changed

10 files changed

+427
-130
lines changed

‎lapack-netlib/SRC/claqr5.f

+14-11
Original file line numberDiff line numberDiff line change
@@ -533,11 +533,13 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
533533
* . Mth bulge. Exploit fact that first two elements
534534
* . of row are actually zero. ====
535535
*
536-
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 )
537-
H( K+3, K ) = -REFSUM
538-
H( K+3, K+1 ) = -REFSUM*CONJG( V( 2, M ) )
539-
H( K+3, K+2 ) = H( K+3, K+2 ) -
540-
$ REFSUM*CONJG( V( 3, M ) )
536+
T1 = V( 1, M )
537+
T2 = T1*CONJG( V( 2, M ) )
538+
T3 = T1*CONJG( V( 3, M ) )
539+
REFSUM = V( 3, M )*H( K+3, K+2 )
540+
H( K+3, K ) = -REFSUM*T1
541+
H( K+3, K+1 ) = -REFSUM*T2
542+
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3
541543
*
542544
* ==== Calculate reflection to move
543545
* . Mth bulge one step. ====
@@ -572,12 +574,13 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
572574
$ S( 2*M ), VT )
573575
ALPHA = VT( 1 )
574576
CALL CLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
575-
REFSUM = CONJG( VT( 1 ) )*
576-
$ ( H( K+1, K )+CONJG( VT( 2 ) )*
577-
$ H( K+2, K ) )
577+
T1 = CONJG( VT( 1 ) )
578+
T2 = T1*VT( 2 )
579+
T3 = T1*VT( 3 )
580+
REFSUM = H( K+1, K )+CONJG( VT( 2 ) )*H( K+2, K )
578581
*
579-
IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+
580-
$ CABS1( REFSUM*VT( 3 ) ).GT.ULP*
582+
IF( CABS1( H( K+2, K )-REFSUM*T2 )+
583+
$ CABS1( REFSUM*T3 ).GT.ULP*
581584
$ ( CABS1( H( K, K ) )+CABS1( H( K+1,
582585
$ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
583586
*
@@ -595,7 +598,7 @@ SUBROUTINE CLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
595598
* . Replace the old reflector with
596599
* . the new one. ====
597600
*
598-
H( K+1, K ) = H( K+1, K ) - REFSUM
601+
H( K+1, K ) = H( K+1, K ) - REFSUM*T1
599602
H( K+2, K ) = ZERO
600603
H( K+3, K ) = ZERO
601604
V( 1, M ) = VT( 1 )

‎lapack-netlib/SRC/dhgeqz.f

+37-33
Original file line numberDiff line numberDiff line change
@@ -337,9 +337,9 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
337337
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
338338
$ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
339339
$ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
340-
$ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
341-
$ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
342-
$ WR2
340+
$ T2, T3, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
341+
$ U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
342+
$ WABS, WI, WR, WR2
343343
* ..
344344
* .. Local Arrays ..
345345
DOUBLE PRECISION V( 3 )
@@ -1127,25 +1127,27 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
11271127
H( J+2, J-1 ) = ZERO
11281128
END IF
11291129
*
1130+
T2 = TAU*V( 2 )
1131+
T3 = TAU*V( 3 )
11301132
DO 230 JC = J, ILASTM
1131-
TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
1132-
$ H( J+2, JC ) )
1133-
H( J, JC ) = H( J, JC ) - TEMP
1134-
H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
1135-
H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
1136-
TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
1137-
$ T( J+2, JC ) )
1138-
T( J, JC ) = T( J, JC ) - TEMP2
1139-
T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
1140-
T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
1133+
TEMP = H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
1134+
$ H( J+2, JC )
1135+
H( J, JC ) = H( J, JC ) - TEMP*TAU
1136+
H( J+1, JC ) = H( J+1, JC ) - TEMP*T2
1137+
H( J+2, JC ) = H( J+2, JC ) - TEMP*T3
1138+
TEMP2 = T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
1139+
$ T( J+2, JC )
1140+
T( J, JC ) = T( J, JC ) - TEMP2*TAU
1141+
T( J+1, JC ) = T( J+1, JC ) - TEMP2*T2
1142+
T( J+2, JC ) = T( J+2, JC ) - TEMP2*T3
11411143
230 CONTINUE
11421144
IF( ILQ ) THEN
11431145
DO 240 JR = 1, N
1144-
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
1145-
$ Q( JR, J+2 ) )
1146-
Q( JR, J ) = Q( JR, J ) - TEMP
1147-
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
1148-
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
1146+
TEMP = Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
1147+
$ Q( JR, J+2 )
1148+
Q( JR, J ) = Q( JR, J ) - TEMP*TAU
1149+
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*T2
1150+
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*T3
11491151
240 CONTINUE
11501152
END IF
11511153
*
@@ -1233,27 +1235,29 @@ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
12331235
*
12341236
* Apply transformations from the right.
12351237
*
1238+
T2 = TAU*V(2)
1239+
T3 = TAU*V(3)
12361240
DO 260 JR = IFRSTM, MIN( J+3, ILAST )
1237-
TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
1238-
$ H( JR, J+2 ) )
1239-
H( JR, J ) = H( JR, J ) - TEMP
1240-
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
1241-
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
1241+
TEMP = H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
1242+
$ H( JR, J+2 )
1243+
H( JR, J ) = H( JR, J ) - TEMP*TAU
1244+
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*T2
1245+
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*T3
12421246
260 CONTINUE
12431247
DO 270 JR = IFRSTM, J + 2
1244-
TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
1245-
$ T( JR, J+2 ) )
1246-
T( JR, J ) = T( JR, J ) - TEMP
1247-
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
1248-
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
1248+
TEMP = T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
1249+
$ T( JR, J+2 )
1250+
T( JR, J ) = T( JR, J ) - TEMP*TAU
1251+
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*T2
1252+
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*T3
12491253
270 CONTINUE
12501254
IF( ILZ ) THEN
12511255
DO 280 JR = 1, N
1252-
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
1253-
$ Z( JR, J+2 ) )
1254-
Z( JR, J ) = Z( JR, J ) - TEMP
1255-
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
1256-
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
1256+
TEMP = Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
1257+
$ Z( JR, J+2 )
1258+
Z( JR, J ) = Z( JR, J ) - TEMP*TAU
1259+
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*T2
1260+
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*T3
12571261
280 CONTINUE
12581262
END IF
12591263
T( J+1, J ) = ZERO

‎lapack-netlib/SRC/dlaqr5.f

+14-9
Original file line numberDiff line numberDiff line change
@@ -558,10 +558,13 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
558558
* . Mth bulge. Exploit fact that first two elements
559559
* . of row are actually zero. ====
560560
*
561-
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 )
562-
H( K+3, K ) = -REFSUM
563-
H( K+3, K+1 ) = -REFSUM*V( 2, M )
564-
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*V( 3, M )
561+
T1 = V( 1, M )
562+
T2 = T1*V( 2, M )
563+
T3 = T1*V( 3, M )
564+
REFSUM = V( 3, M )*H( K+3, K+2 )
565+
H( K+3, K ) = -REFSUM*T1
566+
H( K+3, K+1 ) = -REFSUM*T2
567+
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3
565568
*
566569
* ==== Calculate reflection to move
567570
* . Mth bulge one step. ====
@@ -597,11 +600,13 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
597600
$ VT )
598601
ALPHA = VT( 1 )
599602
CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
600-
REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )*
601-
$ H( K+2, K ) )
603+
T1 = VT( 1 )
604+
T2 = T1*VT( 2 )
605+
T3 = T1*VT( 3 )
606+
REFSUM = H( K+1, K ) + VT( 2 )*H( K+2, K )
602607
*
603-
IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+
604-
$ ABS( REFSUM*VT( 3 ) ).GT.ULP*
608+
IF( ABS( H( K+2, K )-REFSUM*T2 )+
609+
$ ABS( REFSUM*T3 ).GT.ULP*
605610
$ ( ABS( H( K, K ) )+ABS( H( K+1,
606611
$ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
607612
*
@@ -619,7 +624,7 @@ SUBROUTINE DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
619624
* . Replace the old reflector with
620625
* . the new one. ====
621626
*
622-
H( K+1, K ) = H( K+1, K ) - REFSUM
627+
H( K+1, K ) = H( K+1, K ) - REFSUM*T1
623628
H( K+2, K ) = ZERO
624629
H( K+3, K ) = ZERO
625630
V( 1, M ) = VT( 1 )

‎lapack-netlib/SRC/shgeqz.f

+37-33
Original file line numberDiff line numberDiff line change
@@ -337,9 +337,9 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
337337
$ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
338338
$ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
339339
$ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
340-
$ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
341-
$ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
342-
$ WR2
340+
$ T2, T3, TAU, TEMP, TEMP2, TEMPI, TEMPR, U1,
341+
$ U12, U12L, U2, ULP, VS, W11, W12, W21, W22,
342+
$ WABS, WI, WR, WR2
343343
* ..
344344
* .. Local Arrays ..
345345
REAL V( 3 )
@@ -1127,25 +1127,27 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
11271127
H( J+2, J-1 ) = ZERO
11281128
END IF
11291129
*
1130+
T2 = TAU * V( 2 )
1131+
T3 = TAU * V( 3 )
11301132
DO 230 JC = J, ILASTM
1131-
TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
1132-
$ H( J+2, JC ) )
1133-
H( J, JC ) = H( J, JC ) - TEMP
1134-
H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
1135-
H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
1136-
TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
1137-
$ T( J+2, JC ) )
1138-
T( J, JC ) = T( J, JC ) - TEMP2
1139-
T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
1140-
T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
1133+
TEMP = H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
1134+
$ H( J+2, JC )
1135+
H( J, JC ) = H( J, JC ) - TEMP*TAU
1136+
H( J+1, JC ) = H( J+1, JC ) - TEMP*T2
1137+
H( J+2, JC ) = H( J+2, JC ) - TEMP*T3
1138+
TEMP2 = T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
1139+
$ T( J+2, JC )
1140+
T( J, JC ) = T( J, JC ) - TEMP2*TAU
1141+
T( J+1, JC ) = T( J+1, JC ) - TEMP2*T2
1142+
T( J+2, JC ) = T( J+2, JC ) - TEMP2*T3
11411143
230 CONTINUE
11421144
IF( ILQ ) THEN
11431145
DO 240 JR = 1, N
1144-
TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
1145-
$ Q( JR, J+2 ) )
1146-
Q( JR, J ) = Q( JR, J ) - TEMP
1147-
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
1148-
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
1146+
TEMP = Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
1147+
$ Q( JR, J+2 )
1148+
Q( JR, J ) = Q( JR, J ) - TEMP*TAU
1149+
Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*T2
1150+
Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*T3
11491151
240 CONTINUE
11501152
END IF
11511153
*
@@ -1233,27 +1235,29 @@ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
12331235
*
12341236
* Apply transformations from the right.
12351237
*
1238+
T2 = TAU*V( 2 )
1239+
T3 = TAU*V( 3 )
12361240
DO 260 JR = IFRSTM, MIN( J+3, ILAST )
1237-
TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
1238-
$ H( JR, J+2 ) )
1239-
H( JR, J ) = H( JR, J ) - TEMP
1240-
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
1241-
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
1241+
TEMP = H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
1242+
$ H( JR, J+2 )
1243+
H( JR, J ) = H( JR, J ) - TEMP*TAU
1244+
H( JR, J+1 ) = H( JR, J+1 ) - TEMP*T2
1245+
H( JR, J+2 ) = H( JR, J+2 ) - TEMP*T3
12421246
260 CONTINUE
12431247
DO 270 JR = IFRSTM, J + 2
1244-
TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
1245-
$ T( JR, J+2 ) )
1246-
T( JR, J ) = T( JR, J ) - TEMP
1247-
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
1248-
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
1248+
TEMP = T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
1249+
$ T( JR, J+2 )
1250+
T( JR, J ) = T( JR, J ) - TEMP*TAU
1251+
T( JR, J+1 ) = T( JR, J+1 ) - TEMP*T2
1252+
T( JR, J+2 ) = T( JR, J+2 ) - TEMP*T3
12491253
270 CONTINUE
12501254
IF( ILZ ) THEN
12511255
DO 280 JR = 1, N
1252-
TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
1253-
$ Z( JR, J+2 ) )
1254-
Z( JR, J ) = Z( JR, J ) - TEMP
1255-
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
1256-
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
1256+
TEMP = Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
1257+
$ Z( JR, J+2 )
1258+
Z( JR, J ) = Z( JR, J ) - TEMP*TAU
1259+
Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*T2
1260+
Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*T3
12571261
280 CONTINUE
12581262
END IF
12591263
T( J+1, J ) = ZERO

‎lapack-netlib/SRC/slaqr5.f

+14-9
Original file line numberDiff line numberDiff line change
@@ -558,10 +558,13 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
558558
* . Mth bulge. Exploit fact that first two elements
559559
* . of row are actually zero. ====
560560
*
561-
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 )
562-
H( K+3, K ) = -REFSUM
563-
H( K+3, K+1 ) = -REFSUM*V( 2, M )
564-
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*V( 3, M )
561+
T1 = V( 1, M )
562+
T2 = T1*V( 2, M )
563+
T3 = T1*V( 3, M )
564+
REFSUM = V( 3, M )*H( K+3, K+2 )
565+
H( K+3, K ) = -REFSUM*T1
566+
H( K+3, K+1 ) = -REFSUM*T2
567+
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3
565568
*
566569
* ==== Calculate reflection to move
567570
* . Mth bulge one step. ====
@@ -597,11 +600,13 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
597600
$ VT )
598601
ALPHA = VT( 1 )
599602
CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
600-
REFSUM = VT( 1 )*( H( K+1, K )+VT( 2 )*
601-
$ H( K+2, K ) )
603+
T1 = VT( 1 )
604+
T2 = T1*VT( 2 )
605+
T3 = T2*VT( 3 )
606+
REFSUM = H( K+1, K )+VT( 2 )*H( K+2, K )
602607
*
603-
IF( ABS( H( K+2, K )-REFSUM*VT( 2 ) )+
604-
$ ABS( REFSUM*VT( 3 ) ).GT.ULP*
608+
IF( ABS( H( K+2, K )-REFSUM*T2 )+
609+
$ ABS( REFSUM*T3 ).GT.ULP*
605610
$ ( ABS( H( K, K ) )+ABS( H( K+1,
606611
$ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
607612
*
@@ -619,7 +624,7 @@ SUBROUTINE SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS,
619624
* . Replace the old reflector with
620625
* . the new one. ====
621626
*
622-
H( K+1, K ) = H( K+1, K ) - REFSUM
627+
H( K+1, K ) = H( K+1, K ) - REFSUM*T1
623628
H( K+2, K ) = ZERO
624629
H( K+3, K ) = ZERO
625630
V( 1, M ) = VT( 1 )

‎lapack-netlib/SRC/zlaqr5.f

+14-11
Original file line numberDiff line numberDiff line change
@@ -533,11 +533,13 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
533533
* . Mth bulge. Exploit fact that first two elements
534534
* . of row are actually zero. ====
535535
*
536-
REFSUM = V( 1, M )*V( 3, M )*H( K+3, K+2 )
537-
H( K+3, K ) = -REFSUM
538-
H( K+3, K+1 ) = -REFSUM*DCONJG( V( 2, M ) )
539-
H( K+3, K+2 ) = H( K+3, K+2 ) -
540-
$ REFSUM*DCONJG( V( 3, M ) )
536+
T1 = V( 1, M )
537+
T2 = T1*DCONJG( V( 2, M ) )
538+
T3 = T1*DCONJG( V( 3, M ) )
539+
REFSUM = V( 3, M )*H( K+3, K+2 )
540+
H( K+3, K ) = -REFSUM*T1
541+
H( K+3, K+1 ) = -REFSUM*T2
542+
H( K+3, K+2 ) = H( K+3, K+2 ) - REFSUM*T3
541543
*
542544
* ==== Calculate reflection to move
543545
* . Mth bulge one step. ====
@@ -572,12 +574,13 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
572574
$ S( 2*M ), VT )
573575
ALPHA = VT( 1 )
574576
CALL ZLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
575-
REFSUM = DCONJG( VT( 1 ) )*
576-
$ ( H( K+1, K )+DCONJG( VT( 2 ) )*
577-
$ H( K+2, K ) )
577+
T1 = DCONJG( VT( 1 ) )
578+
T2 = T1*VT( 2 )
579+
T3 = T1*VT( 3 )
580+
REFSUM = H( K+1, K )+DCONJG( VT( 2 ) )*H( K+2, K )
578581
*
579-
IF( CABS1( H( K+2, K )-REFSUM*VT( 2 ) )+
580-
$ CABS1( REFSUM*VT( 3 ) ).GT.ULP*
582+
IF( CABS1( H( K+2, K )-REFSUM*T2 )+
583+
$ CABS1( REFSUM*T3 ).GT.ULP*
581584
$ ( CABS1( H( K, K ) )+CABS1( H( K+1,
582585
$ K+1 ) )+CABS1( H( K+2, K+2 ) ) ) ) THEN
583586
*
@@ -595,7 +598,7 @@ SUBROUTINE ZLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NSHFTS, S,
595598
* . Replace the old reflector with
596599
* . the new one. ====
597600
*
598-
H( K+1, K ) = H( K+1, K ) - REFSUM
601+
H( K+1, K ) = H( K+1, K ) - REFSUM*T1
599602
H( K+2, K ) = ZERO
600603
H( K+3, K ) = ZERO
601604
V( 1, M ) = VT( 1 )

0 commit comments

Comments
 (0)