snrm2.f

          REAL FUNCTION SNRM2(N,X,INCX)
    *     .. Scalar Arguments ..
          INTEGER INCX,N
    *     ..
    *     .. Array Arguments ..
          REAL X(*)
    *     ..
    *
    *  Purpose
    *  =======
    *
    *  SNRM2 returns the euclidean norm of a vector via the function
    *  name, so that
    *
    *     SNRM2 := sqrt( x'*x ).
    *
    *  Further Details
    *  ===============
    *
    *  -- This version written on 25-October-1982.
    *     Modified on 14-October-1993 to inline the call to SLASSQ.
    *     Sven Hammarling, Nag Ltd.
    *
    *
    *     .. Parameters ..
          REAL ONE,ZERO
          PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
    *     ..
    *     .. Local Scalars ..
          REAL ABSXI,NORM,SCALE,SSQ
          INTEGER IX
    *     ..
    *     .. Intrinsic Functions ..
          INTRINSIC ABS,SQRT
    *     ..
          IF (N.LT.1 .OR. INCX.LT.1) THEN
              NORM = ZERO
          ELSE IF (N.EQ.1) THEN
              NORM = ABS(X(1))
          ELSE
              SCALE = ZERO
              SSQ = ONE
    *        The following loop is equivalent to this call to the LAPACK
    *        auxiliary routine:
    *        CALL SLASSQ( N, X, INCX, SCALE, SSQ )
    *
              DO 10 IX = 1,1 + (N-1)*INCX,INCX
                  IF (X(IX).NE.ZERO) THEN
                      ABSXI = ABS(X(IX))
                      IF (SCALE.LT.ABSXI) THEN
                          SSQ = ONE + SSQ* (SCALE/ABSXI)**2
                          SCALE = ABSXI
                      ELSE
                          SSQ = SSQ + (ABSXI/SCALE)**2
                      END IF
                  END IF
       10     CONTINUE
              NORM = SCALE*SQRT(SSQ)
          END IF
    *
          SNRM2 = NORM
          RETURN
    *
    *     End of SNRM2.
    *
          END