vendor/gonum.org/v1/gonum/lapack/internal/testdata/netlib/dnrm2.f

   1 *> \brief \b DNRM2
   2 *
   3 *  =========== DOCUMENTATION ===========
   4 *
   5 * Online html documentation available at
   6 *            http://www.netlib.org/lapack/explore-html/
   7 *
   8 *  Definition:
   9 *  ===========
  10 *
  11 *       DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
  12 *
  13 *       .. Scalar Arguments ..
  14 *       INTEGER INCX,N
  15 *       ..
  16 *       .. Array Arguments ..
  17 *       DOUBLE PRECISION X(*)
  18 *       ..
  19 *
  20 *
  21 *> \par Purpose:
  22 *  =============
  23 *>
  24 *> \verbatim
  25 *>
  26 *> DNRM2 returns the euclidean norm of a vector via the function
  27 *> name, so that
  28 *>
  29 *>    DNRM2 := sqrt( x'*x )
  30 *> \endverbatim
  31 *
  32 *  Authors:
  33 *  ========
  34 *
  35 *> \author Univ. of Tennessee
  36 *> \author Univ. of California Berkeley
  37 *> \author Univ. of Colorado Denver
  38 *> \author NAG Ltd.
  39 *
  40 *> \date November 2011
  41 *
  42 *> \ingroup double_blas_level1
  43 *
  44 *> \par Further Details:
  45 *  =====================
  46 *>
  47 *> \verbatim
  48 *>
  49 *>  -- This version written on 25-October-1982.
  50 *>     Modified on 14-October-1993 to inline the call to DLASSQ.
  51 *>     Sven Hammarling, Nag Ltd.
  52 *> \endverbatim
  53 *>
  54 *  =====================================================================
  55       DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
  56 *
  57 *  -- Reference BLAS level1 routine (version 3.4.0) --
  58 *  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
  59 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
  60 *     November 2011
  61 *
  62 *     .. Scalar Arguments ..
  63       INTEGER INCX,N
  64 *     ..
  65 *     .. Array Arguments ..
  66       DOUBLE PRECISION X(*)
  67 *     ..
  68 *
  69 *  =====================================================================
  70 *
  71 *     .. Parameters ..
  72       DOUBLE PRECISION ONE,ZERO
  73       PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
  74 *     ..
  75 *     .. Local Scalars ..
  76       DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
  77       INTEGER IX
  78 *     ..
  79 *     .. Intrinsic Functions ..
  80       INTRINSIC ABS,SQRT
  81 *     ..
  82       IF (N.LT.1 .OR. INCX.LT.1) THEN
  83           NORM = ZERO
  84       ELSE IF (N.EQ.1) THEN
  85           NORM = ABS(X(1))
  86       ELSE
  87           SCALE = ZERO
  88           SSQ = ONE
  89 *        The following loop is equivalent to this call to the LAPACK
  90 *        auxiliary routine:
  91 *        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
  92 *
  93           DO 10 IX = 1,1 + (N-1)*INCX,INCX
  94               IF (X(IX).NE.ZERO) THEN
  95                   ABSXI = ABS(X(IX))
  96                   IF (SCALE.LT.ABSXI) THEN
  97                       SSQ = ONE + SSQ* (SCALE/ABSXI)**2
  98                       SCALE = ABSXI
  99                   ELSE
 100                       SSQ = SSQ + (ABSXI/SCALE)**2
 101                   END IF
 102               END IF
 103    10     CONTINUE
 104           NORM = SCALE*SQRT(SSQ)
 105       END IF
 106 *
 107       DNRM2 = NORM
 108       RETURN
 109 *
 110 *     End of DNRM2.
 111 *
 112       END