d7/df1/snrm2_8f_source.html

00001       REAL FUNCTION SNRM2(N,X,INCX)
00002 *     .. Scalar Arguments ..
00003       INTEGER INCX,N
00004 *     ..
00005 *     .. Array Arguments ..
00006       REAL X(*)
00007 *     ..
00008 *
00009 *  Purpose
00010 *  =======
00011 *
00012 *  SNRM2 returns the euclidean norm of a vector via the function
00013 *  name, so that
00014 *
00015 *     SNRM2 := sqrt( x'*x ).
00016 *
00017 *  Further Details
00018 *  ===============
00019 *
00020 *  -- This version written on 25-October-1982.
00021 *     Modified on 14-October-1993 to inline the call to SLASSQ.
00022 *     Sven Hammarling, Nag Ltd.
00023 *
00024 *  =====================================================================
00025 *
00026 *     .. Parameters ..
00027       REAL ONE,ZERO
00028       PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
00029 *     ..
00030 *     .. Local Scalars ..
00031       REAL ABSXI,NORM,SCALE,SSQ
00032       INTEGER IX
00033 *     ..
00034 *     .. Intrinsic Functions ..
00035       INTRINSIC ABS,SQRT
00036 *     ..
00037       IF (N.LT.1 .OR. INCX.LT.1) THEN
00038           NORM = ZERO
00039       ELSE IF (N.EQ.1) THEN
00040           NORM = ABS(X(1))
00041       ELSE
00042           SCALE = ZERO
00043           SSQ = ONE
00044 *        The following loop is equivalent to this call to the LAPACK
00045 *        auxiliary routine:
00046 *        CALL SLASSQ( N, X, INCX, SCALE, SSQ )
00047 *
00048           DO 10 IX = 1,1 + (N-1)*INCX,INCX
00049               IF (X(IX).NE.ZERO) THEN
00050                   ABSXI = ABS(X(IX))
00051                   IF (SCALE.LT.ABSXI) THEN
00052                       SSQ = ONE + SSQ* (SCALE/ABSXI)**2
00053                       SCALE = ABSXI
00054                   ELSE
00055                       SSQ = SSQ + (ABSXI/SCALE)**2
00056                   END IF
00057               END IF
00058    10     CONTINUE
00059           NORM = SCALE*SQRT(SSQ)
00060       END IF
00061 *
00062       SNRM2 = NORM
00063       RETURN
00064 *
00065 *     End of SNRM2.
00066 *
00067       END