libgomp/testsuite/libgomp.fortran/udr7.f90

   1 ! { dg-do run }
   2
   3 program udr7
   4   implicit none
   5   interface
   6     elemental subroutine omp_priv (x, y, z)
   7       real, intent (in) :: x
   8       real, intent (inout) :: y
   9       real, intent (in) :: z
  10     end subroutine omp_priv
  11     elemental real function omp_orig (x)
  12       real, intent (in) :: x
  13     end function omp_orig
  14   end interface
  15 !$omp declare reduction (omp_priv : real : &
  16 !$omp & omp_priv (omp_orig (omp_in), omp_out, 1.0)) &
  17 !$omp & initializer (omp_out (omp_priv, omp_in (omp_orig)))
  18   real :: x (2:4, 1:1, -2:0)
  19   integer :: i
  20   x = 0
  21 !$omp parallel do reduction (omp_priv : x)
  22   do i = 1, 64
  23     x = x + i
  24   end do
  25   if (any (x /= 2080.0)) call abort
  26 contains
  27   elemental subroutine omp_out (x, y)
  28     real, intent (out) :: x
  29     real, intent (in) :: y
  30     x = y - 4.0
  31   end subroutine omp_out
  32   elemental real function omp_in (x)
  33     real, intent (in) :: x
  34     omp_in = x + 4.0
  35   end function omp_in
  36 end program udr7
  37 elemental subroutine omp_priv (x, y, z)
  38   real, intent (in) :: x
  39   real, intent (inout) :: y
  40   real, intent (in) :: z
  41   y = y + (x - 4.0) + (z - 1.0)
  42 end subroutine omp_priv
  43 elemental real function omp_orig (x)
  44   real, intent (in) :: x
  45   omp_orig = x + 4.0
  46 end function omp_orig