libgomp/testsuite/libgomp.fortran/refcount-1.f90

   1 program main
   2   use omp_lib
   3   use iso_c_binding
   4   implicit none (type, external)
   5
   6   integer :: d, id
   7   integer(kind=1), target :: a(4)
   8   integer(kind=1), pointer :: p, q
   9
  10   d = omp_get_default_device ()
  11   id = omp_get_initial_device ()
  12
  13   if (d < 0 .or. d >= omp_get_num_devices ()) &
  14     d = id
  15
  16   a = transfer (int(z'cdcdcdcd'), mold=a)
  17
  18   !$omp target enter data map (to:a)
  19
  20   a = transfer (int(z'abababab'), mold=a)
  21   p => a(1)
  22   q => a(3)
  23
  24   !$omp target enter data map (alloc:p, q)
  25
  26   if (d /= id) then
  27     if (omp_target_is_present (c_loc(a), d) == 0) &
  28       stop 1
  29     if (omp_target_is_present (c_loc(p), d) == 0) &
  30       stop 2
  31     if (omp_target_is_present (c_loc(q), d) == 0) &
  32       stop 3
  33   end if
  34
  35   !$omp target exit data map (release:a)
  36
  37     if (d /= id) then
  38       if (omp_target_is_present (c_loc(a), d) == 0) &
  39         stop 4
  40       if (omp_target_is_present (c_loc(p), d) == 0) &
  41         stop 5
  42       if (omp_target_is_present (c_loc(q), d) == 0) &
  43         stop 6
  44     end if
  45
  46   !$omp target exit data map (from:q)
  47
  48     if (d /= id) then
  49       if (omp_target_is_present (c_loc(a), d) /= 0) &
  50         stop 7
  51       if (omp_target_is_present (c_loc(p), d) /= 0) &
  52         stop 8
  53       if (omp_target_is_present (c_loc(q), d) /= 0) &
  54         stop 9
  55
  56       if (q /= int(z'cd', kind=1)) &
  57         stop 10
  58       if (p /= int(z'ab', kind=1)) &
  59         stop 11
  60     end if
  61 end program main