Compiler Explorer

Source code

module hash_integers
    use iso_c_binding, only: c_intptr_t
    use iso_fortran_env, only: int32
    implicit none(type, external)
    private

public :: integer_key
    public :: node_clear
    public :: hash_integer
    public :: hash_integer_node
    public :: hash_integer_iterator

integer, parameter :: ISIZE = int32
    integer(ISIZE), parameter :: SMALL_SIZE  = 20_ISIZE

! Magic numbers to cope with gfortran finalization issues
    integer, parameter, public :: HASH_ADDR = c_intptr_t
    integer(HASH_ADDR), parameter :: HASH_TRUE  = int(Z'DEADC0DEFEEDFACE', HASH_ADDR)
    integer(HASH_ADDR), parameter :: HASH_FALSE = int(Z'BAADF00DBAADCAFE', HASH_ADDR)

type integer_key

integer :: ints = 0

contains

procedure, private :: hash_value_ints
        generic :: hash_value => hash_value_ints

procedure, private, pass(lhs) :: ints_equal
        generic :: operator(==) => ints_equal

procedure :: print => int_key_print

end type integer_key

type kv_type
        integer(HASH_ADDR) :: set = HASH_FALSE
        type(integer_key)  :: key = integer_key(0)
        integer            :: value = 0
    end type kv_type

type :: hash_integer_node

type(kv_type) :: kv
        integer(HASH_ADDR) :: continues = HASH_FALSE
        type(hash_integer_node), allocatable :: next

contains

!final :: node_final

end type hash_integer_node

type hash_integer
        private

integer :: n_buckets = 0

integer, public :: n_keys = 0

integer(HASH_ADDR) :: initialized = HASH_FALSE
        type(hash_integer_node), allocatable, public :: buckets(:)

contains

! Create a new integer->ID map for an integer array
        procedure, public :: new => new_from_array

! Returns the number of buckets.
        procedure, public :: bucket_count

! Return the number of collisions.
        procedure, public :: n_collisions

! Reserve certain number of buckets.
        procedure, public :: reserve

! Returns number of keys.
        procedure, public :: key_count

! Set the value at a given a key.
        procedure, private :: set_key_val
        procedure, private :: set_integer
        procedure, private :: set_integers
        generic :: set => set_key_val, set_integer, set_integers

! Get the value at the given key.
        procedure, public :: get

! Get all key-value pairs
        procedure, private :: hash_get_all_keys
        procedure, private :: hash_get_all_keys_int
        generic :: get_all_keys => hash_get_all_keys,hash_get_all_keys_int

procedure :: dequeue

! Remove the value with the given key.
        procedure, public :: remove

procedure, private :: remove_bothsigns
        procedure, private :: remove_bothsigns_int
        generic :: delete => remove_bothsigns,remove_bothsigns_int

! Clear all the allocated memory (must be called to prevent memory leak).
        procedure, public :: clear

! Merge table with another one
        procedure, public :: merge_with

! Resize the hash table
        procedure, public :: resize => hash_resize

! Move allocation between two tables
        procedure, public :: move_alloc     => hash_move_alloc

procedure, public :: contains       => hash_contains

procedure, public :: in_range       => hash_in_range
        procedure, public :: replace        => hash_replace
        procedure, public :: new_with_list  => hash_new_with_list

procedure, private :: hash_assign
        generic :: assignment(=) => hash_assign

final :: hash_final

end type hash_integer

type hash_integer_iterator
        private

integer :: bucket_id
        type(hash_integer_node), pointer :: node_ptr => null()
        type(hash_integer),      pointer :: fhash_ptr => null()

contains
        ! Set the iterator to the beginning of a hash table.
        procedure, public :: begin

! Point to the first node in the hash table
        procedure, public :: first

! Point to the next node in the table
        procedure, public :: to_next

! Get the key value of the next element and advance the iterator.
        procedure, public :: next_key
        procedure, public :: next_ptr
        generic :: next => next_key, next_ptr

end type hash_integer_iterator

! Standard bucket sizes: Cunningham series. Fast: powers of 2
    logical, parameter :: FAST_MODULO_BUCKETS = .true.
    integer :: j
    integer, parameter :: sizes     (29) = [5, 11, 23, 47, 97, 199, 409, 823, 1741, 3469, 6949, 14033, 28411, 57557, 116731, &
        236897, 480881, 976369,1982627, 4026031, 8175383, 16601593, 33712729, 68460391, &
        139022417, 282312799, 573292817, 1164186217, 2147483647]
    integer, parameter :: fast_sizes(29) = [(2**j,j=2,30)]
    integer, parameter :: use_sizes (29) = merge(fast_sizes,sizes,FAST_MODULO_BUCKETS)

interface operator(.not.)
        module procedure HASH_NOT
    end interface operator(.not.)

contains

elemental integer(ISIZE) function hash_optimal_size(n_keys)
        integer, intent(in) :: n_keys

integer :: bucket_target,i

! Target 75% fill
        bucket_target = ceiling(1.33*n_keys)

! Find an optimal allocation size
        do i = 1, size(use_sizes)
            if (use_sizes(i) >= bucket_target .or. i==size(use_sizes)) then
                hash_optimal_size = use_sizes(i)
                return
            endif
        end do

end function hash_optimal_size

elemental logical function TRUE(addr)
        integer(HASH_ADDR), intent(in) :: addr
        TRUE = addr==HASH_TRUE
    end function TRUE

elemental logical function HASH_NOT(addr)
        integer(HASH_ADDR), intent(in) :: addr
        HASH_NOT = addr==HASH_FALSE
    end function HASH_NOT

