We have a project with some novel challenges and I decided that one thing it needs is a balanced binary tree, something I learned about in a data structures class. It meant delving into some new-to-me sides of the Fortran standard, but Fortran 90 supports pointers which should be able to do the job. Because I’m not that familiar with Fortran pointers, I started building my tree with a short test program just to make sure I’m on the right track before including this stuff into the full ROMS code.
I started by creating a treenode object with pointers to the left and right children, plus the parent. I used them to insert objects into a binary tree, no problem. Then I started adding the code so that the tree would be balanced after each insertion, using the standard red-black algorithm that’s in any algorithms textbook. I repeat, this is meat-and-potatoes homework assignment level of algorithm, not something exotic at all. Here’s my f90 version:
MODULE mod_tree
!
!================================================== Kate Hedstrom ======
! Copyright (c) 2002-2009 The ROMS/TOMS Group !
! Licensed under a MIT/X style license !
! See License_ROMS.txt !
!=======================================================================
! Set up tree structure and functions. !
!=======================================================================
!
implicit none
type treenode
type(treenode), pointer :: left => null()
type(treenode), pointer :: right => null()
type(treenode), pointer :: parent => null()
logical :: red = .FALSE.
integer :: eggs = 0
real*8 :: dist
end type treenode
type(treenode), pointer :: tree
PRIVATE
PUBLIC :: init, insert
CONTAINS
SUBROUTINE init
ALLOCATE(tree)
END SUBROUTINE init
SUBROUTINE insert(eggs, dist)
integer, intent(in) :: eggs
real*8, intent(in) :: dist
type(treenode), pointer :: cur, p, x, y
ALLOCATE(cur)
cur % eggs = eggs
cur % dist = dist
! Empty tree, deposit eggs at the top
IF (.not. ASSOCIATED(tree % left)) THEN
tree % left => cur
cur % parent => tree
RETURN
END IF
! Otherwise find somewhere to put these eggs
! New nodes end up at the bottom until a rebalance
p => tree % left
DO
IF (dist <= p % dist) THEN
IF (ASSOCIATED(p % left)) THEN
p => p % left
CYCLE
ELSE
p % left => cur
cur % parent => p
EXIT
END IF
ELSE
IF (ASSOCIATED(p % right)) THEN
p => p % right
CYCLE
ELSE
p % right => cur
cur % parent => p
EXIT
END IF
END IF
END DO
! Balance the thing... red-black for now, until I get smarter about
! balancing eggs.
cur % red = .true.
x => cur
DO WHILE (x % parent % red)
IF (ASSOCIATED(x % parent % parent % left, x % parent)) THEN
IF (ASSOCIATED(x % parent % parent % right)) THEN
y => x % parent % parent % right ! uncle
IF (y % red) THEN
x % parent % red = .false.
y % red = .false.
x % parent % parent % red = .true.
x => x % parent % parent
END IF
ELSE
IF (ASSOCIATED(x, x % parent % right)) THEN
CALL rotate_left(x % parent)
END IF
x % parent % red = .false.
x % parent % parent % red = .true.
CALL rotate_right(x % parent % parent)
END IF
ELSE
! Must be right grandchild to get here
IF (ASSOCIATED(x % parent % parent % left)) THEN
y => x % parent % parent % left ! aunt
IF (y % red) THEN
x % parent % red = .false.
y % red = .false.
x % parent % parent % red = .true.
x => x % parent % parent
END IF
ELSE
IF (ASSOCIATED(x, x % parent % left)) THEN
CALL rotate_right(x % parent)
END IF
x % parent % red = .false.
x % parent % parent % red = .true.
CALL rotate_left(x % parent % parent)
END IF
END IF
END DO
tree % left % red = .false.
END SUBROUTINE insert
!
! For the rotating, I'm working from C code I found online for red-black trees,
! with reference to Introduction to Algorithms by Cormen, Leiserson,
! Rivest (Chapter 14). It makes right child of x into the parent of x.
!
SUBROUTINE rotate_left(x)
type(treenode), pointer :: x, y
integer :: mine, theirs
y => x % right
IF (ASSOCIATED(y % left)) THEN
x % right => y % left
x % right % parent => x
ELSE
NULLIFY(x % right)
END IF
print *, "rotate_left before ", x % dist, x % eggs
y % parent => x % parent
print *, "rotate_left after ", x % dist, x % eggs
IF (ASSOCIATED(x, x % parent % left)) THEN
x % parent % left => y
ELSE
x % parent % right => y
END IF
y % left => x
x % parent => y
END SUBROUTINE rotate_left
SUBROUTINE rotate_right(x)
type(treenode), pointer :: x, y
y => x % left
IF (ASSOCIATED(y % right)) THEN
x % left => y % right
x % left % parent => x
ELSE
NULLIFY(x % left)
END IF
print *, "rotate_right before ", x % dist, x % eggs
y % parent => x % parent
print *, "rotate_right after ", x % dist, x % eggs
IF (ASSOCIATED(x, x % parent % left)) THEN
x % parent % left => y
ELSE
x % parent % right => y
END IF
y % right => x
x % parent => y
END SUBROUTINE rotate_right
END MODULE mod_tree
program main
use mod_tree
implicit none
integer, parameter :: num = 3
integer :: caviar(num)
real*8 :: dist(num)
integer :: i
dist = (/ 21, 56, 78 /)
caviar = 100*dist
call init
do i=1,num
call insert(caviar(i), dist(i))
end do
end program main
I defy you to find a compiler which does the right thing for this code (or to find a bug in this code to explain this). I’ve tried gfortran, ifort, PGI, and Pathscale. A typical response:
rotate_left before 21.0000000000000 2100
rotate_left after 0.000000000000000E+000 0
forrtl: severe (174): SIGSEGV, segmentation fault occurred