initial upload
This commit is contained in:
520
src/ColoredGraphModule.f90
Executable file
520
src/ColoredGraphModule.f90
Executable file
@@ -0,0 +1,520 @@
|
||||
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
!!
|
||||
!! 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
|
||||
Reference in New Issue
Block a user