elemental logical function HASH_VALID_INITIALIZATION(initialized) result(is_valid)
        integer(HASH_ADDR), intent(in) :: initialized
        is_valid = initialized==HASH_TRUE .or. initialized==HASH_FALSE
    end function HASH_VALID_INITIALIZATION

! Extract first instance from the table
    elemental pure subroutine dequeue(table,found,key_type,key_value)
        class(hash_integer), intent(inout), target :: table
        logical, intent(out) :: found
        type(integer_key), intent(inout) :: key_type
        integer       , intent(inout) :: key_value

integer :: nkeys,hash_status
        type(hash_integer_iterator) :: hashLoop

nkeys = table%key_count()
        found = .false.
        if (nkeys<=0) return

! Traverse hash table
        call hashLoop%begin(table)
        call hashLoop%next(key_type,value=key_value,status=hash_status)
        found = hash_status==0
        if (found) call table%remove(key_type)

end subroutine dequeue

pure subroutine hash_get_all_keys_int(table,valueSorted,keysList,valueList)
        class(hash_integer), intent(in), target :: table
        logical, intent(in) :: valueSorted
        integer, allocatable, intent(out) :: keysList(:)
        integer, allocatable, optional, intent(out) :: valueList(:)

integer :: nk,ik
        type(integer_key), allocatable :: keysDataList(:)

call hash_get_all_keys(table,valueSorted,keysDataList,valueList)

nk = 0; if (allocated(keysDataList)) nk = size(keysDataList)
        allocate(keysList(nk))
        do ik=1,nk
            keysList(ik) = keysDataList(ik)%ints
        end do

end subroutine hash_get_all_keys_int

pure subroutine hash_get_all_keys(table,valueSorted,keysList,valueList)
        class(hash_integer), intent(in), target :: table
        logical, intent(in) :: valueSorted
        type(integer_key), allocatable, intent(out) :: keysList(:)
        integer, allocatable, optional, intent(out) :: valueList(:)

integer :: nkeys,hash_status,key_value,bid,last
        integer, allocatable :: isort(:),values(:)
        type(integer_key) :: key_type
        type(hash_integer_iterator) :: hashLoop
        type(hash_integer_node), allocatable :: node

nkeys = table%key_count()
        allocate(keysList(nkeys),values(nkeys)); if (nkeys<=0) goto 1

! Start from first nonempty bucket
        last = 0
        do bid=1,table%n_buckets
            call get_bucket_keys(table%buckets(bid),last,keysList,values)
        end do

if (last/=nkeys) error stop 'table/=nkeys'

if (valueSorted .and. nkeys>1) then
            isort = idxRange(1,nkeys)
            call int32_quicksort_andlist_i32(values,isort)
            keysList(:) = keysList(isort)
        endif

1 if (present(valueList)) call move_alloc(from=values,to=valueList)
        return

contains

end subroutine hash_get_all_keys

pure recursive subroutine get_bucket_keys(bucket,last,keysList,valuesList)
        type(hash_integer_node), intent(in) :: bucket
        integer, intent(inout) :: last
        type(integer_key), intent(inout) :: keysList(:)
        integer, intent(inout) :: valuesList(:)

if (.not.bucket%kv%set) return

last = last+1
        keysList(last)   = bucket%kv%key
        valuesList(last) = bucket%kv%value

if (TRUE(bucket%continues)) call get_bucket_keys(bucket%next,last,keysList,valuesList)

end subroutine get_bucket_keys

! KEY Type
    elemental function hash_value_ints(ints) result(hash)
        class(integer_key), intent(in) :: ints
        integer :: hash
        integer :: i

hash = 0
        !do i = 1, size(ints%ints)
        !  hash = ieor(hash, ints%ints(i) + 1640531527 + ishft(hash, 6) + ishft(hash, -2))
        !enddo
        hash = ieor(hash, ints%ints + 1640531527 + ishft(hash, 6) + ishft(hash, -2))
    end function hash_value_ints

elemental function ints_equal(lhs, rhs)
        class(integer_key), intent(in) :: lhs, rhs
        logical :: ints_equal
        integer :: i

ints_equal = lhs%ints==rhs%ints

end function ints_equal

elemental integer function bucket_count(this)
        class(hash_integer), intent(in) :: this
        if (.not.HASH_VALID_INITIALIZATION(this%initialized)) then
            bucket_count = 0
        else
            bucket_count = this%n_buckets
        end if
    end function bucket_count

pure recursive function n_collisions(this)
        class(hash_integer), intent(in) :: this
        integer :: n_collisions
        integer :: i

n_collisions = 0
        do i = 1, this%n_buckets
            n_collisions = n_collisions + node_depth(this%buckets(i)) - 1
        enddo
    end function n_collisions

! Return the length of the linked list start from the current node.
    pure recursive integer function node_depth(this) result(depth)
        class(hash_integer_node), intent(in) :: this

if (.not.this%continues) then
            depth = 1
        else
            depth = 1 + node_depth(this%next)
        endif
    end function node_depth

pure subroutine reserve(this, n_buckets)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: n_buckets
        integer :: i,nnew,nold

nnew = 0
        find_size: do i = 1, size(use_sizes)
            if (use_sizes(i) >= n_buckets) then
                nnew = use_sizes(i)
                exit find_size
            endif
        end do find_size

if (.not.this%initialized) then

allocate(this%buckets(nnew))
            this%n_buckets   = nnew
            this%initialized = HASH_TRUE

else

