disjoin_kernel Subroutine

private pure subroutine disjoin_kernel(list)

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.

Arguments

Type IntentOptional Attributes Name
type(segment_t), intent(inout), allocatable :: list(:)

Source Code

   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