| 12266 | } /* sger_ */ |
| 12267 | |
| 12268 | doublereal snrm2_(integer *n, real *x, integer *incx) |
| 12269 | { |
| 12270 | /* System generated locals */ |
| 12271 | integer i__1, i__2; |
| 12272 | real ret_val, r__1; |
| 12273 | |
| 12274 | /* Local variables */ |
| 12275 | static integer ix; |
| 12276 | static real ssq, norm, scale, absxi; |
| 12277 | |
| 12278 | |
| 12279 | /* |
| 12280 | Purpose |
| 12281 | ======= |
| 12282 | |
| 12283 | SNRM2 returns the euclidean norm of a vector via the function |
| 12284 | name, so that |
| 12285 | |
| 12286 | SNRM2 := sqrt( x'*x ). |
| 12287 | |
| 12288 | Further Details |
| 12289 | =============== |
| 12290 | |
| 12291 | -- This version written on 25-October-1982. |
| 12292 | Modified on 14-October-1993 to inline the call to SLASSQ. |
| 12293 | Sven Hammarling, Nag Ltd. |
| 12294 | |
| 12295 | ===================================================================== |
| 12296 | */ |
| 12297 | |
| 12298 | /* Parameter adjustments */ |
| 12299 | --x; |
| 12300 | |
| 12301 | /* Function Body */ |
| 12302 | if (*n < 1 || *incx < 1) { |
| 12303 | norm = 0.f; |
| 12304 | } else if (*n == 1) { |
| 12305 | norm = dabs(x[1]); |
| 12306 | } else { |
| 12307 | scale = 0.f; |
| 12308 | ssq = 1.f; |
| 12309 | /* |
| 12310 | The following loop is equivalent to this call to the LAPACK |
| 12311 | auxiliary routine: |
| 12312 | CALL SLASSQ( N, X, INCX, SCALE, SSQ ) |
| 12313 | */ |
| 12314 | |
| 12315 | i__1 = (*n - 1) * *incx + 1; |
| 12316 | i__2 = *incx; |
| 12317 | for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) { |
| 12318 | if (x[ix] != 0.f) { |
| 12319 | absxi = (r__1 = x[ix], dabs(r__1)); |
| 12320 | if (scale < absxi) { |
| 12321 | /* Computing 2nd power */ |
| 12322 | r__1 = scale / absxi; |
| 12323 | ssq = ssq * (r__1 * r__1) + 1.f; |
| 12324 | scale = absxi; |
| 12325 | } else { |