Add queue implementation (simplest features)

src/queue_mod.f90

@@ -0,0 +1,90 @@
+module queue_mod
+ !* Implementation of queue via double-linked list
+ !
+ use common_mod, only : mold, DATA_KIND
+ use dllnode_mod, only : dllnode_t, dllnode_count, dllnode_insertinfrontof, &
+ dllnode_read, dllnode_remove, dllnode_free, dllnode_validate, dllnode_tail,&
+ dllnode_freechain
+ implicit none
+ private
+
+ type, public :: queue_t
+ private
+ type(dllnode_t), pointer :: back => null()
+ type(dllnode_t), pointer :: front => null()
+ contains
+ procedure :: enqueue => queue_enqueue, dequeue => queue_dequeue
+ procedure :: isempty => queue_isempty, size => queue_size
+ procedure :: isvalid => queue_validate
+ final :: queue_finalize
+ end type
+
+contains
+
+ function queue_isempty(this) result(isempty)
+ class(queue_t), intent(in) :: this
+ logical :: isempty
+ isempty = .not. associated(this%back)
+ end function queue_isempty
+
+
+ function queue_size(this) result(n)
+ class(queue_t), intent(in) :: this
+ integer :: n
+ n = dllnode_count(this%back)
+ end function queue_size
+
+
+ subroutine queue_enqueue(this, val)
+ class(queue_t), intent(inout) :: this
+ integer(DATA_KIND), intent(in) :: val(:)
+
+ type(dllnode_t), pointer :: output
+
+ call dllnode_insertinfrontof(this%back, dllnode_t(val), output)
+ this%back => output
+ if (.not. associated(output%nextnode())) this%front => output
+ end subroutine queue_enqueue
+
+
+ function queue_dequeue(this) result(val)
+ class(queue_t), intent(inout) :: this
+ integer(DATA_KIND), allocatable :: val(:)
+
+ type(dllnode_t), pointer :: deleted, next
+
+ if (.not. associated(this%front)) error stop 'dequeue - queue is empty'
+ val = dllnode_read(this%front)
+
+ call dllnode_remove(this%front, deleted, next)
+ this%front => next
+ call dllnode_free(deleted)
+ if (.not. associated(next)) this%back => null()
+ end function queue_dequeue
+
+
+ elemental impure subroutine queue_finalize(this)
+ type(queue_t), intent(inout) :: this
+ call dllnode_freechain(this%back)
+ this%front => null()
+ end subroutine queue_finalize
+
+
+ function queue_validate(this) result(isvalid)
+ class(queue_t), intent(in) :: this
+ logical :: isvalid
+
+ ! both pointers must be either associated or null
+ isvalid = associated(this%back) .eqv. associated(this%front)
+ if (.not. isvalid) return
+
+ ! linked-list starting at the back of the queue must be valid
+ isvalid = dllnode_validate(this%back)
+ if (.not. isvalid) return
+
+ ! tail of linked-list is the front of the queue
+ if (associated(this%back)) &
+ isvalid = associated(this%front, dllnode_tail(this%back))
+ end function queue_validate
+
+end module queue_mod

test/test_queue.f90

@@ -0,0 +1,47 @@
+program test_queue
+ implicit none
+ interface
+ subroutine test_queue_sub()
+ end subroutine
+ end interface
+
+ call test_queue_sub
+end program test_queue
+
+
+subroutine test_queue_sub()
+ use common_mod, only : DATA_KIND, mold
+ use queue_mod, only : queue_t
+ implicit none
+
+ type(queue_t) :: q
+
+ print 900,"Empty queue", q%isempty(), q%isvalid(), q%size()
+
+ call q%enqueue(transfer(10,mold))
+ print 900,"One element added", q%isempty(), q%isvalid(), q%size()
+ print '("Dequeued =",i0)', q%dequeue()
+ print 900,"One element removed", q%isempty(), q%isvalid(), q%size()
+
+ call q%enqueue(transfer(10,mold))
+ call q%enqueue(transfer(20,mold))
+ print 900,"Two elements added", q%isempty(), q%isvalid(), q%size()
+ print '("Dequeued =",i0)', q%dequeue()
+ print 900,"One element removed", q%isempty(), q%isvalid(), q%size()
+ print '("Dequeued =",i0)', q%dequeue()
+ print 900,"One element removed", q%isempty(), q%isvalid(), q%size()
+
+ print *
+ call q%enqueue(transfer(10,mold))
+ call q%enqueue(transfer(20,mold))
+ print 900,"Two elements added", q%isempty(), q%isvalid(), q%size()
+ print '("Dequeued =",i0)', q%dequeue()
+ call q%enqueue(transfer(30,mold))
+ print 900,"Two add, one remove, one add", q%isempty(), q%isvalid(), q%size()
+ print '("Dequeued =",i0)', q%dequeue()
+ print 900,"removed", q%isempty(), q%isvalid(), q%size()
+ print '("Dequeued =",i0)', q%dequeue()
+ print 900,"removed", q%isempty(), q%isvalid(), q%size()
+
+ 900 format (a,": empty=",L1," valid=",L1," size=",I0)
+end subroutine test_queue_sub