mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
117 lines
3.4 KiB
Fortran
117 lines
3.4 KiB
Fortran
*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
|