List.f90

Go to the documentation of this file.

module listmodule
  use kindmodule, only: dp, i4b
  use errorutilmodule, only: pstop
  use constantsmodule, only: linelength
  implicit none
  private
  public :: listtype, listnodetype, isequaliface
 
  !> @brief A generic heterogeneous doubly-linked list.
  type :: listtype
    ! -- Public members
    type(listnodetype), pointer, public :: firstnode => null()
    character(len=20), public :: name = ' '
    ! -- Private members
    type(listnodetype), pointer, private :: lastnode => null()
    type(listnodetype), pointer, private :: currentnode => null()
    integer(I4B), private :: currentnodeindex = 0
    integer(I4B), private :: nodecount = 0
  contains
    ! -- Public procedures
    procedure, public :: add
    procedure, public :: clear
    procedure, public :: count
    procedure, public :: containsobject
    procedure, public :: deallocatebackward
    procedure, public :: getindex
    procedure, public :: getnextitem
    procedure, public :: getpreviousitem
    generic, public :: getitem => get_item_by_index, get_current_item
    procedure, public :: insertafter
    procedure, public :: insertbefore
    procedure, public :: next
    procedure, public :: previous
    procedure, public :: reset
    generic, public :: removenode => remove_node_by_index, remove_this_node
    ! -- Private procedures
    procedure, private :: get_current_item
    procedure, private :: get_item_by_index
    procedure, private :: get_node_by_index
    procedure, private :: remove_node_by_index
    procedure, private :: remove_this_node
    ! Finalization is not supported in gfortran (as of 4.10.0)
    !final :: clear_list
  end type listtype
 
  type :: listnodetype
    ! -- Public members
    type(listnodetype), pointer, public :: nextnode => null()
    type(listnodetype), pointer, public :: prevnode => null()
    ! -- Private members
    class(*), pointer, private :: Value => null()
  contains
    ! -- Public procedure
    procedure, public :: getitem
    ! -- Private procedures
    procedure, private :: deallocvalue
  end type listnodetype
 
  interface
    function isequaliface(obj1, obj2) result(isEqual)
      class(*), pointer :: obj1, obj2
      logical :: isequal
    end function
  end interface
 
