| ! { dg-do run } |
| ! |
| ! PR fortran/33197 |
| ! |
| ! Check implementation of L2 norm (Euclidean vector norm) |
| ! |
| implicit none |
| |
| real :: a(3) = [real :: 1, 2, huge(3.0)] |
| real :: b(3) = [real :: 1, 2, 3] |
| real :: c(4) = [real :: 1, 2, 3, -1] |
| real :: e(0) = [real :: ] |
| real :: f(4) = [real :: 0, 0, 3, 0 ] |
| |
| real :: d(4,1) = RESHAPE ([real :: 1, 2, 3, -1], [4,1]) |
| real :: g(4,1) = RESHAPE ([real :: 0, 0, 4, -1], [4,1]) |
| |
| ! Check compile-time version |
| |
| if (abs (NORM2 ([real :: 1, 2, huge(3.0)]) - huge(3.0)) & |
| > epsilon(0.0)*huge(3.0)) STOP 1 |
| |
| if (abs (SNORM2([real :: 1, 2, huge(3.0)],3) - huge(3.0)) & |
| > epsilon(0.0)*huge(3.0)) STOP 2 |
| |
| if (abs (SNORM2([real :: 1, 2, 3],3) - NORM2([real :: 1, 2, 3])) & |
| > epsilon(0.0)*SNORM2([real :: 1, 2, 3],3)) STOP 3 |
| |
| if (NORM2([real :: ]) /= 0.0) STOP 4 |
| if (abs (NORM2([real :: 0, 0, 3, 0]) - 3.0) > epsilon(0.0)) STOP 5 |
| |
| ! Check TREE version |
| |
| if (abs (NORM2 (a) - huge(3.0)) & |
| > epsilon(0.0)*huge(3.0)) STOP 6 |
| |
| if (abs (SNORM2(b,3) - NORM2(b)) & |
| > epsilon(0.0)*SNORM2(b,3)) STOP 7 |
| |
| if (abs (SNORM2(c,4) - NORM2(c)) & |
| > epsilon(0.0)*SNORM2(c,4)) STOP 8 |
| |
| if (ANY (abs (abs(d(:,1)) - NORM2(d, 2)) & |
| > epsilon(0.0))) STOP 9 |
| |
| ! Check libgfortran version |
| |
| if (ANY (abs (SNORM2(d,4) - NORM2(d, 1)) & |
| > epsilon(0.0)*SNORM2(d,4))) STOP 10 |
| |
| if (abs (SNORM2(f,4) - NORM2(f, 1)) & |
| > epsilon(0.0)*SNORM2(d,4)) STOP 11 |
| |
| if (ANY (abs (abs(g(:,1)) - NORM2(g, 2)) & |
| > epsilon(0.0))) STOP 12 |
| |
| contains |
| ! NORM2 algorithm based on BLAS, cf. |
| ! http://www.netlib.org/blas/snrm2.f |
| REAL FUNCTION SNORM2 (X,n) |
| INTEGER, INTENT(IN) :: n |
| REAL, INTENT(IN) :: X(n) |
| |
| REAL :: absXi, scale, SSQ |
| INTEGER :: i |
| |
| INTRINSIC :: ABS, SQRT |
| |
| IF (N < 1) THEN |
| snorm2 = 0.0 |
| ELSE IF (N == 1) THEN |
| snorm2 = ABS(X(1)) |
| ELSE |
| scale = 0.0 |
| SSQ = 1.0 |
| |
| DO i = 1, N |
| IF (X(i) /= 0.0) THEN |
| absXi = ABS(X(i)) |
| IF (scale < absXi) THEN |
| SSQ = 1.0 + SSQ * (scale/absXi)**2 |
| scale = absXi |
| ELSE |
| SSQ = SSQ + (absXi/scale)**2 |
| END IF |
| END IF |
| END DO |
| snorm2 = scale * SQRT(SSQ) |
| END IF |
| END FUNCTION SNORM2 |
| end |
