mirror of
https://github.com/autc04/Retro68.git
synced 2024-06-28 11:30:19 +00:00
92 lines
2.2 KiB
Fortran
92 lines
2.2 KiB
Fortran
! { 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
|