linkedlist_routines.f90

Go to the documentation of this file.

MODULE linkedlist_routines

#include "macros.h"  

  USE base_routines
  USE constants
  USE kinds
  USE iso_varying_string
  implicit none
  
  private  ! by default

  ! types
  type linkedlistitem
    integer(intg) :: data
    type(linkedlistitem),pointer :: next => null()
  end type

  type linkedlist
    type(linkedlistitem),pointer :: root => null()
    type(linkedlistitem),pointer :: last => null()
  end type

  interface linkedlist_add
    module procedure linkedlist_add_data
    module procedure linkedlist_add_list
  end interface

  ! public types
  public :: linkedlistitem,linkedlist

  ! public subs
  public :: linkedlist_add,linkedlist_destroy,linkedlist_remove_first,linkedlist_remove_last
  public :: linkedlist_is_empty,linkedlist_to_array

contains

! -------------------------------------------------------------------

  SUBROUTINE linkedlist_add_data(list,data,ERR,ERROR,*)

    TYPE(linkedlist),INTENT(INOUT) :: list
    INTEGER(INTG),INTENT(IN) :: data
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    ! local variables
    TYPE(linkedlistitem),pointer :: current

    enters("LinkedList_Add_Data",err,error,*999)

    if (associated(list%root)) then
      ! add to the tail end (for now)
      current => list%last
      allocate(current%next)
      current%next%data = data
      list%last => current%next
    else
      allocate(list%root)
      list%root%data = data
      list%last => list%root
    endif

    exits("LinkedList_Add_Data")
    RETURN
999 errorsexits("LinkedList_Add_Data",err,error)
    RETURN 1

  End SUBROUTINE linkedlist_add_data


! -------------------------------------------------------------------

  Subroutine linkedlist_add_list(list,addlist,ERR,ERROR,*)
    type(linkedlist),intent(inout) :: list
    type(linkedlist),intent(in) :: addlist
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    ! local variables
    type(linkedlistitem),pointer :: current

    if (linkedlist_is_empty(addlist)) return

    current => addlist%root
    do
      call linkedlist_add_data(list,current%data,err,error,*999)
      if (associated(current%next)) then
        current => current%next
      else
        exit
      endif
    enddo

    exits("LinkedList_Add_List")
    RETURN
999 errorsexits("LinkedList_Add_List",err,error)
    RETURN 1

  End Subroutine linkedlist_add_list

! -------------------------------------------------------------------

  Subroutine linkedlist_remove_first(list,data,ERR,ERROR,*)
    type(linkedlist),intent(inout) :: list
    integer(intg),intent(out) :: data
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    ! local variables
    type(linkedlistitem),pointer :: next
    
    if (associated(list%root)) then
      data = list%root%data
      next => list%root%next
      deallocate(list%root)
      list%root => next
      if (associated(list%root)) then
        if (.not.associated(list%root%next)) list%last => list%root  ! only one left
      else
        list%last => null()
      endif
    else
      write(*,*) ">>> warning: linked list is empty and cannot remove first item"
    endif

  End Subroutine linkedlist_remove_first

! -------------------------------------------------------------------

  Subroutine linkedlist_remove_last(list,data,ERR,ERROR,*)
    type(linkedlist),intent(inout) :: list
    integer(intg),intent(out) :: data
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    ! local variables
    type(linkedlistitem),pointer :: current

    if (.not.associated(list%root)) then
      write(*,*) ">>> warning: linked list is empty and cannot remove last item"
      return
    endif
    current => list%root

    do
      if (associated(current%next)) then
        if (associated(current%next%next)) then
          current => current%next
        else
          ! next one is the last one
          data = current%next%data
          deallocate(current%next)
          current%next => null()
          list%last => current
          exit
        endif
      else
        ! there must be only one item in the list?
        data = current%data
        deallocate(list%root)
        list%root => null()
        list%last => null()
        exit
      endif
    enddo

  End Subroutine linkedlist_remove_last

! -------------------------------------------------------------------

  Subroutine linkedlist_destroy(list,ERR,ERROR,*)

    TYPE(linkedlist), INTENT(inout) :: list
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    ! local variables
    TYPE(linkedlistitem), POINTER :: current,next

    if (.not.associated(list%root)) return

    current => list%root
    do
      if (associated(current%next)) then
        next => current%next
        deallocate(current)
        current => next
      else
        deallocate(current)
        exit
      endif
    enddo
    
    list%root => null()
    list%last => null()

  End SUBROUTINE linkedlist_destroy

! -------------------------------------------------------------------

  Function linkedlist_is_empty(list)
    type(linkedlist),intent(in) :: list
    logical :: LinkedList_is_Empty

    linkedlist_is_empty = .true.
    if (associated(list%root)) linkedlist_is_empty = .false.
    
  End Function linkedlist_is_empty

! -------------------------------------------------------------------

  Subroutine linkedlist_to_array(list,array,ERR,ERROR,*)
    type(linkedlist),intent(in) :: list
    integer(INTG),allocatable,intent(out) :: array(:)
    INTEGER(INTG), INTENT(OUT) :: ERR
    TYPE(varying_string), INTENT(OUT) :: ERROR
    ! local variables
    integer(INTG) :: i,n
    type(linkedlistitem),pointer :: current

    ! return zero-size array if list is empty
    if (linkedlist_is_empty(list)) then
      allocate(array(0))
      return
    endif

    ! first traversing to find size
    current => list%root
    n=1
    do
      if (associated(current%next)) then
        n=n+1
        current => current%next
      else
        exit
      endif
    enddo

    ! copy to array
    if (allocated(array)) deallocate(array)
    allocate(array(n),stat=err)
    !IF (ERR/=0) CALL ...
    current => list%root
    do i=1,n
      array(i)=current%data
      current => current%next
    enddo

  End Subroutine linkedlist_to_array

End Module linkedlist_routines