libgomp/testsuite/libgomp.fortran/examples-4/teams-2.f90

   1 ! { dg-do run }
   2
   3 function dotprod_ref (B, C, N) result (sum)
   4   implicit none
   5   real :: B(N), C(N), sum
   6   integer :: N, i
   7   sum = 0.0e0
   8   do i = 1, N
   9     sum = sum + B(i) * C(i)
  10   end do
  11 end function
  12
  13 function dotprod (B, C, N, block_size, num_teams, block_threads) result (sum)
  14   implicit none
  15   real :: B(N), C(N), sum
  16   integer :: N, block_size, num_teams, block_threads, i, i0
  17   sum = 0.0e0
  18   !$omp target map(to: B, C, block_size, num_teams, block_threads) &
  19   !$omp& map(tofrom: sum)
  20     !$omp teams num_teams(num_teams) thread_limit(block_threads) &
  21     !$omp& reduction(+:sum)
  22       !$omp distribute
  23       do i0 = 1, N, block_size
  24         !$omp parallel do reduction(+:sum)
  25         do i = i0, min (i0 + block_size - 1, N)
  26           sum = sum + B(i) * C(i)
  27         end do
  28       end do
  29     !$omp end teams
  30   !$omp end target
  31 end function
  32
  33 subroutine init (B, C, N)
  34   real :: B(N), C(N)
  35   integer :: N, i
  36   do i = 1, N
  37     B(i) = 0.0001 * i
  38     C(i) = 0.000001 * i * i
  39   end do
  40 end subroutine
  41
  42 subroutine check (a, b)
  43   real :: a, b, err
  44   real, parameter :: EPS = 0.0001
  45   if (b == 0.0) then
  46     err = a
  47   else if (a == 0.0) then
  48     err = b
  49   else
  50     err = (a - b) / b
  51   end if
  52   if (err > EPS .or. err < -EPS) STOP 1
  53 end subroutine
  54
  55 program e_54_1
  56   integer :: n
  57   real :: ref, d
  58   real, pointer, dimension(:) :: B, C
  59   n = 1024 * 1024
  60   allocate (B(n), C(n))
  61   call init (B, C, n)
  62   ref = dotprod_ref (B, C, n)
  63   d = dotprod (B, C, n, n / 8, 2, 8)
  64   call check (ref, d)
  65   deallocate (B, C)
  66 end program