libgomp/testsuite/libgomp.fortran/procptr1.f90

   1 ! { dg-do run }
   2   interface
   3     integer function foo ()
   4     end function
   5     integer function bar ()
   6     end function
   7     integer function baz ()
   8     end function
   9   end interface
  10   procedure(foo), pointer :: ptr
  11   integer :: i
  12   ptr => foo
  13 !$omp parallel shared (ptr)
  14   if (ptr () /= 1) STOP 1
  15 !$omp end parallel
  16   ptr => bar
  17 !$omp parallel firstprivate (ptr)
  18   if (ptr () /= 2) STOP 2
  19 !$omp end parallel
  20 !$omp parallel sections lastprivate (ptr)
  21 !$omp section
  22   ptr => foo
  23   if (ptr () /= 1) STOP 3
  24 !$omp section
  25   ptr => bar
  26   if (ptr () /= 2) STOP 4
  27 !$omp section
  28   ptr => baz
  29   if (ptr () /= 3) STOP 5
  30 !$omp end parallel sections
  31   if (ptr () /= 3) STOP 6
  32   if (.not.associated (ptr, baz)) STOP 7
  33 end
  34 integer function foo ()
  35   foo = 1
  36 end function
  37 integer function bar ()
  38   bar = 2
  39 end function
  40 integer function baz ()
  41   baz = 3
  42 end function