Add merge-sort

references.txt

@@ -1,5 +1,5 @@
-Markdown:
-https://www.markdowntutorial.com/
+Markdown: https://www.markdowntutorial.com/
 
-FORD:
-https://forddocs.readthedocs.io/en/latest/
+FORD: https://forddocs.readthedocs.io/en/latest/
+
+Sorting linked-list: https://www.geeksforgeeks.org/merge-sort-for-linked-list/

src/dllnode_mod.f90

@@ -25,12 +25,24 @@ module dllnode_mod
  module procedure dllnode_copy
  end interface
 
+ abstract interface
+ function compare_fun(adat, bdat) result(ires)
+ !! User function to compare value of two nodes and return:
+ !! "-1" if A<B, "0" if A==B, or "1" if A>B
+ import :: DATA_KIND, DATA_SIZE
+ implicit none
+ integer(DATA_KIND), dimension(DATA_SIZE), intent(in) :: adat, bdat
+ integer :: ires
+ end function
+ end interface
+
  type(dllnode_t) :: mold
 
  public dllnode_update, dllnode_read, dllnode_free
  public dllnode_count, dllnode_export
  public dllnode_insertinfrontof, dllnode_remove, dllnode_freechain
- public dllnode_find, dllnode_head, dllnode_tail
+ public dllnode_find, dllnode_head, dllnode_tail, dllnode_validate
+ public dllnode_mergesort
 
 contains
 
@@ -123,7 +135,7 @@ end subroutine dllnode_free
  ! ========================================
 
  function dllnode_count(head) result(n)
- !! Return the number of nodes starting with *head* node and traversing 
+ !! Return the number of nodes starting with **head** node and traversing
  !! the chain forward
  type(dllnode_t), pointer, intent(in) :: head
  integer :: n
@@ -140,7 +152,7 @@ end function dllnode_count
 
 
  function dllnode_export(head) result(arr)
- !! Return rank-2 array with the data from all nodes starting with *head*
+ !! Return rank-2 array with the data from all nodes starting with **head**
  !! and traversing the chain forward
  type(dllnode_t), pointer, intent(in) :: head
  integer(DATA_KIND), allocatable :: arr(:,:)
@@ -181,7 +193,7 @@ end function dllnode_import
 
 
  function dllnode_copy(oldhead) result(newhead)
- !! Make a new list that is a copy of the chain starting with *oldhead*
+ !! Make a new list that is a copy of the chain starting with **oldhead**
  !! and traversing the chain forwards
  type(dllnode_t), pointer, intent(in) :: oldhead
  type(dllnode_t), pointer :: newhead
@@ -205,8 +217,8 @@ end function dllnode_copy
 
 
  subroutine dllnode_insertinfrontof(where, new, output)
- !! Insert node *new* in front of node *where*.
- !! Optional *output* points to the inserted node in the chain
+ !! Insert node **new** in front of node **where**.
+ !! Optional **output** points to the inserted node in the chain
  type(dllnode_t), pointer, intent(in) :: where, new
  type(dllnode_t), pointer, intent(out), optional :: output
 
@@ -229,9 +241,9 @@ end subroutine dllnode_insertinfrontof
 
 
  subroutine dllnode_remove(what, deleted, next_in_chain)
- !! Remove *what* from chain. On return, *deleted* points to the
+ !! Remove **what** from chain. On return, **deleted** points to the
  !! removed node, the node must be dealocated else-where. 
- !! Pointer *next_in_chain* points preferentialy to the next node
+ !! Pointer **next_in_chain** points preferentialy to the next node
  !! (if it exists), or to the prev node, or to null.
  type(dllnode_t), pointer, intent(in) :: what
  type(dllnode_t), pointer, intent(out) :: deleted, next_in_chain
@@ -251,8 +263,8 @@ end subroutine dllnode_remove
 
 
  subroutine dllnode_freechain(first)
- !! Remove and deallocate the whole chain starting with *first*
- !! The NEXT pointer of a node in front of *first* is also modified
+ !! Remove and deallocate the whole chain starting with **first**
+ !! The NEXT pointer of a node in front of **first** is also modified
  type(dllnode_t), intent(inout), pointer :: first
 
  type(dllnode_t), pointer :: deleted
@@ -274,11 +286,12 @@ end subroutine dllnode_freechain
  ! Search for a particular node
  ! Move to the head of the chain
  ! Move to the tail of the chain
+ ! Validate the chain
  ! ===============================
 
  function dllnode_find(start, value) result(found)
- !! Traverse the chain forward from *start* node. Return pointer to the
- !! node that matches the *value* or null if the search failed.
+ !! Traverse the chain forward from **start** node. Return pointer to the
+ !! node that matches the **value** or null if the search failed.
  type(dllnode_t), pointer, intent(in) :: start
  integer(DATA_KIND), intent(in) :: value(:)
  type(dllnode_t), pointer :: found
@@ -327,4 +340,118 @@ function dllnode_tail(start) result(tail)
  end do
  end function dllnode_tail
 
