Add union with leaking bug

src/rbnode_mod.f90

@@ -50,7 +50,7 @@ module rbnode_mod
  public rbnode_leftmost, rbnode_nextnode, rbnode_prevnode
  public rbnode_insert, rbnode_delete
  public rbnode_validate, rbnode_blackheight
- public join, split
+ public join, split, union
 
  integer, public, save :: allocation_counter = 0
  !! temporary, just for mem.leakage debuging TODO
@@ -1207,6 +1207,47 @@ recursive subroutine split(l_root, key_node, r_root, old_root, key, cfun)
  end subroutine split
 
 
+ recursive function union(t1, t2, cfun) result(t)
+ type(rbnode_t), pointer, intent(in) :: t1, t2
+ procedure(compare_fun) :: cfun
+ type(rbnode_t), pointer :: t
+
+ type(rbnode_t), pointer :: l1, r1, key_node, left, right, other_node
+ integer(DATA_KIND), allocatable :: key(:)
+
+ if (.not. associated(t1)) then
+ t => t2
+ return
+ else if (.not. associated(t2)) then
+ t => t1
+ return
+ end if
+
+ print *, 'pre-split', transfer(rbnode_read(t1),1), allocation_counter
+ key = rbnode_read(t1)
+ call split(l1, key_node, r1, t2, key, cfun)
+ other_node => rbnode_find(t1, key, cfun)
+ print *, 'exp-split - key_node', associated(key_node), associated(other_node), allocation_counter
+
+ ! one independent branch (for MPI?)
+ left => union(t1%left, l1, cfun)
+
+ ! second independent branch
+ right => union(t1%right, r1, cfun)
+
+ ! as soon as both branches are complete
+
+print *, 'pre-join', transfer(key,1), allocation_counter
+ t => join(left, key, right)
+ if (associated(key_node)) then
+ call rbnode_free(key_node)
+ end if
+ call rbnode_free(other_node)
+print *, 'ex-join', transfer(key,1), allocation_counter
+print *
+ end function union
+
+
  ! ================================
  ! Validation and debugging helpers
  ! ================================

test/check.f90

@@ -9,7 +9,8 @@ end subroutine test2
  end interface
 
  !call tree_test_basic()
- call tree_test_join()
+ !call tree_test_joinsplit()
+ call tree_test_union()
  stop
 
  call test1()

test/tree_test.f90

@@ -5,7 +5,56 @@ module tree_test_mod
 
 contains
 
- subroutine tree_test_join()
+ subroutine tree_test_union()
+ integer, parameter, dimension(*) :: &
+ DAT1=[10, 1, 5, 13], &
+ DAT2=[1, 9, 10, 6, 13]
+ type(rbbasetree_t) :: t1, t2, t12
+ type(rbnode_t), pointer :: found
+ integer :: i
+
+ do i=1, size(DAT1)
+ call rbnode_insert(t1, rbnode_t(transfer(DAT1(i),mold)), tree_test_basic_comp)
+ end do
+ do i=1, size(DAT2)
+ call rbnode_insert(t2, rbnode_t(transfer(DAT2(i),mold)), tree_test_basic_comp)
+ end do
+ call dump_graphviz('our_a', t1)
+ call dump_graphviz('our_b', t2)
+ print *
+ print *, 'Traverse A'
+ call traverse(t1)
+ print *
+ print *, 'Traverse B'
+ call traverse(t2)
+
+ print *, 'UNION'
+ t12%root => union(t1%root, t2%root, tree_test_basic_comp)
+
+ print '("Empty tree - Valid? ",L2," black height is ",i0)', &
+ t12%isvalid(tree_test_basic_comp), t12%blackheight()
+ print *
+ print *, 'Traverse A+B'
+ call traverse(t12)
+ call dump_graphviz('our_ab', t12)
+
+ ! Delete
+ do i=1,size(DAT1)
+ call rbnode_delete(t12, rbnode_find(t12%root, transfer(DAT1(i),mold), tree_test_basic_comp))
+ end do
+ do i=1,size(DAT2)
+ found => rbnode_find(t12%root, transfer(DAT2(i),mold), tree_test_basic_comp)
+ if (associated(found)) call rbnode_delete(t12, found)
+ end do
+
+ print '("Empty tree - Valid? ",L2," black height is ",i0)', &
+ t12%isvalid(tree_test_basic_comp), t12%blackheight()
+ print *, 'Allocated nodes zero? =', allocation_counter
+
+ end subroutine tree_test_union
+
+
+ subroutine tree_test_joinsplit()
  type(rbbasetree_t) :: tree_a, tree_b, tree_ab
  integer :: i, ierr
  integer, parameter :: IMID=4000, ISPLIT=3914080, NTOT=4120000
@@ -88,7 +137,7 @@ subroutine tree_test_join()
  tree_b%isvalid(tree_test_basic_comp), tree_b%blackheight()
  print *, 'Allocated nodes zero? =', allocation_counter
 
- end subroutine tree_test_join
+ end subroutine tree_test_joinsplit
 
  subroutine tree_test_basic()
  integer, parameter, dimension(*) :: DATA=[10, 5, 7, 8, 9, 11, 12, 13]