libgomp/testsuite/libgomp.fortran/use_device_addr-5.f90

   1 program main
   2   use omp_lib
   3   implicit none
   4   integer, allocatable :: aaa(:,:,:)
   5   integer :: i
   6
   7   allocate (aaa(-4:10,-3:8,2))
   8   aaa(:,:,:) = reshape ([(i, i = 1, size(aaa))], shape(aaa))
   9
  10   do i = 0, omp_get_num_devices()
  11     !$omp target data map(to: aaa) device(i)
  12       call test_addr (aaa, i)
  13       call test_ptr (aaa, i)
  14     !$omp end target data
  15   end do
  16   deallocate (aaa)
  17
  18 contains
  19
  20   subroutine test_addr (aaaa, dev)
  21     use iso_c_binding
  22     integer, target, allocatable :: aaaa(:,:,:), bbbb(:,:,:)
  23     integer, value :: dev
  24     integer :: i
  25     type(c_ptr) :: ptr
  26     logical :: is_shared
  27
  28     is_shared = .false.
  29     !$omp target device(dev) map(to: is_shared)
  30       is_shared = .true.
  31     !$omp end target
  32
  33     allocate (bbbb(-4:10,-3:8,2))
  34     bbbb(:,:,:) = reshape ([(-i, i = 1, size(bbbb))], shape(bbbb))
  35     !$omp target enter data map(to: bbbb) device(dev)
  36     if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 1
  37     if (any (shape (aaaa) /= [15, 12, 2])) error stop 2
  38     if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 3
  39     if (any (shape (bbbb) /= [15, 12, 2])) error stop 4
  40     if (any (aaaa /= -bbbb)) error stop 5
  41     if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
  42       error stop 6
  43
  44     !$omp parallel do shared(bbbb, aaaa)
  45     do i = 1,1
  46       if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 5
  47       if (any (shape (aaaa) /= [15, 12, 2])) error stop 6
  48       if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 7
  49       if (any (shape (bbbb) /= [15, 12, 2])) error stop 8
  50       if (any (aaaa /= -bbbb)) error stop 5
  51       if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
  52         error stop 6
  53       ptr = c_loc (aaaa)
  54       !$omp target data use_device_addr(bbbb, aaaa) device(dev)
  55         if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
  56         if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
  57         if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
  58         if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
  59         if (is_shared) then
  60           if (any (aaaa /= -bbbb)) error stop 5
  61           if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
  62             error stop 6
  63         end if
  64         if (is_shared .neqv. c_associated (ptr, c_loc (aaaa))) error stop
  65
  66         !$omp target has_device_addr(bbbb, aaaa) device(dev)
  67            if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
  68            if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
  69            if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
  70            if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
  71            if (any (aaaa /= -bbbb)) error stop 5
  72            if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
  73              error stop 6
  74         !$omp end target
  75       !$omp end target data
  76     end do
  77     !$omp target exit data map(delete: bbbb) device(dev)
  78     deallocate (bbbb)
  79   end subroutine test_addr
  80
  81   subroutine test_ptr (aaaa, dev)
  82     use iso_c_binding
  83     integer, target, allocatable :: aaaa(:,:,:), bbbb(:,:,:)
  84     integer, value :: dev
  85     integer :: i
  86     type(c_ptr) :: ptr
  87     logical :: is_shared
  88
  89     is_shared = .false.
  90     !$omp target device(dev) map(to: is_shared)
  91       is_shared = .true.
  92     !$omp end target
  93
  94     allocate (bbbb(-4:10,-3:8,2))
  95     bbbb(:,:,:) = reshape ([(-i, i = 1, size(bbbb))], shape(bbbb))
  96     !$omp target enter data map(to: bbbb) device(dev)
  97     if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 1
  98     if (any (shape (aaaa) /= [15, 12, 2])) error stop 2
  99     if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 3
 100     if (any (shape (bbbb) /= [15, 12, 2])) error stop 4
 101     if (any (aaaa /= -bbbb)) error stop 5
 102     if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
 103       error stop 6
 104
 105     !$omp parallel do shared(bbbb, aaaa)
 106     do i = 1,1
 107       if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 5
 108       if (any (shape (aaaa) /= [15, 12, 2])) error stop 6
 109       if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 7
 110       if (any (shape (bbbb) /= [15, 12, 2])) error stop 8
 111       if (any (aaaa /= -bbbb)) error stop 5
 112       if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
 113         error stop 6
 114       ptr = c_loc (aaaa)
 115       !$omp target data use_device_ptr(bbbb, aaaa) device(dev)
 116         if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
 117         if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
 118         if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
 119         if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
 120         if (is_shared) then
 121           if (any (aaaa /= -bbbb)) error stop 5
 122           if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
 123             error stop 6
 124         end if
 125         if (is_shared .neqv. c_associated (ptr, c_loc (aaaa))) error stop
 126
 127         ! Uses has_device_addr due to PR fortran/105318
 128         !!$omp target is_device_ptr(bbbb, aaaa) device(dev)
 129         !$omp target has_device_addr(bbbb, aaaa) device(dev)
 130            if (any (lbound (aaaa) /= [-4, -3, 1])) error stop 9
 131            if (any (shape (aaaa) /= [15, 12, 2])) error stop 10
 132            if (any (lbound (bbbb) /= [-4, -3, 1])) error stop 11
 133            if (any (shape (bbbb) /= [15, 12, 2])) error stop 12
 134            if (any (aaaa /= -bbbb)) error stop 5
 135            if (any (aaaa /= reshape ([(i, i = 1, size(aaaa))], shape(aaaa)))) &
 136              error stop 6
 137         !$omp end target
 138       !$omp end target data
 139     end do
 140     !$omp target exit data map(delete: bbbb) device(dev)
 141     deallocate (bbbb)
 142   end subroutine test_ptr
 143 end program main