+
+ function dllnode_validate(head) result(isvalid)
+ !! Verify that the double-linked list at **head** is valid
+ type(dllnode_t), pointer, intent(in) :: head
+ logical :: isvalid
+
+ type(dllnode_t), pointer :: current
+
+ ! Empty list is valid
+ isvalid = .true.
+ if (.not. associated(head)) return
+
+ ! Head node must not have a previous node
+ if (associated(head%prev)) isvalid = .false.
+ if (.not. isvalid) return
+
+ ! Next node must have a back-link to current node
+ current => head
+ do
+ if (.not. associated(current%next)) exit
+ if (.not. associated(current%next%prev, current)) then
+ isvalid = .false.
+ return
+ end if
+ current => current%next
+ end do
+ end function dllnode_validate
+
+
+ ! =====================================================================
+ ! Sort the list
+ ! Ref: https://www.geeksforgeeks.org/merge-sort-for-doubly-linked-list
+ ! =====================================================================
+
+ recursive function dllnode_mergesort(head, cfun) result(sortedhead)
+ !! Sort the list starting at **head**, return a new head pointer
+ !! **cfun** is a function that returns -1|0|1 based on the comparison
+ !! of two nodes.
+ type(dllnode_t), intent(in), pointer :: head
+ procedure(compare_fun) :: cfun
+
+ type(dllnode_t), pointer :: sortedhead
+
+ type(dllnode_t), pointer :: headone, headtwo
+
+ ! zero- or one-sized list is sorted
+ sortedhead => head
+ if (.not. associated(head)) return
+ if (.not. associated(head%next)) return
+
+ ! split into two and sort left and right halves recursively
+ headtwo => split(head)
+ headone => dllnode_mergesort(head, cfun)
+ headtwo => dllnode_mergesort(headtwo, cfun)
+
+ ! merge sorted halves
+ sortedhead => merge0(headone, headtwo, cfun)
+ end function dllnode_mergesort
+
+
+ function split(head) result(two)
+ !! Split the chain in the middle, eg. 1|1, 2|1, 2|2, 3|2, etc.,
+ !! and return pointer at the second half
+ type(dllnode_t), intent(in), pointer :: head
+ type(dllnode_t), pointer :: two
+
+ type(dllnode_t), pointer :: fast, slow
+
+ fast => head
+ slow => head
+ do
+ ! it is assummed the chain has two or more nodes,
+ ! therefore the loop will run at least once
+ if (.not. associated(fast%next)) exit
+ if (.not. associated(fast%next%next)) exit
+ fast => fast%next%next
+ slow => slow%next
+ end do
+ ! "slow" now points at the middle-node (odd number of nodes) or
+ ! at the node before middle of the chain (even number of nodes)
+ ! "slow" is therefore the last node of the first half
+ two => slow%next
+ slow%next => null()
+ end function split
+
+
+ recursive function merge0(headone, headtwo, cfun) result(mergedhead)
+ type(dllnode_t), intent(in), pointer :: headone, headtwo
+ procedure(compare_fun) :: cfun
+ type(dllnode_t), pointer :: mergedhead
+
+ if (.not. associated(headone)) then
+ mergedhead => headtwo
+ return
+ else if (.not. associated(headtwo)) then
+ mergedhead => headone
+ return
+ end if
+
+ ! Select a smaller value
+ if (cfun(headone%data, headtwo%data) < 0) then
+ headone%next => merge0(headone%next, headtwo, cfun)
+ headone%next%prev => headone
+ headone%prev => null()
+ mergedhead => headone
+ else
+ headtwo%next => merge0(headone, headtwo%next, cfun)
+ headtwo%next%prev => headtwo
+ headtwo%prev => null()
+ mergedhead => headtwo
+ end if
+ end function merge0
+
+
 end module dllnode_mod

test/check.f90

@@ -24,6 +24,7 @@ subroutine test1()
  print '("Head node is = ",L)', associated(dllnode_head(head))
  print '("3 node is = ",L)', &
  associated(dllnode_find(head,int([3,33],DATA_KIND)))
+ print '("Is valid an empty node ? ",L)', dllnode_validate(head)
 
  ! Add nodes to the list
  do i=1, MAXN
@@ -33,8 +34,15 @@ subroutine test1()
  head1)
  head => head1
  print '("Head export = ",*(i0,1x))', dllnode_export(head)
+ print '("Is list valid? ",L)', dllnode_validate(head)
  end do
 
+ print '("Sorting...")'
+ head => dllnode_mergesort(head, cfun_my)
+ print '("... sorted")'
+ print '("After sort = ",*(i0,1x))', dllnode_export(head)
+ print '("Is list valid? ",L)', dllnode_validate(head)
+
  found=>dllnode_find(head,int([7,7],DATA_KIND))
  if (associated(found)) then
  call dllnode_update(found, int([42,42],DATA_KIND))
@@ -48,6 +56,8 @@ subroutine test1()
  print '("Head node is = ",*(i0,1x))', dllnode_read(dllnode_head(head))
  print '("42 node is = ",*(i0,1x))', &
  dllnode_read(dllnode_find(head,int([42,42],DATA_KIND)))
+ print '("Is list valid? Should be F ",L)', dllnode_validate(dllnode_find(head,int([42,42],DATA_KIND)))
+
 
  ! Delete nodes from the list
  do i=MAXN,1,-3
@@ -77,6 +87,9 @@ subroutine test1()
  !head_c => dllnode_t(found) ! dllnode_copy
  head_c => dllnode_t(head) ! dllnode_copy
  print '("HeadC export = ",*(i0,1x))', dllnode_export(head_c)
+ head_c => dllnode_mergesort(head_c, cfun_my)
+ print '("HeadC sorted = ",*(i0,1x))', dllnode_export(head_c)
+ print '("Is list valid? ",L)', dllnode_validate(head)
 
  ! Deallocation tests
  print *
@@ -93,6 +106,17 @@ subroutine test1()
  call dllnode_freechain(head_c)
  print '("HeadB export = ",*(i0,1x))', dllnode_export(head_c)
 
+contains
+ integer function cfun_my(a, b) result(ierr)
+ integer(DATA_KIND), dimension(DATA_SIZE), intent(in) :: a, b
+ if (a(1) < b(1)) then
+ ierr = -1
+ else if (a(1)==b(1)) then
+ ierr = 0
+ else
+ ierr = 1
+ end if
+ end function cfun_my
 
 
 end subroutine test1