nold = size(this%buckets)
            if (nnew>nold) then
                call this%clear(dealloc=.true.)
                allocate(this%buckets(nnew))
                this%initialized = HASH_TRUE
                this%n_buckets = nnew
            else
                this%n_buckets = nold
            endif

endif

end subroutine reserve

elemental integer function key_count(this)
        class(hash_integer), intent(in) :: this
        key_count = this%n_keys
    end function key_count

pure subroutine set_only_kv(this,kv,is_new)
        class(hash_integer), intent(inout), target :: this
        type(kv_type), intent(in) :: kv
        logical, intent(out) :: is_new
        integer :: bucket_id
        type(hash_integer_node), pointer :: node

bucket_id = get_bucket_id(kv%key%hash_value(), this%n_buckets)
        node      => this%buckets(bucket_id)
        is_new    = .false.

set_node: do while (associated(node))

if (.not.node%kv%set) then
                ! This node not yet used
                node%kv     = kv
                node%kv%set = HASH_TRUE
                is_new      = .true.
                exit set_node
            elseif (node%kv%key == kv%key) then
                ! Same key, but update value
                node%kv     = kv
                node%kv%set = HASH_TRUE
                is_new      = .false.
                exit set_node
            elseif (.not.node%continues) then
                ! Add trailing node
                allocate(node%next)
                node%continues   = HASH_TRUE
                node%next%kv     = kv
                node%next%kv%set = HASH_TRUE
                is_new  = .true.
                exit set_node
            else

! Move to the next node
                node => node%next

endif

end do set_node

if (is_new) this%n_keys = this%n_keys + 1

end subroutine set_only_kv

pure subroutine set_only(this,key,value,is_new)
        class(hash_integer), intent(inout), target :: this
        type(integer_key), intent(in), value :: key
        integer, intent(in), value :: value
        logical, intent(out) :: is_new
        call set_only_kv(this,kv_type(HASH_TRUE,key,value),is_new)
    end subroutine set_only

! Decide if the map should be rehashed when adding a new node
    pure subroutine resize_on_add(this,resized)
        class(hash_integer), intent(inout) :: this
        logical, intent(out) :: resized

integer(ISIZE) :: opt_nbuck

opt_nbuck = hash_optimal_size(this%n_keys)

! Size is too small for the number of stored items
        resized = opt_nbuck>ceiling(1.5*this%n_buckets) .or. &
            opt_nbuck<max(1,floor(0.015*this%n_buckets))

if (resized) call hash_resize(this,opt_nbuck)

end subroutine resize_on_add

pure subroutine set_kv(this, kv, is_new)
        class(hash_integer), intent(inout) :: this
        type(kv_type), intent(in) :: kv
        logical, intent(out), optional :: is_new
        integer :: opt_nbuck
        logical :: new,resized

if (this%n_buckets<=0) call this%reserve(11)
        call resize_on_add(this,resized)

! Set node only
        call set_only_kv(this,kv,new)

if (present(is_new)) is_new = new

end subroutine set_kv

pure subroutine set_key_val(this, key, value, is_new)
        class(hash_integer), intent(inout) :: this
        type(integer_key), intent(in) :: key
        integer, intent(in) :: value
        logical, intent(out), optional :: is_new
        integer :: opt_nbuck
        logical :: new,resized

if (this%n_buckets<=0) call this%reserve(11)
        call resize_on_add(this,resized)

! Set node only
        call set_only(this,key,value,new)

if (present(is_new)) is_new = new

end subroutine set_key_val

pure subroutine set_integer(this, keyval, is_new)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: keyval
        logical, intent(out), optional :: is_new
        call set_key_val(this, integer_key(keyval), keyval, is_new)
    end subroutine set_integer

pure subroutine set_integers(this, keyval)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: keyval(:)

integer :: i
        type(integer_key) :: k

do i=1,size(keyval)
            call set_integer(this,keyval(i))
        end do

end subroutine set_integers

pure subroutine get(this, key, value, success)
        class(hash_integer), intent(in) :: this
        type(integer_key), intent(in) :: key
        integer, intent(out) :: value
        logical, optional, intent(out) :: success

integer :: bucket_id
        logical :: found

if (this%n_keys<=0) then
            value = 0
            found = .false.
        else
            bucket_id = get_bucket_id(key%hash_value(), this%n_buckets)
            call node_get(this%buckets(bucket_id),key, value, found)
        end if

if (present(success)) success = found
    end subroutine get

! If kv is not allocated, fail and return 0.
    ! If key is present and the same as the key passed in, return the value in kv.
    ! If next pointer is associated, delegate to it.
    ! Otherwise, fail and return 0.
    pure recursive subroutine node_get(this, key, value, success)
        class(hash_integer_node), intent(in) :: this
        type(integer_key), intent(in) :: key
        integer, intent(out) :: value
        logical, intent(out) :: success

if (.not.this%kv%set) then
            ! Not found. (Initial node in the bucket not set)
            success  = .false.
            value    = 0
        else if (this%kv%key == key) then
            value   = this%kv%value
            success = .true.
        else if (TRUE(this%continues)) then
            call node_get(this%next,key, value, success)
        else
            value   = 0
            success = .false.
        endif

end subroutine node_get

pure elemental subroutine remove_bothsigns(this, key, success)
        class(hash_integer), intent(inout) :: this
        type(integer_key), intent(in) :: key
        logical, optional, intent(out) :: success

logical :: found(2)
        type(integer_key) :: neg

neg%ints = -key%ints
        call remove(this,key,found(1))
        call remove(this,neg,found(2))

