Add exceptional shift to fix rare convergence problems

martin-frbg · web-flow · commit 856bc365338f · 2021-01-27T13:41:45.000+01:00
diff --git a/lapack-netlib/SRC/chgeqz.f b/lapack-netlib/SRC/chgeqz.f
@@ -743,8 +743,14 @@ SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
 *
 *           Exceptional shift.  Chosen for no particularly good reason.
 *
-            ESHIFT = ESHIFT + (ASCALE*H(ILAST,ILAST-1))/
-     $                        (BSCALE*T(ILAST-1,ILAST-1))
+            IF( ( IITER / 20 )*20.EQ.IITER .AND. 
+     $         BSCALE*ABS1(T( ILAST, ILAST )).GT.SAFMIN ) THEN
+               ESHIFT = ESHIFT + ( ASCALE*H( ILAST,
+     $            ILAST ) )/( BSCALE*T( ILAST, ILAST ) )
+            ELSE
+               ESHIFT = ESHIFT + ( ASCALE*H( ILAST,
+     $            ILAST-1 ) )/( BSCALE*T( ILAST-1, ILAST-1 ) )
+            END IF
             SHIFT = ESHIFT
          END IF
 *
diff --git a/lapack-netlib/SRC/zhgeqz.f b/lapack-netlib/SRC/zhgeqz.f
@@ -744,8 +744,14 @@ SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
 *
 *           Exceptional shift.  Chosen for no particularly good reason.
 *
-            ESHIFT = ESHIFT + (ASCALE*H(ILAST,ILAST-1))/
-     $                        (BSCALE*T(ILAST-1,ILAST-1))
+            IF( ( IITER / 20 )*20.EQ.IITER .AND. 
+     $         BSCALE*ABS1(T( ILAST, ILAST )).GT.SAFMIN ) THEN
+               ESHIFT = ESHIFT + ( ASCALE*H( ILAST,
+     $            ILAST ) )/( BSCALE*T( ILAST, ILAST ) )
+            ELSE
+               ESHIFT = ESHIFT + ( ASCALE*H( ILAST,
+     $            ILAST-1 ) )/( BSCALE*T( ILAST-1, ILAST-1 ) )
+            END IF
             SHIFT = ESHIFT
          END IF
 *

Original file line number	Diff line number	Diff line change
`@@ -743,8 +743,14 @@ SUBROUTINE CHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,`
`743`	`743`	`*`
`744`	`744`	`* Exceptional shift. Chosen for no particularly good reason.`
`745`	`745`	`*`
`746`		`- ESHIFT = ESHIFT + (ASCALE*H(ILAST,ILAST-1))/`
`747`		`- $ (BSCALE*T(ILAST-1,ILAST-1))`
	`746`	`+ IF( ( IITER / 20 )*20.EQ.IITER .AND.`
	`747`	`+ $ BSCALE*ABS1(T( ILAST, ILAST )).GT.SAFMIN ) THEN`
	`748`	`+ ESHIFT = ESHIFT + ( ASCALE*H( ILAST,`
	`749`	`+ $ ILAST ) )/( BSCALE*T( ILAST, ILAST ) )`
	`750`	`+ ELSE`
	`751`	`+ ESHIFT = ESHIFT + ( ASCALE*H( ILAST,`
	`752`	`+ $ ILAST-1 ) )/( BSCALE*T( ILAST-1, ILAST-1 ) )`
	`753`	`+ END IF`
`748`	`754`	`SHIFT = ESHIFT`
`749`	`755`	`END IF`
`750`	`756`	`*`
Original file line number	Diff line number	Diff line change
`@@ -744,8 +744,14 @@ SUBROUTINE ZHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,`
`744`	`744`	`*`
`745`	`745`	`* Exceptional shift. Chosen for no particularly good reason.`
`746`	`746`	`*`
`747`		`- ESHIFT = ESHIFT + (ASCALE*H(ILAST,ILAST-1))/`
`748`		`- $ (BSCALE*T(ILAST-1,ILAST-1))`
	`747`	`+ IF( ( IITER / 20 )*20.EQ.IITER .AND.`
	`748`	`+ $ BSCALE*ABS1(T( ILAST, ILAST )).GT.SAFMIN ) THEN`
	`749`	`+ ESHIFT = ESHIFT + ( ASCALE*H( ILAST,`
	`750`	`+ $ ILAST ) )/( BSCALE*T( ILAST, ILAST ) )`
	`751`	`+ ELSE`
	`752`	`+ ESHIFT = ESHIFT + ( ASCALE*H( ILAST,`
	`753`	`+ $ ILAST-1 ) )/( BSCALE*T( ILAST-1, ILAST-1 ) )`
	`754`	`+ END IF`
`749`	`755`	`SHIFT = ESHIFT`
`750`	`756`	`END IF`
`751`	`757`	`*`