scale_linkedlist.F90

Go to the documentation of this file.

 
#include "scaleFElib.h"
module scale_linkedlist
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  use scale_precision
  use scale_io
  
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public type & procedures
  !
  
  !---
  type, abstract, public :: linkedlistkey
  contains
    procedure(key_equal_func), private, deferred :: key_equal
    generic, public :: operator(==) => key_equal
  end type linkedlistkey
 
  abstract interface
    pure elemental logical function key_equal_func( item1, item2 )
      import linkedlistkey
      class(linkedlistkey), intent(in) :: item1
      class(linkedlistkey), intent(in) :: item2
    end function key_equal_func
  end interface
 
  !---
  type :: node
    private
    class(*), allocatable :: key
    class(*), pointer     :: value => null()
    logical :: destroy_on_delete
    type(node), pointer :: next => null()
    type(node), pointer :: previous => null()
  contains
    procedure, public :: init => node_init
    procedure, public :: final => node_final
    procedure, public :: getdata => node_get_data
  end type
 
 
  type, public :: linkedlist
    type(node), pointer, private :: head
    type(node), pointer, private :: tail
    integer, private :: counter
  contains
    procedure, public :: init  => linkedlist_init
    procedure, public :: final => linkedlist_final
    procedure, public :: addbypointer => linkedlist_add_by_pointer
    procedure, public :: removebypointer => linkedlist_remove_by_pointer
    procedure, public :: remove => linkedlist_remove_by_key
    procedure, public :: addbyclone => linkedlist_add_by_clone
    procedure, public :: getnode => linkedlist_get_node
    procedure, public :: get => linkedlist_get_data
    procedure, public :: traverselist =>  linkedlist_traverse_list
    procedure, public :: traverse =>  linkedlist_traverse
 
    procedure, private :: keysequal => linkedlist_keys_eqaul
  end type 
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  
  !-----------------------------------------------------------------------------
  !
  !++ Private procedures & variables
  !
  !------------------
 
  abstract interface
    subroutine iterator_func(this, done)
      import :: node
      implicit none
      type(node), pointer  :: this
      logical, intent(out) :: done
    end subroutine iterator_func
 
    subroutine key_iterator(key, value, done)
      implicit none
      class(*), intent(in) :: key
      class(*), pointer    :: value
      logical, intent(out) :: done
    end subroutine key_iterator   
  end interface
 
contains
  subroutine node_init( this, key, value, previous_node, destroy_on_delete ) 
    implicit none
    class(node) :: this
    class(*), intent(in) :: key
    class(*), pointer, intent(in) :: value
    type(node), pointer :: previous_node
    logical, intent(in) :: destroy_on_delete
    !---------------------------------------------
 
    allocate( this%key, source=key )
    this%value => value
    this%previous => previous_node
    this%destroy_on_delete = destroy_on_delete
 
    return
  end subroutine node_init
 
  subroutine node_final( this ) 
    implicit none
    class(node), intent(inout) :: this
    !---------------------------------------------
 
    if( allocated( this%key ) ) deallocate( this%key )
    if ( this%destroy_on_delete ) then
      if (associated( this%value) ) deallocate( this%value )
    end if
 
    return
  end subroutine node_final
 
  subroutine node_get_data( this, value ) 
    implicit none
    class(node) :: this
    class(*), pointer, intent(out) :: value
    !---------------------------------------------
    
    if ( associated(this%value) )then
      value => this%value
    else
      log_error(" Node_get_data",*)   "The pointer into data of node is not associated. Check!"      
    end if
 
    return
  end subroutine node_get_data
 
  !-------------------------------------------------------
 
  subroutine linkedlist_init( this )
    implicit none
    class(linkedlist), intent(inout) :: this
    !---------------------------------------------
 
    this%counter = 0
    nullify( this%head, this%tail )
 
    return
  end subroutine linkedlist_init
 
  subroutine linkedlist_final( this )
    implicit none
    class(linkedlist), intent(inout) :: this
    !---------------------------------------------
 
    this%counter = 0
    if ( associated(this%head) ) call destroy_subsequent_nodes( this%head )
 
    return
  end subroutine linkedlist_final
 
  recursive subroutine destroy_subsequent_nodes( this_node )
    implicit none
    type(node), pointer, intent(inout) :: this_node
 
    !---------------------------------------------
    if ( associated(this_node) ) then
      call this_node%Final()
      call destroy_subsequent_nodes( this_node%next )
      nullify( this_node%previous )
      deallocate( this_node )
      nullify( this_node )
    end if
 
    return
  end subroutine destroy_subsequent_nodes
 
 
  function linkedlist_has_key( this, key ) result(has_key)
    implicit none
    class(linkedlist), intent(inout) :: this
    class(*), intent(in)             :: key
    logical                          :: has_key
    !---------------------------------------------
 
    has_key = .false.
    call this%TraverseList( key_search )
    return
  contains
    subroutine key_search(ptr, done)
      implicit none
      type(node), pointer :: ptr
      logical, intent(out) :: done
      !-------------------------------------------------
      has_key = this%keysEqual(ptr%key, key)
      done = has_key
      return
    end subroutine key_search
  end function linkedlist_has_key
 
  subroutine linkedlist_traverse_list( &
    this, iterator )
 
    implicit none
    class(linkedlist), intent(inout) :: this
    procedure(iterator_func) :: iterator
 
    type(node), pointer :: ptr
    logical :: done
    !----------------------------------------------------
    
    done = .false.
    ptr => this%head
 
    do 
      if (associated(ptr)) then
        call iterator( ptr, done )
        if (done) exit
        ptr => ptr%next
      else
        exit
      end if
    end do
 
    return
  end subroutine linkedlist_traverse_list
 
  subroutine linkedlist_traverse( &
    this, iterator )
 
    implicit none
    class(linkedlist), intent(inout) :: this
    procedure(key_iterator) :: iterator
 
    !----------------------------------------------------
    
    call this%TraverseList( key_iterator_wrapper )
    return
 
  contains
    subroutine key_iterator_wrapper( this_node, done )
      implicit none
      type(node), pointer :: this_node
      logical, intent(out) :: done
      !----------------------------------------------------
 
      call iterator( this_node%key, this_node%value, done )
      return
    end subroutine key_iterator_wrapper
 
  end subroutine linkedlist_traverse
 
  subroutine linkedlist_add_by_pointer( &
      this, key, value, destroy_on_delete )
    
    implicit none
    class(linkedlist), intent(inout) :: this
    class(*), intent(in) :: key
    class(*), pointer, intent(in) :: value
    logical, intent(in), optional :: destroy_on_delete
 
    type(node), pointer :: pNode
    logical :: destroy_on_delete_ = .false.
    !---------------------------------------------
 
    select type (key)
    type is (integer)
    type is (character(len=*))
