Original Version

1 files changed, 205 insertions, 0 deletions

diff --git a/src/fortran/lapack/dlanv2.f b/src/fortran/lapack/dlanv2.f
new file mode 100644
index 0000000..cef3f47
--- /dev/null
+++ b/src/fortran/lapack/dlanv2.f
@@ -0,0 +1,205 @@
+      SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
+*
+*  -- LAPACK driver routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION   A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
+*  matrix in standard form:
+*
+*       [ A  B ] = [ CS -SN ] [ AA  BB ] [ CS  SN ]
+*       [ C  D ]   [ SN  CS ] [ CC  DD ] [-SN  CS ]
+*
+*  where either
+*  1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
+*  2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
+*  conjugate eigenvalues.
+*
+*  Arguments
+*  =========
+*
+*  A       (input/output) DOUBLE PRECISION
+*  B       (input/output) DOUBLE PRECISION
+*  C       (input/output) DOUBLE PRECISION
+*  D       (input/output) DOUBLE PRECISION
+*          On entry, the elements of the input matrix.
+*          On exit, they are overwritten by the elements of the
+*          standardised Schur form.
+*
+*  RT1R    (output) DOUBLE PRECISION
+*  RT1I    (output) DOUBLE PRECISION
+*  RT2R    (output) DOUBLE PRECISION
+*  RT2I    (output) DOUBLE PRECISION
+*          The real and imaginary parts of the eigenvalues. If the
+*          eigenvalues are a complex conjugate pair, RT1I > 0.
+*
+*  CS      (output) DOUBLE PRECISION
+*  SN      (output) DOUBLE PRECISION
+*          Parameters of the rotation matrix.
+*
+*  Further Details
+*  ===============
+*
+*  Modified by V. Sima, Research Institute for Informatics, Bucharest,
+*  Romania, to reduce the risk of cancellation errors,
+*  when computing real eigenvalues, and to ensure, if possible, that
+*  abs(RT1R) >= abs(RT2R).
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ZERO, HALF, ONE
+      PARAMETER          ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+      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
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY2
+      EXTERNAL           DLAMCH, DLAPY2
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, MAX, MIN, SIGN, SQRT
+*     ..
+*     .. Executable Statements ..
+*
+      EPS = DLAMCH( 'P' )
+      IF( C.EQ.ZERO ) THEN
+         CS = ONE
+         SN = ZERO
+         GO TO 10
+*
+      ELSE IF( B.EQ.ZERO ) THEN
+*
+*        Swap rows and columns
+*
+         CS = ZERO
+         SN = ONE
+         TEMP = D
+         D = A
+         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
+         P = HALF*TEMP
+         BCMAX = MAX( ABS( B ), ABS( C ) )
+         BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
+         SCALE = MAX( ABS( P ), BCMAX )
+         Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
+*
+*        If Z is of the order of the machine accuracy, postpone the
+*        decision on the nature of eigenvalues
+*
+         IF( Z.GE.MULTPL*EPS ) THEN
+*
+*           Real eigenvalues. Compute A and D.
+*
+            Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
+            A = D + Z
+            D = D - ( BCMAX / Z )*BCMIS
+*
+*           Compute B and the rotation matrix
+*
+            TAU = DLAPY2( C, Z )
+            CS = Z / TAU
+            SN = C / TAU
+            B = B - C
+            C = ZERO
+         ELSE
+*
+*           Complex eigenvalues, or real (almost) equal eigenvalues.
+*           Make diagonal elements equal.
+*
+            SIGMA = B + C
+            TAU = DLAPY2( SIGMA, TEMP )
+            CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
+            SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
+*
+*           Compute [ AA  BB ] = [ A  B ] [ CS -SN ]
+*                   [ CC  DD ]   [ C  D ] [ SN  CS ]
+*
+            AA = A*CS + B*SN
+            BB = -A*SN + B*CS
+            CC = C*CS + D*SN
+            DD = -C*SN + D*CS
+*
+*           Compute [ A  B ] = [ CS  SN ] [ AA  BB ]
+*                   [ C  D ]   [-SN  CS ] [ CC  DD ]
+*
+            A = AA*CS + CC*SN
+            B = BB*CS + DD*SN
+            C = -AA*SN + CC*CS
+            D = -BB*SN + DD*CS
+*
+            TEMP = HALF*( A+D )
+            A = TEMP
+            D = TEMP
+*
+            IF( C.NE.ZERO ) THEN
+               IF( B.NE.ZERO ) THEN
+                  IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
+*
+*                    Real eigenvalues: reduce to upper triangular form
+*
+                     SAB = SQRT( ABS( B ) )
+                     SAC = SQRT( ABS( C ) )
+                     P = SIGN( SAB*SAC, C )
+                     TAU = ONE / SQRT( ABS( B+C ) )
+                     A = TEMP + P
+                     D = TEMP - P
+                     B = B - C
+                     C = ZERO
+                     CS1 = SAB*TAU
+                     SN1 = SAC*TAU
+                     TEMP = CS*CS1 - SN*SN1
+                     SN = CS*SN1 + SN*CS1
+                     CS = TEMP
+                  END IF
+               ELSE
+                  B = -C
+                  C = ZERO
+                  TEMP = CS
+                  CS = -SN
+                  SN = TEMP
+               END IF
+            END IF
+         END IF
+*
+      END IF
+*
+   10 CONTINUE
+*
+*     Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
+*
+      RT1R = A
+      RT2R = D
+      IF( C.EQ.ZERO ) THEN
+         RT1I = ZERO
+         RT2I = ZERO
+      ELSE
+         RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
+         RT2I = -RT1I
+      END IF
+      RETURN
+*
+*     End of DLANV2
+*
+      END