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

fix calculation of non-exceptional shift (from Reference-LAPACK PR 477)

This commit is contained in:
Martin Kroeker 2021-01-29 09:56:12 +01:00 committed by GitHub
parent 3dbb32c734
commit f87842483e
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
2 changed files with 34 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
lapack-netlib/SRC/chgeqz.f
View File

@ -320,12 +320,13 @@
$ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
COMPLEX ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, COMPLEX ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
$ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1,
$ U12, X $ U12, X, ABI12, Y
* .. * ..
* .. External Functions .. * .. External Functions ..
COMPLEX CLADIV
LOGICAL LSAME LOGICAL LSAME
REAL CLANHS, SLAMCH REAL CLANHS, SLAMCH
EXTERNAL LSAME, CLANHS, SLAMCH EXTERNAL CLADIV, LLSAME, CLANHS, SLAMCH
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL CLARTG, CLASET, CROT, CSCAL, XERBLA EXTERNAL CLARTG, CLASET, CROT, CSCAL, XERBLA
@ -729,15 +730,21 @@
AD22 = ( ASCALE*H( ILAST, ILAST ) ) / AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) ) $ ( BSCALE*T( ILAST, ILAST ) )
ABI22 = AD22 - U12*AD21 ABI22 = AD22 - U12*AD21
ABI12 = AD12 - U12*AD11
* *
T1 = HALF*( AD11+ABI22 ) SHIFT = ABI22
RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 ) CTEMP = SQRT( ABI12 )*SQRT( AD21 )
TEMP = REAL( T1-ABI22 )*REAL( RTDISC ) + TEMP = ABS1( CTEMP )
$ AIMAG( T1-ABI22 )*AIMAG( RTDISC ) IF( CTEMP.NE.ZERO ) THEN
IF( TEMP.LE.ZERO ) THEN X = HALF*( AD11-SHIFT )
SHIFT = T1 + RTDISC TEMP2 = ABS1( X )
ELSE TEMP = MAX( TEMP, ABS1( X ) )
SHIFT = T1 - RTDISC Y = TEMP*SQRT( ( X / TEMP )**2+( CTEMP / TEMP )**2 )
IF( TEMP2.GT.ZERO ) THEN
IF( DBLE( X / TEMP2 )*DBLE( Y )+
$ DIMAG( X / TEMP2 )*DIMAG( Y ).LT.ZERO )Y = -Y
END IF
SHIFT = SHIFT - CTEMP*CLADIV( CTEMP, ( X+Y ) )
END IF END IF
ELSE ELSE
* *

27
lapack-netlib/SRC/zhgeqz.f
View File

@ -320,12 +320,13 @@
$ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP $ C, SAFMIN, TEMP, TEMP2, TEMPR, ULP
COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2, COMPLEX*16 ABI22, AD11, AD12, AD21, AD22, CTEMP, CTEMP2,
$ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1, $ CTEMP3, ESHIFT, RTDISC, S, SHIFT, SIGNBC, T1,
$ U12, X $ U12, X, ABI12, Y
* .. * ..
* .. External Functions .. * .. External Functions ..
COMPLEX*16 ZLADIV
LOGICAL LSAME LOGICAL LSAME
DOUBLE PRECISION DLAMCH, ZLANHS DOUBLE PRECISION DLAMCH, ZLANHS
EXTERNAL LSAME, DLAMCH, ZLANHS EXTERNAL ZLADIV, LSAME, DLAMCH, ZLANHS
* .. * ..
* .. External Subroutines .. * .. External Subroutines ..
EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL EXTERNAL XERBLA, ZLARTG, ZLASET, ZROT, ZSCAL
@ -730,15 +731,21 @@
AD22 = ( ASCALE*H( ILAST, ILAST ) ) / AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
$ ( BSCALE*T( ILAST, ILAST ) ) $ ( BSCALE*T( ILAST, ILAST ) )
ABI22 = AD22 - U12*AD21 ABI22 = AD22 - U12*AD21
ABI12 = AD12 - U12*AD11
* *
T1 = HALF*( AD11+ABI22 ) SHIFT = ABI22
RTDISC = SQRT( T1**2+AD12*AD21-AD11*AD22 ) CTEMP = SQRT( ABI12 )*SQRT( AD21 )
TEMP = DBLE( T1-ABI22 )*DBLE( RTDISC ) + TEMP = ABS1( CTEMP )
$ DIMAG( T1-ABI22 )*DIMAG( RTDISC ) IF( CTEMP.NE.ZERO ) THEN
IF( TEMP.LE.ZERO ) THEN X = HALF*( AD11-SHIFT )
SHIFT = T1 + RTDISC TEMP2 = ABS1( X )
ELSE TEMP = MAX( TEMP, ABS1( X ) )
SHIFT = T1 - RTDISC Y = TEMP*SQRT( ( X / TEMP )**2+( CTEMP / TEMP )**2 )
IF( TEMP2.GT.ZERO ) THEN
IF( DBLE( X / TEMP2 )*DBLE( Y )+
$ DIMAG( X / TEMP2 )*DIMAG( Y ).LT.ZERO )Y = -Y
END IF
SHIFT = SHIFT - CTEMP*ZLADIV( CTEMP, ( X+Y ) )
END IF END IF
ELSE ELSE
* *