1! PR fortran/98858
2!
3! Assumed-size array with use_device_ptr()
4!
5program test_use_device_ptr
6  use iso_c_binding, only: c_ptr, c_loc, c_f_pointer
7  implicit none
8  double precision :: alpha
9  integer, parameter :: lda = 10
10  integer, allocatable :: mat(:, :)
11       integer :: i, j
12
13  allocate(mat(lda, lda))
14  do i = 1, lda
15    do j = 1, lda
16      mat(j,i) = i*100 + j
17    end do
18  end do
19
20  !$omp target enter data map(to:mat)
21  call dgemm(lda, mat)
22  !$omp target exit data map(from:mat)
23
24  do i = 1, lda
25    do j = 1, lda
26      if (mat(j,i) /= -(i*100 + j)) stop 1
27    end do
28  end do
29
30  !$omp target enter data map(to:mat)
31  call dgemm2(lda, mat)
32  !$omp target exit data map(from:mat)
33
34  do i = 1, lda
35    do j = 1, lda
36      if (mat(j,i) /= (i*100 + j)) stop 1
37    end do
38  end do
39
40  contains
41
42    subroutine dgemm(lda, a)
43      implicit none
44      integer :: lda
45      integer, target:: a(lda,*) ! need target attribute to use c_loc
46      !$omp target data use_device_ptr(a)
47        call negate_it(c_loc(a), lda)
48      !$omp end target data
49    end subroutine
50
51    subroutine dgemm2(lda, a)
52      implicit none
53      integer :: lda
54      integer, target:: a(lda,*) ! need target attribute to use c_loc
55      !$omp target data use_device_addr(a)
56        call negate_it(c_loc(a), lda)
57      !$omp end target data
58    end subroutine
59
60    subroutine negate_it(a, n)
61      type(c_ptr), value :: a
62      integer, value :: n
63      integer, pointer :: array(:,:)
64
65      ! detour due to OpenMP 5.0 oddness
66      call c_f_pointer(a, array, [n,n])
67      call do_offload(array, n)
68    end
69
70    subroutine do_offload(aptr, n)
71      integer, target :: aptr(:,:)
72      integer, value :: n
73      !$omp target is_device_ptr(aptr)
74      call negate_it_tgt(aptr, n)
75      !$omp end target
76    end subroutine do_offload
77
78    subroutine negate_it_tgt(array, n)
79      !$omp declare target
80       integer, value :: n
81       integer :: array(n,n)
82       integer :: i, j
83       !$omp parallel do collapse(2)
84       do i = 1, n
85         do j = 1, n
86           array(j,i) = - array(j,i)
87         end do
88       end do
89       !$omp end parallel do
90  end subroutine
91end program
92