--- rpl/lapack/lapack/dlanv2.f 2016/08/27 15:34:28 1.15
+++ rpl/lapack/lapack/dlanv2.f 2023/08/07 08:38:55 1.20
@@ -2,28 +2,28 @@
*
* =========== DOCUMENTATION ===========
*
-* Online html documentation available at
-* http://www.netlib.org/lapack/explore-html/
+* Online html documentation available at
+* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
-*> Download DLANV2 + dependencies
-*>
-*> [TGZ]
-*>
-*> [ZIP]
-*>
+*> Download DLANV2 + dependencies
+*>
+*> [TGZ]
+*>
+*> [ZIP]
+*>
*> [TXT]
-*> \endhtmlonly
+*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
-*
+*
* .. Scalar Arguments ..
* DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
* ..
-*
+*
*
*> \par Purpose:
* =============
@@ -104,12 +104,10 @@
* Authors:
* ========
*
-*> \author Univ. of Tennessee
-*> \author Univ. of California Berkeley
-*> \author Univ. of Colorado Denver
-*> \author NAG Ltd.
-*
-*> \date September 2012
+*> \author Univ. of Tennessee
+*> \author Univ. of California Berkeley
+*> \author Univ. of Colorado Denver
+*> \author NAG Ltd.
*
*> \ingroup doubleOTHERauxiliary
*
@@ -127,10 +125,9 @@
* =====================================================================
SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
*
-* -- LAPACK auxiliary routine (version 3.4.2) --
+* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
-* September 2012
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
@@ -139,14 +136,17 @@
* =====================================================================
*
* .. Parameters ..
- DOUBLE PRECISION ZERO, HALF, ONE
- PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0,
+ $ TWO = 2.0D0 )
DOUBLE PRECISION MULTPL
PARAMETER ( MULTPL = 4.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
- $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
+ $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z, SAFMIN,
+ $ SAFMN2, SAFMX2
+ INTEGER COUNT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
@@ -157,11 +157,14 @@
* ..
* .. Executable Statements ..
*
+ SAFMIN = DLAMCH( 'S' )
EPS = DLAMCH( 'P' )
+ SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+ $ LOG( DLAMCH( 'B' ) ) / TWO )
+ SAFMX2 = ONE / SAFMN2
IF( C.EQ.ZERO ) THEN
CS = ONE
SN = ZERO
- GO TO 10
*
ELSE IF( B.EQ.ZERO ) THEN
*
@@ -174,12 +177,12 @@
A = TEMP
B = -C
C = ZERO
- GO TO 10
+*
ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) )
$ THEN
CS = ONE
SN = ZERO
- GO TO 10
+*
ELSE
*
TEMP = A - D
@@ -207,12 +210,30 @@
SN = C / TAU
B = B - C
C = ZERO
+*
ELSE
*
* Complex eigenvalues, or real (almost) equal eigenvalues.
* Make diagonal elements equal.
*
+ COUNT = 0
SIGMA = B + C
+ 10 CONTINUE
+ COUNT = COUNT + 1
+ SCALE = MAX( ABS(TEMP), ABS(SIGMA) )
+ IF( SCALE.GE.SAFMX2 ) THEN
+ SIGMA = SIGMA * SAFMN2
+ TEMP = TEMP * SAFMN2
+ IF (COUNT .LE. 20)
+ $ GOTO 10
+ END IF
+ IF( SCALE.LE.SAFMN2 ) THEN
+ SIGMA = SIGMA * SAFMX2
+ TEMP = TEMP * SAFMX2
+ IF (COUNT .LE. 20)
+ $ GOTO 10
+ END IF
+ P = HALF*TEMP
TAU = DLAPY2( SIGMA, TEMP )
CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
@@ -269,8 +290,6 @@
*
END IF
*
- 10 CONTINUE
-*
* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
*
RT1R = A