OpenCores
URL https://opencores.org/ocsvn/openrisc/openrisc/trunk

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-dev/] [or1k-gcc/] [gcc/] [testsuite/] [gfortran.dg/] [norm2_1.f90] - Blame information for rev 694

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 694 jeremybenn
! { 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

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.