Disjoins overlapping segments and creates a new list of non-overlapping segments.
This subroutine takes a list of segments, disjoins any overlapping segments, and creates a new list of non-overlapping segments. It uses a priority queue to sort the segments and processes them to ensure they are disjoined.
Type | Intent | Optional | Attributes | Name | ||
---|---|---|---|---|---|---|
type(segment_t), | intent(inout), | allocatable | :: | list(:) |
pure subroutine disjoin_kernel(list) use, intrinsic :: iso_fortran_env, only: int32 implicit none type(segment_t), intent(inout), allocatable :: list(:) type(segment_t), allocatable :: old_list(:) type(priority_queue_t) :: pqueue type(segment_t), allocatable :: buff(:) type(segment_t), allocatable :: cache(:) type(segment_t) :: new integer(int32), allocatable :: index_list(:) integer(int32) :: i, j, k, count, siz, top, bottom, real_size, m logical :: flag ! If list is not allocated, it returns immediately. if (.not. allocated(list)) return siz = size(list, dim=1) if (siz <= 0) then return end if ! Move the currnet list to `old_list` call move_alloc(list, old_list) ! Sort segments using a priority queue (heap sort) block allocate(buff(siz)) do j = 1, siz call pqueue%enqueue(old_list(j)) end do do j = 1, siz call pqueue%dequeue(buff(j)) ! The `buff` is sorted array. end do end block ! Determine the bottom and top value from the segment array. block bottom = buff(1)%min top = 0 do j = 1, siz top = max(top, buff(j)%max) end do end block allocate(list(siz*2)) ! Generate a list of unique indices from the `old_list`. call index_list_from_segment_list(index_list, old_list) !== At this point, index_list is allocated by index_list_from_segment_list procedure. ! Initialize new = SEG_UPPER ! segment_t(2**21, 2**21) k = 1 m = 1 ! NOTE: this is a complex loop with multiple counters, so HANDLE WITH CARE. ! do while(m <= size(index_list)) i = index_list(m) ! Get the current value of `index_list`. ! NOTE: the `index_list` is in ASCENDING order. ! Check if `i` is within any of the segments. ! ! This loop iterates over each value in the `index_list` and checks if the current ! value `i` is present in any of the segments stored in the `buff` array. ! If it is present and less than the current minimum value of the new segment, it ! updates the new segment's minimum value. if (i .in. buff(1:siz)) then if (i < new%min) new%min = i else ! Otherwise, advance the index in `index_list` and move to the next cycle. m = m + 1 cycle end if ! Check if `i+1` is the start of any segment. ! ! This section checks if the value `i+1` is the starting point (`min`) of any segment ! in the `buff` array. If it is, then it sets the new segment's `max` value to `i` and ! registers the new segment. flag = .false. do j = 1, siz if (i+1 == buff(j)%min) flag = flag .or. .true. ! This `if` statement is redundant and should be fixed. end do if (flag) then new%max = i call register_seg_list(new, list, k) m = m + 1 cycle end if ! Check for multiple segments starting at `i`. ! ! This part counts how many segments start at the current value `i`. If more than ! one segment starts at `i`, it sets the new segment's max value to `i` and register ! the new segment. count = 0 do j = 1, siz if (buff(j)%min == i) count = count + 1 end do if (count > 1) then new%max = i call register_seg_list(new, list, k) end if ! Check for any segments ending at `i`. ! ! This part counts how many segments end at the current value `i`. ! If any segment ends at `i`, it sets the new segment's max value to `i` ! and registers the new segment. count = 0 do j = 1, siz if (buff(j)%max == i) count = count + 1 end do if (count >0) then new%max = i call register_seg_list(new, list, k) end if m = m + 1 end do ! Determine the real size of the new list. ! This loop calculates the actual number of non-empty segments in the new `list`. real_size = 0 do i = 1, size(list) if (list(i) /= SEG_INIT) real_size = real_size + 1 end do ! Move `list` to `cache` and reallocate `list` to the real size. call move_alloc(list, cache) ! list is now deallocated. allocate(list(real_size)) list(:) = cache(1:real_size) ! Deallocate used arrays and clear the priority queue call pqueue%clear() deallocate(buff) deallocate(cache) deallocate(index_list) end subroutine disjoin_kernel