sci2c arduino updated

1 files changed, 145 insertions, 0 deletions

diff --git a/src/fortran/lapack/zlarfg.f b/src/fortran/lapack/zlarfg.f
new file mode 100644
index 0000000..d024f92
--- /dev/null
+++ b/src/fortran/lapack/zlarfg.f
@@ -0,0 +1,145 @@
+      SUBROUTINE ZLARFG( N, ALPHA, X, INCX, TAU )
+*
+*  -- LAPACK auxiliary routine (version 3.1) --
+*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+*     November 2006
+*
+*     .. Scalar Arguments ..
+      INTEGER            INCX, N
+      COMPLEX*16         ALPHA, TAU
+*     ..
+*     .. Array Arguments ..
+      COMPLEX*16         X( * )
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  ZLARFG generates a complex elementary reflector H of order n, such
+*  that
+*
+*        H' * ( alpha ) = ( beta ),   H' * H = I.
+*             (   x   )   (   0  )
+*
+*  where alpha and beta are scalars, with beta real, and x is an
+*  (n-1)-element complex vector. H is represented in the form
+*
+*        H = I - tau * ( 1 ) * ( 1 v' ) ,
+*                      ( v )
+*
+*  where tau is a complex scalar and v is a complex (n-1)-element
+*  vector. Note that H is not hermitian.
+*
+*  If the elements of x are all zero and alpha is real, then tau = 0
+*  and H is taken to be the unit matrix.
+*
+*  Otherwise  1 <= real(tau) <= 2  and  abs(tau-1) <= 1 .
+*
+*  Arguments
+*  =========
+*
+*  N       (input) INTEGER
+*          The order of the elementary reflector.
+*
+*  ALPHA   (input/output) COMPLEX*16
+*          On entry, the value alpha.
+*          On exit, it is overwritten with the value beta.
+*
+*  X       (input/output) COMPLEX*16 array, dimension
+*                         (1+(N-2)*abs(INCX))
+*          On entry, the vector x.
+*          On exit, it is overwritten with the vector v.
+*
+*  INCX    (input) INTEGER
+*          The increment between elements of X. INCX > 0.
+*
+*  TAU     (output) COMPLEX*16
+*          The value tau.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION   ONE, ZERO
+      PARAMETER          ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+*     ..
+*     .. Local Scalars ..
+      INTEGER            J, KNT
+      DOUBLE PRECISION   ALPHI, ALPHR, BETA, RSAFMN, SAFMIN, XNORM
+*     ..
+*     .. External Functions ..
+      DOUBLE PRECISION   DLAMCH, DLAPY3, DZNRM2
+      COMPLEX*16         ZLADIV
+      EXTERNAL           DLAMCH, DLAPY3, DZNRM2, ZLADIV
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC          ABS, DBLE, DCMPLX, DIMAG, SIGN
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL           ZDSCAL, ZSCAL
+*     ..
+*     .. Executable Statements ..
+*
+      IF( N.LE.0 ) THEN
+         TAU = ZERO
+         RETURN
+      END IF
+*
+      XNORM = DZNRM2( N-1, X, INCX )
+      ALPHR = DBLE( ALPHA )
+      ALPHI = DIMAG( ALPHA )
+*
+      IF( XNORM.EQ.ZERO .AND. ALPHI.EQ.ZERO ) THEN
+*
+*        H  =  I
+*
+         TAU = ZERO
+      ELSE
+*
+*        general case
+*
+         BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+         SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+         RSAFMN = ONE / SAFMIN
+*
+         IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+*           XNORM, BETA may be inaccurate; scale X and recompute them
+*
+            KNT = 0
+   10       CONTINUE
+            KNT = KNT + 1
+            CALL ZDSCAL( N-1, RSAFMN, X, INCX )
+            BETA = BETA*RSAFMN
+            ALPHI = ALPHI*RSAFMN
+            ALPHR = ALPHR*RSAFMN
+            IF( ABS( BETA ).LT.SAFMIN )
+     $         GO TO 10
+*
+*           New BETA is at most 1, at least SAFMIN
+*
+            XNORM = DZNRM2( N-1, X, INCX )
+            ALPHA = DCMPLX( ALPHR, ALPHI )
+            BETA = -SIGN( DLAPY3( ALPHR, ALPHI, XNORM ), ALPHR )
+            TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+            ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
+            CALL ZSCAL( N-1, ALPHA, X, INCX )
+*
+*           If ALPHA is subnormal, it may lose relative accuracy
+*
+            ALPHA = BETA
+            DO 20 J = 1, KNT
+               ALPHA = ALPHA*SAFMIN
+   20       CONTINUE
+         ELSE
+            TAU = DCMPLX( ( BETA-ALPHR ) / BETA, -ALPHI / BETA )
+            ALPHA = ZLADIV( DCMPLX( ONE ), ALPHA-BETA )
+            CALL ZSCAL( N-1, ALPHA, X, INCX )
+            ALPHA = BETA
+         END IF
+      END IF
+*
+      RETURN
+*
+*     End of ZLARFG
+*
+      END