libgomp/testsuite/libgomp.fortran/target-firstprivate-2.f90

   1 ! PR fortran/104949
   2
   3 module m
   4 use omp_lib
   5 implicit none (type, external)
   6
   7 contains
   8 subroutine one
   9   integer, allocatable :: x(:)
  10   integer :: i
  11
  12   do i = 1, omp_get_num_devices() + 1
  13     !$omp target firstprivate(x)
  14       if (allocated(x)) error stop
  15     !$omp end target
  16     if (allocated(x)) error stop
  17   end do
  18
  19   do i = 1, omp_get_num_devices() + 1
  20     !$omp target firstprivate(x, i)
  21       if (allocated(x)) error stop
  22       x = [10,20,30,40] + i
  23       if (any (x /= [10,20,30,40] + i)) error stop
  24       ! This leaks memory!
  25       ! deallocate(x)
  26     !$omp end target
  27     if (allocated(x)) error stop
  28   end do
  29
  30   x = [1,2,3,4]
  31
  32   do i = 1, omp_get_num_devices() + 1
  33     !$omp target firstprivate(x, i)
  34       if (i <= 0) error stop
  35       if (.not.allocated(x)) error stop
  36       if (size(x) /= 4) error stop
  37       if (lbound(x,1) /= 1) error stop
  38       if (any (x /= [1,2,3,4])) error stop
  39       ! no reallocation, just malloced + assignment
  40       x = [10,20,30,40] + i
  41       if (any (x /= [10,20,30,40] + i)) error stop
  42       ! This leaks memory!
  43       ! deallocate(x)
  44     !$omp end target
  45     if (.not.allocated(x)) error stop
  46     if (size(x) /= 4) error stop
  47     if (lbound(x,1) /= 1) error stop
  48     if (any (x /= [1,2,3,4])) error stop
  49   end do
  50   deallocate(x)
  51 end
  52
  53 subroutine two
  54   character(len=:), allocatable :: x(:)
  55   character(len=5)  :: str
  56   integer :: i
  57
  58   str = "abcde" ! work around for PR fortran/91544
  59   do i = 1, omp_get_num_devices() + 1
  60     !$omp target firstprivate(x)
  61       if (allocated(x)) error stop
  62     !$omp end target
  63     if (allocated(x)) error stop
  64   end do
  65
  66   do i = 1, omp_get_num_devices() + 1
  67     !$omp target firstprivate(x, i)
  68       if (allocated(x)) error stop
  69       ! no reallocation, just malloced + assignment
  70       x = [character(len=2+i) :: str,"fhji","klmno"]
  71       if (len(x) /= 2+i) error stop
  72       if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
  73       ! This leaks memory!
  74       ! deallocate(x)
  75     !$omp end target
  76     if (allocated(x)) error stop
  77   end do
  78
  79   x = [character(len=4) :: "ABCDE","FHJI","KLMNO"]
  80
  81   do i = 1, omp_get_num_devices() + 1
  82     !$omp target firstprivate(x, i)
  83       if (i <= 0) error stop
  84       if (.not.allocated(x)) error stop
  85       if (size(x) /= 3) error stop
  86       if (lbound(x,1) /= 1) error stop
  87       if (len(x) /= 4) error stop
  88       if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
  89       !! Reallocation runs into the issue PR fortran/105538
  90       !!
  91       !!x = [character(len=2+i) :: str,"fhji","klmno"]
  92       !!if (len(x) /= 2+i) error stop
  93       !!if (any (x /= [character(len=2+i) :: str,"fhji","klmno"])) error stop
  94       !! This leaks memory!
  95       !! deallocate(x)
  96       ! Just assign:
  97       x = [character(len=4) :: "abcde","fhji","klmno"]
  98       if (any (x /= [character(len=4) :: "abcde","fhji","klmno"])) error stop
  99     !$omp end target
 100     if (.not.allocated(x)) error stop
 101     if (lbound(x,1) /= 1) error stop
 102     if (size(x) /= 3) error stop
 103     if (len(x) /= 4) error stop
 104     if (any (x /= [character(len=4) :: "ABCDE","FHJI","KLMNO"])) error stop
 105   end do
 106   deallocate(x)
 107 end
 108 end module m
 109
 110 use m
 111 call one
 112 call two
 113 end