libgomp/testsuite/libgomp.oacc-fortran/optional-nested-calls.f90

   1 ! Test propagation of optional arguments from within an OpenACC parallel region.
   2
   3 ! { dg-do run }
   4
   5 program test
   6   implicit none
   7
   8   integer, parameter :: n = 64
   9   integer :: i
  10   integer :: res_int
  11   integer :: a_arr(n), b_arr(n), res_arr(n)
  12   integer, allocatable :: a_alloc(:), b_alloc(:), res_alloc(:)
  13
  14   call test_int_caller(res_int, 5)
  15   if (res_int .ne. 10) stop 1
  16
  17   call test_int_caller(res_int, 2, 3)
  18   if (res_int .ne. 11) stop 2
  19
  20   do i = 1, n
  21     a_arr(i) = i
  22     b_arr(i) = n - i + 1
  23   end do
  24
  25   call test_array_caller(res_arr, a_arr)
  26   do i = 1, n
  27     if (res_arr(i) .ne. 2 * a_arr(i)) stop 3
  28   end do
  29
  30   call test_array_caller(res_arr, a_arr, b_arr)
  31   do i = 1, n
  32     if (res_arr(i) .ne. a_arr(i) * b_arr(i) + a_arr(i) + b_arr(i)) stop 4
  33   end do
  34
  35   allocate(a_alloc(n))
  36   allocate(b_alloc(n))
  37   allocate(res_alloc(n))
  38
  39   do i = 1, n
  40     a_alloc(i) = i
  41     b_alloc(i) = n - i + 1
  42   end do
  43
  44   call test_array_caller(res_arr, a_arr)
  45   do i = 1, n
  46     if (res_arr(i) .ne. 2 * a_alloc(i)) stop 5
  47   end do
  48
  49   call test_array_caller(res_arr, a_arr, b_arr)
  50   do i = 1, n
  51     if (res_arr(i) .ne. a_arr(i) * b_alloc(i) + a_alloc(i) + b_alloc(i)) stop 6
  52   end do
  53
  54   deallocate(a_alloc)
  55   deallocate(b_alloc)
  56   deallocate(res_alloc)
  57 contains
  58   subroutine test_int_caller(res, a, b)
  59     integer :: res, a
  60     integer, optional :: b
  61
  62     !$acc data copyin(a, b) copyout (res)
  63     !$acc parallel
  64     res = a
  65     if (present(b)) res = res * b
  66     call test_int_callee(res, a, b)
  67     !$acc end parallel
  68     !$acc end data
  69   end subroutine test_int_caller
  70
  71   subroutine test_int_callee(res, a, b)
  72     !$acc routine seq
  73     integer :: res, a
  74     integer, optional :: b
  75
  76     res = res + a
  77     if (present(b)) res = res + b
  78   end subroutine test_int_callee
  79
  80   subroutine test_array_caller(res, a, b)
  81     integer :: res(n), a(n), i
  82     integer, optional :: b(n)
  83
  84     !$acc data copyin(a, b) copyout(res)
  85     !$acc parallel
  86     !$acc loop seq
  87     do i = 1, n
  88       res(i) = a(i)
  89       if (present(b)) res(i) = res(i) * b(i)
  90     end do
  91     call test_array_callee(res, a, b)
  92     !$acc end parallel
  93     !$acc end data
  94   end subroutine test_array_caller
  95
  96   subroutine test_array_callee(res, a, b)
  97     !$acc routine seq
  98     integer :: res(n), a(n), i
  99     integer, optional :: b(n)
 100
 101     do i = 1, n
 102       res(i) = res(i) + a(i)
 103       if (present(b)) res(i) = res(i) + b(i)
 104     end do
 105   end subroutine test_array_callee
 106
 107   subroutine test_allocatable_caller(res, a, b)
 108     integer :: i
 109     integer, allocatable :: res(:), a(:)
 110     integer, allocatable, optional :: b(:)
 111
 112     !$acc data copyin(a, b) copyout(res)
 113     !$acc parallel
 114     !$acc loop seq
 115     do i = 1, n
 116       res(i) = a(i)
 117       if (present(b)) res(i) = res(i) * b(i)
 118     end do
 119     call test_array_callee(res, a, b)
 120     !$acc end parallel
 121     !$acc end data
 122   end subroutine test_allocatable_caller
 123
 124   subroutine test_allocatable_callee(res, a, b)
 125     !$acc routine seq
 126     integer :: i
 127     integer, allocatable :: res(:), a(:)
 128     integer, allocatable, optional :: b(:)
 129
 130     do i = 1, n
 131       res(i) = res(i) + a(i)
 132       if (present(b)) res(i) = res(i) + b(i)
 133     end do
 134   end subroutine test_allocatable_callee
 135 end program test