website/archive/binaries/mac/src/disembl/Tisean_3.0.1/source_f/slatec/enorm.f

   1 *DECK ENORM
   2       REAL FUNCTION ENORM (N, X)
   3 C***BEGIN PROLOGUE  ENORM
   4 C***SUBSIDIARY
   5 C***PURPOSE  Subsidiary to SNLS1, SNLS1E, SNSQ and SNSQE
   6 C***LIBRARY   SLATEC
   7 C***TYPE      SINGLE PRECISION (ENORM-S, DENORM-D)
   8 C***AUTHOR  (UNKNOWN)
   9 C***DESCRIPTION
  10 C
  11 C     Given an N-vector X, this function calculates the
  12 C     Euclidean norm of X.
  13 C
  14 C     The Euclidean norm is computed by accumulating the sum of
  15 C     squares in three different sums. The sums of squares for the
  16 C     small and large components are scaled so that no overflows
  17 C     occur. Non-destructive underflows are permitted. Underflows
  18 C     and overflows do not occur in the computation of the unscaled
  19 C     sum of squares for the intermediate components.
  20 C     The definitions of small, intermediate and large components
  21 C     depend on two constants, RDWARF and RGIANT. The main
  22 C     restrictions on these constants are that RDWARF**2 not
  23 C     underflow and RGIANT**2 not overflow. The constants
  24 C     given here are suitable for every known computer.
  25 C
  26 C     The function statement is
  27 C
  28 C       REAL FUNCTION ENORM(N,X)
  29 C
  30 C     where
  31 C
  32 C       N is a positive integer input variable.
  33 C
  34 C       X is an input array of length N.
  35 C
  36 C***SEE ALSO  SNLS1, SNLS1E, SNSQ, SNSQE
  37 C***ROUTINES CALLED  (NONE)
  38 C***REVISION HISTORY  (YYMMDD)
  39 C   800301  DATE WRITTEN
  40 C   890831  Modified array declarations.  (WRB)
  41 C   891214  Prologue converted to Version 4.0 format.  (BAB)
  42 C   900326  Removed duplicate information from DESCRIPTION section.
  43 C           (WRB)
  44 C   900328  Added TYPE section.  (WRB)
  45 C***END PROLOGUE  ENORM
  46       INTEGER N
  47       REAL X(*)
  48       INTEGER I
  49       REAL AGIANT,FLOATN,ONE,RDWARF,RGIANT,S1,S2,S3,XABS,X1MAX,X3MAX,
  50      1     ZERO
  51       SAVE ONE, ZERO, RDWARF, RGIANT
  52       DATA ONE,ZERO,RDWARF,RGIANT /1.0E0,0.0E0,3.834E-20,1.304E19/
  53 C***FIRST EXECUTABLE STATEMENT  ENORM
  54       S1 = ZERO
  55       S2 = ZERO
  56       S3 = ZERO
  57       X1MAX = ZERO
  58       X3MAX = ZERO
  59       FLOATN = N
  60       AGIANT = RGIANT/FLOATN
  61       DO 90 I = 1, N
  62          XABS = ABS(X(I))
  63          IF (XABS .GT. RDWARF .AND. XABS .LT. AGIANT) GO TO 70
  64             IF (XABS .LE. RDWARF) GO TO 30
  65 C
  66 C              SUM FOR LARGE COMPONENTS.
  67 C
  68                IF (XABS .LE. X1MAX) GO TO 10
  69                   S1 = ONE + S1*(X1MAX/XABS)**2
  70                   X1MAX = XABS
  71                   GO TO 20
  72    10          CONTINUE
  73                   S1 = S1 + (XABS/X1MAX)**2
  74    20          CONTINUE
  75                GO TO 60
  76    30       CONTINUE
  77 C
  78 C              SUM FOR SMALL COMPONENTS.
  79 C
  80                IF (XABS .LE. X3MAX) GO TO 40
  81                   S3 = ONE + S3*(X3MAX/XABS)**2
  82                   X3MAX = XABS
  83                   GO TO 50
  84    40          CONTINUE
  85                   IF (XABS .NE. ZERO) S3 = S3 + (XABS/X3MAX)**2
  86    50          CONTINUE
  87    60       CONTINUE
  88             GO TO 80
  89    70    CONTINUE
  90 C
  91 C           SUM FOR INTERMEDIATE COMPONENTS.
  92 C
  93             S2 = S2 + XABS**2
  94    80    CONTINUE
  95    90    CONTINUE
  96 C
  97 C     CALCULATION OF NORM.
  98 C
  99       IF (S1 .EQ. ZERO) GO TO 100
 100          ENORM = X1MAX*SQRT(S1+(S2/X1MAX)/X1MAX)
 101          GO TO 130
 102   100 CONTINUE
 103          IF (S2 .EQ. ZERO) GO TO 110
 104             IF (S2 .GE. X3MAX)
 105      1         ENORM = SQRT(S2*(ONE+(X3MAX/S2)*(X3MAX*S3)))
 106             IF (S2 .LT. X3MAX)
 107      1         ENORM = SQRT(X3MAX*((S2/X3MAX)+(X3MAX*S3)))
 108             GO TO 120
 109   110    CONTINUE
 110             ENORM = X3MAX*SQRT(S3)
 111   120    CONTINUE
 112   130 CONTINUE
 113       RETURN
 114 C
 115 C     LAST CARD OF FUNCTION ENORM.
 116 C
 117       END