! { dg-do compile }
|
! { dg-do compile }
|
! { dg-options "-fdump-tree-original" }
|
! { dg-options "-fdump-tree-original" }
|
!
|
!
|
! PR fortran/37626
|
! PR fortran/37626
|
! Contributed by Rich Townsend
|
! Contributed by Rich Townsend
|
!
|
!
|
! The problem was an ICE when trying to deallocate the
|
! The problem was an ICE when trying to deallocate the
|
! result variable "x_unique".
|
! result variable "x_unique".
|
!
|
!
|
function unique_A (x, sorted) result (x_unique)
|
function unique_A (x, sorted) result (x_unique)
|
implicit none
|
implicit none
|
character(*), dimension(:), intent(in) :: x
|
character(*), dimension(:), intent(in) :: x
|
logical, intent(in), optional :: sorted
|
logical, intent(in), optional :: sorted
|
character(LEN(x)), dimension(:), allocatable :: x_unique
|
character(LEN(x)), dimension(:), allocatable :: x_unique
|
|
|
logical :: sorted_
|
logical :: sorted_
|
character(LEN(x)), dimension(SIZE(x)) :: x_sorted
|
character(LEN(x)), dimension(SIZE(x)) :: x_sorted
|
integer :: n_x
|
integer :: n_x
|
logical, dimension(SIZE(x)) :: mask
|
logical, dimension(SIZE(x)) :: mask
|
|
|
integer, external :: b3ss_index
|
integer, external :: b3ss_index
|
|
|
! Set up sorted_
|
! Set up sorted_
|
|
|
if(PRESENT(sorted)) then
|
if(PRESENT(sorted)) then
|
sorted_ = sorted
|
sorted_ = sorted
|
else
|
else
|
sorted_ = .FALSE.
|
sorted_ = .FALSE.
|
endif
|
endif
|
|
|
! If necessary, sort x
|
! If necessary, sort x
|
|
|
if(sorted_) then
|
if(sorted_) then
|
x_sorted = x
|
x_sorted = x
|
else
|
else
|
x_sorted = x(b3ss_index(x))
|
x_sorted = x(b3ss_index(x))
|
endif
|
endif
|
|
|
! Set up the unique array
|
! Set up the unique array
|
|
|
n_x = SIZE(x)
|
n_x = SIZE(x)
|
|
|
mask = (/.TRUE.,x_sorted(2:n_x) /= x_sorted(1:n_x-1)/)
|
mask = (/.TRUE.,x_sorted(2:n_x) /= x_sorted(1:n_x-1)/)
|
|
|
allocate(x_unique(COUNT(mask)))
|
allocate(x_unique(COUNT(mask)))
|
|
|
x_unique = PACK(x_sorted, MASK=mask)
|
x_unique = PACK(x_sorted, MASK=mask)
|
|
|
! Finish
|
! Finish
|
|
|
return
|
return
|
end function unique_A
|
end function unique_A
|
|
|
! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
|
! { dg-final { scan-tree-dump-times "__builtin_free" 5 "original" } }
|
! { dg-final { cleanup-tree-dump "original" } }
|
! { dg-final { cleanup-tree-dump "original" } }
|
|
|
|
|
