program grafpack_prb ! !******************************************************************************* ! !! GRAFPACK_PRB calls the GRAFPACK test routines. ! implicit none ! call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAFPACK_PRB' write ( *, '(a)' ) ' Tests for the GRAFPACK graph routines.' call test001 call test002 call test003 call test004 call test005 call test006 call test007 call test008 call test009 call test0095 call test010 call test0105 call test011 call test012 call test013 call test014 call test015 call test0155 call test016 call test017 call test018 call test019 call test020 call test021 call test022 call test023 call test024 call test025 call test026 call test027 call test028 call test029 call test030 call test031 call test032 call test033 call test034 call test035 call test0335 call test036 call test0365 call test0366 call test037 call test038 call test039 call test040 call test041 call test042 call test043 call test044 call test045 call test046 call test047 call test048 call test049 call test050 call test051 call test052 call test053 call test054 call test055 call test056 call test057 call test058 call test059 call test060 call test061 call test062 call test063 call test064 call test065 call test066 call test0665 call test067 call test068 call test069 call test0695 call test0696 call test0697 call test070 call test071 call test072 call test073 call test074 call test075 call test076 call test077 call test078 call test079 call test080 call test081 call test082 call test083 call test084 call test085 call test086 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAFPACK_PRB' write ( *, '(a)' ) ' Normal end of execution.' stop end subroutine test001 ! !******************************************************************************* ! !! TEST001 tests COLOR_DIGRAPH_ADJ_RANDOM; ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer mcolor integer ncolor integer nedge ! ncolor = 3 nedge = 15 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST001' write ( *, '(a)' ) ' COLOR_DIGRAPH_ADJ_RANDOM returns a random ' write ( *, '(a)' ) ' color digraph.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Random object is to have:' write ( *, '(a,i6)' ) ' Number of colors = ', ncolor write ( *, '(a,i6)' ) ' Number of nodes = ', nnode write ( *, '(a,i6)' ) ' Number of edges = ', nedge call color_digraph_adj_random ( adj, lda, nnode, ncolor, nedge ) call color_digraph_adj_print ( adj, lda, nnode, ' The color digraph:' ) ! ! Count the edges. ! call color_digraph_adj_edge_count ( adj, lda, nnode, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of edges is ', nedge ! ! Count the colors. ! call color_graph_adj_color_count ( adj, lda, nnode, mcolor, ncolor ) write ( *, '(a,i6)' ) ' Number of colors is ', ncolor write ( *, '(a,i6)' ) ' Maximum color index is ', mcolor return end subroutine test002 ! !******************************************************************************* ! !! TEST002 tests COLOR_GRAPH_ADJ_CONNECT_RANDOM. ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer mcolor integer ncolor integer nedge integer result ! ncolor = 3 nedge = 8 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST002' write ( *, '(a)' ) ' COLOR_GRAPH_ADJ_CONNECT_RANDOM returns a random ' // & 'connected color graph;' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Random object is to have:' write ( *, '(a,i6)' ) ' Number of colors = ', ncolor write ( *, '(a,i6)' ) ' Number of nodes = ', nnode write ( *, '(a,i6)' ) ' Number of edges = ', nedge call color_graph_adj_connect_random ( adj, lda, nnode, nedge, ncolor ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) ! ! Check connectedness. ! call graph_adj_is_edge_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT edgewise connected.' else write ( *, '(a)' ) ' The graph IS edgewise connected.' end if call graph_adj_is_node_connected ( adj, lda, nnode, result ) if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT nodewise connected.' else write ( *, '(a)' ) ' The graph IS nodewise connected.' end if ! ! Count the edges. ! call color_graph_adj_edge_count ( adj, lda, nnode, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of edges is ', nedge ! ! Count the colors. ! call color_graph_adj_color_count ( adj, lda, nnode, mcolor, ncolor ) write ( *, '(a,i6)' ) ' Number of colors is ', ncolor write ( *, '(a,i6)' ) ' Maximum color index is ', mcolor return end subroutine test003 ! !******************************************************************************* ! !! TEST003 tests COLOR_GRAPH_ADJ_RANDOM; ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer mcolor integer ncolor integer nedge ! ncolor = 3 nedge = 7 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST003' write ( *, '(a)' ) ' COLOR_GRAPH_ADJ_RANDOM returns a random color digraph.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Random object is to have:' write ( *, '(a,i6)' ) ' Number of colors = ', ncolor write ( *, '(a,i6)' ) ' Number of nodes = ', nnode write ( *, '(a,i6)' ) ' Number of edges = ', nedge call color_graph_adj_random ( adj, lda, nnode, ncolor, nedge ) call color_graph_adj_print ( adj, lda, nnode, ' The color graph:' ) ! ! Count the edges. ! call color_graph_adj_edge_count ( adj, lda, nnode, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of edges is ', nedge ! ! Count the colors. ! call color_graph_adj_color_count ( adj, lda, nnode, mcolor, ncolor ) write ( *, '(a,i6)' ) ' Number of colors is ', ncolor write ( *, '(a,i6)' ) ' Maximum color index is ', mcolor return end subroutine test004 ! !******************************************************************************* ! !! TEST004 tests DEGREE_SEQ_IS_GRAPHIC. ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: ntest = 5 ! integer degree_seq(nnode) integer i integer j integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST004' write ( *, '(a)' ) ' DEGREE_SEQ_IS_GRAPHIC reports whether' write ( *, '(a)' ) ' a given sequence can represent the degree' write ( *, '(a)' ) ' sequence of a graph.' write ( *, '(a)' ) ' ' do i = 1, ntest call ivec_random ( nnode, degree_seq, 1, nnode-1 ) call ivec_sort_heap_d ( nnode, degree_seq ) call ivec_print ( nnode, degree_seq, ' The degree sequence:' ) call degree_seq_is_graphic ( nnode, degree_seq, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The sequence is NOT graphic.' else if ( result == 1 ) then write ( *, '(a)' ) ' The sequence IS graphic.' end if end do return end subroutine test005 ! !******************************************************************************* ! !! TEST005 tests DEGREE_SEQ_TO_GRAPH_ADJ. ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,lda) integer ierror integer, dimension ( nnode ) :: seq = (/ 5, 5, 4, 3, 3, 2 /) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST005' write ( *, '(a)' ) ' DEGREE_SEQ_TO_GRAPH_ADJ is given a degree' write ( *, '(a)' ) ' sequence, and constructs the adjancency' write ( *, '(a)' ) ' matrix of a corresponding graph.' call ivec_print ( nnode, seq, ' The degree sequence:' ) call degree_seq_to_graph_adj ( nnode, seq, lda, adj, ierror ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) return end subroutine test006 ! !******************************************************************************* ! !! TEST006 tests DIGRAPH_ADJ_CLOSURE; !! TEST006 tests DIGRAPH_ADJ_REDUCE. ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer i integer j ! adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,6) = 1 adj(1,7) = 1 adj(3,1) = 1 adj(4,6) = 1 adj(5,4) = 1 adj(6,5) = 1 adj(7,3) = 1 adj(7,5) = 1 adj(7,10) = 1 adj(8,7) = 1 adj(8,9) = 1 adj(9,8) = 1 adj(10,11) = 1 adj(10,12) = 1 adj(10,13) = 1 adj(12,7) = 1 adj(12,13) = 1 adj(13,12) = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST006' write ( *, '(a)' ) ' DIGRAPH_ADJ_CLOSURE finds the transitive ' write ( *, '(a)' ) ' closure of a digraph;' write ( *, '(a)' ) ' DIGRAPH_ADJ_REDUCE finds the transitive ' write ( *, '(a)' ) ' reduction of a digraph.' write ( *, '(a)' ) ' ' call digraph_adj_print ( adj, lda, nnode, ' Adjacency matrix for G:' ) call digraph_adj_closure ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, & ' Adjacency matrix for H, the transitive closure of G:' ) call digraph_adj_reduce ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, & ' Adjacency matrix for G2, the transitive reduction of H:' ) call digraph_adj_closure ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, & ' Adjacency matrix for H2, the transitive closure of G2:' ) return end subroutine test007 ! !******************************************************************************* ! !! TEST007 tests DIGRAPH_ADJ_COMPONENTS. ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer comp(nnode) integer dad(nnode) integer i integer j integer ncomp integer order(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST007' write ( *, '(a)' ) ' DIGRAPH_ADJ_COMPONENTS finds strongly connected' write ( *, '(a)' ) ' components of a directed graph.' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,11) = 1 adj(2,3) = 1 adj(2,6) = 1 adj(3,4) = 1 adj(3,5) = 1 adj(4,3) = 1 adj(5,4) = 1 adj(6,7) = 1 adj(6,8) = 1 adj(7,6) = 1 adj(8,9) = 1 adj(8,10) = 1 adj(9,7) = 1 adj(10,9) = 1 adj(11,12) = 1 adj(11,13) = 1 adj(12,1) = 1 adj(13,1) = 1 adj(13,12) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph' ) call digraph_adj_components ( adj, lda, nnode, ncomp, comp, dad, order ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of components = ', ncomp write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Node, Dad, Component, Order' write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(5i8)' ) i, dad(i), comp(i), order(i) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The correct components are:' write ( *, '(a)' ) ' (1,11,12,13), (2), (3,4,5), (6,7,8,9,10).' ! ! Compute a reordering of the nodes. ! do i = 1, nnode order(i) = i end do do i = 2, nnode do j = 1, i - 1 if ( comp(j) > comp(i) .or. & ( comp(j) == comp(i) .and. order(j) > order(i) ) ) then call i_swap ( comp(j), comp(i) ) call i_swap ( order(j), order(i) ) end if end do end do call ivec2_print ( nnode, comp, order, ' I, Component(I), Node(I)' ) call perm_inv ( nnode, order ) call imat_perm ( lda, nnode, adj, order ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) return end subroutine test008 ! !******************************************************************************* ! !! TEST008 tests DIGRAPH_ADJ_CYCLE. ! implicit none ! integer, parameter :: lda = 9 ! integer adj(lda,lda) integer adj2(lda,lda) integer dad(lda) integer i integer j integer nedge integer nnode integer order(lda) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST008' write ( *, '(a)' ) ' DIGRAPH_ADJ_CYCLE searches for cycles in a digraph.' call digraph_adj_example_cycler ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) ! ! Count the edges. ! call digraph_adj_edge_count ( adj, lda, nnode, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The number of edges is ', nedge call digraph_adj_cycle ( adj, lda, nnode, adj2, dad, order ) call ivec2_print ( nnode, dad, order, ' Node, Dad, Order' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Adjacency matrix with cycles marked.' write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(10i3)' ) adj2(i,1:nnode) end do return end subroutine test009 ! !******************************************************************************* ! !! TEST009 tests DIGRAPH_ADJ_DEGREE. !! TEST009 tests DIGRAPH_ADJ_DEGREE_MAX. !! TEST009 tests DIGRAPH_ADJ_DEGREE_SEQ. ! implicit none ! integer, parameter :: lda = 10 ! integer adj(lda,lda) integer degree_max integer i integer indegree(lda) integer indegree_max integer indegree_seq(lda) integer nnode integer outdegree(lda) integer outdegree_max integer outdegree_seq(lda) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST009' write ( *, '(a)' ) ' For a directed graph:' write ( *, '(a)' ) ' DIGRAPH_ADJ_DEGREE computes the degree of the nodes;' write ( *, '(a)' ) ' DIGRAPH_ADJ_DEGREE_MAX computes the maximum' write ( *, '(a)' ) ' degree of the nodes;' write ( *, '(a)' ) ' DIGRAPH_ADJ_DEGREE_SEQ computes the degree' write ( *, '(a)' ) ' sequence;' call digraph_adj_example_cycler ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_degree ( adj, lda, nnode, indegree, outdegree ) call ivec2_print ( nnode, indegree, outdegree, ' Node, In/Outdegree' ) call digraph_adj_degree_seq ( adj, lda, nnode, indegree_seq, outdegree_seq ) call ivec2_print ( nnode, indegree_seq, outdegree_seq, & ' Node, In/Outdegree sequence' ) call digraph_adj_degree_max ( adj, lda, nnode, indegree_max, outdegree_max, & degree_max ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Maximum indegree is ', indegree_max write ( *, '(a,i6)' ) ' Maximum outdegree is ', outdegree_max write ( *, '(a,i6)' ) ' Maximum degree is ', degree_max write ( *, '(a)' ) ' ' return end subroutine test0095 ! !******************************************************************************* ! !! TEST0095 tests DIGRAPH_ADJ_EIGEN. ! implicit none ! integer, parameter :: lda = 9 ! integer adj(lda,lda) real eigeni(lda) real eigenr(lda) integer neigen integer nnode ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0095' write ( *, '(a)' ) ' For a digraph:' write ( *, '(a)' ) ' DIGRAPH_ADJ_EIGEN computes the eigenvalues.' call digraph_adj_example_cycler ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_eigen ( adj, lda, nnode, neigen, eigenr, eigeni ) call rvec2_print ( neigen, eigenr, eigeni, & ' Real and imaginary parts of eigenvalues:' ) if ( neigen < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Warning! Not all eigenvalues were computed.' end if return end subroutine test010 ! !******************************************************************************* ! !! TEST010 tests DIGRAPH_ADJ_HAM_NEXT. ! implicit none ! integer, parameter :: nnode = 20 integer, parameter :: lda = nnode integer, parameter :: maxstack = 100 ! integer adj(lda,nnode) integer circuit(nnode) integer i integer j logical more integer ncan(nnode) integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST010' write ( *, '(a)' ) ' DIGRAPH_ADJ_HAM_NEXT produces Hamilton circuits;' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,8) = 1 adj(1,2) = 1 adj(1,20) = 1 adj(2,3) = 1 adj(2,15) = 1 adj(3,7) = 1 adj(3,4) = 1 adj(4,5) = 1 adj(4,14) = 1 adj(5,6) = 1 adj(5,12) = 1 adj(6,10) = 1 adj(6,7) = 1 adj(7,8) = 1 adj(8,9) = 1 adj(9,10) = 1 adj(9,19) = 1 adj(10,11) = 1 adj(11,12) = 1 adj(11,18) = 1 adj(12,13) = 1 adj(13,14) = 1 adj(13,17) = 1 adj(14,15) = 1 adj(15,16) = 1 adj(16,17) = 1 adj(16,20) = 1 adj(17,18) = 1 adj(18,19) = 1 adj(19,20) = 1 do i = 1, nnode-1 do j = i+1, nnode if ( adj(i,j) == 1 ) then adj(j,i) = 1 end if end do end do call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 more = .false. do call digraph_adj_ham_next ( adj, lda, nnode, circuit, stack, maxstack, & ncan, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nnode) end do return end subroutine test0105 ! !******************************************************************************* ! !! TEST0105 tests DIGRAPH_ADJ_HAM_NEXT. ! implicit none ! integer, parameter :: nnode = 9 integer, parameter :: lda = nnode integer, parameter :: maxstack = 100 ! integer adj(lda,nnode) integer circuit(nnode) integer i integer j logical more integer ncan(nnode) integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0105' write ( *, '(a)' ) ' DIGRAPH_ADJ_HAM_NEXT produces Hamilton circuits;' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,6) = 1 adj(2,3) = 1 adj(2,5) = 1 adj(3,4) = 1 adj(4,1) = 1 adj(4,5) = 1 adj(4,8) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(5,3) = 1 adj(5,4) = 1 adj(5,7) = 1 adj(5,8) = 1 adj(5,9) = 1 adj(6,3) = 1 adj(6,5) = 1 adj(6,8) = 1 adj(7,2) = 1 adj(7,4) = 1 adj(7,5) = 1 adj(8,4) = 1 adj(8,5) = 1 adj(8,6) = 1 adj(8,9) = 1 adj(9,5) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 more = .false. do call digraph_adj_ham_next ( adj, lda, nnode, circuit, stack, maxstack, & ncan, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nnode) end do return end subroutine test011 ! !******************************************************************************* ! !! TEST011 tests DIGRAPH_ADJ_HAM_NEXT_BRUTE. ! implicit none ! integer, parameter :: nnode = 9 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer circuit(nnode) integer i integer iset integer j ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST011' write ( *, '(a)' ) ' DIGRAPH_ADJ_HAM_NEXT_BRUTE seeks circuits' write ( *, '(a)' ) ' in a directed graph which visit every node.' write ( *, '(a)' ) ' A brute force algorithm is used.' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,6) = 1 adj(2,3) = 1 adj(2,5) = 1 adj(3,4) = 1 adj(4,1) = 1 adj(4,5) = 1 adj(4,8) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(5,3) = 1 adj(5,4) = 1 adj(5,7) = 1 adj(5,8) = 1 adj(5,9) = 1 adj(6,3) = 1 adj(6,5) = 1 adj(6,8) = 1 adj(7,2) = 1 adj(7,4) = 1 adj(7,5) = 1 adj(8,4) = 1 adj(8,5) = 1 adj(8,6) = 1 adj(8,9) = 1 adj(9,5) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) iset = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 do call digraph_adj_ham_next_brute ( adj, lda, nnode, circuit, iset ) if ( iset == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' No more circuits were found.' exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nnode) end do return end subroutine test012 ! !******************************************************************************* ! !! TEST012 tests DIGRAPH_ADJ_HAM_PATH_NEXT_BRUTE. ! implicit none ! integer, parameter :: nnode = 4 integer, parameter :: lda = nnode ! integer i integer adj(lda,nnode) integer iset integer j integer path(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST012' write ( *, '(a)' ) ' DIGRAPH_ADJ_HAM_PATH_NEXT_BRUTE seeks paths in a' write ( *, '(a)' ) ' digraph which visit every node once.' write ( *, '(a)' ) ' A brute force algorithm is used.' ! ! Initialize the adjacency matrix to the identity. ! do i = 1, nnode do j = 1, nnode if ( i == j ) then adj(i,j) = 1 else adj(i,j) = 0 end if end do end do ! ! Add entries for specific edges. This is a directed graph. ! ADJ(I, j) = 1 means there's a edge from I to J. ! adj(1,2) = 1 adj(1,4) = 1 adj(2,4) = 1 adj(3,1) = 1 adj(3,4) = 1 adj(4,2) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) iset = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Paths:' write ( *, '(a)' ) ' ' i = 0 do call digraph_adj_ham_path_next_brute ( adj, lda, nnode, path, iset ) if ( iset == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' No more paths were found.' exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, path(1:nnode) end do return end subroutine test013 ! !******************************************************************************* ! !! TEST013 tests DIGRAPH_ADJ_IS_EDGE_CONNECTED; ! ! ! 1-->--2 ! | | ! A A ! | | ! 4--<--3 ! implicit none ! integer, parameter :: nnode = 4 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer i integer j integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST013' write ( *, '(a)' ) ' DIGRAPH_ADJ_IS_EDGE_CONNECTED reports if a' write ( *, '(a)' ) ' digraph is edgewise connected;' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(3,2) = 1 adj(3,4) = 1 adj(4,1) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_is_edge_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT edgewise connected.' else write ( *, '(a)' ) ' The digraph IS edgewise connected.' end if return end subroutine test014 ! !******************************************************************************* ! !! TEST014 tests DIGRAPH_ADJ_IS_EULERIAN; ! ! 1->---2-->---3 ! A V V ! 6<--5--<---4 ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer i integer j integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST014' write ( *, '(a)' ) ' DIGRAPH_ADJ_IS_EULERIAN reports if a digraph is Eulerian;' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(2,3) = 1 adj(3,4) = 1 adj(4,5) = 1 adj(5,6) = 1 adj(6,2) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_is_eulerian ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT Eulerian.' else if ( result == 1 ) then write ( *, '(a)' ) ' The digraph IS path Eulerian.' else if ( result == 2 ) then write ( *, '(a)' ) ' The digraph IS circuit Eulerian.' end if return end subroutine test015 ! !******************************************************************************* ! !! TEST015 tests DIGRAPH_ADJ_IS_STRONG_CONNECTED; ! ! 1) ! ! 1-->--2 ! | | ! A A ! | | ! 4--<--3 ! ! 2) ! ! 1-->--2-->--3-->--4 ! | | | | ! A V A V ! | | | | ! 5--<--6 7--<--8 ! ! 3) ! ! 1-->--2-->--3-->--4 ! | | | | ! A V A V ! | | | | ! 5--<--6--<--7--<--8 ! implicit none ! integer, parameter :: lda = 8 ! integer adj(lda,lda) integer i integer j integer nnode integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST015' write ( *, '(a)' ) ' DIGRAPH_ADJ_IS_STRONG_CONNECTED reports if a' write ( *, '(a)' ) ' digraph is strongly connected;' nnode = 4 adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(3,2) = 1 adj(3,4) = 1 adj(4,1) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_is_strong_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT strongly connected.' else write ( *, '(a)' ) ' The digraph IS strongly connected.' end if nnode = 8 adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(2,3) = 1 adj(2,6) = 1 adj(6,5) = 1 adj(5,1) = 1 adj(3,4) = 1 adj(4,8) = 1 adj(8,7) = 1 adj(7,3) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_is_strong_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT strongly connected.' else write ( *, '(a)' ) ' The digraph IS strongly connected.' end if nnode = 8 adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(2,3) = 1 adj(2,6) = 1 adj(6,5) = 1 adj(5,1) = 1 adj(3,4) = 1 adj(4,8) = 1 adj(8,7) = 1 adj(7,3) = 1 adj(7,6) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_is_strong_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT strongly connected.' else write ( *, '(a)' ) ' The digraph IS strongly connected.' end if return end subroutine test0155 ! !******************************************************************************* ! !! TEST0155 tests DIGRAPH_ADJ_TOURNAMENT_RANDOM; !! TEST0155 tests DIGRAPH_ADJ_IS_TOURNAMENT; ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,lda) integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0155' write ( *, '(a)' ) ' DIGRAPH_ADJ_TOURNAMENT_RANDOM returns a random' write ( *, '(a)' ) ' tourname digraph.' write ( *, '(a)' ) ' DIGRAPH_ADJ_IS_TOURNAMENT reports if a' write ( *, '(a)' ) ' digraph is a tournament.' call digraph_adj_tournament_random ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, ' A random tournament digraph:' ) call digraph_adj_is_tournament ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT a tournament.' else write ( *, '(a)' ) ' The digraph IS a tournament.' end if return end subroutine test016 ! !******************************************************************************* ! !! TEST016 tests DIGRAPH_ADJ_IS_TRANSITIVE; ! implicit none ! integer, parameter :: lda = 12 ! integer adj(lda,lda) integer nnode integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST016' write ( *, '(a)' ) ' DIGRAPH_ADJ_IS_TRANSITIVE reports if a' write ( *, '(a)' ) ' digraph is transitive;' call digraph_adj_example_sixty ( adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_is_transitive ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The digraph is NOT transitive.' else write ( *, '(a)' ) ' The digraph IS transitive.' end if return end subroutine test017 ! !******************************************************************************* ! !! TEST017 tests DIGRAPH_ADJ_RANDOM; ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer nedge ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST017' write ( *, '(a)' ) ' DIGRAPH_ADJ_RANDOM returns a random digraph.' write ( *, '(a)' ) ' ' nedge = 10 write ( *, '(a,i6)' ) ' Number of edges requested = ', nedge call digraph_adj_random ( adj, lda, nnode, nedge ) call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) ! ! Count the edges. ! call digraph_adj_edge_count ( adj, lda, nnode, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of edges is ', nedge return end subroutine test018 ! !******************************************************************************* ! !! TEST018 tests DIGRAPH_ADJ_TO_DIGRAPH_ARC; ! ! 1->---2-->---3 ! A V V ! 6--<--5--<---4 ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode integer, parameter :: maxarc = 10 ! integer adj(lda,nnode) integer inode(maxarc) integer jnode(maxarc) integer narc ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST018' write ( *, '(a)' ) ' DIGRAPH_ADJ_TO_DIGRAPH_ARC converts a digraph in' write ( *, '(a)' ) ' adjacency form to arc list form;' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(2,3) = 1 adj(3,4) = 1 adj(4,5) = 1 adj(5,6) = 1 adj(6,2) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph in adjacency form:' ) call digraph_adj_to_digraph_arc ( adj, lda, nnode, maxarc, narc, & inode, jnode ) call digraph_arc_print ( narc, inode, jnode, & ' The digraph in arc list form:' ) return end subroutine test019 ! !******************************************************************************* ! !! TEST019 tests DIGRAPH_ADJ_TO_DIGRAPH_INC; ! ! 1->---2-->---3 ! A V V ! 6<--5--<---4 ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode integer, parameter :: maxarc = 10 ! integer adj(lda,nnode) integer inc(lda,maxarc) integer narc ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST019' write ( *, '(a)' ) ' DIGRAPH_ADJ_TO_DIGRAPH_INC converts a digraph in' write ( *, '(a)' ) ' adjacency form to incidence matrix form;' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(2,3) = 1 adj(3,4) = 1 adj(4,5) = 1 adj(5,6) = 1 adj(6,2) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph in adjacency form:' ) call digraph_adj_to_digraph_inc ( adj, lda, nnode, maxarc, narc, inc ) call digraph_inc_print ( lda, nnode, narc, inc, & ' The digraph in incidence form:' ) return end subroutine test020 ! !******************************************************************************* ! !! TEST020 tests DIGRAPH_ADJ_TOP_SORT. ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer j integer node_list(nnode) integer order(nnode) integer visit(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST020' write ( *, '(a)' ) ' DIGRAPH_ADJ_TOP_SORT does a topological sort' write ( *, '(a)' ) ' of an acyclic digraph.' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,3) = 1 adj(1,6) = 1 adj(5,4) = 1 adj(6,4) = 1 adj(6,5) = 1 adj(7,3) = 1 adj(7,5) = 1 adj(7,8) = 1 adj(8,9) = 1 adj(10,7) = 1 adj(10,11) = 1 adj(10,12) = 1 adj(10,13) = 1 adj(12,7) = 1 adj(12,13) = 1 call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) call digraph_adj_top_sort ( adj, lda, nnode, dad, visit, node_list ) call ivec_print ( nnode, dad, ' Nodes and "Dads":' ) call ivec_print ( nnode, visit, ' Nodes and order of visit:' ) call ivec_print ( nnode, node_list, ' Nodes and reverse topological order:' ) ! ! Invert the listing to get a permutation. ! order(1:nnode) = node_list(1:nnode) call perm_inv ( nnode, order ) ! ! Apply reordering and print adjacency matrix. ! call imat_perm ( lda, nnode, adj, order ) call digraph_adj_print ( adj, lda, nnode, ' The reordered digraph:' ) return end subroutine test021 ! !******************************************************************************* ! !! TEST021 tests DIGRAPH_ARC_DEGREE. ! ! ! 5--2--10--1--3--6 ! | | | / ! 8 | 9 ! | | ! 4--7 ! implicit none ! integer, parameter :: nedge = 11 integer, parameter :: nnode = 10 ! integer i integer indegree(nnode) integer inode(nedge) integer jnode(nedge) integer outdegree(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST021' write ( *, '(a)' ) ' For a digraph described by an arc list:' write ( *, '(a)' ) ' DIGRAPH_ARC_DEGREE computes the degree of the nodes;' inode = (/ 1, 1, 1, 2, 2, 3, 3, 4, 4, 6, 8 /) jnode = (/ 3, 7, 10, 5, 10, 6, 9, 7, 8, 9, 10 /) call digraph_arc_print ( nedge, inode, jnode, ' The graph:' ) call digraph_arc_degree ( nnode, nedge, inode, jnode, indegree, outdegree ) call ivec2_print ( nnode, indegree, outdegree, ' Node, Indegree, Outdegree' ) return end subroutine test022 ! !******************************************************************************* ! !! TEST022 tests DIGRAPH_ARC_EULER_CIRC_NEXT. !! TEST022 tests DIGRAPH_ARC_IS_EULERIAN. ! implicit none ! integer, parameter :: maxstack = 130 integer, parameter :: nedge = 10 integer, parameter :: nnode = 5 ! integer circuit(nedge) integer i integer indegree(nnode) integer, dimension ( nedge ) :: inode = (/ 1, 3, 1, 5, 2, 4, 2, 4, 3, 5 /) integer, dimension ( nedge ) :: jnode = (/ 2, 1, 4, 1, 3, 2, 5, 3, 5, 4 /) logical more integer ncan(nedge) integer outdegree(nnode) integer result integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST022' write ( *, '(a)' ) ' For a digraph described by an arc list:' write ( *, '(a)' ) ' DIGRAPH_ARC_IS_EULERIAN checks if a graph' write ( *, '(a)' ) ' has an Euler circuit.' write ( *, '(a)' ) ' DIGRAPH_ARC_EULER_CIRC_NEXT finds the next' write ( *, '(a)' ) ' Euler circuit of a graph.' write ( *, '(a)' ) ' ' call digraph_arc_print ( nedge, inode, jnode, ' The digraph:' ) call digraph_arc_is_eulerian ( nnode, nedge, inode, jnode, indegree, & outdegree, result ) if ( result == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The digraph is NOT eulerian.' return else if ( result == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The digraph has an eulerian path,' write ( *, '(a)' ) ' but not an eulerian circuit.' else if ( result == 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The digraph has an eulerian circuit.' end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 more = .false. do call digraph_arc_euler_circ_next ( nedge, inode, jnode, circuit, stack, & maxstack, ncan, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nedge) end do return end subroutine test023 ! !******************************************************************************* ! !! TEST023 tests DIGRAPH_ARC_TO_DIGRAPH_ADJ. ! implicit none ! integer, parameter :: maxedge = 20 integer, parameter :: maxnode = 20 integer, parameter :: lda = maxnode ! integer adj(lda,maxnode) integer inode(maxedge) integer jnode(maxedge) integer nedge integer nnode ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST023' write ( *, '(a)' ) ' DIGRAPH_ARC_TO_DIGRAPH_ADJ converts an arclist' write ( *, '(a)' ) ' digraph to an adjacency digraph.' write ( *, '(a)' ) ' ' call digraph_arc_example_cycler ( maxedge, nedge, inode, jnode ) call digraph_arc_print ( nedge, inode, jnode, ' The graph:' ) call digraph_arc_to_digraph_adj ( nedge, inode, jnode, adj, lda, nnode ) call digraph_adj_print ( adj, lda, nnode, ' The digraph:' ) return end subroutine test024 ! !******************************************************************************* ! !! TEST024 tests FACE_CHECK. ! implicit none ! integer, parameter :: max_edge = 30 integer, parameter :: max_order = 4 integer, parameter :: max_face = 10 ! integer edge(4,max_edge) integer face(max_order,max_face) integer face_object(max_face) integer face_order(max_face) integer face_rank(max_face) integer face_tier(max_face) integer i integer j integer num_edge integer num_face integer num_object ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST024' write ( *, '(a)' ) ' FACE_CHECK checks faces;' ! ! Get the problem data. ! write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' max_face = ', max_face write ( *, '(a,i6)' ) ' max_order = ', max_order write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Get a test example' call face_example_pieces ( face, face_order, max_face, max_order, num_face ) ! ! List the problem data. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Order, Nodes' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(10i3)' ) i, face_order(i), ( face(j,i), j = 1, face_order(i) ) end do ! ! Check the problem data. ! call face_check ( edge, face, face_object, face_order, face_rank, & face_tier, max_edge, max_order, num_edge, num_face, num_object ) return end subroutine test025 ! !******************************************************************************* ! !! TEST025 tests GRAPH_ADJ_BFS. ! ! This example is from page 22 of ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985 ! ISBN 0-521-28881-9 ! ! The correct result is ! ! Node Idad Ideep Iorder ! ! 1 0 1 1 ! 2 1 2 2 ! 3 1 2 3 ! 4 1 2 4 ! 5 1 2 5 ! 6 1 2 6 ! 7 1 2 7 ! 8 1 2 8 ! 9 0 3 9 ! 10 9 4 10 ! 11 10 5 12 ! 12 10 5 13 ! 13 9 4 11 ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer i integer adj(lda,nnode) integer dad(nnode) integer deep(nnode) integer j integer order(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST025' write ( *, '(a)' ) ' GRAPH_ADJ_BFS sets up a breadth-first' write ( *, '(a)' ) ' traversal of a graph.' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,3) = 1 adj(1,4) = 1 adj(1,5) = 1 adj(1,6) = 1 adj(1,7) = 1 adj(1,8) = 1 adj(2,1) = 1 adj(2,5) = 1 adj(2,6) = 1 adj(2,8) = 1 adj(3,1) = 1 adj(3,4) = 1 adj(3,7) = 1 adj(4,1) = 1 adj(4,3) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(6,1) = 1 adj(6,2) = 1 adj(7,1) = 1 adj(7,3) = 1 adj(8,1) = 1 adj(8,2) = 1 adj(9,10) = 1 adj(9,13) = 1 adj(10,9) = 1 adj(10,11) = 1 adj(10,12) = 1 adj(10,13) = 1 adj(11,10) = 1 adj(11,12) = 1 adj(12,10) = 1 adj(12,11) = 1 adj(13,9) = 1 adj(13,10) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_bfs ( adj, lda, nnode, dad, deep, order ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I, dad(i), deep(i), order(i)' write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(4i6)' ) i, dad(i), deep(i), order(i) end do return end subroutine test026 ! !******************************************************************************* ! !! TEST026 tests GRAPH_ADJ_BIPARTITE_RANDOM. !! TEST026 tests GRAPH_ADJ_IS_BIPARTITE. ! implicit none ! integer, parameter :: nnode1 = 4 integer, parameter :: nnode2 = 6 integer, parameter :: nnode = nnode1 + nnode2 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer nedge integer nedge2 integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST026' write ( *, '(a)' ) ' GRAPH_ADJ_BIPARTITE_RANDOM returns a random ' // & 'bipartite graph;' write ( *, '(a)' ) ' GRAPH_ADJ_IS_BIPARTITE reports if a graph is bipartite.' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of nodes in set 1 is ', nnode1 write ( *, '(a,i6)' ) ' Number of nodes in set 2 is ', nnode2 call graph_adj_bipartite_random ( adj, lda, nedge, nnode1, nnode2 ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_is_bipartite ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT bipartite.' else write ( *, '(a)' ) ' The graph IS bipartite.' end if ! ! Count the edges. ! call graph_adj_edge_count ( adj, lda, nnode, nedge2 ) write ( *, '(a,i6)' ) ' Total number of edges is ', nedge write ( *, '(a,i6)' ) ' Counted number of edges is ', nedge2 return end subroutine test027 ! !******************************************************************************* ! !! TEST027 tests GRAPH_ADJ_BLOCK. ! ! The correct result is ! ! 3 blocks ! ! Node Idad Iorder ! ! 1 0 -1 ! 2 1 2 ! 3 4 5 ! 4 1 -4 ! 5 4 6 ! 6 2 3 ! ! Revised adjacency matrix: ! ! 0 1 0 3 3 1 ! 1 0 0 0 0 1 ! 0 0 0 2 0 0 ! 3 0 2 0 3 0 ! 3 0 0 3 0 0 ! 1 1 0 0 0 0 ! ! The three blocks are defined by the edges: ! ! 1: (6,1), (2,6), (1,2) ! ! 2: (4,3) ! ! 3: (1,4), (4,5), (5,1) ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer i integer dad(nnode) integer order(nnode) integer j integer nblock integer stack(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST027' write ( *, '(a)' ) ' GRAPH_ADJ_BLOCK finds the blocks in a graph.' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,4) = 1 adj(1,5) = 1 adj(1,6) = 1 adj(2,1) = 1 adj(2,6) = 1 adj(3,4) = 1 adj(4,1) = 1 adj(4,3) = 1 adj(4,5) = 1 adj(5,1) = 1 adj(5,4) = 1 adj(6,1) = 1 adj(6,2) = 1 call graph_adj_block ( adj, lda, nnode, dad, order, stack, nblock ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of blocks = ', nblock call ivec2_print ( nnode, dad, order, ' I, DAD(I), ORDER(I)' ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) return end subroutine test028 ! !******************************************************************************* ! !! TEST028 tests GRAPH_ADJ_CLOSURE; !! TEST028 tests GRAPH_ADJ_REDUCE. ! ! 1--5 2 ! | /| ! |/ | 8--3--7 ! 4 6 ! implicit none ! integer, parameter :: nnode = 8 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer i integer j ! do i = 1, nnode do j = 1, nnode if ( i == j ) then adj(i,j) = 1 else adj(i,j) = 0 end if end do end do adj(1,4) = 1 adj(1,5) = 1 adj(3,7) = 1 adj(3,8) = 1 adj(4,1) = 1 adj(4,5) = 1 adj(5,1) = 1 adj(5,4) = 1 adj(5,6) = 1 adj(6,5) = 1 adj(7,3) = 1 adj(8,3) = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST028' write ( *, '(a)' ) ' GRAPH_ADJ_CLOSURE finds the transitive closure ' write ( *, '(a)' ) ' of a graph;' write ( *, '(a)' ) ' GRAPH_ADJ_REDUCE finds the transitive reduction' write ( *, '(a)' ) ' of a graph.' call graph_adj_print ( adj, lda, nnode, ' The adjacency matrix for G:' ) call graph_adj_closure ( adj, lda, nnode ) call graph_adj_print ( adj, lda, nnode, & ' Adjacency matrix for H, the transitive closure of G:' ) call graph_adj_reduce ( adj, lda, nnode ) call graph_adj_print ( adj, lda, nnode, & ' Adjacency matrix for G2, the transitive reduction of H:' ) call graph_adj_closure ( adj, lda, nnode ) call graph_adj_print ( adj, lda, nnode, & ' Adjacency matrix for H2, the transitive closure of G2:' ) return end subroutine test029 ! !******************************************************************************* ! !! TEST029 tests GRAPH_ADJ_COLOR_NEXT. ! implicit none ! integer, parameter :: nnode = 4 integer, parameter :: lda = nnode integer, parameter :: maxstack = 20 ! integer adj(lda,nnode) integer color(nnode) integer i integer j logical more integer ncan(nnode) integer :: ncolor = 3 integer stack(maxstack) ! data ( ( adj(i,j), j = 1, nnode ), i = 1, nnode) / & 0, 1, 0, 1, & 1, 0, 1, 0, & 0, 1, 0, 1, & 1, 0, 1, 0 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST029' write ( *, '(a)' ) ' GRAPH_ADJ_COLOR_NEXT produces colorings of a graph' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The number of colors available is ', ncolor call graph_adj_print ( adj, lda, nnode, ' The graph:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Possible node colorings:' write ( *, '(a)' ) ' ' more = .false. do call graph_adj_color_next ( adj, lda, nnode, ncolor, color, stack, & maxstack, ncan, more ) if ( .not. more ) then exit end if write ( *, '(19i4)' ) color(1:nnode) end do return end subroutine test030 ! !******************************************************************************* ! !! TEST030 tests GRAPH_ADJ_CONNECT_RANDOM. !! TEST030 tests GRAPH_ADJ_IS_EDGE_CONNECTED; !! TEST030 tests GRAPH_ADJ_IS_NODE_CONNECTED. ! implicit none ! integer, parameter :: nedge = 8 integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST030' write ( *, '(a)' ) ' GRAPH_ADJ_CONNECT_RANDOM returns a random connected graph;' write ( *, '(a)' ) ' GRAPH_ADJ_IS_EDGE_CONNECTED reports if a' write ( *, '(a)' ) ' graph is edgewise connected;' write ( *, '(a)' ) ' GRAPH_ADJ_IS_NODE_CONNECTED reports if a' write ( *, '(a)' ) ' graph is node connected;' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of nodes is ', nnode write ( *, '(a,i6)' ) ' Number of edges is ', nedge call graph_adj_connect_random ( adj, lda, nnode, nedge ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) ! ! Check connectedness. ! call graph_adj_is_edge_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT edgewise connected.' else write ( *, '(a)' ) ' The graph IS edgewise connected.' end if call graph_adj_is_node_connected ( adj, lda, nnode, result ) if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT nodewise connected.' else write ( *, '(a)' ) ' The graph IS nodewise connected.' end if return end subroutine test031 ! !******************************************************************************* ! !! TEST031 tests GRAPH_ADJ_CONNECT_RANDOM. !! TEST031 tests GRAPH_ADJ_IS_EDGE_CONNECTED; !! TEST031 tests GRAPH_ADJ_IS_NODE_CONNECTED; !! TEST031 tests GRAPH_ADJ_IS_TREE; ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: nedge = nnode - 1 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST031' write ( *, '(a)' ) ' GRAPH_ADJ_CONNECT_RANDOM returns a random connected graph;' write ( *, '(a)' ) ' GRAPH_ADJ_IS_EDGE_CONNECTED reports if a' write ( *, '(a)' ) ' graph is edgewise connected;' write ( *, '(a)' ) ' GRAPH_ADJ_IS_NODE_CONNECTED reports if a' write ( *, '(a)' ) ' graph is node connected;' write ( *, '(a)' ) ' GRAPH_ADJ_IS_TREE reports if a graph is a tree.' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of nodes is ', nnode write ( *, '(a,i6)' ) ' Number of edges is ', nedge call graph_adj_connect_random ( adj, lda, nnode, nedge ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) ! ! Check connectedness. ! call graph_adj_is_edge_connected ( adj, lda, nnode, result ) write ( *, '(a)' ) ' ' if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT edgewise connected.' else write ( *, '(a)' ) ' The graph IS edgewise connected.' end if call graph_adj_is_node_connected ( adj, lda, nnode, result ) if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT nodewise connected.' else write ( *, '(a)' ) ' The graph IS nodewise connected.' end if ! ! Check arboricity. ! call graph_adj_is_tree ( adj, lda, nnode, result ) if ( result == 0 ) then write ( *, '(a)' ) ' The graph is NOT a tree.' else write ( *, '(a)' ) ' The graph IS a tree.' end if return end subroutine test032 ! !******************************************************************************* ! !! TEST032 tests GRAPH_ADJ_CYCLE. ! ! ! 5--2--10--1--3--6 ! | | | / ! 8 | 9 ! | | ! 4--7 ! implicit none ! integer, parameter :: maxstack = 100 integer, parameter :: nnode = 10 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer j integer order(nnode) integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST032' write ( *, '(a)' ) ' GRAPH_ADJ_CYCLE searches for cycles in a graph.' adj(1:nnode,1:nnode) = 0 adj(1,3) = 1 adj(1,7) = 1 adj(1,10) = 1 adj(2,5) = 1 adj(2,10) = 1 adj(3,1) = 1 adj(3,6) = 1 adj(3,9) = 1 adj(4,7) = 1 adj(4,8) = 1 adj(5,2) = 1 adj(6,3) = 1 adj(6,9) = 1 adj(7,1) = 1 adj(7,4) = 1 adj(8,4) = 1 adj(8,10) = 1 adj(9,3) = 1 adj(9,6) = 1 adj(10,1) = 1 adj(10,2) = 1 adj(10,8) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_cycle ( adj, lda, nnode, dad, order, maxstack, stack ) call ivec2_print ( nnode, dad, order, ' Node, Dad, Order' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Adjacency matrix with cycles marked.' write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(10i3)') adj(i,1:nnode) end do return end subroutine test033 ! !******************************************************************************* ! !! TEST033 tests GRAPH_ADJ_DEGREE. !! TEST033 tests GRAPH_ADJ_DEGREE_MAX. !! TEST033 tests GRAPH_ADJ_DEGREE_SEQ. ! ! ! 5--2--10--1--3--6 ! | | | / ! 8 | 9 ! | | ! 4--7 ! implicit none ! integer, parameter :: nnode = 10 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer degree(nnode) integer degree_max integer degree_seq(nnode) integer i integer j ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST033' write ( *, '(a)' ) ' For a graph:' write ( *, '(a)' ) ' GRAPH_ADJ_DEGREE computes the degree of the nodes;' write ( *, '(a)' ) ' GRAPH_ADJ_DEGREE_MAX computes the maximum' write ( *, '(a)' ) ' degree of the nodes;' write ( *, '(a)' ) ' GRAPH_ADJ_DEGREE_SEQ computes the degree sequence;' adj(1:nnode,1:nnode) = 0 adj(1,3) = 1 adj(1,7) = 1 adj(1,10) = 1 adj(2,5) = 1 adj(2,10) = 1 adj(3,1) = 1 adj(3,6) = 1 adj(3,9) = 1 adj(4,7) = 1 adj(4,8) = 1 adj(5,2) = 1 adj(6,3) = 1 adj(6,9) = 1 adj(7,1) = 1 adj(7,4) = 1 adj(8,4) = 1 adj(8,10) = 1 adj(9,3) = 1 adj(9,6) = 1 adj(10,1) = 1 adj(10,2) = 1 adj(10,8) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_degree ( adj, lda, nnode, degree ) call ivec_print ( nnode, degree, ' Node degrees:' ) call graph_adj_degree_seq ( adj, lda, nnode, degree_seq ) call ivec_print ( nnode, degree_seq, ' Degree sequence:' ) call graph_adj_degree_max ( adj, lda, nnode, degree_max ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Maximum node degree is ', degree_max write ( *, '(a)' ) ' ' return end subroutine test034 ! !******************************************************************************* ! !! TEST034 tests GRAPH_ADJ_DFS. ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer j integer order(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST034' write ( *, '(a)' ) ' GRAPH_ADJ_DFS does depth first search of graph.' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,3) = 1 adj(1,6) = 1 adj(1,7) = 1 adj(5,4) = 1 adj(5,7) = 1 adj(6,5) = 1 adj(8,9) = 1 adj(10,11) = 1 adj(10,12) = 1 adj(10,13) = 1 adj(12,13) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_dfs ( adj, lda, nnode, dad, order ) call ivec2_print ( nnode, dad, order, ' Node, Dad, Order' ) return end subroutine test0335 ! !******************************************************************************* ! !! TEST0335 tests GRAPH_ADJ_EIGEN. ! ! ! 5--2--10--1--3--6 ! | | | / ! 8 | 9 ! | | ! 4--7 ! implicit none ! integer, parameter :: nnode = 10 integer, parameter :: lda = nnode ! integer adj(lda,nnode) real eigen(nnode) integer neigen ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0335' write ( *, '(a)' ) ' For a graph:' write ( *, '(a)' ) ' GRAPH_ADJ_EIGEN computes the eigenvalues.' adj(1:nnode,1:nnode) = 0 adj(1,3) = 1 adj(1,7) = 1 adj(1,10) = 1 adj(2,5) = 1 adj(2,10) = 1 adj(3,1) = 1 adj(3,6) = 1 adj(3,9) = 1 adj(4,7) = 1 adj(4,8) = 1 adj(5,2) = 1 adj(6,3) = 1 adj(6,9) = 1 adj(7,1) = 1 adj(7,4) = 1 adj(8,4) = 1 adj(8,10) = 1 adj(9,3) = 1 adj(9,6) = 1 adj(10,1) = 1 adj(10,2) = 1 adj(10,8) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_eigen ( adj, lda, nnode, neigen, eigen ) call rvec_print ( neigen, eigen, ' The eigenvalues:' ) if ( neigen < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Warning! Not all eigenvalues were computed.' end if return end subroutine test035 ! !******************************************************************************* ! !! TEST035 tests GRAPH_ADJ_DFS_2. ! ! This example is from page 22 of ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985 ! ISBN 0-521-28881-9 ! ! The correct result is ! ! Node Idad Iorder ! ! 1 0 1 ! 2 1 2 ! 3 1 6 ! 4 3 7 ! 5 2 3 ! 6 2 4 ! 7 3 8 ! 8 2 5 ! 9 0 9 ! 10 9 10 ! 11 10 11 ! 12 10 12 ! 13 10 13 ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer j integer order(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST035' write ( *, '(a)' ) ' GRAPH_ADJ_DFS_2 sets up depth-first traversal' write ( *, '(a)' ) ' of a graph described by an adjacency matrix.' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,3) = 1 adj(1,4) = 1 adj(1,5) = 1 adj(1,6) = 1 adj(1,7) = 1 adj(1,8) = 1 adj(2,1) = 1 adj(2,5) = 1 adj(2,6) = 1 adj(2,8) = 1 adj(3,1) = 1 adj(3,4) = 1 adj(3,7) = 1 adj(4,1) = 1 adj(4,3) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(6,1) = 1 adj(6,2) = 1 adj(7,1) = 1 adj(7,3) = 1 adj(8,1) = 1 adj(8,2) = 1 adj(9,10) = 1 adj(9,13) = 1 adj(10,9) = 1 adj(10,11) = 1 adj(10,12) = 1 adj(10,13) = 1 adj(11,10) = 1 adj(11,12) = 1 adj(12,10) = 1 adj(12,11) = 1 adj(13,9) = 1 adj(13,10) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_dfs_2 ( adj, lda, nnode, dad, order ) call ivec2_print ( nnode, dad, order, ' I, DAD(I), ORDER(I)' ) return end subroutine test036 ! !******************************************************************************* ! !! TEST036 tests GRAPH_ADJ_HAM_NEXT. ! implicit none ! integer, parameter :: nnode = 20 integer, parameter :: lda = nnode integer, parameter :: maxstack = 100 ! integer adj(lda,nnode) integer circuit(nnode) integer i integer j logical more integer ncan(nnode) integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST036' write ( *, '(a)' ) ' GRAPH_ADJ_HAM_NEXT produces Hamilton circuits;' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,8) = 1 adj(1,20) = 1 adj(2,1) = 1 adj(2,3) = 1 adj(2,15) = 1 adj(3,2) = 1 adj(3,7) = 1 adj(3,4) = 1 adj(4,3) = 1 adj(4,5) = 1 adj(4,14) = 1 adj(5,4) = 1 adj(5,6) = 1 adj(5,12) = 1 adj(6,10) = 1 adj(6,7) = 1 adj(7,3) = 1 adj(7,6) = 1 adj(7,8) = 1 adj(8,1) = 1 adj(8,7) = 1 adj(8,9) = 1 adj(9,8) = 1 adj(9,10) = 1 adj(9,19) = 1 adj(10,6) = 1 adj(10,9) = 1 adj(10,11) = 1 adj(11,10) = 1 adj(11,12) = 1 adj(11,18) = 1 adj(12,5) = 1 adj(12,11) = 1 adj(12,13) = 1 adj(13,12) = 1 adj(13,14) = 1 adj(13,17) = 1 adj(14,4) = 1 adj(14,13) = 1 adj(14,15) = 1 adj(15,2) = 1 adj(15,14) = 1 adj(15,16) = 1 adj(16,15) = 1 adj(16,17) = 1 adj(16,20) = 1 adj(17,13) = 1 adj(17,16) = 1 adj(17,18) = 1 adj(18,11) = 1 adj(18,17) = 1 adj(18,19) = 1 adj(19,9) = 1 adj(19,18) = 1 adj(19,20) = 1 adj(20,1) = 1 adj(20,16) = 1 adj(20,19) = 1 do i = 1, nnode-1 do j = i+1, nnode if ( adj(i,j) == 1 ) then adj(j,i) = 1 end if end do end do call graph_adj_print ( adj, lda, nnode, ' The graph:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 more = .false. do call graph_adj_ham_next ( adj, lda, nnode, circuit, stack, maxstack, & ncan, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nnode) end do return end subroutine test0365 ! !******************************************************************************* ! !! TEST0365 tests GRAPH_ADJ_HAM_NEXT. ! implicit none ! integer, parameter :: nnode = 9 integer, parameter :: lda = nnode integer, parameter :: maxstack = 100 ! integer adj(lda,nnode) integer circuit(nnode) integer i integer j logical more integer ncan(nnode) integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0365' write ( *, '(a)' ) ' GRAPH_ADJ_HAM_NEXT produces Hamilton circuits;' write ( *, '(a)' ) ' ' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,4) = 1 adj(1,6) = 1 adj(2,1) = 1 adj(2,3) = 1 adj(2,7) = 1 adj(3,2) = 1 adj(3,4) = 1 adj(3,6) = 1 adj(4,1) = 1 adj(4,3) = 1 adj(4,7) = 1 adj(5,6) = 1 adj(5,7) = 1 adj(5,9) = 1 adj(6,1) = 1 adj(6,3) = 1 adj(6,5) = 1 adj(6,8) = 1 adj(7,2) = 1 adj(7,4) = 1 adj(7,5) = 1 adj(8,6) = 1 adj(8,9) = 1 adj(9,5) = 1 adj(9,8) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 more = .false. do call graph_adj_ham_next ( adj, lda, nnode, circuit, stack, maxstack, & ncan, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nnode) end do return end subroutine test0366 ! !******************************************************************************* ! !! TEST0366 tests GRAPH_ADJ_HAM_NEXT_BRUTE. ! implicit none ! integer, parameter :: nnode = 9 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer circuit(nnode) integer i integer iset integer j ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0366' write ( *, '(a)' ) ' GRAPH_ADJ_HAM_NEXT_BRUTE seeks circuits' write ( *, '(a)' ) ' in a graph which visit every node.' write ( *, '(a)' ) ' A brute force algorithm is used.' adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,4) = 1 adj(1,6) = 1 adj(2,1) = 1 adj(2,3) = 1 adj(2,7) = 1 adj(3,2) = 1 adj(3,4) = 1 adj(3,6) = 1 adj(4,1) = 1 adj(4,3) = 1 adj(4,7) = 1 adj(5,6) = 1 adj(5,7) = 1 adj(5,9) = 1 adj(6,1) = 1 adj(6,3) = 1 adj(6,5) = 1 adj(6,8) = 1 adj(7,2) = 1 adj(7,4) = 1 adj(7,5) = 1 adj(8,6) = 1 adj(8,9) = 1 adj(9,5) = 1 adj(9,8) = 1 call graph_adj_print ( adj, lda, nnode, ' The graph:' ) iset = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 do call graph_adj_ham_next_brute ( adj, lda, nnode, circuit, iset ) if ( iset == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' No more circuits were found.' exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nnode) end do return end subroutine test037 ! !******************************************************************************* ! !! TEST037 tests GRAPH_ADJ_RANDOM. ! implicit none ! integer, parameter :: nedge = 10 integer, parameter :: nnode = 6 integer, parameter :: lda = nnode ! integer adj(lda,nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST037' write ( *, '(a)' ) ' GRAPH_ADJ_RANDOM returns a random graph;' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of edges requested = ', nedge call graph_adj_random ( adj, lda, nnode, nedge ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) return end subroutine test038 ! !******************************************************************************* ! !! TEST038 tests GRAPH_ADJ_SPAN_TREE. !! TEST038 tests GRAPH_ADJ_SPAN_TREE_ENUM. ! implicit none ! integer, parameter :: nnode = 13 integer, parameter :: lda = nnode ! integer adj(lda,nnode) integer i integer inode(nnode-1) integer j integer jnode(nnode-1) integer tree_num ! adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,3) = 1 adj(1,4) = 1 adj(1,5) = 1 adj(1,6) = 1 adj(1,7) = 1 adj(1,8) = 1 adj(2,1) = 1 adj(2,5) = 1 adj(2,6) = 1 adj(2,8) = 1 adj(3,1) = 1 adj(3,4) = 1 adj(3,7) = 1 adj(4,1) = 1 adj(4,3) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(6,1) = 1 adj(6,2) = 1 adj(7,1) = 1 adj(7,3) = 1 adj(8,1) = 1 adj(8,2) = 1 adj(8,9) = 1 adj(9,8) = 1 adj(9,10) = 1 adj(9,13) = 1 adj(10,9) = 1 adj(10,11) = 1 adj(10,12) = 1 adj(10,13) = 1 adj(11,10) = 1 adj(11,12) = 1 adj(12,10) = 1 adj(12,11) = 1 adj(13,9) = 1 adj(13,10) = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST038' write ( *, '(a)' ) ' GRAPH_ADJ_SPAN_TREE constructs a spanning tree of a graph.' write ( *, '(a)' ) ' GRAPH_ADJ_SPAN_TREE_ENUM enumerates the spanning trees' write ( *, '(a)' ) ' of a graph.' call graph_adj_print ( adj, lda, nnode, ' The graph:' ) call graph_adj_span_tree_enum ( adj, lda, nnode, tree_num ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Total number of spanning trees is ', tree_num call graph_adj_span_tree ( adj, lda, nnode, inode, jnode ) call graph_arc_print ( nnode-1, inode, jnode, ' The spanning tree:' ) return end subroutine test039 ! !******************************************************************************* ! !! TEST039 tests GRAPH_ARC_EDGE_CON2. ! implicit none ! integer, parameter :: nedge = 17 integer, parameter :: nnode = 9 ! integer edge_con integer i integer, dimension ( nedge ) :: inode = & (/ 6,2,3,6,7,1,4,7,3,4,9,6,5,4,2,9,4 /) integer, dimension ( nedge ) :: jnode = & (/ 8,5,1,3,2,8,3,5,8,1,2,1,9,8,6,7,2 /) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST039' write ( *, '(a)' ) ' GRAPH_ARC_EDGE_CON2 finds graph edge connectivity.' call graph_arc_print ( nedge, inode, jnode, ' The arc list of the graph:' ) call graph_arc_edge_con2 ( nnode, nedge, inode, jnode, edge_con ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The computed edge connectivity is ', edge_con return end subroutine test040 ! !******************************************************************************* ! ! TEST040 tests GRAPH_ARC_MATCH. ! integer, parameter :: nedge = 14 integer, parameter :: nnode = 12 ! integer, dimension ( nedge ) :: inode = & (/ 6, 9, 3, 4, 11, 6, 4, 5, 6, 10, 3, 4, 1, 3 /) integer, dimension ( nedge ) :: jnode = & (/ 2, 7, 7, 10, 5, 8, 6, 7, 12, 2, 1, 2, 5, 5 /) integer, dimension ( nnode ) :: match integer, dimension ( nnode ) :: type = (/ & 1, 1, 2, 1, 2, 2, 1, 2, 2, 2, 1, 1 /) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST040' write ( *, '(a)' ) ' GRAPH_ARC_MATCH finds a maximal matching in a graph.' call graph_arc_print ( nedge, inode, jnode, ' The edge list of the graph:' ) call ivec_print ( nnode, type, ' Nodes and their types:' ) call graph_arc_match ( nnode, nedge, inode, jnode, type, match ) call ivec_print ( nnode, match, ' Node and matching node:' ) return end subroutine test041 ! !******************************************************************************* ! !! TEST041 tests GRAPH_ARC_MIN_PATH. ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: lda = nnode integer, parameter :: nedge = 6 ! real, save, dimension ( nedge ) :: cost = (/ & 1.0, 1.0, 3.0, 2.0, 2.0, 5.0E+00 /) real dist(lda,nnode) integer, save, dimension ( nedge ) :: inode = (/ 1, 1, 2, 2, 3, 3 /) integer i integer istart integer istop integer, save, dimension ( nedge ) :: jnode = (/ 2, 3, 3, 5, 4, 5 /) integer num_path integer path(nnode) real path_length ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST041' write ( *, '(a)' ) ' GRAPH_ARC_MIN_PATH computes the shortest path from one' write ( *, '(a)' ) ' node to another.' write ( *, '(a)' ) ' ' call graph_arc_weight_print ( nedge, inode, jnode, cost, & ' The weighted graph:' ) dist(1:nnode,1:nnode) = 0.0E+00 do istart = 1, nnode do istop = istart+1, nnode call graph_arc_min_path ( nnode, nedge, inode, jnode, cost, istart, & istop, num_path, path, path_length ) dist(istart,istop) = path_length dist(istop,istart) = path_length end do end do call graph_dist_print ( dist, lda, nnode, & ' The distance matrix constructed by GRAPH_ARC_MIN_PATH:' ) istart = 4 istop = 5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The routine actually also computes the path.' write ( *, '(a,i6)' ) ' For instance, starting at node ', istart write ( *, '(a,i6)' ) ' we compute the shortest path to node ', istop call graph_arc_min_path ( nnode, nedge, inode, jnode, cost, istart, & istop, num_path, path, path_length ) call ivec_print ( num_path, path, ' The path:' ) return end subroutine test042 ! !******************************************************************************* ! !! TEST042 tests GRAPH_ARC_MIN_SPAN_TREE. ! implicit none ! integer, parameter :: nedge = 10 integer, parameter :: nnode = 5 ! real, dimension ( nedge ) :: cost = & (/ 100.0, 125.0, 120.0, 110.0, 40.0, 65.0, 60.0, 45.0, 55.0, 50.0 /) real, dimension ( nnode-1) :: ctree integer, dimension ( nedge ) :: inode = (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 4 /) integer i integer itree(nnode-1) integer j integer, dimension ( nedge ) :: jnode = (/ 2, 3, 4, 5, 3, 4, 5, 4, 5, 5 /) integer jtree(nnode-1) real tree_cost ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST042' write ( *, '(a)' ) ' GRAPH_ARC_MIN_SPAN_TREE finds a minimum length' write ( *, '(a)' ) ' spanning tree.' write ( *, '(a)' ) ' ' call graph_arc_weight_print ( nedge, inode, jnode, cost, & ' The weighted graph:' ) call graph_arc_min_span_tree ( nnode, nedge, inode, jnode, cost, & itree, jtree, tree_cost ) do i = 1, nnode-1 ctree(i) = 0.0E+00 do j = 1, nedge if ( ( inode(j) == itree(i) .and. jnode(j) == jtree(i) ) .or. & ( inode(j) == jtree(i) .and. jnode(j) == itree(i) ) ) then ctree(i) = cost(j) exit end if end do end do call graph_arc_weight_print ( nnode-1, itree, jtree, ctree, & ' The minimal spanning tree:' ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The length of the minimal tree is ', sum ( ctree ) return end subroutine test043 ! !******************************************************************************* ! !! TEST043 tests GRAPH_ARC_SPAN_FOREST. ! implicit none ! integer, parameter :: nnode = 14 integer, parameter :: nedge = 10 ! integer component(nnode) integer i integer, save, dimension ( nedge ) :: inode = & (/ 2, 4, 1, 7, 5, 2, 6, 2, 3, 4 /) integer, save, dimension ( nedge ) :: jnode = & (/ 3, 7, 9, 11, 8, 5, 10, 8, 8, 11 /) integer ncomp ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST043' write ( *, '(a)' ) ' GRAPH_ARC_SPAN_FOREST' write ( *, '(a)' ) ' computes a spanning forest for a graph' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_span_forest ( nnode, nedge, inode, jnode, ncomp, component ) call graph_arc_print ( nedge, inode, jnode, & ' The reordered endpoint array:' ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of connected components = ', ncomp call ivec_print ( nnode, component, ' Node component membership:' ) return end subroutine test044 ! !******************************************************************************* ! !! TEST044 tests GRAPH_ARC_TO_DIGRAPH_ARC. ! implicit none ! integer, parameter :: nedge = 8 integer, parameter :: maxarc = 2 * nedge ! integer iarc(maxarc) integer, dimension ( nedge ) :: inode = (/ 1, 1, 1, 2, 3, 4, 2, 4 /) integer jarc(maxarc) integer, dimension ( nedge ) :: jnode = (/ 2, 1, 4, 1, 2, 1, 3, 2 /) integer narc ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST044' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_TO_DIGRAPH_ARC makes a directed graph' write ( *, '(a)' ) ' from an undirected one.' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_to_digraph_arc ( iarc, jarc, inode, jnode, maxarc, narc, & nedge ) call digraph_arc_print ( narc, iarc, jarc, ' The digraph:' ) return end subroutine test045 ! !******************************************************************************* ! !! TEST045 tests GRAPH_ARC_TO_GRAPH_ADJ. ! implicit none ! integer, parameter :: nedge = 8 integer, parameter :: maxnode = 5 integer, parameter :: lda = maxnode ! integer adj(lda,maxnode) integer, dimension ( nedge ) :: inode = (/ 1, 1, 1, 2, 3, 4, 2, 4 /) integer, dimension ( nedge ) :: jnode = (/ 2, 1, 4, 1, 2, 1, 3, 2 /) integer nnode ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST045' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_TO_GRAPH_ADJ converts an arclist' write ( *, '(a)' ) ' graph to an adjacency graph.' write ( *, '(a)' ) ' ' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_to_graph_adj ( nedge, inode, jnode, adj, lda, nnode ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) return end subroutine test046 ! !******************************************************************************* ! !! TEST046 tests GRAPH_ARC_COMPLEMENT; !! TEST046 tests GRAPH_ARC_EDGE_SORT. ! implicit none ! integer, parameter :: maxedge = 90 integer, parameter :: maxnode = 10 ! integer inode(maxedge) integer inode2(maxedge) integer jnode(maxedge) integer jnode2(maxedge) integer nedge integer nedge2 integer nnode real x(maxnode) real y(maxnode) real z(maxnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST046' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_COMPLEMENT computes the complement' write ( *, '(a)' ) ' of a graph described by its edge array;' write ( *, '(a)' ) ' GRAPH_ARC_EDGE_SORT sorts the edge array.' call graph_arc_example_diamond ( inode, jnode, maxedge, nedge, nnode, x, y, z ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of edges in original graph is ', nedge write ( *, '(a,i6)' ) ' Number of nodes is ', nnode call graph_arc_edge_sort ( nedge, inode, jnode ) call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_complement ( inode, jnode, inode2, jnode2, maxedge, nedge, & nedge2, nnode ) write ( *, '(a,i6)' ) 'Number of edges in complement is ', nedge2 call graph_arc_edge_sort ( nedge2, inode2, jnode2 ) call graph_arc_print ( nedge, inode, jnode, ' The complement graph:' ) return end subroutine test047 ! !******************************************************************************* ! !! TEST047 tests GRAPH_ARC_DEGREE. ! ! ! 5--2--10--1--3--6 ! | | | / ! 8 | 9 ! | | ! 4--7 ! implicit none ! integer, parameter :: nedge = 11 integer, parameter :: nnode = 10 ! integer degree(nnode) integer i integer inode(nedge) integer jnode(nedge) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST047' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_DEGREE computes the degree of the nodes;' inode = (/ 1, 1, 1, 2, 2, 3, 3, 4, 4, 6, 8 /) jnode = (/ 3, 7, 10, 5, 10, 6, 9, 7, 8, 9, 10 /) call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_degree ( nnode, nedge, inode, jnode, degree ) call ivec_print ( nnode, degree, ' The node degrees:' ) return end subroutine test048 ! !******************************************************************************* ! !! TEST048 tests GRAPH_ARC_DEGREE. ! ! ! 5--2--100-1--3--0 ! | | | / ! 88 | 9 ! | | ! (-4)--7 ! implicit none ! integer, parameter :: nedge = 11 ! integer, dimension ( nedge ) :: inode = & (/ 1, 1, 1, 2, 2, 3, 3, -4, -4, 0, 88 /) integer, dimension ( nedge ) :: jnode = & (/ 3, 7, 100, 5, 100, 0, 9, 7, 88, 9, 100 /) integer mnode integer nnode ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST048' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_NODE_COUNT counts the nodes and' write ( *, '(a)' ) ' finds the highest label.' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_node_count ( nedge, inode, jnode, mnode, nnode ) write ( *, '(a,i6)' ) ' Number of nodes is ', nnode write ( *, '(a,i6)' ) ' Maximum node label is ', mnode return end subroutine test049 ! !******************************************************************************* ! !! TEST049 tests GRAPH_ARC_EULER_CIRC_NEXT. !! TEST049 tests GRAPH_ARC_IS_EULERIAN. ! implicit none ! integer, parameter :: maxstack = 130 integer, parameter :: nedge = 10 integer, parameter :: nnode = 5 ! integer circuit(nedge) integer degree(nnode) integer i integer, dimension ( nedge ) :: inode = (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 4 /) integer, dimension ( nedge ) :: jnode = (/ 2, 3, 4, 5, 3, 4, 5, 4, 5, 5 /) logical more integer ncan(nedge) integer result integer stack(maxstack) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST049' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_IS_EULERIAN checks if a graph has an' write ( *, '(a)' ) ' Euler circuit.' write ( *, '(a)' ) ' GRAPH_ARC_EULER_CIRC_NEXT finds the next' write ( *, '(a)' ) ' Euler circuit of a graph.' write ( *, '(a)' ) ' ' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_is_eulerian ( nnode, nedge, inode, jnode, degree, result ) if ( result == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The graph is NOT eulerian.' return else write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The graph is eulerian.' end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Circuits:' write ( *, '(a)' ) ' ' i = 0 more = .false. do call graph_arc_euler_circ_next ( nedge, inode, jnode, circuit, stack, & maxstack, ncan, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i3,2x,20i3)' ) i, circuit(1:nedge) end do return end subroutine test050 ! !******************************************************************************* ! !! TEST050 tests GRAPH_ARC_EULER_CIRC. ! implicit none ! integer, parameter :: nedge = 10 integer, parameter :: nnode = 5 ! integer circuit(nedge) integer degree(nnode) integer i integer, dimension ( nedge ) :: inode = (/ 1, 1, 1, 1, 2, 2, 2, 3, 3, 4 /) integer, dimension ( nedge ) :: jnode = (/ 2, 3, 4, 5, 3, 4, 5, 4, 5, 5 /) integer result ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST050' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_IS_EULERIAN determines if a graph' write ( *, '(a)' ) ' is Eulerian;' write ( *, '(a)' ) ' GRAPH_ARC_EULER_CIRC returns an Euler circuit' write ( *, '(a)' ) ' of a graph.' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_is_eulerian ( nnode, nedge, inode, jnode, degree, result ) if ( result == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The graph is NOT eulerian.' return else write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The graph is eulerian.' end if call graph_arc_euler_circ ( nnode, nedge, inode, jnode, circuit ) call ivec_print ( nedge, circuit, ' The nodes in the Euler circuit:' ) return end subroutine test051 ! !******************************************************************************* ! !! TEST051 tests GRAPH_ARC_SPAN_TREE. ! implicit none ! integer, parameter :: nedge = 18 integer, parameter :: nnode = 13 ! integer dad(nnode) integer inode(nedge) integer jnode(nedge) ! inode(1) = 1 jnode(1) = 2 inode(2) = 1 jnode(2) = 3 inode(3) = 1 jnode(3) = 4 inode(4) = 1 jnode(4) = 5 inode(5) = 1 jnode(5) = 6 inode(6) = 1 jnode(6) = 7 inode(7) = 1 jnode(7) = 8 inode(8) = 2 jnode(8) = 5 inode(9) = 2 jnode(9) = 6 inode(10) = 2 jnode(10) = 8 inode(11) = 3 jnode(11) = 4 inode(12) = 3 jnode(12) = 7 inode(13) = 9 jnode(13) = 10 inode(14) = 9 jnode(14) = 13 inode(15) = 10 jnode(15) = 11 inode(16) = 10 jnode(16) = 12 inode(17) = 10 jnode(17) = 13 inode(18) = 11 jnode(18) = 12 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST051' write ( *, '(a)' ) ' For a graph described by an arc list:' write ( *, '(a)' ) ' GRAPH_ARC_SPAN_TREE constructs a spanning tree.' write ( *, '(a)' ) ' ' call graph_arc_print ( nedge, inode, jnode, ' The graph:' ) call graph_arc_span_tree ( nedge, inode, jnode, nnode, dad ) call ivec_print ( nnode, dad, ' Nodes and Parent Nodes:' ) return end subroutine test052 ! !******************************************************************************* ! !! TEST052 tests GRAPH_CHRO. ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: nedge = 12 integer, parameter :: maxstack = nnode * nedge ! integer i integer iarray(nnode) integer iendpt(2,nedge) integer j integer jarray(nnode) integer karray(nnode) integer stack(2,maxstack) ! data ( ( iendpt(i,j), i = 1, 2 ), j = 1, nedge ) / & 1,2, 1,3, 1,4, 1,5, 2,3, 2,4, 2,6, 3,5, 3,6, 4,5, 4,6, 5,6 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST052' write ( *, '(a)' ) ' GRAPH_CHRO finds the chromatic polynomial of a graph.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The end point array:' write ( *, '(a)' ) ' ' write ( *, '(19i4)' ) ( iendpt(1,i), i = 1, nedge ) write ( *, '(19i4)' ) ( iendpt(2,i), i = 1, nedge ) call graph_chro ( nnode, nedge, iendpt, iarray, jarray, karray, & stack, maxstack ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The chromatic polynomial:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Power sum form:' write ( *, '(19i4)' ) iarray(1:nnode) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Tutte or tree form:' write ( *, '(19i4)' ) jarray(1:nnode) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Stirling form:' write ( *, '(19i4)' ) karray(1:nnode) return end subroutine test053 ! !******************************************************************************* ! !! TEST053 tests GRAPH_DIST_ALL. ! ! The graph is: ! ! N3 --3-- N2 --4-- N4 --5-- N5 ! ! \ | / ! 6 2 1 ! \ | / ! ! N1 ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: lda = nnode ! real dinfin real dist(lda,nnode) integer i integer j real path_dist(lda,nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST053' write ( *, '(a)' ) ' GRAPH_DIST_ALL computes the distance between' write ( *, '(a)' ) ' all pairs of nodes.' write ( *, '(a)' ) ' ' dinfin = 1000.0E+00 dist(1:nnode,1:nnode) = dinfin do i = 1, nnode dist(i,i) = 0.0E+00 end do dist(1,2) = 2.0E+00 dist(1,3) = 6.0E+00 dist(1,4) = 1.0E+00 dist(2,1) = 2.0E+00 dist(2,3) = 3.0E+00 dist(2,4) = 4.0E+00 dist(3,1) = 6.0E+00 dist(3,2) = 3.0E+00 dist(4,1) = 1.0E+00 dist(4,2) = 4.0E+00 dist(4,5) = 5.0E+00 dist(5,4) = 5.0E+00 call graph_dist_print ( dist, lda, nnode, & ' Immediate node distance matrix:' ) call graph_dist_all ( dist, dinfin, lda, nnode, path_dist ) call graph_dist_print ( path_dist, lda, nnode, & ' Total node distance matrix:' ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' Note that "infinity" is represented by ', dinfin return end subroutine test054 ! !******************************************************************************* ! !! TEST054 tests GRAPH_DIST_CHECK. ! implicit none ! integer, parameter :: nnode = 15 integer, parameter :: lda = nnode real a(lda,nnode) integer i integer ierror integer j data ( ( a(i,j), j = 1, nnode ), i = 1, nnode ) / & 0., 29., 82., 46., 68., 52., 72., 42., 51., 55., 29., 74., 23., 72., 46., & 29., 0., 55., 46., 42., 43., 43., 23., 23., 31., 41., 51., 11., 52., 21., & 82., 55., 0., 68., 46., 55., 23., 43., 41., 29., 79., 21., 64., 31., 51., & 46., 46., 68., 0., 82., 15., 72., 31., 62., 42., 21., 51., 51., 43., 64., & 68., 42., 46., 82., 0., 74., 23., 52., 21., 46., 82., 58., 46., 65., 23., & 52., 43., 55., 15., 74., 0., 61., 23., 55., 31., 33., 37., 51., 29., 59., & 72., 43., 23., 72., 23., 61., 0., 42., 23., 31., 77., 37., 51., 46., 33., & 42., 23., 43., 31., 52., 23., 42., 0., 33., 15., 37., 33., 33., 31., 37., & 51., 23., 41., 62., 21., 55., 23., 33., 0., 29., 62., 46., 29., 51., 11., & 55., 31., 29., 42., 46., 31., 31., 15., 29., 0., 51., 21., 41., 23., 37., & 29., 41., 79., 21., 82., 33., 77., 37., 62., 51., 0., 65., 42., 59., 61., & 74., 51., 21., 51., 58., 37., 37., 33., 46., 21., 65., 0., 61., 11., 55., & 23., 11., 64., 51., 46., 51., 51., 33., 29., 41., 42., 61., 0., 62., 23., & 72., 52., 31., 43., 65., 29., 46., 31., 51., 23., 59., 11., 62., 0., 59., & 46., 21., 51., 64., 23., 59., 33., 37., 11., 37., 61., 55., 23., 59., 0. / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST054' write ( *, '(a)' ) ' GRAPH_DIST_CHECK checks a distance matrix.' call graph_dist_check ( a, lda, nnode, ierror ) if ( ierror == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'The distance matrix passed all tests.' else write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'The distance matrix failed test ', ierror end if return end subroutine test055 ! !******************************************************************************* ! !! TEST055 tests GRAPH_DIST_MIN_SPAN_TREE. ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: lda = nnode ! integer class(nnode) real dist(lda,nnode) integer i integer itree(nnode-1) integer j integer jtree(nnode-1) integer tree(2,nnode-1) real wtree(nnode-1) ! data ( ( dist(i,j), i = 1, nnode ), j = 1, nnode ) / & 0.0E+00, 100.0E+00, 125.0E+00, 120.0E+00, 110.0E+00, & 100.0E+00, 0.0E+00, 40.0E+00, 65.0E+00, 60.0E+00, & 125.0E+00, 40.0E+00, 0.0E+00, 45.0E+00, 55.0E+00, & 120.0E+00, 65.0E+00, 45.0E+00, 0.0E+00, 50.0E+00, & 110.0E+00, 60.0E+00, 55.0E+00, 50.0E+00, 0.0E+00 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST055' write ( *, '(a)' ) ' For a graph defined by a distance matrix,' write ( *, '(a)' ) ' GRAPH_DIST_MIN_SPAN_TREE finds a minimum spanning tree.' write ( *, '(a)' ) ' ' call graph_dist_print ( dist, lda, nnode, ' The graph:' ) call graph_dist_min_span_tree ( lda, nnode, dist, itree, jtree ) do i = 1, nnode-1 wtree(i) = dist(itree(i),jtree(i)) end do call graph_arc_weight_print ( nnode-1, itree, jtree, wtree, & ' The minimal spanning tree:' ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The length of the minimal tree is ', sum ( wtree ) return end subroutine test056 ! !******************************************************************************* ! !! TEST056 tests GRAPH_DIST_MIN_SPAN_TREE2. ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: lda = nnode ! integer class(nnode) real dist(lda,nnode) integer i integer itree(nnode-1) integer j integer jtree(nnode-1) real wtree(nnode-1) ! data ( ( dist(i,j), i = 1, nnode ), j = 1, nnode ) / & 0.0, 100.0, 125.0, 120.0, 110.0, & 100.0, 0.0, 40.0, 65.0, 60.0, & 125.0, 40.0, 0.0, 45.0, 55.0, & 120.0, 65.0, 45.0, 0.0, 50.0, & 110.0, 60.0, 55.0, 50.0, 0.0E+00 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST056' write ( *, '(a)' ) ' For a graph defined by a distance matrix,' write ( *, '(a)' ) ' GRAPH_DIST_MIN_SPAN_TREE2 finds a minimum spanning tree.' write ( *, '(a)' ) ' ' call graph_dist_print ( dist, lda, nnode, ' The graph:' ) call graph_dist_min_span_tree2 ( lda, nnode, dist, class, itree, jtree ) do i = 1, nnode-1 wtree(i) = dist(itree(i),jtree(i)) end do call graph_arc_weight_print ( nnode-1, itree, jtree, wtree, & ' The minimal spanning tree:' ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The length of the minimal tree is ', sum ( wtree ) return end subroutine test057 ! !******************************************************************************* ! !! TEST057 tests GRAPH_DIST_MIN_SPAN_TREE3. ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: lda = nnode ! integer class(nnode) real dist(lda,nnode) integer i integer itree(nnode-1) integer jtree(nnode-1) integer j real wtree(nnode-1) ! data ( ( dist(i,j), i = 1, nnode ), j = 1, nnode ) / & 0.0, 100.0, 125.0, 120.0, 110.0, & 100.0, 0.0, 40.0, 65.0, 60.0, & 125.0, 40.0, 0.0, 45.0, 55.0, & 120.0, 65.0, 45.0, 0.0, 50.0, & 110.0, 60.0, 55.0, 50.0, 0.0E+00 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST057' write ( *, '(a)' ) ' For a graph defined by a distance matrix,' write ( *, '(a)' ) ' GRAPH_DIST_MIN_SPAN_TREE3 finds a minimum spanning tree.' write ( *, '(a)' ) ' ' call graph_dist_print ( dist, lda, nnode, ' The graph:' ) call graph_dist_min_span_tree3 ( lda, nnode, dist, itree, jtree ) do i = 1, nnode-1 wtree(i) = dist(itree(i),jtree(i)) end do call graph_arc_weight_print ( nnode-1, itree, jtree, wtree, & ' The minimal spanning tree:' ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The length of the minimal tree is ', sum ( wtree ) return end subroutine test058 ! !******************************************************************************* ! !! TEST058 tests GRAPH_DIST_MIN_SPAN_TREE. ! implicit none ! integer, parameter :: nnode = 57 integer, parameter :: lda = nnode ! real dist(lda,nnode) character ( len = 80 ) :: file_name = '57_city_distances.txt' integer i integer ihi integer ilo integer ios integer itree(nnode-1) integer iunit integer j integer jtree(nnode-1) real wtree(nnode-1) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST058' write ( *, '(a)' ) ' GRAPH_DIST_MIN_SPAN_TREE finds a minimum ' write ( *, '(a)' ) ' spanning tree.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Read distance data for 57 cities from file.' ! ! Read the data. ! call get_unit ( iunit ) open ( unit = iunit, file = file_name, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Problems opening the file: ' // trim ( file_name ) write ( *, '(a)' ) ' The test was abandoned.' return end if do i = 1, nnode read ( iunit, *, iostat = ios ) dist(i,1:nnode) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Problems reading the data.' write ( *, '(a)' ) ' The test was abandoned.' return end if end do close ( unit = iunit ) ! ! Compute the tree. ! call graph_dist_min_span_tree ( lda, nnode, dist, itree, jtree ) do i = 1, nnode-1 wtree(i) = dist(itree(i),jtree(i)) end do call graph_arc_weight_print ( nnode-1, itree, jtree, wtree, & ' The weighted tree:' ) write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The length of the minimal tree is ', sum ( wtree ) return end subroutine test059 ! !******************************************************************************* ! !! TEST059 tests GRAPH_DIST_ONE. ! ! This example appears on page 15 of the reference book by Gibbons. ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: lda = nnode ! real dinfin real dist(lda,nnode) integer i integer idad(nnode) integer inode integer path(nnode) integer itemp(nnode) integer j integer length real path_dist(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST059' write ( *, '(a)' ) ' GRAPH_DIST_ONE computes the distance from one' write ( *, '(a)' ) ' node to all others in a graph.' write ( *, '(a)' ) ' ' dinfin = 1000.0E+00 do i = 1, nnode do j = 1, nnode dist(i,j) = dinfin end do dist(i,i) = 0.0E+00 end do dist(1,2) = 1.0E+00 dist(1,3) = 3.0E+00 dist(2,1) = 2.0E+00 dist(2,3) = 1.0E+00 dist(2,5) = 2.0E+00 dist(3,4) = 2.0E+00 dist(3,5) = 3.0E+00 dist(4,3) = 1.0E+00 dist(5,1) = 1.0E+00 dist(5,2) = 3.0E+00 dist(5,4) = 6.0E+00 call graph_dist_print ( dist, lda, nnode, ' Edge Distance Matrix:' ) inode = 5 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'The starting node is ', inode write ( *, '(a)' ) ' ' call graph_dist_one ( dist, dinfin, path_dist, idad, inode, path, & lda, nnode ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Node Distance Path Idad' write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(i5,g14.6,2i5)' ) i, path_dist(i), path(i), idad(i) end do write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' Note that "infinity" is represented by ', dinfin write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Here are the paths for each node:' write ( *, '(a)' ) ' ' do i = 1, nnode length = 1 itemp(length) = i do while ( itemp(length) /= inode ) length = length+1 itemp(length) = idad(itemp(length-1)) end do write ( *, '(5i5)' ) itemp(1:length) end do return end subroutine test060 ! !******************************************************************************* ! !! TEST060 tests VLA_TO_GRAPH_ARC; !! TEST060 tests GRAPH_ARC_FACE; !! TEST060 tests FACE_TO_IV; ! implicit none ! integer, parameter :: maxedge = 1000 integer, parameter :: maxface = 2000 integer, parameter :: maxnode = 1000 integer, parameter :: maxorder = 20 ! integer face(maxorder,maxface) integer face_count(maxedge) integer face_order(maxface) character ( len = 80 ) :: file_in = 'fish_lines.vla' character ( len = 80 ) :: file_out = 'fish_faces.iv' integer i integer ierror integer iface(maxedge) integer inode(maxedge) integer ios integer iunit integer j integer jface(maxedge) integer jnode(maxedge) integer nedge integer nface integer nnode real x(maxnode) real y(maxnode) real z(maxnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST060' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC converts VLA edge data to a' write ( *, '(a)' ) ' graph defined by arcs;' write ( *, '(a)' ) ' GRAPH_ARC_FACE constructs the faces of an orientable graph.' write ( *, '(a)' ) ' FACE_TO_IV writes face data to an IV file.' ! ! Get the edge array for the graph. ! call vla_to_graph_arc ( file_in, maxedge, maxnode, nedge, nnode, inode, & jnode, x, y, z, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) 'TEST060 - Error!' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC returned an error.' return end if ! ! Sort the edge array. write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Sort the edges:' call graph_arc_edge_sort ( nedge, inode, jnode ) ! ! Determine the faces. ! write ( *, '(a)' ) ' Determine the faces:' call graph_arc_face ( face, face_count, face_order, iface, jface, & inode, jnode, maxface, maxorder, nedge, nface, nnode ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of faces found was ', nface write ( *, '(a,i6)' ) ' Euler predicted ', nedge + 2 - nnode ! ! Write the faces to an IV file. ! call face_to_iv ( file_out, face, face_order, inode, jnode, & nedge, maxnode, maxface, maxorder, nnode, nface, x, y, z ) return end subroutine test061 ! !******************************************************************************* ! !! TEST061 tests GRF_READ; !! TEST061 tests GRAPH_ARC_TO_PS. ! implicit none ! integer, parameter :: maxedge = 500 integer, parameter :: maxnode = 100 integer, parameter :: lda = maxnode ! integer adj(lda,maxnode) character ( len = 80 ) :: file_grf = 'knightstour.grf' character ( len = 80 ) :: file_ps = 'knightstour.ps' integer i integer inode(maxedge) integer jnode(maxedge) integer nedge integer nnode real x(maxnode) real y(maxnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST061' write ( *, '(a)' ) ' GRF_READ reads a GRF file,' write ( *, '(a)' ) ' GRAPH_ARC_TO_PS writes a PostScript version of it.' call grf_read ( file_grf, inode, jnode, maxedge, maxnode, nedge, nnode, x, y ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Node, X, Y' write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(i8,2g14.6)' ) i, x(i), y(i) end do call graph_arc_to_graph_adj ( nedge, inode, jnode, adj, lda, nnode ) call graph_adj_print ( adj, lda, nnode, ' The graph:' ) ! ! Now write out a PostScript version. ! call graph_arc_to_ps ( file_ps, inode, jnode, nedge, nnode, x, y ) return end subroutine test062 ! !******************************************************************************* ! !! TEST062 tests GREEDY. ! ! Random data is used in setting up the problem. ! implicit none ! integer, parameter :: nnode = 15 ! real dist integer ido integer indx integer maxit integer nodeb(nnode) integer nodeb1 integer noder(nnode) integer noder1 real tol real total real xb(nnode) real xhi real xlo real xr(nnode) real yb(nnode) real yhi real ylo real yr(nnode) ! ! IDO just tells us if this is the first or later trials. ! ido = 1 ! ! Set the maximum number of iterations. ! maxit = 10 ! ! Set the range of the X and Y coordinates. ! xhi = 10.0E+00 xlo = 0.0E+00 yhi = 5.0E+00 ylo = 3.0E+00 ! ! Set the relative tolerance for the stepwise distance decrease. ! tol = 0.05E+00 ! ! Say hello. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST062' write ( *, '(a)' ) ' GREEDY tries to minimize the total distance' write ( *, '(a)' ) ' in a pairing of black and red nodes.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Try to find a pairing of two sets of nodes' write ( *, '(a)' ) ' with a low discrepancy.' write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' Relative tolerance for step decrease = ', tol write ( *, '(a,i6)' ) ' Maximum number of steps = ', maxit write ( *, '(a,g14.6,a,g14.6)' ) ' X range is ', xlo,' to ', xhi write ( *, '(a,g14.6,a,g14.6)' ) ' Y range is ', ylo,' to ', yhi ! ! Make an arbitrary pairing of the nodes. ! do indx = 1, nnode nodeb(indx) = indx noder(indx) = indx end do ! ! Make up a random set of X, Y coordinates for the nodes. ! call rvec_random ( nnode, xb, xlo, xhi ) call rvec_random ( nnode, xr, xlo, xhi ) call rvec_random ( nnode, yb, ylo, yhi ) call rvec_random ( nnode, yr, ylo, yhi ) ! ! We will jump back here if we restart with a permuted NODER. ! do ido = 1, 2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Initial black node coordinates:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I Black X Y' write ( *, '(a)' ) ' ' do indx = 1, nnode write ( *, '(2i6,2g14.6)' ) indx, nodeb(indx), xb(indx), yb(indx) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Initial red node coordinates:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I Red X Y' write ( *, '(a)' ) ' ' do indx = 1, nnode write ( *, '(2i6,2g14.6)' ) indx, noder(indx), xr(indx), yr(indx) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Initial pairing of nodes:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I Black Red Distance' write ( *, '(a)' ) ' ' do indx = 1, nnode nodeb1 = nodeb(indx) noder1 = noder(indx) dist = sqrt ( ( xb(nodeb1) - xr(noder1) )**2 + & ( yb(nodeb1) - yr(noder1) )**2 ) write ( *, '(3i6,g14.6)' ) indx, nodeb1, noder1, dist end do total = 0.0E+00 do indx = 1, nnode nodeb1 = nodeb(indx) noder1 = noder(indx) total = total + sqrt ( ( xb(nodeb1) - xr(noder1) )**2 & + ( yb(nodeb1) - yr(noder1) )**2 ) end do write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) 'Total discrepancy of initial pairing = ', total ! ! Call GREEDY to seek a better pairing. ! call greedy ( maxit, nodeb, noder, nnode, tol, xb, xr, yb, yr ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Final black node coordinates:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I Black X Y' write ( *, '(a)' ) ' ' do indx = 1, nnode write ( *, '(2i6,2g14.6)' ) indx, nodeb(indx), xb(indx), yb(indx) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Final red node coordinates:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I Red X Y' write ( *, '(a)' ) ' ' do indx = 1, nnode write ( *, '(2i6,2g14.6)' ) indx, noder(indx), xr(indx), yr(indx) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Final pairing of nodes:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I Black Red Distance' write ( *, '(a)' ) ' ' do indx = 1, nnode nodeb1 = nodeb(indx) noder1 = noder(indx) dist = sqrt ( ( xb(nodeb1) - xr(noder1) )**2 & + ( yb(nodeb1) - yr(noder1) )**2 ) write ( *, '(3i6,g14.6)') indx, nodeb1, noder1, dist end do total = 0.0E+00 do indx = 1, nnode nodeb1 = nodeb(indx) noder1 = noder(indx) dist = sqrt ( ( xb(nodeb1) - xr(noder1) )**2 & + ( yb(nodeb1) - yr(noder1) )**2 ) total = total + dist end do write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' Total discrepancy of final pairing = ', total ! ! On the second try, reverse the ordering of the red nodes. ! Any random permutation would be worth trying. ! if ( ido == 1 ) then do indx = 1, nnode / 2 call i_swap ( noder(indx), noder(nnode+1-indx) ) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Reversing NODER!' end if end do return end subroutine test063 ! !******************************************************************************* ! !! TEST063 tests MAZE_DIAM; !! TEST063 tests MAZE_PATH; !! TEST063 tests MAZE_PRINT; !! TEST063 tests MAZE_RANDOM. ! implicit none ! integer, parameter :: m = 8 integer, parameter :: n = 10 ! integer bar(m,n+1) integer dad(m,n) integer degree(m,n) integer diam integer flat(m+1,n) integer i integer istart integer istop integer j integer jstart integer jstop integer path(m,n) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST063' write ( *, '(a)' ) ' MAZE_RANDOM: generate a random maze;' write ( *, '(a)' ) ' MAZE_DIAM: find two far apart cells;' write ( *, '(a)' ) ' MAZE_PATH: generate a path.' write ( *, '(a)' ) ' MAZE_PRINT: print a maze.' ! ! Print out the cell numbers for the maze. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Cell numbers for the maze:' write ( *, '(a)' ) ' ' do i = 1, m write ( *, '(20i3)' ) ( (j-1)*m+i, j = 1, n ) end do ! ! Get a random maze and print it. ! call maze_random ( bar, dad, flat, m, n ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' A random maze:' write ( *, '(a,i6)' ) ' Number of rows = ', m write ( *, '(a,i6)' ) ' Number of columns = ', n istart = 0 jstart = 0 istop = 0 jstop = 0 call maze_print ( bar, flat, m, n, istart, jstart, istop, jstop, & ' The maze:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Rooted tree representation:' write ( *, '(a)' ) ' (0 is the root. All other cells print the' write ( *, '(a)' ) ' cell number of their parent on the tree.)' write ( *, '(a)' ) ' ' do i = 1, m write ( *, '(20i3)' ) dad(i,1:n) end do ! ! Get start and end points that are far apart and print the maze. ! call maze_diam ( bar, degree, diam, flat, m, n, path, istart, jstart, & istop, jstop ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Random maze with far apart ends:' write ( *, '(a,i6)' ) ' Diameter = ', diam write ( *, '(a,2i6)' ) ' Starting cell = ', istart, jstart write ( *, '(a,2i6)' ) ' Stopping cell = ', istop, jstop call maze_print ( bar, flat, m, n, istart, jstart, istop, jstop, & ' The maze:' ) ! ! Find a path and print it. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Random maze with path from start to stop:' call maze_path ( bar, flat, m, n, istart, jstart, istop, jstop ) call maze_print ( bar, flat, m, n, istart, jstart, istop, jstop, & ' The maze' ) return end subroutine test064 ! !******************************************************************************* ! !! TEST064 tests MAZE_PRINT. ! implicit none ! integer, parameter :: m = 2 integer, parameter :: n = 3 integer, parameter :: INDEF = -1 integer, parameter :: WALL = 0 integer, parameter :: OPEN = 1 ! integer bar(m,n+1) integer flat(m+1,n) integer i integer istart integer istop integer j integer jstart integer jstop ! bar(1:m,1:n+1) = WALL flat(1:m+1,1:n) = WALL bar(1,2) = OPEN bar(1,4) = INDEF bar(2,3) = OPEN flat(1,3) = INDEF flat(2,1) = OPEN flat(2,2) = OPEN flat(2,3) = OPEN flat(3,1) = OPEN istart = 2 jstart = 1 istop = 1 jstop = 3 ! ! Now mark the path. ! flat(2,1) = 2 bar(1,2) = 2 flat(2,2) = 2 bar(2,3) = 2 flat(2,3) = 2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST064' write ( *, '(a)' ) ' MAZE_PRINT prints a maze with path marked.' write ( *, '(a)' ) ' ' call maze_print ( bar, flat, m, n, istart, jstart, istop, jstop, & ' The maze:' ) return end subroutine test065 ! !******************************************************************************* ! !! TEST065 tests NETWORK_FLOW_MAX. ! implicit none ! integer, parameter :: nnode = 6 integer, parameter :: nedge = 20 ! integer i integer icut(nnode) integer icpflo(2,nedge) integer iendpt(2,nedge) integer :: isink = 6 integer :: isorce = 1 integer j integer node_flow(nnode) ! data ( ( iendpt(i,j), j = 1, nedge ), i = 1, 2 ) / & 1,2, 1,3, 2,3, 2,4, 2,5, 3,4, 3,5, 4,5, 4,6, 5,6, & 2,1, 3,1, 3,2, 4,2, 5,2, 4,3, 5,3, 5,4, 6,4, 6,5 / data ( ( icpflo(i,j), j = 1, nedge ), i = 1, 2 ) / & 3,0,7,0,2,0,5,0,4,0,1,0,4,0,2,0,8,0,3,0, & 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST065' write ( *, '(a)' ) ' NETWORK_FLOW_MAX finds the maximum flow on a network.' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The source is node ', isorce write ( *, '(a,i6)' ) ' The sink is node ', isink write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Endpoint array:' write ( *, '(a)' ) ' ' write ( *, '(20i3)' ) ( iendpt(1,i), i = 1, nedge ) write ( *, '(20i3)' ) ( iendpt(2,i), i = 1, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Input edge capacity array:' write ( *, '(a)' ) ' ' write ( *, '(20i3)' ) ( icpflo(1,i), i = 1, nedge) call network_flow_max ( nnode, nedge, iendpt, icpflo, isorce, & isink, icut, node_flow ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Reordered endpoint array:' write ( *, '(a)' ) ' ' write ( *, '(20i3)' ) ( iendpt(1,i), i = 1, nedge ) write ( *, '(20i3)' ) ( iendpt(2,i), i = 1, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Output edge capacity/flow array:' write ( *, '(a)' ) ' ' write ( *, '(20i3)' ) ( icpflo(1,i), i = 1, nedge ) write ( *, '(20i3)' ) ( icpflo(2,i), i = 1, nedge ) call ivec_print ( nnode, icut, ' Minimal node cut vector:' ) call ivec_print ( nnode, node_flow, ' Nodal flow vector:' ) return end subroutine test066 ! !******************************************************************************* ! !! TEST066 tests NODE_RELAX. ! implicit none ! integer, parameter :: max_cor3 = 100 integer, parameter :: max_face = 100 integer, parameter :: max_order = 5 ! real cor3(3,max_cor3) real cor3_new(3,max_cor3) integer cor3_num(max_cor3) integer face(max_order,max_face) integer face_order(max_face) integer i integer j integer num_cor3 integer num_face ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST066' write ( *, '(a)' ) ' NODE_RELAX smooths a surface.' num_cor3 = 8 cor3(1,1) = 0.0E+00 cor3(2,1) = 0.0E+00 cor3(3,1) = 0.0E+00 cor3(1,2) = 1.0E+00 cor3(2,2) = 0.0E+00 cor3(3,2) = 0.0E+00 cor3(1,3) = 1.0E+00 cor3(2,3) = 1.0E+00 cor3(3,3) = 0.0E+00 cor3(1,4) = 0.0E+00 cor3(2,4) = 1.0E+00 cor3(3,4) = 0.0E+00 cor3(1,5) = 0.0E+00 cor3(2,5) = 0.0E+00 cor3(3,5) = 1.0E+00 cor3(1,6) = 1.0E+00 cor3(2,6) = 0.0E+00 cor3(3,6) = 1.0E+00 cor3(1,7) = 1.0E+00 cor3(2,7) = 1.0E+00 cor3(3,7) = 1.0E+00 cor3(1,8) = 0.0E+00 cor3(2,8) = 1.0E+00 cor3(3,8) = 1.0E+00 num_face = 6 face(1,1) = 1 face(2,1) = 4 face(3,1) = 3 face(4,1) = 2 face(1,2) = 2 face(2,2) = 6 face(3,2) = 7 face(4,2) = 3 face(1,3) = 3 face(2,3) = 7 face(3,3) = 8 face(4,3) = 4 face(1,4) = 4 face(2,4) = 8 face(3,4) = 5 face(4,4) = 1 face(1,5) = 1 face(2,5) = 5 face(3,5) = 6 face(4,5) = 2 face(1,6) = 5 face(2,6) = 8 face(3,6) = 7 face(4,6) = 6 face_order(1:num_face) = 4 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Old coordinates' write ( *, '(a)' ) ' ' do j = 1, num_cor3 write ( *, '(i4, 3g14.6)' ) j, cor3(1:3,j) end do call node_relax ( cor3, cor3_new, cor3_num, face, face_order, max_cor3, & max_face, max_order, num_cor3, num_face ) write ( *, '(a)' ) ' ' write ( *, '(a)') ' After 1 step' write ( *, '(a)' ) ' ' do j = 1, num_cor3 write ( *, '(i4, 3g14.6)' ) j, cor3_new(1:3,j) end do cor3(1:3,1:num_cor3) = cor3_new(1:3,1:num_cor3) call node_relax ( cor3, cor3_new, cor3_num, face, face_order, max_cor3, & max_face, max_order, num_cor3, num_face ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' After 2 steps' write ( *, '(a)' ) ' ' do j = 1, num_cor3 write ( *, '(i4, 3g14.6)' ) j, cor3_new(1:3,j) end do cor3(1:3,1:num_cor3) = cor3_new(1:3,1:num_cor3) call node_relax ( cor3, cor3_new, cor3_num, face, face_order, max_cor3, & max_face, max_order, num_cor3, num_face ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' After 3 steps' write ( *, '(a)' ) ' ' do j = 1, num_cor3 write ( *, '(i4, 3g14.6)' ) j, cor3_new(1:3,j) end do return end subroutine test0665 ! !******************************************************************************* ! !! TEST0665 tests PERM_INC. ! implicit none ! integer, parameter :: n = 4 ! integer i integer ipos integer perm(n) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0665' write ( *, '(a)' ) ' PERM_INC increments a permutation.' write ( *, '(a)' ) ' ' i = 0 ipos = 0 do call perm_inc ( perm, ipos, n ) if ( ipos == 0 ) then exit end if i = i + 1 write ( *, '(i3,2x,4i2)' ) i, perm(1:n) end do return end subroutine test067 ! !******************************************************************************* ! !! TEST067 tests POLY_TO_TRI. ! implicit none ! integer, parameter :: max_face = 20 integer, parameter :: max_vert = 5 ! integer face(max_vert,max_face) integer i integer ierror integer j integer num_face integer num_vert(max_face) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST067' write ( *, '(a)' ) ' POLY_TO_TRI replaces a polygonal mesh with a' write ( *, '(a)' ) ' triangular one.' num_face = 4 num_vert(1) = 4 face(1,1) = 1 face(2,1) = 3 face(3,1) = 5 face(4,1) = 7 num_vert(2) = 3 face(1,2) = 2 face(2,2) = 3 face(3,2) = 9 num_vert(3) = 5 face(1,3) = 3 face(2,3) = 7 face(3,3) = 8 face(4,3) = 23 face(5,3) = 2 num_vert(4) = 4 face(1,4) = 4 face(2,4) = 7 face(3,4) = 8 face(4,4) = 23 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of faces = ', num_face call ivec_print ( num_face, num_vert, ' Faces and number of vertices:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Face Vertices' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(6i8)' ) i, ( face(j,i), j = 1, num_vert(i) ) end do call poly_to_tri ( face, ierror, max_face, max_vert, num_face, num_vert ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The algorithm failed.' else write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of faces = ', num_face call ivec_print ( num_face, num_vert, ' Faces and number of vertices:' ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Face Vertices' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(6i8)' ) i, ( face(j,i), j = 1, num_vert(i) ) end do end if return end subroutine test068 ! !******************************************************************************* ! !! TEST068 tests PRUEFER_TO_TREE_ARC. ! ! The tree is ! ! 5 ! | ! 2-3-6-8-1-9 ! | | ! 7 4 ! implicit none ! integer, parameter :: nnode = 9 ! integer, save, dimension ( nnode-2 ) :: code = (/ 1, 3, 8, 8, 3, 6, 8 /) integer i integer inode(nnode-1) integer jnode(nnode-1) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST068' write ( *, '(a)' ) ' PRUEFER_TO_TREE_ARC computes a tree from its Pruefer code.' call ivec_print ( nnode-2, code, ' The Pruefer code:' ) call pruefer_to_tree_arc ( nnode, code, inode, jnode ) call graph_arc_print ( nnode-1, inode, jnode, ' The graph:' ) return end subroutine test069 ! !******************************************************************************* ! !! TEST069 tests PRUEFER_TO_TREE_2. ! ! The tree is ! ! 5 ! | ! 2-3-6-8-1-9 ! | | ! 7 4 ! implicit none ! integer, parameter :: nnode = 9 ! integer, save, dimension ( nnode ) :: code = (/ 1, 3, 8, 8, 3, 6, 8, 0, 0 /) integer itree(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST069' write ( *, '(a)' ) ' PRUEFER_TO_TREE_2 produces a tree from its Pruefer code' call ivec_print ( nnode-2, code, ' The Pruefer code:' ) call pruefer_to_tree_2 ( nnode, code, itree ) call ivec_print ( nnode-1, itree, ' The edge list of the tree:' ) return end subroutine test0695 ! !******************************************************************************* ! !! TEST0695 tests VLA_TO_GRAPH_ARC. !! TEST0695 tests SHAPE_3D_NODES_TO_PS. ! implicit none ! integer, parameter :: max_edge = 1000 integer, parameter :: max_node = 1000 ! character ( len = 80 ) :: file_in = 'fish_lines.vla' character ( len = 80 ) :: file_out = 'fish_nodes.ps' integer ierror integer inode(max_edge) integer jnode(max_edge) integer num_edge integer num_node real x(max_node) real y(max_node) real z(max_node) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0695' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC reads a VLA file and converts it' write ( *, '(a)' ) ' to a graph defined by an arc list.' write ( *, '(a)' ) ' SHAPE_3D_NODES_TO_PS writes the nodes to a PostScript file.' ! ! Get the edge array for the graph. ! call vla_to_graph_arc ( file_in, max_edge, max_node, num_edge, & num_node, inode, jnode, x, y, z, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)') ' VLA_TO_GRAPH_ARC returned an error.' return end if call shape_3d_nodes_to_ps ( file_out, num_node, x, y, z ) return end subroutine test0696 ! !******************************************************************************* ! !! TEST0696 tests VLA_TO_GRAPH_ARC. !! TEST0696 tests SHAPE_3D_EDGES_TO_PS. ! implicit none ! integer, parameter :: max_edge = 1000 integer, parameter :: max_face = 2000 integer, parameter :: max_node = 1000 integer, parameter :: max_order = 20 ! integer face(max_order,max_face) integer face_count(max_edge) integer face_order(max_face) character ( len = 80 ) :: file_in = 'fish_lines.vla' character ( len = 80 ) :: file_out = 'fish_edges.ps' integer i integer ierror integer iface(max_edge) integer inode(max_edge) integer j integer jface(max_edge) integer jnode(max_edge) integer num_edge integer num_face integer num_node real x(max_node) real y(max_node) real z(max_node) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0696' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC reads a VLA file and converts it' write ( *, '(a)' ) ' to a graph defined by an arc list.' write ( *, '(a)' ) ' SHAPE_3D_EDGES_TO_PS writes the edges to a PostScript file.' ! ! Get the edge array for the graph. ! call vla_to_graph_arc ( file_in, max_edge, max_node, num_edge, & num_node, inode, jnode, x, y, z, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC returned an error.' return end if ! ! Sort the edge array. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Sort the edges:' call graph_arc_edge_sort ( num_edge, inode, jnode ) ! ! Determine the faces. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Determine the faces:' call graph_arc_face ( face, face_count, face_order, iface, jface, inode, & jnode, max_face, max_order, num_edge, num_face, num_node ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The faces were determined.' write ( *, '(a,i6)' ) ' Number of faces found was ', num_face write ( *, '(a,i6)' ) ' Euler predicted ', num_edge + 2 - num_node call shape_3d_edges_to_ps ( file_out, max_order, num_face, num_node, & face, face_order, x, y, z ) return end subroutine test0697 ! !******************************************************************************* ! !! TEST0697 tests VLA_TO_GRAPH_ARC. !! TEST0697 tests SHAPE_3D_FACES_TO_PS. ! implicit none ! integer, parameter :: max_edge = 1000 integer, parameter :: max_face = 2000 integer, parameter :: max_node = 500 integer, parameter :: max_order = 20 ! integer face(max_order,max_face) integer face_count(max_edge) integer face_order(max_face) character ( len = 80 ) :: file_in = 'fish_lines.vla' character ( len = 80 ) :: file_out = 'fish_faces.ps' integer i integer ierror integer iface(max_edge) integer inode(max_edge) integer j integer jface(max_edge) integer jnode(max_edge) integer num_edge integer num_face integer num_node real x(max_node) real y(max_node) real z(max_node) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST0697' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC reads a VLA file and converts it' write ( *, '(a)' ) ' to a graph defined by an arc list.' write ( *, '(a)' ) ' SHAPE_3D_FACES_TO_PS writes the faces to a PostScript file.' ! ! Get the edge array for the graph. ! call vla_to_graph_arc ( file_in, max_edge, max_node, num_edge, & num_node, inode, jnode, x, y, z, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) 'TEST0697 - Error!' write ( *, '(a)' ) ' VLA_TO_GRAPH_ARC returned an error.' return end if ! ! Sort the edge array. call graph_arc_edge_sort ( num_edge, inode, jnode ) ! ! Determine the faces. ! call graph_arc_face ( face, face_count, face_order, iface, jface, inode, & jnode, max_face, max_order, num_edge, num_face, num_node ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of faces found was ', num_face write ( *, '(a,i6)' ) ' Euler predicted ', num_edge + 2 - num_node call shape_3d_faces_to_ps ( file_out, max_order, num_face, num_node, & face, face_order, x, y, z ) return end subroutine test070 ! !******************************************************************************* ! !! TEST070 tests SORT_HEAP_EXTERNAL. ! implicit none ! integer, parameter :: n = 20 ! integer a(n) integer i integer indx integer isgn integer j ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST070' write ( *, '(a)' ) ' SORT_HEAP_EXTERNAL sorts objects externally.' write ( *, '(a)' ) ' ' indx = 0 i = 0 j = 0 isgn = 0 call ivec_random ( n, a, 1, n ) call ivec_print ( n, a, ' Before sorting:' ) do call sort_heap_external ( n, indx, i, j, isgn ) if ( indx < 0 ) then isgn = 1 if ( a(i) <= a(j) ) then isgn = -1 end if else if ( indx > 0 ) then call i_swap ( a(i), a(j) ) else exit end if end do call ivec_print ( n, a, ' After sorting:' ) return end subroutine test071 ! !******************************************************************************* ! !! TEST071 tests SPAN_FOREST. ! implicit none ! integer, parameter :: nnode = 14 integer, parameter :: nedge = 10 ! integer component(nnode) integer i integer iendpt(2,nedge) integer j integer k ! data ( ( iendpt(i,j), i = 1, 2 ), j = 1, nedge ) / & 2,3, 4,7, 1,9, 7,11, 5,8, 2,5, 6,10, 2,8, 3,8, 4,11 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST071' write ( *, '(a)' ) ' SPAN_FOREST: a spanning forest for a graph' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Initial end point array:' write ( *, '(a)' ) ' ' write ( *, '(19i4)' ) ( iendpt(1,j), j = 1, nedge ) write ( *, '(19i4)' ) ( iendpt(2,j), j = 1, nedge ) call span_forest ( nnode, nedge, iendpt, k, component ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Reordered endpoint array:' write ( *, '(a)' ) ' ' write ( *, '(19i4)' ) ( iendpt(1,j), j = 1, nedge ) write ( *, '(19i4)' ) ( iendpt(2,j), j = 1, nedge ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of connected components = ', k call ivec_print ( nnode, component, ' Node, Component' ) return end subroutine test072 ! !******************************************************************************* ! !! TEST072 tests SPAN_TREE_NEXT; ! implicit none ! integer, parameter :: nnode = 5 integer, parameter :: nedge = 10 ! integer i integer iarray(nnode-1) integer iendpt(2,nedge) integer j integer ncan(nnode-1) integer nspan integer signal ! data ( ( iendpt(i,j), i = 1, 2 ), j = 1, nedge ) / & 1,2, 1,3, 1,4, 1,5, 2,3, 2,4, 2,5, 3,4, 3,5, 4,5 / ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST072' write ( *, '(a)' ) ' SPAN_TREE_NEXT constructs spanning trees' write ( *, '(a)' ) ' of a graph using a backtrack search.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Node1 Node2' write ( *, '(a)' ) ' ' do i = 1, nedge write ( *, '(3i8)' ) iendpt(1,i), iendpt(2,i) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Edges in spanning tree:' write ( *, '(a)' ) ' ' nspan = 0 signal = 0 do call span_tree_next ( signal, nnode, nedge, iendpt, iarray, ncan ) if ( signal == 0 ) then exit end if nspan = nspan + 1 write ( *, '(i4,4x,5i4)' ) nspan, iarray(1:nnode-1) end do write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Number of spanning trees found was ', nspan return end subroutine test073 ! !******************************************************************************* ! !! TEST073 tests TREE_ARC_TO_PRUEFER. ! ! The tree is ! ! 5 ! | ! 2-3-6-8-1-9 ! | | ! 7 4 ! implicit none ! integer, parameter :: nnode = 9 ! integer iarray(nnode-2) integer, dimension ( nnode - 1 ) :: inode = (/ 2, 3, 3, 6, 8, 8, 8, 1 /) integer, dimension ( nnode - 1 ) :: jnode = (/ 3, 7, 6, 8, 4, 5, 1, 9 /) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST073' write ( *, '(a)' ) ' TREE_ARC_TO_PRUEFER: Tree => Pruefer code' call graph_arc_print ( nnode-1, inode, jnode, ' The graph:' ) call tree_arc_to_pruefer ( nnode, inode, jnode, iarray ) call ivec_print ( nnode-2, iarray, ' The Pruefer code:' ) return end subroutine test074 ! !***************************************************************************** ! !! TEST074 tests TREE_ARC_CENTER. ! ! 2---3---6---8---1---9 ! / / \ ! 7 5 4 ! implicit none ! integer, parameter :: nnode = 9 ! integer center(2) integer eccent integer i integer, dimension ( nnode - 1 ) :: inode = (/ 2, 3, 3, 6, 8, 8, 8, 1 /) integer, dimension ( nnode - 1 ) :: jnode = (/ 3, 7, 6, 8, 4, 5, 1, 9 /) integer parity ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST074' write ( *, '(a)' ) ' TREE_ARC_CENTER computes the center of a tree.' call graph_arc_print ( nnode-1, inode, jnode, ' The edge list of the tree:' ) call tree_arc_center ( nnode, inode, jnode, center, eccent, parity ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Parity = ', parity write ( *, '(a,i6)' ) ' Eccentricity is ', eccent if ( parity == 0 ) then write ( *, '(a)' ) ' No center node (degenerate case).' else if ( parity == 1 ) then write ( *, '(a,i6)' ) ' Center node: ', center(1) else write ( *, '(a,2i6)' ) ' Center nodes: ', center(1), center(2) end if return end subroutine test075 ! !***************************************************************************** ! !! TEST075 tests TREE_ARC_DIAM. ! ! 2---3---6---8---1---9 ! / / \ ! 7 5 4 ! integer, parameter :: nnode = 9 ! integer diam integer i integer, dimension ( nnode-1 ) :: inode = (/ 2, 3, 3, 6, 8, 8, 8, 1 /) integer, dimension ( nnode-1 ) :: jnode = (/ 3, 7, 6, 8, 4, 5, 1, 9 /) integer label(nnode) integer nnode1 integer nnode2 ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST075' write ( *, '(a)' ) ' TREE_ARC_DIAM computes the diameter of a tree.' call graph_arc_print ( nnode-1, inode, jnode, ' The edge list of the tree:' ) call tree_arc_diam ( nnode, inode, jnode, diam, label, nnode1, nnode2 ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' This tree has a diameter of ', diam write ( *, '(a,i6,a,i6)' ) ' between nodes ', nnode1, ' and ', nnode2 call ivec_print ( nnode, label, ' Nodes and labels:' ) return end subroutine test076 ! !******************************************************************************* ! !! TEST076 tests TREE_ARC_RANDOM. ! implicit none ! integer, parameter :: nnode = 4 ! integer i integer icode(nnode-2) integer inode(nnode-1) integer j integer jnode(nnode-1) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST076' write ( *, '(a)' ) ' TREE_ARC_RANDOM produces a random labeled' write ( *, '(a)' ) ' tree and its Pruefer code.' write ( *, '(a)' ) ' ' do i = 1, 5 call tree_arc_random ( nnode, icode, inode, jnode ) call graph_arc_print ( nnode-1, inode, jnode, ' The random tree:' ) call ivec_print ( nnode-2, icode, ' The Pruefer code:' ) end do return end subroutine test077 ! !******************************************************************************* ! !! TEST077 tests TREE_ENUM. ! implicit none ! integer nnode integer num ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST077' write ( *, '(a)' ) ' TREE_ENUM enumerates the labeled trees on a given' write ( *, '(a)' ) ' number of nodes.' write ( *, '(a)' ) ' ' do nnode = 0, 10 call tree_enum ( nnode, num ) write ( *, '(i6,i10)' ) nnode, num end do return end subroutine test078 ! !******************************************************************************* ! !! TEST078 tests TREE_PARENT_NEXT. ! implicit none ! integer, parameter :: nnode = 4 ! integer iarray(nnode) integer icode(nnode) integer itree(nnode) logical more ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST078' write ( *, '(a)' ) ' TREE_PARENT_NEXT finds all labeled trees of a given ' write ( *, '(a)' ) ' order, and their Pruefer codes.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Pruefer code Tree' write ( *, '(a)' ) ' ' more = .false. do call tree_parent_next ( nnode, iarray, icode, itree, more ) write ( *, '(2i2,14x,3i2)' ) icode(1:nnode-2), itree(1:nnode-1) if ( .not. more ) then exit end if end do return end subroutine test079 ! !******************************************************************************* ! !! TEST079 tests TREE_RB_ENUM. ! implicit none ! integer nnode integer num ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST079' write ( *, '(a)' ) ' TREE_RB_ENUM enumerates the rooted binary trees on a ' write ( *, '(a)' ) ' given number of nodes.' write ( *, '(a)' ) ' ' do nnode = 0, 11 call tree_rb_enum ( nnode, num ) write ( *, '(2i6)' ) nnode, num end do return end subroutine test080 ! !******************************************************************************* ! !! TEST080 tests TREE_RB_LEX_NEXT. ! implicit none ! integer, parameter :: n = 11 ! integer a(n) integer i logical more ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST080' write ( *, '(a)' ) ' TREE_RB_LEX_NEXT produces all rooted binary trees with' write ( *, '(a)' ) ' a given number of nodes, in lexicographic order, using' write ( *, '(a)' ) ' the preorder traversal representation.' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The number of nodes N = ', n write ( *, '(a)' ) ' ' more = .false. i = 0 do call tree_rb_lex_next ( n, a, more ) if ( .not. more ) then exit end if i = i + 1 write ( *, '(i2,2x,11i1)' ) i, a(1:11) end do return end subroutine test081 ! !******************************************************************************* ! !! TEST081 tests TREE_RB_LEX_NEXT. !! TEST081 tests TREE_RB_TO_PARENT. ! implicit none ! integer, parameter :: n = 11 ! integer a(n) integer i logical more integer parent(n) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST081' write ( *, '(a)' ) ' TREE_RB_LEX_NEXT produces all rooted binary trees with' write ( *, '(a)' ) ' a given number of nodes, in lexicographic order,' write ( *, '(a)' ) ' using the preorder traversal representation.' write ( *, '(a)' ) ' TREE_RB_TO_PARENT converts the preorder traversal form' write ( *, '(a)' ) ' to the more comprehensible parent node representation.' write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' The number of nodes N = ', n write ( *, '(a)' ) ' ' more = .false. i = 0 do call tree_rb_lex_next ( n, a, more ) if ( .not. more ) then exit end if call tree_rb_to_parent ( n, a, parent ) i = i + 1 write ( *, '(i2,2x,11i3)' ) i, parent(1:n) end do return end subroutine test082 ! !******************************************************************************* ! !! TEST082 tests TREE_RB_YULE. ! implicit none ! integer, parameter :: n_max = 11 ! integer a(n_max) integer i integer n ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST082' write ( *, '(a)' ) ' TREE_RB_YULE carries out one step of the Yule model' write ( *, '(a)' ) ' on a rooted binary tree stored in preorder traversal form.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Each call adds two children to an arbitary leaf.' do i = 1, 5 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Simulation ', i write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Nodes Preorder code' write ( *, '(a)' ) ' ' n = 0 do call tree_rb_yule ( n, a ) write ( *, '(i2,2x,11i1)' ) n, a(1:n) if ( n + 2 > n_max ) then exit end if end do end do return end subroutine test083 ! !******************************************************************************* ! !! TEST083 tests TREE_ROOTED_CODE. ! implicit none ! integer, parameter :: nnode = 12 ! integer code(2*nnode) integer, dimension ( nnode ) :: parent = & (/ 0, 1, 1, 2, 2, 2, 3, 3, 5, 5, 6, 10 /) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST083' write ( *, '(a)' ) ' TREE_ROOTED_CODE: code of a rooted tree.' write ( *, '(a)' ) ' ' call ivec_print ( nnode, parent, ' Parent vector for tree:' ) call tree_rooted_code ( nnode, parent, code ) call ivec_print ( 2*nnode, code, ' The tree code:' ) return end subroutine test084 ! !******************************************************************************* ! !! TEST084 tests TREE_ROOTED_DEPTH. ! implicit none ! integer, parameter :: nnode = 12 ! integer depth integer depth_node(nnode) integer, dimension ( nnode ) :: parent = & (/ 0, 1, 1, 2, 2, 2, 3, 3, 5, 5, 6, 10 /) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST084' write ( *, '(a)' ) ' TREE_ROOTED_DEPTH: depth of a rooted tree.' write ( *, '(a)' ) ' ' call ivec_print ( nnode, parent, ' Parent vector for tree:' ) call tree_rooted_depth ( nnode, parent, depth, depth_node ) call ivec_print ( nnode, depth_node, ' Individual node depths:' ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) ' Overall rooted tree depth: ', depth return end subroutine test085 ! !******************************************************************************* ! !! TEST085 tests TREE_ROOTED_RANDOM. ! implicit none ! integer, parameter :: nnode = 5 ! integer i integer itree(nnode) integer j integer ntree(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST085' write ( *, '(a)' ) ' TREE_ROOTED_RANDOM: random unlabeled rooted trees.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Random trees, rooted at 1' do i = 1, 5 call tree_rooted_random ( nnode, ntree, itree ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Endpoint array for tree:' write ( *, '(19i4)' ) ( j, j = 2, nnode ) write ( *, '(19i4)' ) itree(2:nnode) end do call ivec_print ( nnode, ntree, & ' Number of trees with given number of nodes:' ) return end subroutine test086 ! !******************************************************************************* ! !! TEST086 tests TREE_ROOTED_ENUM. ! implicit none ! integer, parameter :: nnode = 10 ! integer ntree(nnode) ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TEST086' write ( *, '(a)' ) ' TREE_ROOTED_ENUM counts unlabeled rooted trees.' call tree_rooted_enum ( nnode, ntree ) call ivec_print ( nnode, ntree, & ' Number of trees with given number of nodes:' ) return end