1 /* blas/scnrm2.f -- translated by f2c (version 20050501).
2 You must link the resulting object file with libf2c:
3 on Microsoft Windows system, link with libf2c.lib;
4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm
5 or, if you install libf2c.a in a standard place, with -lf2c -lm
6 -- in that order, at the end of the command line, as in
7 cc *.o -lf2c -lm
8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
9
10 http://www.netlib.org/f2c/libf2c.zip
11 */
12
13 #ifdef __cplusplus
14 extern "C" {
15 #endif
16 #include "v3p_netlib.h"
17
18 /*< REAL FUNCTION SCNRM2( N, X, INCX ) >*/
scnrm2_(integer * n,complex * x,integer * incx)19 doublereal scnrm2_(integer *n, complex *x, integer *incx)
20 {
21 /* System generated locals */
22 integer i__1, i__2, i__3;
23 real ret_val, r__1;
24
25 /* Builtin functions */
26 double r_imag(complex *), sqrt(doublereal);
27
28 /* Local variables */
29 integer ix;
30 real ssq, temp, norm, scale;
31
32 /* .. Scalar Arguments .. */
33 /*< INTEGER INCX, N >*/
34 /* .. Array Arguments .. */
35 /*< COMPLEX X( * ) >*/
36 /* .. */
37
38 /* SCNRM2 returns the euclidean norm of a vector via the function */
39 /* name, so that */
40
41 /* SCNRM2 := sqrt( conjg( x' )*x ) */
42
43
44
45 /* -- This version written on 25-October-1982. */
46 /* Modified on 14-October-1993 to inline the call to CLASSQ. */
47 /* Sven Hammarling, Nag Ltd. */
48
49
50 /* .. Parameters .. */
51 /*< REAL ONE , ZERO >*/
52 /*< PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 ) >*/
53 /* .. Local Scalars .. */
54 /*< INTEGER IX >*/
55 /*< REAL NORM, SCALE, SSQ, TEMP >*/
56 /* .. Intrinsic Functions .. */
57 /*< INTRINSIC ABS, AIMAG, REAL, SQRT >*/
58 /* .. */
59 /* .. Executable Statements .. */
60 /*< IF( N.LT.1 .OR. INCX.LT.1 )THEN >*/
61 /* Parameter adjustments */
62 --x;
63
64 /* Function Body */
65 if (*n < 1 || *incx < 1) {
66 /*< NORM = ZERO >*/
67 norm = (float)0.;
68 /*< ELSE >*/
69 } else {
70 /*< SCALE = ZERO >*/
71 scale = (float)0.;
72 /*< SSQ = ONE >*/
73 ssq = (float)1.;
74 /* The following loop is equivalent to this call to the LAPACK */
75 /* auxiliary routine: */
76 /* CALL CLASSQ( N, X, INCX, SCALE, SSQ ) */
77
78 /*< DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX >*/
79 i__1 = (*n - 1) * *incx + 1;
80 i__2 = *incx;
81 for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
82 /*< IF( REAL( X( IX ) ).NE.ZERO )THEN >*/
83 i__3 = ix;
84 if (x[i__3].r != (float)0.) {
85 /*< TEMP = ABS( REAL( X( IX ) ) ) >*/
86 i__3 = ix;
87 temp = (r__1 = x[i__3].r, dabs(r__1));
88 /*< IF( SCALE.LT.TEMP )THEN >*/
89 if (scale < temp) {
90 /*< SSQ = ONE + SSQ*( SCALE/TEMP )**2 >*/
91 /* Computing 2nd power */
92 r__1 = scale / temp;
93 ssq = ssq * (r__1 * r__1) + (float)1.;
94 /*< SCALE = TEMP >*/
95 scale = temp;
96 /*< ELSE >*/
97 } else {
98 /*< SSQ = SSQ + ( TEMP/SCALE )**2 >*/
99 /* Computing 2nd power */
100 r__1 = temp / scale;
101 ssq += r__1 * r__1;
102 /*< END IF >*/
103 }
104 /*< END IF >*/
105 }
106 /*< IF( AIMAG( X( IX ) ).NE.ZERO )THEN >*/
107 if (r_imag(&x[ix]) != (float)0.) {
108 /*< TEMP = ABS( AIMAG( X( IX ) ) ) >*/
109 temp = (r__1 = r_imag(&x[ix]), dabs(r__1));
110 /*< IF( SCALE.LT.TEMP )THEN >*/
111 if (scale < temp) {
112 /*< SSQ = ONE + SSQ*( SCALE/TEMP )**2 >*/
113 /* Computing 2nd power */
114 r__1 = scale / temp;
115 ssq = ssq * (r__1 * r__1) + (float)1.;
116 /*< SCALE = TEMP >*/
117 scale = temp;
118 /*< ELSE >*/
119 } else {
120 /*< SSQ = SSQ + ( TEMP/SCALE )**2 >*/
121 /* Computing 2nd power */
122 r__1 = temp / scale;
123 ssq += r__1 * r__1;
124 /*< END IF >*/
125 }
126 /*< END IF >*/
127 }
128 /*< 10 CONTINUE >*/
129 /* L10: */
130 }
131 /*< NORM = SCALE * SQRT( SSQ ) >*/
132 norm = scale * sqrt(ssq);
133 /*< END IF >*/
134 }
135
136 /*< SCNRM2 = NORM >*/
137 ret_val = norm;
138 /*< RETURN >*/
139 return ret_val;
140
141 /* End of SCNRM2. */
142
143 /*< END >*/
144 } /* scnrm2_ */
145
146 #ifdef __cplusplus
147 }
148 #endif
149