521 lines
15 KiB
Fortran
Executable File
521 lines
15 KiB
Fortran
Executable File
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
!!
|
|
!! ColoredGraphModule --
|
|
!!
|
|
!! This module provides a derived type ColoredGraph for representing
|
|
!! colored graphs, and procedures for creating and manipulating them.
|
|
!!
|
|
!! The only functionality provided by this module is that which is
|
|
!! required by the module ColormapModule, and as such it is far from
|
|
!! complete. This module should probably be folded in with the module
|
|
!! GraphModule.
|
|
!!
|
|
!! PROGRAMMING INTERFACE
|
|
!!
|
|
!! type(ColoredGraph) is an ADT with private components that holds the
|
|
!! representation of a colored graph.
|
|
!!
|
|
!! call CreateGraph (g [,directed]) returns a ColoredGraph G with no nodes
|
|
!! and no edges. DIRECTED is an optional intent(in) logical variable
|
|
!! that specifies whether the graph is a directed graph or an
|
|
!! undirected graph (default).
|
|
!!
|
|
!! call DeleteGraph (g) deallocates the internal storage associated
|
|
!! with the ColoredGraph variable G.
|
|
!!
|
|
!! call AddEdge (g, from, to) adds to the graph G an edge from the node
|
|
!! FROM to the node TO. FROM and TO are default integer variables
|
|
!! which serve as labels for the nodes. If either node isn't found
|
|
!! in G it is added. Edges that are not consistent with the type of
|
|
!! graph are silently ignored. In the case of a undirected graph,
|
|
!! the edge from TO to FROM is also added.
|
|
!!
|
|
!! call PrintGraph (g) prints the ColoredGraph G to standard output in
|
|
!! a readable format. Mainly useful for debugging.
|
|
!!
|
|
!! call ColorGraph (g, ncolors) colors the nodes in the graph G such
|
|
!! that adjacent nodes have different colors. The algorithm used
|
|
!! is simple-minded. Multiple passes through the nodes are made
|
|
!! until all nodes are colored. On the first pass, a node is
|
|
!! assigned a color of "1" if it has no neighbors of that color.
|
|
!! On the second pass, an uncolored node is assigned a color of "2"
|
|
!! if it has no neighbors of that color. This proceeds until all
|
|
!! nodes are colored. The number of colors used is returned in the
|
|
!! intent(out) integer variable NCOLORS.
|
|
!!
|
|
!! call GetColormap (g, colormap) returns the colormap for the
|
|
!! ColoredGraph variable G. COLORMAP is a rank-2 integer pointer
|
|
!! which is allocated with shape (2,N) by the routine, where N
|
|
!! is the number of nodes in G. COLORMAP(1,:) are the node labels
|
|
!! and COLORMAP(2,:) are the corresponding colors. If G has no nodes
|
|
!! then COLORMAP is nullified rather than being allocated with
|
|
!! zero size.
|
|
!!
|
|
!! CHANGE HISTORY
|
|
!!
|
|
!! $Log: ColoredGraphModule.f90,v $
|
|
!! Revision 2.00 2007/11/05 19:45:45 spchu
|
|
!! Import to CVS
|
|
!!
|
|
!!PVCS
|
|
!!PVCS Rev 1.1 Fri Apr 07 15:54:44 2000 nnc
|
|
!!PVCS Internal lists reimplemented as binary search trees.
|
|
!!PVCS No external changes.
|
|
!!PVCS
|
|
!!PVCS Rev 1.0 Fri Apr 02 09:59:26 1999 nnc
|
|
!!PVCS Initial revision.
|
|
!!
|
|
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
|
|
|
module CGNodeType
|
|
|
|
implicit none
|
|
private
|
|
|
|
!!!
|
|
!!! RECURSIVE LIST STRUCTURE FOR STORING GRAPH NODE ADJACENCY
|
|
|
|
type, public :: CGNodePointerList
|
|
type(CGNodePointerListItem), pointer :: first ! => null() ! Uncomment for F95
|
|
end type CGNodePointerList
|
|
|
|
type, public :: CGNodePointerListItem
|
|
type(CGNode), pointer :: node
|
|
type(CGNodePointerList) :: rest
|
|
end type CGNodePointerListItem
|
|
|
|
!!!
|
|
!!! GRAPH NODE DATA TYPE
|
|
|
|
type, public :: CGNode
|
|
integer :: label
|
|
integer :: color ! = 0 ! Uncomment for F95
|
|
type(CGNodePointerList) :: nbrs
|
|
end type CGNode
|
|
|
|
end module CGNodeType
|
|
|
|
module ColoredGraphModule
|
|
|
|
use CGNodeType
|
|
implicit none
|
|
private
|
|
|
|
public :: CreateGraph, DeleteGraph, AddEdge, PrintGraph, ColorGraph, GetColormap
|
|
|
|
private :: CreateColoredGraph, DeleteColoredGraph, AddEdgeToColoredGraph, PrintColoredGraph
|
|
private :: AddToCGNodePointerList, DeleteFromCGNodePointerList
|
|
private :: DeleteCGNodePointerList, CGNodePointer
|
|
|
|
private :: DeleteCGNodeTree
|
|
|
|
interface CreateGraph
|
|
module procedure CreateColoredGraph
|
|
end interface
|
|
|
|
interface DeleteGraph
|
|
module procedure DeleteColoredGraph
|
|
end interface
|
|
|
|
interface AddEdge
|
|
module procedure AddEdgeToColoredGraph
|
|
end interface
|
|
|
|
interface PrintGraph
|
|
module procedure PrintColoredGraph
|
|
end interface
|
|
|
|
!!!
|
|
!!! BINARY SEARCH TREE FOR STORAGE OF GRAPH NODES
|
|
|
|
type, private :: CGNodeTree
|
|
type(CGNodeTreeNode), pointer :: root ! => null() ! Uncomment for F95
|
|
end type CGNodeTree
|
|
|
|
type, private :: CGNodeTreeNode
|
|
type(CGNode) :: node
|
|
type(CGNodeTree) :: lt, gt
|
|
end type CGNodeTreeNode
|
|
|
|
!!!
|
|
!!! GRAPH DATA TYPE
|
|
|
|
type, public :: ColoredGraph
|
|
private
|
|
logical :: directed ! = .false. ! Uncomment for F95
|
|
logical :: colored ! = .false. ! Uncomment for F95
|
|
type(CGNodeTree) :: nodes
|
|
end type ColoredGraph
|
|
|
|
!!!
|
|
!!! STATE VARIABLES FOR NODE_COLOR PROCEDURE
|
|
|
|
integer, save, private :: color
|
|
logical, save, private :: uncolored
|
|
|
|
contains
|
|
|
|
subroutine CreateColoredGraph (g, directed)
|
|
|
|
logical, intent(in), optional :: directed
|
|
type(ColoredGraph) :: g
|
|
|
|
g % colored = .false. ! Delete this statement for F95
|
|
g % directed = .false. ! Delete this statement for F95
|
|
|
|
if (present(directed)) g % directed = directed
|
|
|
|
nullify(g % nodes % root) ! Delete this statement for F95
|
|
|
|
end subroutine CreateColoredGraph
|
|
|
|
subroutine DeleteColoredGraph (g)
|
|
|
|
type(ColoredGraph) :: g
|
|
|
|
g % colored = .false.
|
|
g % directed = .false.
|
|
call DeleteCGNodeTree (g % nodes)
|
|
|
|
end subroutine DeleteColoredGraph
|
|
|
|
subroutine AddEdgeToColoredGraph (g, from, to)
|
|
|
|
type(ColoredGraph), intent(inout) :: g
|
|
integer, intent(in) :: from, to
|
|
|
|
type(CGNode), pointer :: from_node, to_node
|
|
|
|
if (from == to) return
|
|
|
|
call CGNodePointer (g % nodes, from, from_node)
|
|
call CGNodePointer (g % nodes, to, to_node)
|
|
|
|
call AddToCGNodePointerList (from_node % nbrs, to_node)
|
|
if (g % directed) return
|
|
call AddToCGNodePointerList (to_node % nbrs, from_node)
|
|
|
|
end subroutine AddEdgeToColoredGraph
|
|
|
|
subroutine AddToCGNodePointerList (list, node)
|
|
|
|
type(CGNodePointerList), intent(inout), target :: list
|
|
type(CGNode), intent(in), target :: node
|
|
|
|
type(CGNodePointerList) :: r
|
|
type(CGNodePointerList), pointer :: l
|
|
|
|
l => list
|
|
do while (associated(l % first))
|
|
if (node % label > l % first % node % label) then
|
|
l => l % first % rest
|
|
else
|
|
if (node % label == l % first % node % label) return
|
|
exit
|
|
end if
|
|
end do
|
|
|
|
r = l
|
|
allocate(l % first)
|
|
l % first % node => node
|
|
l % first % rest = r
|
|
|
|
end subroutine AddToCGNodePointerList
|
|
|
|
subroutine DeleteFromCGNodePointerList (list, node)
|
|
|
|
type(CGNodePointerList), intent(inout), target :: list
|
|
type(CGNode), intent(in) :: node
|
|
|
|
type(CGNodePointerList) :: r
|
|
type(CGNodePointerList), pointer :: l
|
|
|
|
l => list
|
|
do while (associated(l % first))
|
|
if (node % label > l % first % node % label) then
|
|
l => l % first % rest
|
|
else
|
|
if (node % label == l % first % node % label) then
|
|
r = l % first % rest
|
|
deallocate (l % first)
|
|
l = r
|
|
end if
|
|
exit
|
|
end if
|
|
end do
|
|
|
|
end subroutine DeleteFromCGNodePointerList
|
|
|
|
subroutine DeleteCGNodePointerList (list)
|
|
|
|
type(CGNodePointerList), intent(inout) :: list
|
|
|
|
type(CGNodePointerList) :: rest
|
|
|
|
do while (associated(list % first))
|
|
rest = list % first % rest
|
|
deallocate(list % first)
|
|
list = rest
|
|
end do
|
|
|
|
end subroutine DeleteCGNodePointerList
|
|
|
|
recursive subroutine DeleteCGNodeTree (bst)
|
|
|
|
type(CGNodeTree), intent(inout) :: bst
|
|
|
|
do while (associated(bst % root))
|
|
call DeleteCGNodeTree (bst % root % lt)
|
|
call DeleteCGNodeTree (bst % root % gt)
|
|
call DeleteCGNodePointerList (bst % root % node % nbrs)
|
|
deallocate(bst % root)
|
|
end do
|
|
|
|
end subroutine DeleteCGNodeTree
|
|
|
|
recursive subroutine CGNodePointer (bst, label, node)
|
|
|
|
type(CGNodeTree), intent(inout), target :: bst
|
|
integer, intent(in) :: label
|
|
type(CGNode), pointer :: node
|
|
|
|
if (.not.associated(bst % root)) then ! add
|
|
allocate (bst % root)
|
|
bst % root % node % label = label
|
|
bst % root % node % color = 0
|
|
nullify(bst % root % node % nbrs % first) ! Delete this statement for F95
|
|
nullify(bst % root % lt % root) ! Delete this statement for F95
|
|
nullify(bst % root % gt % root) ! Delete this statement for F95
|
|
node => bst % root % node
|
|
|
|
else if (label < bst % root % node % label) then
|
|
call CGNodePointer (bst % root % lt, label, node)
|
|
|
|
else if (label > bst % root % node % label) then
|
|
call CGNodePointer (bst % root % gt, label, node)
|
|
|
|
else
|
|
node => bst % root % node
|
|
end if
|
|
|
|
end subroutine CGNodePointer
|
|
|
|
! recursive function CGNodePointer (bst, label) result (node)
|
|
!
|
|
! type(CGNodeTree), intent(inout), target :: bst
|
|
! integer, intent(in) :: label
|
|
! type(CGNode), pointer :: node
|
|
!
|
|
! if (.not.associated(bst % root)) then ! add
|
|
! allocate (bst % root)
|
|
! bst % root % node % label = label
|
|
! bst % root % node % color = 0
|
|
! nullify(bst % root % node % nbrs % first) ! Delete this statement for F95
|
|
! nullify(bst % root % lt % root) ! Delete this statement for F95
|
|
! nullify(bst % root % gt % root) ! Delete this statement for F95
|
|
!
|
|
! else if (label < bst % root % node % label) then
|
|
! node => CGNodePointer (bst % root % lt, label)
|
|
!
|
|
! else if (label > bst % root % node % label) then
|
|
! node => CGNodePointer (bst % root % gt, label)
|
|
!
|
|
! else
|
|
! node => bst % root % node
|
|
! end if
|
|
!
|
|
! end function CGNodePointer
|
|
|
|
subroutine PrintColoredGraph (g)
|
|
|
|
type(ColoredGraph), intent(in) :: g
|
|
|
|
write(unit=*, fmt="(a,l1)") "directed = ", g % directed
|
|
write(unit=*, fmt="(a)") "node [color] (neighbors):"
|
|
call for_each (g % nodes, print_node)
|
|
|
|
end subroutine PrintColoredGraph
|
|
|
|
subroutine print_node (node)
|
|
|
|
type(CGNode), intent(inout) :: node
|
|
|
|
type(CGNodePointerList) :: nbrs
|
|
|
|
write(unit=*,fmt="(i6)",advance="no") node % label
|
|
write(unit=*,fmt="(a,i3,a)",advance="no") " [", node % color, "] ("
|
|
nbrs = node % nbrs
|
|
do while (associated(nbrs % first))
|
|
write(unit=*,fmt="(i7)",advance="no") nbrs % first % node % label
|
|
nbrs = nbrs % first % rest
|
|
end do
|
|
write(unit=*,fmt="(a)") ")"
|
|
|
|
end subroutine print_node
|
|
|
|
subroutine ColorGraph (g, ncolors)
|
|
|
|
type(ColoredGraph), intent(inout) :: g
|
|
integer, intent(out) :: ncolors
|
|
|
|
!! COLOR and UNCOLORED are state variables for the procedure COLOR_NODE.
|
|
if (associated(g % nodes % root)) then
|
|
call for_each (g % nodes, zero_color) ! Set all colors to 0
|
|
color = 0
|
|
uncolored = .true.
|
|
do while (uncolored)
|
|
color = color + 1
|
|
uncolored = .false.
|
|
call for_each (g % nodes, color_node)
|
|
end do
|
|
g % colored = .true.
|
|
ncolors = color
|
|
else
|
|
ncolors = 0
|
|
end if
|
|
|
|
end subroutine ColorGraph
|
|
|
|
subroutine zero_color (node)
|
|
type(CGNode), intent(inout) :: node
|
|
node % color = 0
|
|
end subroutine zero_color
|
|
|
|
subroutine color_node (node)
|
|
|
|
type(CGNode), intent(inout) :: node
|
|
|
|
type(CGNodePointerList) :: nbrs
|
|
|
|
if (node % color > 0) return ! it's already colored.
|
|
|
|
nbrs = node % nbrs
|
|
do while (associated(nbrs % first))
|
|
if (nbrs % first % node % color == color) then
|
|
uncolored = .true.
|
|
return
|
|
end if
|
|
nbrs = nbrs % first % rest
|
|
end do
|
|
|
|
node % color = color
|
|
|
|
end subroutine color_node
|
|
|
|
subroutine GetColormap (g, colormap)
|
|
|
|
type(ColoredGraph), intent(in) :: g
|
|
integer, dimension(:,:), pointer :: colormap
|
|
|
|
integer :: num_nodes, map_size
|
|
|
|
if (.not. g % colored) then
|
|
nullify(colormap)
|
|
return
|
|
end if
|
|
|
|
num_nodes = tree_size(g % nodes)
|
|
|
|
if (num_nodes == 0) then
|
|
nullify(colormap)
|
|
return
|
|
end if
|
|
|
|
allocate(colormap(2,num_nodes))
|
|
map_size = 0
|
|
call get_colormap (g % nodes, colormap, map_size)
|
|
!! Assert map_size == num_nodes
|
|
|
|
end subroutine GetColormap
|
|
|
|
recursive subroutine get_colormap (bst, colormap, map_size)
|
|
|
|
type(CGNodeTree), intent(in) :: bst
|
|
integer, dimension(:,:), intent(out) :: colormap
|
|
integer, intent(inout) :: map_size
|
|
|
|
if (associated(bst % root)) then
|
|
call get_colormap (bst % root % lt, colormap, map_size)
|
|
map_size = 1 + map_size
|
|
colormap(1,map_size) = bst % root % node % label
|
|
colormap(2,map_size) = bst % root % node % color
|
|
call get_colormap (bst % root % gt, colormap, map_size)
|
|
end if
|
|
|
|
end subroutine get_colormap
|
|
|
|
recursive function tree_size (bst) result (n)
|
|
type(CGNodeTree), intent(in) :: bst
|
|
integer :: n
|
|
if (associated(bst % root)) then
|
|
n = 1 + tree_size(bst % root % lt) + tree_size(bst % root % gt)
|
|
else
|
|
n = 0
|
|
end if
|
|
end function tree_size
|
|
|
|
subroutine map_to_vector (proc, bst, vec, nvec)
|
|
|
|
type(CGNodeTree), intent(in) :: bst
|
|
integer, dimension(:,:), intent(out) :: vec
|
|
integer, intent(out) :: nvec
|
|
|
|
interface
|
|
subroutine proc (node, vec)
|
|
use CGNodeType
|
|
type(CGNode), intent(in) :: node
|
|
integer, dimension(:), intent(out) :: vec
|
|
end subroutine proc
|
|
end interface
|
|
|
|
nvec = 0
|
|
call map_to_vector_aux (proc, bst, vec, nvec)
|
|
|
|
end subroutine map_to_vector
|
|
|
|
recursive subroutine map_to_vector_aux (proc, bst, vec, nvec)
|
|
|
|
type(CGNodeTree), intent(in) :: bst
|
|
integer, dimension(:,:), intent(out) :: vec
|
|
integer, intent(inout) :: nvec
|
|
|
|
interface
|
|
subroutine proc (node, vec)
|
|
use CGNodeType
|
|
type(CGNode), intent(in) :: node
|
|
integer, dimension(:), intent(out) :: vec
|
|
end subroutine proc
|
|
end interface
|
|
|
|
if (associated(bst % root)) then
|
|
call map_to_vector_aux (proc, bst % root % lt, vec, nvec)
|
|
nvec = nvec + 1
|
|
if (nvec <= size(vec,dim=1)) then
|
|
call proc (bst % root % node, vec(:,nvec))
|
|
end if
|
|
call map_to_vector_aux (proc, bst % root % gt, vec, nvec)
|
|
end if
|
|
|
|
end subroutine map_to_vector_aux
|
|
|
|
recursive subroutine for_each (bst, proc)
|
|
|
|
type(CGNodeTree) :: bst
|
|
|
|
interface
|
|
subroutine proc (node)
|
|
use CGNodeType
|
|
type(CGNode), intent(inout) :: node
|
|
end subroutine proc
|
|
end interface
|
|
|
|
if (associated(bst % root)) then
|
|
call for_each (bst % root % lt, proc)
|
|
call proc (bst % root % node)
|
|
call for_each (bst % root % gt, proc)
|
|
end if
|
|
|
|
end subroutine for_each
|
|
|
|
end module ColoredGraphModule
|