1! { dg-do run }
2
3module e_51_3_mod
4contains
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) STOP 1
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
64end module
65
66program 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)
79end program
80