dc_hash.f90

Go to the documentation of this file.

!-----------------------------------------------------------------------
! Copyright (c) 2000-2026 Gtool Development Group. All rights reserved.
!-----------------------------------------------------------------------
 
module dc_hash
  use dc_types, only : string
  implicit none
  private
 
  public:: hash
  public:: dchashput, dchashputline, dchashget
  public:: dchashrewind, dchashnext, dchashdelete, dchashnumber
 
  !-----------------------------------------------
  ! 後方互換用
  ! For backward compatibility
  public:: put, putline, get, rewind, next, delete, number
 
  type hash
    private
    type(HASH_INTERNAL), pointer :: hash_table(:) => null()
                              
    integer :: search_index = 0
                              
  end type hash
 
  type hash_internal
    private
    character(STRING) :: key
                              
    character(STRING) :: value
                              
  end type hash_internal
 
  interface dchashput
    module procedure dchashput0
  end interface
 
  interface dchashnumber
    module procedure dchashnumber0
  end interface
 
  interface dchashputline
    module procedure dchashputline0
  end interface
 
  interface dchashrewind
    module procedure dchashrewind0
  end interface
 
  interface dchashnext
    module procedure dchashnext0
  end interface
 
  interface dchashget
    module procedure dchashget0
  end interface
 
  interface dchashdelete
    module procedure dchashdelete0
  end interface
 
  !-----------------------------------------------
  ! 後方互換用
  ! For backward compatibility
  interface put
    module procedure dchashput0
  end interface
 
  interface number
    module procedure dchashnumber0
  end interface
 
  interface putline
    module procedure dchashputline0
  end interface
 
  interface rewind
    module procedure dchashrewind0
  end interface
 
  interface next
    module procedure dchashnext0
  end interface
 
  interface get
    module procedure dchashget0
  end interface
 
  interface delete
    module procedure dchashdelete0
  end interface
 
contains
 
  subroutine dchashput0(hashv, key, value)
    implicit none
    type(hash), intent(inout) :: hashv
    character(*), intent(in) :: key, value
    type(hash_internal), pointer :: hash_table_tmp(:) => null()
    integer :: table_size, new_index, i
    logical :: found
    character(STRING) :: search_value
  continue
    call dchashget(hashv, key, search_value, found)
    if (.not. found) then
      table_size = dchashnumber(hashv)
      if (table_size > 0) then
        allocate(hash_table_tmp(table_size))
        hash_table_tmp = hashv % hash_table
        deallocate(hashv % hash_table)
        allocate(hashv % hash_table(table_size + 1))
        hashv % hash_table(1:table_size) = hash_table_tmp(1:table_size)
        deallocate(hash_table_tmp)
        new_index = table_size + 1
      else
        allocate(hashv % hash_table(1))
        new_index = 1
      end if
 
      hashv % hash_table(new_index) % key = key
      hashv % hash_table(new_index) % value = value
    else
      do i = 1, size(hashv % hash_table)
        if (trim(hashv % hash_table(i) % key) == trim(key)) then
          hashv % hash_table(i) % value = value
        end if
      end do
    end if
 
  end subroutine dchashput0
 
 
  function dchashnumber0(hashv) result(result)
    implicit none
    type(hash), intent(in) :: hashv
    integer :: result
  continue
    if (associated(hashv % hash_table)) then
      result = size(hashv % hash_table)
    else
      result = 0
    end if
  end function dchashnumber0
 
  subroutine dchashrewind0(hashv)
    implicit none
    type(hash), intent(inout) :: hashv
  continue
    hashv % search_index = 1
  end subroutine dchashrewind0
 
  subroutine dchashnext0(hashv, key, value, end)
    implicit none
    type(hash), intent(inout) :: hashv
    character(*), intent(out) :: key
    character(*), intent(out), optional :: value
    logical, intent(out) :: end
    integer :: table_size
    character(STRING) :: value_tmp
  continue
    table_size = dchashnumber(hashv)
    if (table_size < hashv % search_index) then
      key = ''
      value_tmp = ''
      end = .true.
    else
      key = hashv % hash_table(hashv % search_index) % key
      value_tmp = hashv % hash_table(hashv % search_index) % value
      end = .false.
      hashv % search_index = hashv % search_index + 1
    end if
    if (present(value)) then
      value = value_tmp
    end if
 
  end subroutine dchashnext0
 
 
  subroutine dchashputline0(hashv)
    use dc_types, only: string
    use dc_string, only: printf, joinchar
    implicit none
    type(hash), intent(in) :: hashv
    type(hash) :: hashv_tmp
    character(len = STRING):: key, value
    logical:: end
  continue
    hashv_tmp = hashv
 
    call printf(6, '#<HASH:: ')
    call dchashrewind(hashv_tmp)
    do
      call dchashnext(hashv_tmp, key, value, end)
      if (end) exit
      call printf(6, '         "%c" -> "%c",', &
        & c1=trim(key), c2=trim(value))
    enddo
    call printf(6, '> ')
 
  end subroutine dchashputline0
 
 
  subroutine dchashget0(hashv, key, value, found)
    use dc_types, only: string
    implicit none
    type(hash), intent(inout) :: hashv
    character(*), intent(in)  :: key
    character(*), intent(out) :: value
    logical, intent(out), optional :: found
    character(STRING) :: search_key, search_value
    logical :: end
  continue
    call dchashrewind(hashv)
    do
      call dchashnext(hashv, search_key, search_value, end)
      if (end) then
        value = ''
        if (present(found)) found = .false.
        exit
      end if
 
      if (trim(search_key) == trim(key)) then
        value = search_value
        if (present(found)) found = .true.
        exit
      end if
    enddo
 
  end subroutine dchashget0
 
  subroutine dchashdelete0(hashv, key)
    implicit none
    type(hash), intent(inout) :: hashv
    character(*), intent(in), optional :: key
    type(hash_internal), pointer :: hash_table_tmp(:) => null()
    integer :: table_size, i, j
    logical :: found
    character(STRING) :: search_value
  continue
    if (present(key)) then
      call dchashget(hashv, key, search_value, found)
      table_size = dchashnumber(hashv)
      if (found .and. table_size > 1) then
        allocate(hash_table_tmp(table_size))
        hash_table_tmp = hashv % hash_table
        deallocate(hashv % hash_table)
        allocate(hashv % hash_table(table_size - 1))
        j = 1
        do i = 1, table_size
          if (trim(hash_table_tmp(i) % key) /= trim(key)) then
            hashv % hash_table(j) % key = hash_table_tmp(i) % key
            hashv % hash_table(j) % value = hash_table_tmp(i) % value
            j = j + 1
          end if
        end do
        
        deallocate(hash_table_tmp)
      elseif (found .and. table_size == 1) then
        deallocate(hashv % hash_table)
      end if
    else
      if (associated(hashv % hash_table)) deallocate(hashv % hash_table)
    end if
 
  end subroutine dchashdelete0
 
end module dc_hash