Mac binaries

[jabaws.git] / website / archive / binaries / mac / src / disembl / Tisean_3.0.1 / source_f / slatec / enorm.f

diff --git a/website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f b/website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f
new file mode 100644 (file)
index 0000000..7eeda1e
--- /dev/null
+++ b/website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f
@@ -0,0 +1,117 @@
+*DECK ENORM
+      REAL FUNCTION ENORM (N, X)
+C***BEGIN PROLOGUE  ENORM
+C***SUBSIDIARY
+C***PURPOSE  Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE
+C***LIBRARY   SLATEC
+C***TYPE      SINGLE PRECISION (ENORM-S, DENORM-D)
+C***AUTHOR  (UNKNOWN)
+C***DESCRIPTION
+C
+C     Given an N-vector X, this function calculates the
+C     Euclidean norm of X.
+C
+C     The Euclidean norm is computed by accumulating the sum of
+C     squares in three different sums. The sums of squares for the
+C     small and large components are scaled so that no overflows
+C     occur. Non-destructive underflows are permitted. Underflows
+C     and overflows do not occur in the computation of the unscaled
+C     sum of squares for the intermediate components.
+C     The definitions of small, intermediate and large components
+C     depend on two constants, RDWARF and RGIANT. The main
+C     restrictions on these constants are that RDWARF**2 not
+C     underflow and RGIANT**2 not overflow. The constants
+C     given here are suitable for every known computer.
+C
+C     The function statement is
+C
+C       REAL FUNCTION ENORM(N,X)
+C
+C     where
+C
+C       N is a positive integer input variable.
+C
+C       X is an input array of length N.
+C
+C***SEE ALSO  SNLS1, SNLS1E, SNSQ, SNSQE
+C***ROUTINES CALLED  (NONE)
+C***REVISION HISTORY  (YYMMDD)
+C   800301  DATE WRITTEN
+C   890831  Modified array declarations.  (WRB)
+C   891214  Prologue converted to Version 4.0 format.  (BAB)
+C   900326  Removed duplicate information from DESCRIPTION section.
+C           (WRB)
+C   900328  Added TYPE section.  (WRB)
+C***END PROLOGUE  ENORM
+      INTEGER N
+      REAL X(*)
+      INTEGER I
+      REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX,
+     1     ZERO
+      SAVE ONE, ZERO, RDWARF, RGIANT
+      DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/
+C***FIRST EXECUTABLE STATEMENT  ENORM
+      S1 = ZERO
+      S2 = ZERO
+      S3 = ZERO
+      X1MAX = ZERO
+      X3MAX = ZERO
+      FLOATN = N
+      AGIANT = RGIANT/FLOATN
+      DO 90 I = 1, N
+         XABS = ABS(X(I))
+         IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70
+            IF (XABS .LE. RDWARF) GO TO 30
+C
+C              SUM FOR LARGE COMPONENTS.
+C
+               IF (XABS .LE. X1MAX) GO TO 10
+                  S1 = ONE + S1*(X1MAX/XABS)**2
+                  X1MAX = XABS
+                  GO TO 20
+   10          CONTINUE
+                  S1 = S1 + (XABS/X1MAX)**2
+   20          CONTINUE
+               GO TO 60
+   30       CONTINUE
+C
+C              SUM FOR SMALL COMPONENTS.
+C
+               IF (XABS .LE. X3MAX) GO TO 40
+                  S3 = ONE + S3*(X3MAX/XABS)**2
+                  X3MAX = XABS
+                  GO TO 50
+   40          CONTINUE
+                  IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2
+   50          CONTINUE
+   60       CONTINUE
+            GO TO 80
+   70    CONTINUE
+C
+C           SUM FOR INTERMEDIATE COMPONENTS.
+C
+            S2 = S2 + XABS**2
+   80    CONTINUE
+   90    CONTINUE
+C
+C     CALCULATION OF NORM.
+C
+      IF (S1 .EQ. ZERO) GO TO 100
+         ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX)
+         GO TO 130
+  100 CONTINUE
+         IF (S2 .EQ. ZERO) GO TO 110
+            IF (S2 .GE. X3MAX)
+     1         ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
+            IF (S2 .LT. X3MAX)
+     1         ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
+            GO TO 120
+  110    CONTINUE
+            ENORM = X3MAX*SQRT(S3)
+  120    CONTINUE
+  130 CONTINUE
+      RETURN
+C
+C     LAST CARD OF FUNCTION ENORM.
+C
+      END