if (present(success)) success = found(1) .or. found(2)

end subroutine remove_bothsigns

pure elemental subroutine remove_bothsigns_int(this,elementID,is_found)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: elementID
        logical, optional, intent(out) :: is_found

type(integer_key) :: k

k%ints = elementID
        call remove_bothsigns(this,k,is_found)

end subroutine remove_bothsigns_int

pure elemental subroutine remove(this, key, success)
        class(hash_integer), intent(inout) :: this
        type(integer_key), intent(in) :: key
        logical, optional, intent(out) :: success

integer :: bucket_id
        logical :: locSuccess,had_next
        type(hash_integer_node), allocatable :: tmp

if (.not.this%initialized) then
            if (present(success)) success = .false.
            return
        end if

bucket_id = get_bucket_id(key%hash_value(), this%n_buckets)

associate (first => this%buckets(bucket_id))

if (TRUE(first%kv%set)) then
                ! Delete first key; move any other keys back
                if (first%kv%key == key) then

first%kv%set = HASH_FALSE

if (TRUE(first%continues)) then

! Copy 2nd item to the 1st position, whose former values get deallocated
                        first%kv          = first%next%kv
                        first%next%kv%set = HASH_FALSE

had_next = TRUE(first%next%continues)

! Move the pointer to tmp
                        if (had_next) call move_alloc(from=first%next%next,to=tmp)
                        deallocate(first%next)

if (had_next) then
                            call move_alloc(from=tmp,to=first%next)    
                            first%continues = HASH_TRUE
                        else
                            first%continues = HASH_FALSE
                        endif

endif
                    locSuccess = .true.
                elseif (TRUE(first%continues)) then
                    call node_remove(first%continues,first%next, key, locSuccess)
                else
                    locSuccess = .false.
                end if
            else
                locSuccess = .false.
            endif

endassociate

if (locSuccess) this%n_keys = this%n_keys - 1
        if (present(success)) success = locSuccess

end subroutine remove

pure recursive subroutine node_remove(parent_continues, this, key, success)
        integer(HASH_ADDR), intent(inout) :: parent_continues
        type(hash_integer_node), allocatable, intent(inout) :: this
        type(integer_key), intent(in) :: key
        logical, intent(out) :: success

integer :: ierr
        logical :: had_next
        type(hash_integer_node), allocatable :: tmp

if (.not.parent_continues) return

if (.not.this%kv%set) then
            ! Not found. (Initial node in the bucket not set)
            success = .false.
        else if (this%kv%key == key) then

! Remove current key-value pair
            this%kv%set = HASH_FALSE

! Attach next to the previous (may be unallocated)
            had_next = TRUE(this%continues)
            if (had_next) then
                call move_alloc(from=this%next,to=tmp)
                this%continues = HASH_FALSE
            end if
            ! Delete current node
            deallocate(this)
            ! Replace it with the former next
            if (had_next) then
                call move_alloc(from=tmp,to=this)
                parent_continues = HASH_TRUE
            else
                parent_continues = HASH_FALSE
            endif

! Do not deallocate "this": it is "previous%next"
            success = .true.
        else if (TRUE(this%continues)) then
            call node_remove(this%continues,this%next, key, success)
        else
            success = .false.
        endif
    end subroutine node_remove

pure subroutine clear(this,dealloc,nodes_queue)
        class(hash_integer), intent(inout) :: this
        logical, optional, intent(in) :: dealloc
        type(hash_integer_node), allocatable, optional, intent(out) :: nodes_queue

integer :: i
        logical :: clean_memory

if (.not.HASH_VALID_INITIALIZATION(this%initialized)) return

if (present(dealloc)) then
            clean_memory = dealloc
        else
            clean_memory = .true.
        end if

! Instead of deallocating them, return a queue of pre-allocated nodes
        if (present(nodes_queue)) then
            call data_queue(this,nodes_queue)
        else
            if (TRUE(this%initialized) .and. allocated(this%buckets)) then
                do i = 1, size(this%buckets)
                    call node_clear(this%buckets(i))
                enddo
            endif
        endif
        this%n_keys = 0

if (clean_memory .and. TRUE(this%initialized)) then
            this%n_buckets = 0
            if (allocated(this%buckets)) deallocate(this%buckets)
            this%initialized = HASH_FALSE
        endif

end subroutine clear

pure subroutine hash_final(this)
        type(hash_integer), intent(inout) :: this
        integer :: i

if (.not.HASH_VALID_INITIALIZATION(this%initialized)) return

if (TRUE(this%initialized)) then
            if (allocated(this%buckets)) then
                do i = 1, size(this%buckets)
                    call node_clear(this%buckets(i))
                enddo
                deallocate(this%buckets)
            endif
        endif

this%initialized = HASH_FALSE
        this%n_keys = 0
        this%n_buckets = 0

end subroutine hash_final

pure recursive subroutine node_final(this)
        type(hash_integer_node), intent(inout) :: this
        call node_clear(this)
    end subroutine node_final

pure recursive subroutine node_final_many(these)
        type(hash_integer_node), intent(inout) :: these(:)
        integer :: i
        do i=1,size(these)
           call node_clear(these(i))
        end do
    end subroutine node_final_many

! Deallocate kv is allocated.
    ! Call the clear method of the next node if the next pointer associated.
    ! Deallocate and nullify the next pointer.
    pure recursive subroutine node_clear(this)
        class(hash_integer_node), intent(inout) :: this

if (.not.HASH_VALID_INITIALIZATION(this%continues)) return

