libgomp/testsuite/libgomp.oacc-fortran/attach-descriptor-1.f90

   1 ! { dg-do run }
   2 ! { dg-skip-if "" { *-*-* } { "*" } { "-DACC_MEM_SHARED=0" } }
   3
   4 subroutine test(variant)
   5   use openacc
   6   implicit none
   7   integer :: variant
   8   type t
   9     integer :: arr1(10)
  10     integer, allocatable :: arr2(:)
  11   end type t
  12   integer :: i
  13   type(t) :: myvar
  14   integer, target :: tarr(10)
  15   integer, pointer :: myptr(:)
  16
  17   allocate(myvar%arr2(10))
  18
  19   do i=1,10
  20     myvar%arr1(i) = 0
  21     myvar%arr2(i) = 0
  22     tarr(i) = 0
  23   end do
  24
  25   call acc_copyin(myvar)
  26   call acc_copyin(myvar%arr2)
  27   call acc_copyin(tarr)
  28
  29   myptr => tarr
  30
  31   if (variant == 0 &
  32        .or. variant == 3 &
  33        .or. variant == 5) then
  34      !$acc enter data attach(myvar%arr2, myptr)
  35   else if (variant == 1 &
  36        .or. variant == 2 &
  37        .or. variant == 4) then
  38      !$acc enter data attach(myvar%arr2, myptr)
  39      !$acc enter data attach(myvar%arr2, myptr)
  40   else
  41      ! Internal error.
  42      stop 1
  43   end if
  44
  45   !$acc serial present(myvar%arr2)
  46   ! { dg-warning "using .vector_length \\(32\\)., ignoring 1" "" { target openacc_nvidia_accel_selected } .-1 }
  47   do i=1,10
  48     myvar%arr1(i) = i + variant
  49     myvar%arr2(i) = i - variant
  50   end do
  51   myptr(3) = 99 - variant
  52   !$acc end serial
  53
  54   if (variant == 0) then
  55      !$acc exit data detach(myvar%arr2, myptr)
  56   else if (variant == 1) then
  57      !$acc exit data detach(myvar%arr2, myptr)
  58      !$acc exit data detach(myvar%arr2, myptr)
  59   else if (variant == 2) then
  60      !$acc exit data detach(myvar%arr2, myptr)
  61      !$acc exit data detach(myvar%arr2, myptr) finalize
  62   else if (variant == 3 &
  63        .or. variant == 4) then
  64      !$acc exit data detach(myvar%arr2, myptr) finalize
  65   else if (variant == 5) then
  66      ! Do not detach.
  67   else
  68      ! Internal error.
  69      stop 2
  70   end if
  71
  72   if (.not. acc_is_present(myvar%arr2)) stop 10
  73   if (.not. acc_is_present(myvar)) stop 11
  74   if (.not. acc_is_present(tarr)) stop 12
  75
  76   call acc_copyout(myvar%arr2)
  77   if (acc_is_present(myvar%arr2)) stop 20
  78   if (.not. acc_is_present(myvar)) stop 21
  79   if (.not. acc_is_present(tarr)) stop 22
  80   call acc_copyout(myvar)
  81   if (acc_is_present(myvar%arr2)) stop 30
  82   if (acc_is_present(myvar)) stop 31
  83   if (.not. acc_is_present(tarr)) stop 32
  84   call acc_copyout(tarr)
  85   if (acc_is_present(myvar%arr2)) stop 40
  86   if (acc_is_present(myvar)) stop 41
  87   if (acc_is_present(tarr)) stop 42
  88
  89   do i=1,10
  90      if (myvar%arr1(i) .ne. i + variant) stop 50
  91      if (variant == 5) then
  92         ! We have not detached, so have copyied out a device pointer, so cannot
  93         ! access 'myvar%arr2' on the host.
  94      else
  95         if (myvar%arr2(i) .ne. i - variant) stop 51
  96      end if
  97   end do
  98   if (tarr(3) .ne. 99 - variant) stop 52
  99
 100   if (variant == 5) then
 101      ! If not explicitly stopping here, we'd in the following try to deallocate
 102      ! the device pointer on the host, SIGSEGV.
 103      stop
 104   end if
 105 end subroutine test
 106
 107 program att
 108   implicit none
 109
 110   call test(0)
 111
 112   call test(1)
 113
 114   call test(2)
 115
 116   call test(3)
 117
 118   call test(4)
 119
 120   call test(5)
 121   ! Make sure that 'test(5)' has stopped the program.
 122   stop 60
 123 end program att