1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
|
#include <math.h> /* Needed for fabs() and sqrt() */
#include "blas.h"
double dnrm2_(int *n, double *x, int *incx)
{
long int ix, nn, iincx;
double norm, scale, absxi, ssq, temp;
/* DNRM2 returns the euclidean norm of a vector via the function
name, so that
DNRM2 := sqrt( x'*x )
-- This version written on 25-October-1982.
Modified on 14-October-1993 to inline the call to SLASSQ.
Sven Hammarling, Nag Ltd. */
/* Dereference inputs */
nn = *n;
iincx = *incx;
if( nn > 0 && iincx > 0 )
{
if (nn == 1)
{
norm = fabs(x[0]);
}
else
{
scale = 0.0;
ssq = 1.0;
/* The following loop is equivalent to this call to the LAPACK
auxiliary routine: CALL SLASSQ( N, X, INCX, SCALE, SSQ ) */
for (ix=(nn-1)*iincx; ix>=0; ix-=iincx)
{
if (x[ix] != 0.0)
{
absxi = fabs(x[ix]);
if (scale < absxi)
{
temp = scale / absxi;
ssq = ssq * (temp * temp) + 1.0;
scale = absxi;
}
else
{
temp = absxi / scale;
ssq += temp * temp;
}
}
}
norm = scale * sqrt(ssq);
}
}
else
norm = 0.0;
return norm;
} /* dnrm2_ */
|