if (TRUE(this%continues)) then
            call node_clear(this%next)
            if (allocated(this%next)) deallocate(this%next)
            this%continues = HASH_FALSE
        endif
        this%kv%set = HASH_FALSE

end subroutine node_clear

pure subroutine begin(this, fhash_target)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer), target, intent(inout) :: fhash_target

this%bucket_id = 1
        this%node_ptr  => fhash_target%buckets(1)
        this%fhash_ptr => fhash_target
    end subroutine begin

function first(this, fhash_target) result(node)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer), target, intent(inout) :: fhash_target
        type(hash_integer_node), pointer :: node
        integer :: status

call begin(this,fhash_target)
        call next_ptr(this,node,status)
        if (status/=0) nullify(node)

end function first

pure subroutine next_key(this, key, value, status)
        class(hash_integer_iterator), intent(inout) :: this
        type(integer_key), intent(out) :: key
        integer, intent(out) :: value
        integer, optional, intent(out) :: status

type(hash_integer_node), pointer :: node

call next_ptr(this, node, status)

if (associated(node)) then
            key   = node%kv%key
            value = node%kv%value
        end if

end subroutine next_key

pure subroutine next_ptr(this, node, status)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer_node), pointer, intent(out) :: node
        integer, optional, intent(out) :: status

nullify(node)

do while (.not. valid_node_pointer(this%node_ptr))
            if (this%bucket_id < this%fhash_ptr%n_buckets) then
                this%bucket_id = this%bucket_id + 1
                this%node_ptr => this%fhash_ptr%buckets(this%bucket_id)
            else
                if (present(status)) status = -1
                return
            endif
        enddo

node  => this%node_ptr
        if (present(status)) status = 0

! Position to the next key (may be empty)
        this%node_ptr => this%node_ptr%next

end subroutine next_ptr

function to_next(this) result(node)
        class(hash_integer_iterator), intent(inout) :: this
        type(hash_integer_node), pointer :: node
        integer :: status
        call next_ptr(this, node, status)
        if (status/=0) nullify(node)
    end function to_next

pure logical function valid_node_pointer(node_ptr)
        type(hash_integer_node), pointer, intent(in) :: node_ptr

valid_node_pointer = associated(node_ptr); if (.not.valid_node_pointer) return
        valid_node_pointer = TRUE(node_ptr%kv%set)

end function valid_node_pointer

pure function int_key_print(key) result(msg)
        class(integer_key), intent(in) :: key
        character(len=:), allocatable :: msg

character(32) :: buffer
        integer :: lb

write(buffer,"(i0)") key%ints

lb = len_trim(buffer)
        allocate(character(len=lb) :: msg)
        if (lb>0) msg(1:lb) = buffer(1:lb)

end function int_key_print

!--------------------------------------------------------------------
    !  Detach all ÒpayloadÓ nodes from every bucket and return them as a
    !  single forward-linked queue rooted at QUEUE.  The order of keys in
    !  the queue is the same bucket-order / traversal order found in the
    !  original table.
    !--------------------------------------------------------------------
    pure subroutine data_queue(map, queue, end_of_queue)
        class(hash_integer), target,                  intent(inout) :: map
        type(hash_integer_node), allocatable, target, intent(out)   :: queue
        type(hash_integer_node), pointer, optional,   intent(out)   :: end_of_queue

integer                           :: ib
        type(hash_integer_node), pointer  :: queue_end, tmp

nullify(queue_end)

do ib = 1, map%bucket_count()

if (.not.map%buckets(ib)%kv%set) cycle   ! skip empty head

! -- Step-0 : make a brand-new queue node and copy the head payload
            if (.not. allocated(queue)) then
                allocate(queue)
                queue_end => queue
            else
                allocate(queue_end%next)
                queue_end%continues = HASH_TRUE
                queue_end => queue_end%next
            end if

queue_end%kv       = map%buckets(ib)%kv
            queue_end%continues = HASH_FALSE

! wipe the bucket head
            map%buckets(ib)%kv%set = HASH_FALSE

! -- Step-1 : if the bucket had a trailing list, splice it behind our
            !             queue_end and clear the bucket link.
            if (TRUE(map%buckets(ib)%continues)) then
                
                call move_alloc(from=map%buckets(ib)%next,to=queue_end%next)
                queue_end%continues = HASH_TRUE
                map%buckets(ib)%continues = HASH_FALSE

! Advance queue_end to the *last* node of the newly-attached chain
                do while (TRUE(queue_end%continues))
                    queue_end => queue_end%next
                end do
            end if
        end do

if (present(end_of_queue)) end_of_queue => queue_end
    end subroutine data_queue

! Bucket ID ivaluation
    elemental integer function fast_modulo(n,m)
        integer, intent(in) :: n,m
        fast_modulo = IAND(n,m-1)
    end function fast_modulo

elemental integer function get_bucket_id(hash_value,n_buckets)
        integer, intent(in) :: hash_value,n_buckets
        if (FAST_MODULO_BUCKETS) then
            get_bucket_id = fast_modulo(hash_value,n_buckets)+1
        else
            get_bucket_id = modulo(hash_value,n_buckets)+1
        end if
    end function get_bucket_id

! Merge hash integer table with another
    pure subroutine merge_with(this,that)
        class(hash_integer), intent(inout) :: this
        class(hash_integer), intent(in) :: that

integer :: bt

if (that%n_keys<=0) return

do bt=1,that%n_buckets
            call merge_with_bucket(this,that%buckets(bt))
        end do

end subroutine merge_with