!    class is (LinkedListKey)
    class default
      log_error("LinkedList_add_by_pointer",*)   "The type of key is invalid. Check!"
    end select
 
    call this%GetNode( key, pnode )
    if ( associated(pnode) ) call this%RemoveByPointer( pnode )
 
    allocate( pnode )
    if (present(destroy_on_delete)) then
      destroy_on_delete_ = destroy_on_delete
    end if
    call pnode%Init( key, value, this%tail, destroy_on_delete_ )
 
    if ( associated(this%tail) ) then
      this%tail%next => pnode
    else
      this%head => pnode
    end if
    this%tail => pnode
    this%counter = this%counter + 1
 
    return
  end subroutine linkedlist_add_by_pointer
 
  subroutine linkedlist_add_by_clone( this, key, value )
    implicit none
    class(linkedlist), intent(inout) :: this
    class(*), intent(in) :: key
    class(*), intent(in) :: value
 
    class(*), pointer :: ptr_value
    !---------------------------------------------
 
    allocate(ptr_value, source=value)
    call this%AddByPointer( key, ptr_value, destroy_on_delete=.true. )
 
    return
  end subroutine linkedlist_add_by_clone
 
  subroutine linkedlist_remove_by_key( this, key )
    implicit none
    class(linkedlist), intent(inout) :: this
    class(*), intent(in) :: key
 
    type(node), pointer :: pNode
    !---------------------------------------------
 
    call this%GetNode( key, pnode )
    call this%RemoveByPointer( pnode )
 
    return
  end subroutine linkedlist_remove_by_key
 
  subroutine linkedlist_remove_by_pointer( this, pNode )
    implicit none
    class(linkedlist), intent(inout) :: this
    type(node), pointer :: pNode
 
    logical :: has_next
    logical :: has_previous
    !---------------------------------------------
 
    if ( associated(pnode) ) then
      has_next = associated( pnode%next )
      has_previous = associated( pnode%previous )
 
      if ( has_next .and. has_previous ) then
        pnode%previous%next => pnode%next
        pnode%next%previous => pnode%previous
      else if (       has_next .and. .not. has_previous ) then
        this%head => pnode%next
        nullify( this%head%previous )        
      else if ( .not. has_next .and.       has_previous ) then
        this%tail => pnode%previous
        nullify( this%tail%next )
      else if ( .not. (has_next .or. has_previous) ) then
        nullify( this%head, this%tail )
      end if
 
      call pnode%Final()
      deallocate( pnode )
      nullify( pnode )
 
      this%counter = this%counter - 1
    end if
 
    return
  end subroutine linkedlist_remove_by_pointer
 
  subroutine linkedlist_get_node( this, key, ptr_node )
    implicit none
    class(linkedlist), intent(in) :: this
    class(*), intent(in) :: key
    type(node), pointer, intent(out) :: ptr_node
 
    type(node), pointer :: ptr
    !---------------------------------------------
 
    nullify( ptr_node )
    
    ptr => this%head
    do 
      if ( associated(ptr) ) then
        if (this%keysEqual(ptr%key, key)) then
          ptr_node => ptr
          return
        end if
        ptr => ptr%next
      else
        return
      end if
    end do
 
  end subroutine linkedlist_get_node
 
  subroutine linkedlist_get_data( this, key, ptr_value )
    implicit none
    class(linkedlist), intent(in) :: this
    class(*), intent(in) :: key
    class(*), pointer, intent(out) :: ptr_value
 
    type(node), pointer :: ptr
    !---------------------------------------------
 
    call this%GetNode( key, ptr )
    if ( associated(ptr) ) then
      ptr_value => ptr%value
    else
      nullify( ptr_value )
    end if
 
    return
  end subroutine linkedlist_get_data
 
  function linkedlist_keys_eqaul( this, key1, key2 ) result(is_keys_eqaul)
    implicit none
    class(linkedlist), intent(in) :: this
    class(*), intent(in) :: key1 
    class(*), intent(in) :: key2
    logical :: is_keys_eqaul
 
    !---------------------------------------------
 
    is_keys_eqaul = .false.
 
    if ( same_type_as(key1, key2) ) then
      select type (key1)    
      type is (integer)
        select type(key2)
        type is (integer)
          is_keys_eqaul = (key1 == key2)
        end select         
      type is (character(len=*))
        select type(key2)
        type is (character(len=*))
          is_keys_eqaul = (key1 == key2)
        end select
      ! class is (LinkedListKey)
      ! select type(key2)
      ! class is (LinkedListKey)
      !   is_keys_eqaul = (key1 == key2)
      ! end select       
      end select 
    end if
 
    return
  end function linkedlist_keys_eqaul
 
end module scale_linkedlist