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