pure recursive subroutine merge_with_bucket(this,bucket)
        class(hash_integer), intent(inout) :: this
        type(hash_integer_node), intent(in) :: bucket

if (.not.bucket%kv%set) return
        call this%set(bucket%kv%key,bucket%kv%value)
        if (TRUE(bucket%continues)) call merge_with_bucket(this,bucket%next)

end subroutine merge_with_bucket

! Move allocation from a hash table to another
    pure subroutine hash_move_alloc(from,to)
        class(hash_integer), intent(inout), target :: from,to

integer :: i

! Ensure 'to' is properly deallocated before copying data into it
        call to%clear()

if (.not.HASH_VALID_INITIALIZATION(from%initialized)) return

to%n_buckets   = from%n_buckets
        to%n_keys      = from%n_keys
        to%initialized = from%initialized
        call move_alloc(from=from%buckets,to=to%buckets)
        from%initialized = HASH_FALSE
        from%n_buckets   = 0
        from%n_keys      = 0

end subroutine hash_move_alloc

! This subroutine mimics sl_contains from the sorted integer array
    elemental logical function hash_contains(this,key)
        class(hash_integer), intent(in) :: this
        integer, intent(in) :: key

integer :: ib

do ib=1,this%n_buckets
            if (bucket_contains(this%buckets(ib),key)) then
                hash_contains = .true.
                return
            end if
        end do

hash_contains = .false.

end function hash_contains

pure recursive logical function bucket_contains(bucket,key) result(is_in)
        type(hash_integer_node), intent(in) :: bucket
        integer, intent(in) :: key

if (.not.bucket%kv%set) then
            is_in = .false.
        elseif (bucket%kv%key%ints==key) then
            is_in = .true.
        else if (TRUE(bucket%continues)) then
            is_in = bucket_contains(bucket%next,key)
        else
            is_in = .false.
        end if

end function bucket_contains

! Check that all values are in range
    elemental logical function hash_in_range(this,min,max) result(ok)
        class(hash_integer), intent(in) :: this
        integer, intent(in) :: min,max

integer :: b

ok = .true.

do b=1,this%n_buckets
            ok = ok .and. bucket_in_range(this%buckets(b),min,max)
            if (.not.ok) exit
        end do

end function hash_in_range

pure recursive logical function bucket_in_range(bucket,min,max) result(ok)
        class(hash_integer_node), intent(in) :: bucket
        integer, intent(in) :: min,max

! Empty buckets are valid
        if (.not.bucket%kv%set) then
            ok = .true.
        else
            ok = bucket%kv%key%ints>=min .and. bucket%kv%key%ints<=max
            if (TRUE(bucket%continues)) ok = ok .and. bucket_in_range(bucket%next,min,max)
        endif

end function bucket_in_range

pure subroutine hash_replace(this,elementID,newID,is_found)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: elementID,newID
        logical, optional, intent(out) :: is_found

logical :: found_pos,found_neg,found
        type(integer_key) :: kneg,kpos

if (present(is_found)) is_found = .false.
        if (this%n_keys<=0 .or. abs(elementID)==abs(newID)) return

! Find positive and negative attached IDs
        kneg%ints = -abs(elementID); call this%remove(kneg,found_neg)
        kpos%ints =  abs(elementID); call this%remove(kpos,found_pos)

found = found_pos .or. found_neg

if (found) then

! Replace either negative or positive side
            if (found_neg) then
                kneg%ints = -abs(newID)
                call this%set(kneg,value=kneg%ints)
            endif
            if (found_pos) then
                kpos%ints = abs(newID)
                call this%set(kpos,value=kpos%ints)
            endif

endif

if (present(is_found)) is_found = found
    end subroutine hash_replace

! add a NEW key with an allocatable queue pool
    pure subroutine hash_new_with_list(map,key,value,list)
        class(hash_integer), intent(inout) :: map
        type(integer_key), intent(in) :: key
        integer, intent(in) :: value
        type(hash_integer_node), allocatable, intent(inout) :: list

integer :: ib
        logical :: had_next
        type(hash_integer_node), allocatable :: tmp

ib = get_bucket_id(key%hash_value(), map%n_buckets)

if (.not.map%buckets(ib)%kv%set) then

! Init first element in the bucket
            if (allocated(list)) then
                ! Detach rest of the list
                had_next = TRUE(list%continues)
                if (had_next) call move_alloc(from=list%next,to=tmp)

! Copy data in
                map%buckets(ib)%kv = list%kv

! Clear linked list head
                list%kv%set = HASH_FALSE
                deallocate(list)

! Restore linked list head
                if (had_next) call move_alloc(from=tmp,to=list)

end if

map%buckets(ib)%continues  = HASH_FALSE
            map%buckets(ib)%kv%set     = HASH_TRUE
            map%buckets(ib)%kv%key     = key
            map%buckets(ib)%kv%value   = value
            map%n_keys = map%n_keys + 1

else

! See if there is a leftover element that can be used to avoid new allocateions
            if (allocated(list)) then

! Reuse list head
                had_next = TRUE(list%continues)
                if (had_next) call move_alloc(from=list%next,to=tmp)

else

! No leftovers left: allocate a new value
                allocate(list)
                list%continues = HASH_FALSE
                had_next = .false.

endif

! Set kv-pair
            list%kv%set    = HASH_TRUE
            list%kv%key    = key
            list%kv%value  = value

! If applicable, attach the remaining bucket list to it
            if (TRUE(map%buckets(ib)%continues)) then
                list%continues = HASH_TRUE
                call move_alloc(from=map%buckets(ib)%next,to=list%next)
            else
                list%continues = HASH_FALSE
                if (allocated(list%next)) deallocate(list%next)
            endif

