libgomp/testsuite/libgomp.fortran/examples-4/target_data-3.f90

   1 ! { dg-do run }
   2
   3 module e_51_3_mod
   4 contains
   5   subroutine init (Q, rows, cols)
   6     integer :: i, k, rows, cols
   7     double precision :: Q(rows,cols)
   8     do k = 1, cols
   9       do i = 1, rows
  10         Q(i,k) = 10 * i + k
  11       end do
  12     end do
  13   end subroutine
  14
  15   subroutine check (P, Q, rows, cols)
  16     integer :: i, k, rows, cols
  17     double precision, parameter :: EPS = 0.00001
  18     double precision :: P(rows,cols), Q(rows,cols), diff
  19     do k = 1, cols
  20       do i = 1, rows
  21         diff = P(i,k) - Q(i,k)
  22         if (diff > EPS .or. -diff > EPS) call abort
  23       end do
  24     end do
  25   end subroutine
  26
  27   subroutine gramSchmidt_ref (Q, rows, cols)
  28     integer :: i, k, rows, cols
  29     double precision :: Q(rows,cols), tmp
  30     do k = 1, cols
  31       tmp = 0.0d0
  32       do i = 1, rows
  33         tmp = tmp + (Q(i,k) * Q(i,k))
  34       end do
  35       tmp = 1.0d0 / sqrt (tmp)
  36       do i = 1, rows
  37         Q(i,k) = Q(i,k) * tmp
  38       end do
  39     end do
  40   end subroutine
  41
  42   subroutine gramSchmidt (Q, rows, cols)
  43     integer :: i, k, rows, cols
  44     double precision :: Q(rows,cols), tmp
  45     !$omp target data map(Q)
  46       do k = 1, cols
  47         tmp = 0.0d0
  48         !$omp target map(tofrom: tmp)
  49           !$omp parallel do reduction(+:tmp)
  50           do i = 1, rows
  51             tmp = tmp + (Q(i,k) * Q(i,k))
  52           end do
  53         !$omp end target
  54         tmp = 1.0d0 / sqrt (tmp)
  55         !$omp target
  56           !$omp parallel do
  57           do i = 1, rows
  58             Q(i,k) = Q(i,k) * tmp
  59           end do
  60         !$omp end target
  61       end do
  62     !$omp end target data
  63   end subroutine
  64 end module
  65
  66 program e_51_3
  67   use e_51_3_mod, only : init, check, gramSchmidt, gramSchmidt_ref
  68   integer :: cols, rows
  69   double precision, pointer :: P(:,:), Q(:,:)
  70   cols = 5
  71   rows = 5
  72   allocate (P(rows,cols), Q(rows,cols))
  73   call init (P, rows, cols)
  74   call init (Q, rows, cols)
  75   call gramSchmidt_ref (P, rows, cols)
  76   call gramSchmidt (Q, rows, cols)
  77   call check (P, Q, rows, cols)
  78   deallocate (P, Q)
  79 end program