libgomp/testsuite/libgomp.fortran/do_concurrent_5.f90

   1 ! { dg-do  run }
   2 ! PR 83064 - this used to give wrong results.
   3 ! { dg-additional-options "-O1 -ftree-parallelize-loops=2" }
   4 ! Original test case by Christian Felter
   5
   6 program main
   7     use, intrinsic :: iso_fortran_env
   8     implicit none
   9
  10     integer, parameter :: nsplit = 4
  11     integer(int64), parameter :: ne = 2**20
  12     integer(int64) :: stride, low(nsplit), high(nsplit), i
  13     real(real64), dimension(nsplit) :: pi
  14     integer(int64), dimension(:), allocatable :: edof
  15
  16     allocate (edof(ne))
  17     edof(1::4) = 1
  18     edof(2::4) = 2
  19     edof(3::4) = 3
  20     edof(4::4) = 4
  21
  22     stride = ceiling(real(ne)/nsplit)
  23     do i = 1, nsplit
  24         high(i) = stride*i
  25     end do
  26     do i = 2, nsplit
  27         low(i) = high(i-1) + 1
  28     end do
  29     low(1) = 1
  30     high(nsplit) = ne
  31
  32     pi = 0
  33     do concurrent (i = 1:nsplit)
  34         pi(i) = sum(compute( low(i), high(i) ))
  35     end do
  36     if (abs (sum(pi) - atan(1.0d0)) > 1e-5) STOP 1
  37
  38 contains
  39
  40     pure function compute( low, high ) result( ttt )
  41         integer(int64), intent(in) :: low, high
  42         real(real64), dimension(nsplit) :: ttt
  43         integer(int64) :: j, k
  44
  45         ttt = 0
  46
  47         ! Unrolled loop
  48 !         do j = low, high, 4
  49 !             k = 1
  50 !             ttt(k) = ttt(k) + (-1)**(j+1) / real( 2*j-1 )
  51 !             k = 2
  52 !             ttt(k) = ttt(k) + (-1)**(j+2) / real( 2*j+1 )
  53 !             k = 3
  54 !             ttt(k) = ttt(k) + (-1)**(j+3) / real( 2*j+3 )
  55 !             k = 4
  56 !             ttt(k) = ttt(k) + (-1)**(j+4) / real( 2*j+5 )
  57 !         end do
  58
  59         ! Loop with modulo operation
  60 !         do j = low, high
  61 !             k = mod( j, nsplit ) + 1
  62 !             ttt(k) = ttt(k) + (-1)**(j+1) / real( 2*j-1 )
  63 !         end do
  64
  65         ! Loop with subscripting via host association
  66         do j = low, high
  67             k = edof(j)
  68             ttt(k) = ttt(k) + (-1.0_real64)**(j+1) / real( 2*j-1 )
  69         end do
  70     end function
  71
  72 end program main