! Attach new element to the bucket head
            map%buckets(ib)%continues = HASH_TRUE
            call move_alloc(from=list,to=map%buckets(ib)%next)
            map%n_keys = map%n_keys + 1

! Now reattach remainder of the linked list
            if (had_next) call move_alloc(from=tmp,to=list)

end if

end subroutine hash_new_with_list

! Create hashmap from an array pointing to
    pure subroutine new_from_array(this, array, unique_ID, lb)
        class(hash_integer), intent(inout) :: this
        integer, intent(in) :: array(:)
        ! Request for a unique_ID value (.true.) or the array value (.false.)
        logical, intent(in) :: unique_ID
        ! Optional array lower bound
        integer, optional, intent(in) :: lb

integer :: n,i,start,unique,old
        logical :: found

n = size(array)
        call this%clear()

! Reserve some buckets
        call this%reserve(max(n/2,8))

if (n<=0) return

if (present(lb)) then
            start = lb
        else
            start = 1
        end if

! Add unique nodes
        unique = 0
        do i=1, n
            call this%get(integer_key(array(i)),value=old, success=found)

if (found) cycle

if (unique_ID) then
                ! Assign a unique ID to each key
                unique = unique+1
                call this%set(integer_key(array(i)),value=unique)
            else
                ! Just assign the array index of the first occurrence
                call this%set(integer_key(array(i)),value=start-1+i)
            end if
        end do

end subroutine new_from_array

subroutine hash_assign(this,that)
        class(hash_integer), intent(out) :: this
        class(hash_integer), intent(in), target  :: that

type(hash_integer_iterator) :: iter
        type(hash_integer_node), pointer :: node

call this%clear()
        call this%reserve(n_buckets = that%n_buckets)

if (that%n_buckets<=0) return

! Initialize iterator
        iter%bucket_id = 1
        iter%node_ptr  => that%buckets(1)
        iter%fhash_ptr => that

node => iter%to_next()
        do while (associated(node))

call this%set(key=node%kv%key,value=node%kv%value)

node => iter%to_next()
        end do

end subroutine hash_assign

pure subroutine hash_resize(table, newSize)
        class(hash_integer), intent(inout), target :: table
        integer, intent(in) :: newSize ! desired number of buckets

type(hash_integer) :: new_table
        type(hash_integer_iterator) :: it
        type(hash_integer_node), pointer :: node
        logical :: is_new

! If the table is empty or uninitialized, just reserve directly
        if (table%key_count() <= 0 .or. table%n_buckets <= 0) then
            call table%clear()
            call table%reserve(newSize)
            return
        end if

! Step 1: reserve a new table
        call new_table%reserve(newSize)

! Step 2: iterate and transfer keys
        it%bucket_id = 1
        it%node_ptr  => table%buckets(1)
        it%fhash_ptr => table

call next_ptr(it, node)
        do while (associated(node))
            call set_only_kv(new_table, node%kv, is_new)
            call next_ptr(it, node)
        end do

! Step 3: move allocation from new_table -> table
        call new_table%move_alloc(to=table)

end subroutine hash_resize

pure function idxRange(from,to) result(array)
        integer, intent(in) :: from,to
        integer :: array(sign(1,to-from)*(to-from)+1)
        integer :: j,n,increment
        increment = sign(1,to-from)
        n = increment*(to-from)+1
        forall(j=1:abs(n)) array(j) = from + increment*(j-1)
    end function idxRange

! Quicksort
    pure recursive subroutine sort(list,down)
        integer(int32), dimension(:), intent(inout) :: list
        logical, optional, intent(in) :: down

integer(ISIZE) :: i, j, n
        integer(int32) :: chosen,xmin,xwrk
        logical        :: descending

descending = .false.; if (present(down)) descending = down
        n = size(list,kind=ISIZE)

choose_sorting_algorithm: if (n>1 .and. n <= SMALL_SIZE) then

! Use interchange sort for small lists
            do i = 1, n - 1
                do j = i + 1, n
                    if (toBeSwapped(list(i),list(j),.false.)) then
                        call swap_data_int32(list(i),list(j))
                    end if
                end do
            end do

elseif (n>SMALL_SIZE) then
            ! Use partition (quick) sort if the list is big
            chosen = list(int(n/2,kind=ISIZE))
            i = 0
            j = n + 1

scan_lists: do
                ! Scan list from left end
                ! until element >= chosen is found
                scan_from_left: do
                    i = i + 1
                    if (toBeSwapped(list(i),chosen,.true.) .or. i==n) exit scan_from_left
                end do scan_from_left

! Scan list from right end
                ! until element <= chosen is found

scan_from_right: do
                    j = j - 1
                    if (toBeSwapped(chosen,list(j),.true.) .or. j==1) exit scan_from_right
                end do scan_from_right

swap_element: if (i < j) then
                    ! Swap two out of place elements
                    call swap_data_int32(list(i),list(j))
                else if (i == j) then
                    i = i + 1
                    exit
                else
                    exit
                endif swap_element

end do scan_lists

if (1 < j) call sort(list(:j),down)
            if (i < n) call sort(list(i:),down)

end if choose_sorting_algorithm ! test for small array

contains

elemental logical function toBeSwapped(a,b,orEqual)
            integer(int32), intent(in) :: a,b
            logical, intent(in) :: orEqual

toBeSwapped = merge(is_before(a,b),is_after(a,b),descending)
            if (orEqual .and. a==b) toBeSwapped = .true.

