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