contains
 
  !> @brief Append the given item to the list
  subroutine add(this, objptr)
    ! -- dummy variables
    class(listtype), intent(inout) :: this
    class(*), pointer, intent(inout) :: objptr
    !
    if (.not. associated(this%firstNode)) then
      allocate (this%firstNode)
      this%firstNode%Value => objptr
      this%firstNode%prevNode => null()
      this%lastNode => this%firstNode
    else
      allocate (this%lastNode%nextNode)
      this%lastNode%nextNode%prevNode => this%lastNode
      this%lastNode%nextNode%value => objptr
      this%lastNode => this%lastNode%nextNode
    end if
    this%nodeCount = this%nodeCount + 1
  end subroutine add
 
  !> @brief Deallocate all items in list
  subroutine clear(this, destroy)
    ! -- dummy variables
    class(listtype) :: this
    logical, intent(in), optional :: destroy
    ! -- local
    logical :: destroyLocal
    type(listnodetype), pointer :: current => null()
    type(listnodetype), pointer :: next => null()
    !
    destroylocal = .false.
    if (present(destroy)) then
      destroylocal = destroy
    end if
    !
    if (.not. associated(this%firstNode)) return
    ! -- The last node will be deallocated in the loop below.
    !    Just nullify the pointer to the last node to avoid
    !    having a dangling pointer. Also nullify currentNode.
    nullify (this%lastNode)
    nullify (this%currentNode)
    !
    current => this%firstNode
    do while (associated(current))
      ! -- Assign a pointer to the next node in the list
      next => current%nextNode
      ! -- Deallocate the object stored in the current node
      call current%DeallocValue(destroylocal)
      ! -- Deallocate the current node
      deallocate (current)
      this%firstNode => next
      this%nodeCount = this%nodeCount - 1
      ! -- Advance to the next node
      current => next
    end do
    !
    call this%Reset()
 
  end subroutine clear
 
  !> @brief Return number of nodes in list
  function count(this)
    integer(I4B) :: count
    class(listtype) :: this
    count = this%nodeCount
  end function count
 
  !> @brief Determine whether the list contains the given object.
  function containsobject(this, obj, isEqual) result(hasObj)
    class(listtype), intent(inout) :: this
    class(*), pointer :: obj
    procedure(isequaliface), pointer, intent(in), optional :: isequal
    logical :: hasobj
    ! local
    type(listnodetype), pointer :: current => null()
 
    hasobj = .false.
    current => this%firstNode
    do while (associated(current))
      if (present(isequal)) then
        if (isequal(current%Value, obj)) then
          hasobj = .true.
          return
        end if
      else
        if (associated(current%Value, obj)) then
          hasobj = .true.
          return
        end if
      end if
 
      ! -- Advance to the next node
      current => current%nextNode
    end do
 
  end function
 
  !> @brief Deallocate fromNode and all previous nodes, and reassign firstNode.
  subroutine deallocatebackward(this, fromNode)
    ! -- dummy
    class(listtype), target, intent(inout) :: this
    type(listnodetype), pointer, intent(inout) :: fromNode
    ! -- local
    type(listnodetype), pointer :: current => null()
    type(listnodetype), pointer :: prev => null()
    !
    if (associated(fromnode)) then
      ! -- reassign firstNode
      if (associated(fromnode%nextNode)) then
        this%firstNode => fromnode%nextNode
      else
        this%firstNode => null()
      end if
      ! -- deallocate fromNode and all previous nodes
      current => fromnode
      do while (associated(current))
        prev => current%prevNode
        call current%DeallocValue(.true.)
        deallocate (current)
        this%nodeCount = this%nodeCount - 1
        current => prev
      end do
      fromnode => null()
    end if
 
  end subroutine deallocatebackward
 
  !> @brief Get the index of the given item in the list.
  function getindex(this, obj) result(idx)
    class(listtype), target, intent(inout) :: this
    class(*), pointer :: obj
    integer(I4B) :: idx
    ! local
    integer(I4B) :: i
    class(*), pointer :: obj_in_list
 
    idx = -1
    do i = 1, this%Count()
      obj_in_list => this%GetItem(i)
      if (associated(obj, obj_in_list)) then
        idx = i
        exit
      end if
    end do
 
  end function getindex
 
  !> @brief Get the next item in the list
  function getnextitem(this) result(resultobj)
    class(listtype), target, intent(inout) :: this
    class(*), pointer :: resultobj
    call this%Next()
    resultobj => this%get_current_item()
  end function getnextitem
 
  !> @brief Get the previous item in the list
  function getpreviousitem(this) result(resultobj)
    class(listtype), target, intent(inout) :: this
    class(*), pointer :: resultobj
    call this%Previous()
    resultobj => this%get_current_item()
  end function getpreviousitem
 
  !> @brief Insert the given item after the given index.
  subroutine insertafter(this, objptr, indx)
    ! -- dummy
    class(listtype), intent(inout) :: this
    class(*), pointer, intent(inout) :: objptr
    integer(I4B), intent(in) :: indx
    ! -- local
    integer(I4B) :: numnodes
    type(listnodetype), pointer :: precedingNode => null()
    type(listnodetype), pointer :: followingNode => null()
    type(listnodetype), pointer :: newNode => null()
    !
    numnodes = this%Count()
    if (indx >= numnodes) then
      call this%Add(objptr)
    else
      precedingnode => this%get_node_by_index(indx)
      if (associated(precedingnode%nextNode)) then
        followingnode => precedingnode%nextNode
        allocate (newnode)
        newnode%Value => objptr
        newnode%nextNode => followingnode
        newnode%prevNode => precedingnode
        precedingnode%nextNode => newnode
        followingnode%prevNode => newnode
        this%nodeCount = this%nodeCount + 1
      else
        call pstop(1, 'Programming error in ListType%insert_after')
      end if
    end if
 
  end subroutine insertafter
 
  !> @brief Insert the given item before the given node.
  subroutine insertbefore(this, objptr, targetNode)
    ! -- dummy
    class(listtype), intent(inout) :: this
    class(*), pointer, intent(inout) :: objptr
    type(listnodetype), pointer, intent(inout) :: targetNode
    ! -- local
    type(listnodetype), pointer :: newNode => null()
    !
    if (.not. associated(targetnode)) &
      call pstop(1, 'Programming error in ListType%InsertBefore')
    !
    ! Allocate a new list node and point its Value member to the object
    allocate (newnode)
    newnode%Value => objptr
    !
    ! Do the insertion
    newnode%nextNode => targetnode
    if (associated(targetnode%prevNode)) then
      ! Insert between two nodes
      targetnode%prevNode%nextNode => newnode
      newnode%prevNode => targetnode%prevNode
    else
      ! Insert before first node
      this%firstNode => newnode
      newnode%prevNode => null()
    end if
    targetnode%prevNode => newnode
    this%nodeCount = this%nodeCount + 1
 
  end subroutine insertbefore
 
  !> @brief Move the list's current node pointer and index one node forwards.
  subroutine next(this)
    class(listtype), target, intent(inout) :: this
 
    if (this%currentNodeIndex == 0) then
      if (associated(this%firstNode)) then
        this%currentNode => this%firstNode
        this%currentNodeIndex = 1
      else
        this%currentNode => null()
        this%currentNodeIndex = 0
      end if
    else
      if (associated(this%currentNode%nextNode)) then
        this%currentNode => this%currentNode%nextNode
        this%currentNodeIndex = this%currentNodeIndex + 1
      else
        this%currentNode => null()
        this%currentNodeIndex = 0
      end if
    end if
  end subroutine next
 
  !> @brief Move the list's current node pointer and index one node backwards.
  subroutine previous(this)
    class(listtype), target, intent(inout) :: this
    if (this%currentNodeIndex <= 1) then
      call this%Reset()
    else
      this%currentNode => this%currentNode%prevNode
      this%currentNodeIndex = this%currentNodeIndex - 1
    end if
  end subroutine previous
 
  !> @brief Reset the list's current node pointer and index.
  subroutine reset(this)
    class(listtype), target, intent(inout) :: this
    this%currentNode => null()
    this%currentNodeIndex = 0
  end subroutine reset
 
  !> @brief Remove the node at the given index, optionally destroying its value.
  subroutine remove_node_by_index(this, i, destroyValue)
    ! -- dummy
    class(listtype), intent(inout) :: this
    integer(I4B), intent(in) :: i
    logical, intent(in) :: destroyValue
    ! -- local
    type(listnodetype), pointer :: node
    !
    node => null()
    node => this%get_node_by_index(i)
    if (associated(node)) then
      call this%remove_this_node(node, destroyvalue)
    end if
 
  end subroutine remove_node_by_index
 
  !> @brief Remove the given node, optionally destroying its value.
  subroutine remove_this_node(this, node, destroyValue)
    ! -- dummy
    class(listtype), intent(inout) :: this
    type(listnodetype), pointer, intent(inout) :: node
    logical, intent(in) :: destroyValue
    ! -- local
    !
    logical :: first, last
    !
    first = .false.
    last = .false.
    if (associated(node)) then
      if (associated(node%prevNode)) then
        if (associated(node%nextNode)) then
          node%nextNode%prevNode => node%prevNode
        else
          node%prevNode%nextNode => null()
          this%lastNode => node%prevNode
        end if
      else
        first = .true.
      end if
      if (associated(node%nextNode)) then
        if (associated(node%prevNode)) then
          node%prevNode%nextNode => node%nextNode
        else
          node%nextNode%prevNode => null()
          this%firstNode => node%nextNode
        end if
      else
        last = .true.
      end if
      if (destroyvalue) then
        call node%DeallocValue(destroyvalue)
      end if
      deallocate (node)
      this%nodeCount = this%nodeCount - 1
      if (first .and. last) then
        this%firstNode => null()
        this%lastNode => null()
        this%currentNode => null()
      end if
      call this%Reset()
    end if
 
  end subroutine remove_this_node
 
  ! -- Private type-bound procedures for ListType
 
  !> @brief Get a pointer to the item at the current node.
  function get_current_item(this) result(resultobj)
    class(listtype), target, intent(inout) :: this
    ! result
    class(*), pointer :: resultobj
    !
    resultobj => null()
    if (associated(this%currentNode)) then
      resultobj => this%currentNode%Value
    end if
  end function get_current_item
 
  !> @brief Get a pointer to the item at the given index.
  function get_item_by_index(this, indx) result(resultobj)
    ! -- dummy
    class(listtype), intent(inout) :: this
    integer(I4B), intent(in) :: indx
    ! result
    class(*), pointer :: resultobj
    ! -- local
    integer(I4B) :: i
    !
    ! -- Initialize
    resultobj => null()
    !
    ! -- Ensure that this%currentNode is associated
    if (.not. associated(this%currentNode)) then
      this%currentNodeIndex = 0
    end if
    if (this%currentNodeIndex == 0) then
      if (associated(this%firstNode)) then
        this%currentNode => this%firstNode
        this%currentNodeIndex = 1
      end if
    end if
    !
    ! -- Check indx position relative to current node index
    i = 0
    if (indx < this%currentNodeIndex) then
      ! Start at beginning of list
      call this%Reset()
      if (associated(this%firstNode)) then
        this%currentNode => this%firstNode
        this%currentNodeIndex = 1
        i = 1
      end if
    else
      i = this%currentNodeIndex
    end if
    if (i == 0) return
    !
    ! -- If current node is requested node,
    !    assign pointer and return
    if (i == indx) then
      resultobj => this%currentNode%Value
      return
    end if
    !
    ! -- Iterate from current node to requested node
    do while (associated(this%currentNode%nextNode))
      this%currentNode => this%currentNode%nextNode
      this%currentNodeIndex = this%currentNodeIndex + 1
      if (this%currentNodeIndex == indx) then
        resultobj => this%currentNode%Value
        return
      end if
    end do
  end function get_item_by_index
 
  !> @brief Get the node at the given index
  function get_node_by_index(this, indx) result(resultnode)
    ! -- dummy
    class(listtype), intent(inout) :: this
    integer(I4B), intent(in) :: indx
    ! result
    type(listnodetype), pointer :: resultnode
    ! -- local
    integer(I4B) :: i
    !
    ! -- Initialize
    resultnode => null()
    !
    ! -- Ensure that this%currentNode is associated
    if (this%currentNodeIndex == 0) then
      if (associated(this%firstNode)) then
        this%currentNode => this%firstNode
        this%currentNodeIndex = 1
      end if
    end if
    !
    ! -- Check indx position relative to current node index
    i = 0
    if (indx < this%currentNodeIndex) then
      ! Start at beginning of list
      call this%Reset()
      if (associated(this%firstNode)) then
        this%currentNode => this%firstNode
        this%currentNodeIndex = 1
        i = 1
      end if
    else
      i = this%currentNodeIndex
    end if
    if (i == 0) return
    !
    ! -- If current node is requested node,
    !    assign pointer and return
    if (i == indx) then
      resultnode => this%currentNode
      return
    end if
    !
    ! -- Iterate from current node to requested node
    do while (associated(this%currentNode%nextNode))
      this%currentNode => this%currentNode%nextNode
      this%currentNodeIndex = this%currentNodeIndex + 1
      if (this%currentNodeIndex == indx) then
        resultnode => this%currentNode
        return
      end if
    end do
  end function get_node_by_index
 
  ! -- Type-bound procedures for ListNodeType
 
  !> @brief Return a pointer to this node's value.
  function getitem(this) result(valueObject)
    class(listnodetype), intent(inout) :: this
    class(*), pointer :: valueobject
    valueobject => this%Value
  end function getitem
 
  !> @brief Nullify (optionally deallocating) this node's value.
  subroutine deallocvalue(this, destroy)
    class(listnodetype), intent(inout) :: this
    logical, intent(in), optional :: destroy
 
    if (associated(this%Value)) then
      if (present(destroy)) then
        if (destroy) then
          deallocate (this%Value)
        end if
      end if
      nullify (this%Value)
    end if
  end subroutine deallocvalue
 
end module listmodule