end function toBeSwapped

end subroutine sort

elemental subroutine swap_data_int32(a,b)
        integer(int32), intent(inout) :: a, b
        integer(int32)                :: tmp
        tmp = a
        a   = b
        b   = tmp
        return
    end subroutine swap_data_int32

elemental logical function is_before(a,b)
        integer(int32), intent(in) :: a,b
        is_before = a<b
    end function is_before

elemental logical function is_after(a,b)
        integer(int32), intent(in) :: a,b
        is_after = a>b
    end function is_after

elemental logical function is_ge(a,b)
        integer(int32), intent(in) :: a,b
        is_ge = a>=b
    end function is_ge

elemental logical function is_le(a,b)
        integer(int32), intent(in) :: a,b
        is_le = a<=b
    end function is_le

pure recursive subroutine int32_quicksort_andlist_i32(list,ilist,down)

integer(int32), dimension(:), intent(inout) :: list
        integer(int32), dimension(size(list)), intent(inout) :: ilist
        logical, optional, intent(in) :: down

integer(ISIZE)  :: i, j, n
        integer(int32)  :: chosen
        logical         :: descending

descending = .false.; if (present(down)) descending = down
        n = size(list,kind=ISIZE)

choose_sorting_algorithm: if (n>1 .and. n <= SMALL_SIZE) then

! Use interchange sort for small lists
            do i = 1, n - 1
                do j = i + 1, n
                    if (toBeSwapped(list(i),list(j),.false.)) then
                        call swap_data_int32(list(i),list(j))
                        call swap_list(ilist(i),ilist(j))
                    end if
                end do
            end do

elseif (n>SMALL_SIZE) then
            ! Use partition (quick) sort if the list is big
            chosen = list(int(n/2))
            i = 0
            j = n + 1

! Scan list from right end
                ! until element <= chosen is found

scan_from_right: do
                    j = j - 1
                    if (toBeSwapped(chosen,list(j),.true.) .or. j==1) exit scan_from_right
                end do scan_from_right

swap_element: if (i < j) then
                    ! Swap two out of place elements
                    call swap_data_int32(list(i),list(j))
                    call swap_list(ilist(i),ilist(j))
                else if (i == j) then
                    i = i + 1
                    exit
                else
                    exit
                endif swap_element

end do scan_lists

if (1 < j) call int32_quicksort_andlist_i32(list(:j),ilist(:j),down)
            if (i < n) call int32_quicksort_andlist_i32(list(i:),ilist(i:),down)

end if choose_sorting_algorithm ! test for small array

contains

elemental subroutine swap_list(a,b)
            integer(int32), intent(inout) :: a,b
            integer(int32) :: tmp
            tmp = a
            a = b
            b = tmp
        end subroutine swap_list

elemental logical function toBeSwapped(a,b,orEqual)
            integer(int32), intent(in) :: a,b
            logical, intent(in) :: orEqual

toBeSwapped = merge(is_before(a,b),is_after(a,b),descending)
            if (orEqual .and. a==b) toBeSwapped = .true.

end function toBeSwapped

end subroutine int32_quicksort_andlist_i32

end module hash_integers

program test_hash_integer_driver
   use hash_integers         
   implicit none
   
   type :: derived
      type(hash_integer) :: hash
   end type derived
      
   logical :: success
   type(derived) :: a,b
   
   call a%hash%reserve(12)
   call a%hash%set(123)
   call a%hash%set(124)
   call a%hash%set(125)
   call b%hash%reserve(356)
   call b%hash%set(-1234)

print *, b%hash%contains(123)
   
   b = a ! CRASH!!

print *, b%hash%contains(123)

a = b

print *, a%hash%contains(123)

success = test_hash_resize()
   if (success) stop 'HOORAY'
   stop 'ERROR'

contains
   logical function test_hash_resize() result(success)
      use hash_integers
      implicit none

type(hash_integer) :: h
      type(integer_key)  :: k
      integer            :: i, nk, nk_expected, bucket_before, bucket_after, v
      logical            :: ok

success = .false.

! Fill with many items to force resize later
      nk_expected = 1000

call h%reserve(16)
      bucket_before = h%bucket_count()

do i = 1, nk_expected
         call h%set(i)
      end do

! Should have auto-resized
      bucket_after = h%bucket_count()
      if (.not. assert_true(bucket_after > bucket_before, 'resize did not grow bucket count')) return
      if (.not. assert_true(h%key_count() == nk_expected, 'wrong key count after insertions')) return

! Confirm values are correct
      do i = 1, nk_expected
         k%ints = i
         call h%get(k, v, ok)
         if (.not. assert_true(ok .and. v == i, 'value mismatch after resize')) return
      end do

! Explicit downsize to a smaller bucket count
      call h%resize(11)
      if (.not. assert_true(h%bucket_count() >= 11, 'resize(11) did not set bucket count')) return
      if (.not. assert_true(h%key_count() == nk_expected, 'key count mismatch after resize(11)')) return

! Confirm values still correct
      do i = 1, nk_expected
         k%ints = i
         call h%get(k, v, ok)
         if (.not. assert_true(ok .and. v == i, 'value mismatch after resize(11)')) return
      end do

success = .true.

end function test_hash_resize

logical function assert_true(cond, msg)
      logical, intent(in) :: cond
      character(*), intent(in) :: msg
      assert_true = cond
      if (.not. cond) write(*,*) 'Assertion failed: ', trim(msg)
   end function assert_true

end program test_hash_integer_driver