module cluster_definition implicit none !--------------------------------------------------------------------------- ! Customize here: ! integer, parameter, public:: & !--- number of elements per cluster cluster_size = 1000 ! type, public:: t_element integer:: i !--- replace by whatever you want an element to contain end type t_element ! !--------------------------------------------------------------------------- end module cluster_definition module cluster_tree !--------------------------------------------------------------------------- ! Monotonically growing binary trees of clusters ! ! Purpose: ! ! - maintain dynamic structures of user defined elements ! - provide fast access by index ! - minimize number of allocations ! ! Description: ! ! Cluster_tree maintains an arbitrary number of trees, type(t_tree). ! User definitions of elements and cluster sizes have to be done in ! module cluster_definition, which has to be used by the calling ! routine together with this module. ! ! Consequently, cluster_tree must be recompiled whenever cluster ! definition had been changed. Even worse: if you want to use several ! different definitions simultaneously, you will have to make distinct ! copies of each module, providing distinct names for ! ! cluster_definition, ! cluster_tree, ! cluster_size, ! t_element, ! t_tree. ! ! Nice job for a preprocessor, isn't it? All procedure names are ! declared generic, thus may remain unchanged. ! ! This way does not only have disadvantages: You are really free ! to define an element in any way you feel like, even including dynamic ! structures itself. ! On the other hand, no extra computing time is spent in managing ! elements, that are declared dynamic, but in fact the same way in the ! entire tree. ! ! Usage: ! ! After initialization by ! ! call initialize(tree, stat) ! ! elements can be appended to tree by ! ! call append(tree, element, stat) ! ! Elements are arranged in clusters, fixed sized arrays of elements. ! These clusters represent nodes of a binary tree. ! Argument stat is of type integer, optional and intent(out). It is set ! to zero, if memory allocation has been successful. Otherwise it is set ! to the system dependent nonzero status value of allocate. ! All elements appended may then be addressed by the subroutines ! ! get(tree, i, element) ! return pointer to element number i, ! ! counting from 1 ! next(tree, element) ! return pointer to next element ! prev(tree, element) ! return pointer to previous element ! ! All these return a pointer to t_element in argument element. ! Subroutines next and prev are intended for sequential access, upwards ! and downwards. These are a little bit faster than get, since they only ! need one rather than two comparisions to determine whether the current ! cluster has to be changed. ! The current number of elements in tree is returned by the integer ! function ! ! tree_size(tree) ! ! Cluster trees may grow at any time by further calls to append, but ! cannot shrink. They can be deallocated entirely by ! ! call dealloc(tree) ! ! After deallocation, a new call to initialize is necessary before growing ! a tree again. ! Any attempt to access elements beyond the range of 1..tree_size(tree) ! will be answered by a program stop. ! ! ! Michael Steffens, 07.11.96 ! email: Michael.Steffens@mbox.muk.uni-hannover.de ! ! Modifications: ! ! get, next and prev turned into subroutines, renamed tree_size and ! dealloc, added private and public specifications to make F happy. ! Michael Steffens, 20.05.97 ! ! Added target attribute to definition of tree in get, next and prev. ! Michael Steffens, 27.05.97 !--------------------------------------------------------------------------- use cluster_definition, & only: ct_cluster_size => cluster_size, ct_t_element => t_element implicit none private private:: & !--- subroutines ct_initialize, ct_append, ct_get, ct_next, ct_prev, ct_dealloc, & new_node, dealloc_node private:: & !--- functions ct_tree_size public:: & !--- subroutines initialize, append, get, next, prev, dealloc public:: & !--- functions tree_size type, public:: t_tree private !--- user must use, but not manipulate integer :: n_elem, n_nodes, depth, current_elem type(t_node), pointer:: root, current, last end type t_tree type, private:: t_node type(ct_t_element), dimension(ct_cluster_size):: elements integer :: offset, n_elem type(t_node), pointer :: up, down end type t_node !--- generic interfaces for avoiding conflicts !--- between different trees and other generics interface initialize module procedure ct_initialize end interface interface append module procedure ct_append end interface interface get module procedure ct_get end interface interface next module procedure ct_next end interface interface prev module procedure ct_prev end interface interface dealloc module procedure ct_dealloc end interface interface tree_size module procedure ct_tree_size end interface contains subroutine new_node(new, offset, stat) ! private !------------------------------------------------------ ! Allocate new node for tree !------------------------------------------------------ type(t_node), pointer :: new integer, intent(in) :: offset integer, intent(out), optional:: stat if (present(stat)) then allocate(new, stat=stat) if (stat /= 0) then nullify(new) return end if else allocate(new) end if new%offset = offset new%n_elem = 0 nullify(new%up, new%down) end subroutine new_node subroutine ct_initialize(tree, stat) ! public !------------------------------------------------------ ! Initialize tree, create root node !------------------------------------------------------ type(t_tree), intent(out) :: tree integer, intent(out), optional:: stat nullify(tree%last, tree%current) tree%n_elem = 0 tree%current_elem = 0 call new_node(tree%root, 0, stat) if (present(stat)) then if (stat /= 0) then !--- allocation failed tree%n_nodes = 0 tree%depth = 0 return end if end if tree%last => tree%root tree%current => tree%root tree%n_nodes = 1 tree%depth = 1 end subroutine ct_initialize subroutine ct_append(tree, element, stat) ! public !------------------------------------------------------ ! Append element to tree. Create new node, if last ! cluster is full. !------------------------------------------------------ type(t_tree), intent(inout) :: tree type(ct_t_element), intent(in) :: element integer, intent(out), optional:: stat type(t_node), pointer:: current, new integer :: i, bitsum if (tree%last%n_elem == ct_cluster_size) then !--- cluster full? call new_node(new, tree%n_elem, stat) if (present(stat)) then if (stat /= 0) then return !--- allocation failed end if end if tree%n_nodes = tree%n_nodes + 1 if (btest(tree%n_nodes, 0)) then !--- append odd node on top tree%last%up => new tree%last => new else !--- find position to insert node tree%last => new bitsum = 0 do i = 1, tree%depth if (btest(tree%n_nodes, i)) then bitsum = bitsum + 1 end if end do if (bitsum == 1) then !--- node number is power of 2, node becomes new root tree%last%down => tree%root tree%root => tree%last tree%depth = tree%depth + 1 else !--- insert node in upper branch current => tree%root do i = 3, bitsum current => current%up end do tree%last%down => current%up current%up => tree%last end if end if else if (present(stat)) then stat = 0 end if end if !--- put element into cluster tree%last%n_elem = tree%last%n_elem+1 tree%last%elements(tree%last%n_elem) = element tree%n_elem = tree%n_elem+1 end subroutine ct_append subroutine ct_get(tree, i, element) !------------------------------------------------------ ! Return pointer to element number i of tree !------------------------------------------------------ type(t_tree), target, intent(inout):: tree integer, intent(in) :: i type(ct_t_element), pointer :: element type(t_node), pointer:: current tree%current_elem = i - tree%current%offset !--- outside current cluster? if (tree%current_elem <= 0 .or. tree%current_elem > tree%current%n_elem) & then current => tree%root do !--- traverse tree, find cluster if (.not. (associated(current))) then stop !"tree index out of range!" !--- F doesn't accept argument to stop end if tree%current_elem = i - current%offset if (tree%current_elem <= 0) then current => current%down !--- follow lower branch cycle end if if (tree%current_elem > current%n_elem) then current => current%up !--- follow upper branch cycle end if exit !--- cluster found end do tree%current => current end if element => tree%current%elements(tree%current_elem) end subroutine ct_get subroutine ct_next(tree, element) !------------------------------------------------------ ! Return pointer to next element of tree !------------------------------------------------------ type(t_tree), target, intent(inout):: tree type(ct_t_element), pointer :: element tree%current_elem = tree%current_elem + 1 if (tree%current_elem > tree%current%n_elem) then call ct_get(tree, tree%current%offset + tree%current_elem, element) else element => tree%current%elements(tree%current_elem) end if end subroutine ct_next subroutine ct_prev(tree, element) !------------------------------------------------------ ! Return pointer to previous element of tree !------------------------------------------------------ type(t_tree), target, intent(inout):: tree type(ct_t_element), pointer :: element tree%current_elem = tree%current_elem - 1 if (tree%current_elem <= 0) then call ct_get(tree, tree%current%offset + tree%current_elem, element) else element => tree%current%elements(tree%current_elem) end if end subroutine ct_prev subroutine ct_dealloc(tree) ! public !------------------------------------------------------ ! Deallocate tree. !------------------------------------------------------ type(t_tree), intent(inout):: tree if (associated(tree%root)) then call dealloc_node(tree%root) end if nullify(tree%root, tree%last, tree%current) tree%n_elem = 0 tree%n_nodes = 0 tree%depth = 0 tree%current_elem = 0 end subroutine ct_dealloc recursive subroutine dealloc_node(node) type(t_node), pointer:: node if (associated(node%down)) then call dealloc_node(node%down) end if if (associated(node%up)) then call dealloc_node(node%up) end if deallocate(node) end subroutine dealloc_node function ct_tree_size(tree) result(s) ! public !------------------------------------------------------ ! Return number of elements in tree !------------------------------------------------------ type(t_tree), intent(in):: tree integer :: s s = tree%n_elem end function ct_tree_size end module cluster_tree program example !-------------------------------------------------------------------------- ! Simple example for using cluster_tree: Read some integers from stdin, ! print number of values and values themselves to stdout. Not very im- ! pressing, admittedly. But note that the number of values to be read ! and stored is nowhere been declared nor limited. !-------------------------------------------------------------------------- use cluster_definition use cluster_tree implicit none type(t_element), pointer:: np type(t_element) :: n type(t_tree) :: t integer :: i, j, iostat, stat call initialize(t, stat) if (stat/=0) then stop !"not enough memory for initializing tree" end if do j=0 do write(unit=*, fmt="('Enter ',i6,'. number: ')", advance="no") & tree_size(t)+1 read(unit=*, fmt=*, iostat=iostat) n%i if (iostat /= 0) then exit !--- terminate enter-loop on EOF or illegal number end if call append(t, n, stat) j = j + 1 if (stat /= 0) then stop !"not enough memory for building tree" end if end do write(unit=*, fmt=*) if (j == 0) then exit !--- terminate example if no more numbers were appended end if write(unit=*, fmt="(i6,' numbers appended.')") j do i = 1, tree_size(t) call get(t, i, np) write(unit=*, fmt="(i6,':',i8)") i, np%i end do end do call dealloc(t) end program example