libgomp/testsuite/libgomp.oacc-fortran/host_data-2.f90

   1 ! Test host_data interoperability with CUDA blas.  This test was
   2 ! derived from libgomp.oacc-c-c++-common/host_data-1.c.
   3
   4 ! { dg-do run { target openacc_nvidia_accel_selected } }
   5 ! { dg-additional-options "-lcublas -Wall -Wextra" }
   6
   7 program test
   8   implicit none
   9
  10   integer, parameter :: N = 10
  11   integer :: i
  12   real*4 :: x_ref(N), y_ref(N), x(N), y(N), a
  13
  14   interface
  15      subroutine cublassaxpy(N, alpha, x, incx, y, incy) bind(c, name="cublasSaxpy")
  16        use iso_c_binding
  17        integer(kind=c_int), value :: N
  18        real(kind=c_float), value :: alpha
  19        type(*), dimension(*) :: x
  20        integer(kind=c_int), value :: incx
  21        type(*), dimension(*) :: y
  22        integer(kind=c_int), value :: incy
  23      end subroutine cublassaxpy
  24   end interface
  25
  26   a = 2.0
  27
  28   do i = 1, N
  29      x(i) = 4.0 * i
  30      y(i) = 3.0
  31      x_ref(i) = x(i)
  32      y_ref(i) = y(i)
  33   end do
  34
  35   call saxpy (N, a, x_ref, y_ref)
  36
  37   !$acc data copyin (x) copy (y)
  38   !$acc host_data use_device (x, y)
  39   call cublassaxpy(N, a, x, 1, y, 1)
  40   !$acc end host_data
  41   !$acc end data
  42
  43   call validate_results (N, y, y_ref)
  44
  45   !$acc data create (x) copyout (y)
  46   !$acc parallel loop
  47   do i = 1, N
  48      y(i) = 3.0
  49   end do
  50   !$acc end parallel loop
  51
  52   !$acc host_data use_device (x, y)
  53   call cublassaxpy(N, a, x, 1, y, 1)
  54   !$acc end host_data
  55   !$acc end data
  56
  57   call validate_results (N, y, y_ref)
  58
  59   y(:) = 3.0
  60
  61   !$acc data copyin (x) copyin (a) copy (y)
  62   !$acc parallel present (x) pcopy (y) present (a)
  63   call saxpy (N, a, x, y)
  64   !$acc end parallel
  65   !$acc end data
  66
  67   call validate_results (N, y, y_ref)
  68
  69   y(:) = 3.0
  70
  71   !$acc enter data copyin (x, a, y)
  72   !$acc parallel present (x) pcopy (y) present (a)
  73   call saxpy (N, a, x, y)
  74   !$acc end parallel
  75   !$acc exit data delete (x, a) copyout (y)
  76
  77   call validate_results (N, y, y_ref)
  78 end program test
  79
  80 subroutine saxpy (nn, aa, xx, yy)
  81   integer :: nn
  82   real*4 :: aa, xx(nn), yy(nn)
  83   integer i
  84   !$acc routine
  85
  86   do i = 1, nn
  87     yy(i) = yy(i) + aa * xx(i)
  88   end do
  89 end subroutine saxpy
  90
  91 subroutine validate_results (n, a, b)
  92   integer :: n
  93   real*4 :: a(n), b(n)
  94
  95   do i = 1, N
  96      if (abs(a(i) - b(i)) > 0.0001) call abort
  97   end do
  98 end subroutine validate_results