gcc/testsuite/gfortran.dg/norm2_1.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/33197
   4 !
   5 ! Check implementation of L2 norm (Euclidean vector norm)
   6 !
   7 implicit none
   8
   9 real :: a(3) = [real :: 1, 2, huge(3.0)]
  10 real :: b(3) = [real :: 1, 2, 3]
  11 real :: c(4) = [real :: 1, 2, 3, -1]
  12 real :: e(0) = [real :: ]
  13 real :: f(4) = [real :: 0, 0, 3, 0 ]
  14
  15 real :: d(4,1) = RESHAPE ([real :: 1, 2, 3, -1], [4,1])
  16 real :: g(4,1) = RESHAPE ([real :: 0, 0, 4, -1], [4,1])
  17
  18 ! Check compile-time version
  19
  20 if (abs (NORM2 ([real :: 1, 2, huge(3.0)])   - huge(3.0)) &
  21     > epsilon(0.0)*huge(3.0)) call abort()
  22
  23 if (abs (SNORM2([real :: 1, 2, huge(3.0)],3) - huge(3.0)) &
  24     > epsilon(0.0)*huge(3.0)) call abort()
  25
  26 if (abs (SNORM2([real :: 1, 2, 3],3) - NORM2([real :: 1, 2, 3])) &
  27     > epsilon(0.0)*SNORM2([real :: 1, 2, 3],3)) call abort()
  28
  29 if (NORM2([real :: ]) /= 0.0) call abort()
  30 if (abs (NORM2([real :: 0, 0, 3, 0]) - 3.0) > epsilon(0.0)) call abort()
  31
  32 ! Check TREE version
  33
  34 if (abs (NORM2 (a)   - huge(3.0)) &
  35     > epsilon(0.0)*huge(3.0)) call abort()
  36
  37 if (abs (SNORM2(b,3) - NORM2(b)) &
  38     > epsilon(0.0)*SNORM2(b,3)) call abort()
  39
  40 if (abs (SNORM2(c,4) - NORM2(c)) &
  41     > epsilon(0.0)*SNORM2(c,4)) call abort()
  42
  43 if (ANY (abs (abs(d(:,1)) - NORM2(d, 2)) &
  44     > epsilon(0.0))) call abort()
  45
  46 ! Check libgfortran version
  47
  48 if (ANY (abs (SNORM2(d,4) - NORM2(d, 1)) &
  49     > epsilon(0.0)*SNORM2(d,4))) call abort()
  50
  51 if (abs (SNORM2(f,4) - NORM2(f, 1)) &
  52     > epsilon(0.0)*SNORM2(d,4)) call abort()
  53
  54 if (ANY (abs (abs(g(:,1)) - NORM2(g, 2)) &
  55     > epsilon(0.0))) call abort()
  56
  57 contains
  58    ! NORM2 algorithm based on BLAS, cf.
  59    ! http://www.netlib.org/blas/snrm2.f
  60    REAL FUNCTION SNORM2 (X,n)
  61       INTEGER, INTENT(IN) :: n
  62       REAL, INTENT(IN) :: X(n)
  63
  64       REAL :: absXi, scale, SSQ
  65       INTEGER :: i
  66
  67       INTRINSIC :: ABS, SQRT
  68
  69       IF (N < 1) THEN
  70         snorm2 = 0.0
  71       ELSE IF (N == 1) THEN
  72         snorm2 = ABS(X(1))
  73       ELSE
  74           scale = 0.0
  75           SSQ = 1.0
  76
  77           DO i = 1, N
  78               IF (X(i) /= 0.0) THEN
  79                   absXi = ABS(X(i))
  80                   IF (scale < absXi) THEN
  81                       SSQ = 1.0 + SSQ * (scale/absXi)**2
  82                       scale = absXi
  83                   ELSE
  84                       SSQ = SSQ + (absXi/scale)**2
  85                   END IF
  86               END IF
  87           END DO
  88           snorm2 = scale * SQRT(SSQ)
  89       END IF
  90    END FUNCTION SNORM2
  91 end