subroutine cdg_code_back ( adj, nnode, code, order ) !*****************************************************************************80 ! !! CDG_CODE_BACK computes a color digraph code via backtracking. ! ! Discussion: ! ! The code is the "largest" order code over all possible node ! orderings. The lexicographic ordering is used in comparing codes. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical, parameter :: debug = .false. integer index integer maxstack integer ncan(nnode) integer ncomp integer nopen integer nswap integer nstack integer order(nnode) integer result integer stack(4*nnode) if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_BACK - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if maxstack = 4 * nnode nstack = 0 stack(1) = 0 ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call cdg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! index = 0 do call i4vec_backtrack ( nnode, order, index, nopen, nstack, stack, & maxstack, ncan ) ! ! If the backtracking routine has returned a complete candidate ! ordering, then compute the resulting code, and see it it is better ! then our current best. Then go back for the next backtrack search. ! if ( index == 1 ) then call cdg_order_code ( adj, nnode, nnode, code, order ) call cdg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if ! ! If the backtracking routine has a partial reordering, ! supply candidates for the next item in the ordering. ! else if ( index == 2 ) then call cdg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) else exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_BACK:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap end if return end subroutine cdg_code_brute ( adj, nnode, code, order ) !*****************************************************************************80 ! !! CDG_CODE_BRUTE computes the color digraph code via brute force. ! ! Modified: ! ! 08 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical even logical more integer ncomp integer nswap integer order(nnode) integer result ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call cdg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! more = .false. do call perm_next ( nnode, order, more, even ) call cdg_order_code ( adj, nnode, nnode, code, order ) call cdg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if if ( .not. more ) then exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_BRUTE:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap return end subroutine cdg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) !*****************************************************************************80 ! !! CDG_CODE_CAND finds candidates for a maximal color digraph code ordering. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer BESTCODE(NNODE,NNODE), the best code so far. ! ! Workspace, integer CODE(NNODE,NNODE). ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer NCOMP, the number of code comparisons. ! This routine updates NCOMP by 1 each time the routine is called. ! ! Input, integer NOPEN, identifies the first open position in ORDER. ! 1 <= NOPEN <= NNODE. ! ! Input, integer ORDER(NNODE), contains in entries 1 through NOPEN-1 ! the elements of the current partial list. ! ! Input/output, integer STACK(MAXSTACK), used to store the candidates. ! ! Input, integer MAXSTACK, the maximum size of the STACK array. ! A value of NNODE should be sufficient. ! ! Input/output, integer NSTACK, the current length of the stack. ! On output, NSTACK has been increased by the number of ! candidates found. ! ! Input/output, integer NCAN(NNODE), counts the number of candidates ! for each position. ! implicit none integer maxstack integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer code(nnode,nnode) integer i integer ifree(nnode) integer j integer maxcolor integer ncan(nnode) integer ncomp integer nfree integer ni integer nj integer nopen integer nstack integer order(nnode) integer result integer stack(maxstack) if ( nopen < 1 .or. nnode < nopen ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_CAND - Fatal error 1!' write ( *, '(a)' ) ' 1 <= NOPEN <= NNODE should be true, but' write ( *, '(a,i8)' ) ' NOPEN = ', nopen write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if ! ! Start with no candidates. ! ncan(nopen) = 0 ! ! If we have fixed at least one entry of the list, ! ! Compute the partial code; ! ! Compare the partial code with the corresponding ! part of the the code for the best ordering so far; ! ! If the current incomplete ordering is actually LESS than the ! current best, then bail out now, with zero candidates. ! if ( 1 < nopen ) then call cdg_order_code ( adj, nnode, nopen-1, code, order ) call cdg_code_compare ( bestcode, code, nnode, nopen-1, result ) ncomp = ncomp + 1 if ( result == + 1 ) then ncan(nopen) = 0 return end if end if ! ! Get a list of those nodes which have not been used yet. ! nfree = nnode + 1 - nopen call perm_free ( order, nopen-1, ifree, nfree ) ! ! Our preferred candidates will be: ! do i = 1, nopen-1 ncan(nopen) = 0 ni = order(i) ! ! * for the LOWEST ordered node possible, all unordered OUT neighbors, ! do j = 1, nfree nj = ifree(j) if ( adj(ni,nj) /= 0 ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_CAND - Fatal error 4!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = nj end if end do if ( 0 < ncan(nopen) ) then return end if ! ! * for the LOWEST ordered node possible, all unordered IN neighbors, ! do j = 1, nfree nj = ifree(j) if ( adj(nj,ni) /= 0 ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_CAND - Fatal error 4!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = nj end if end do if ( 0 < ncan(nopen) ) then return end if end do ! ! NO unordered nodes are connected in any way to ordered nodes. ! This can happen in two ways: ! ! * NOPEN = 1; (the list of used nodes is empty) ! * The graph is disconnected; ! ! In either case, we must now consider ALL free nodes. ! ! Compute the maximal color. ! maxcolor = 0 do i = 1, nfree ni = ifree(i) maxcolor = max ( maxcolor, adj(ni,ni) ) end do ! ! Take as candidates every node of color MAXCOLOR. ! ! We could thin the list down, by looking ahead, and only taking ! candidates of MAXCOLOR who also happen to have at least one free ! out neighbor, and so on. ! ncan(nopen) = 0 do i = 1, nfree ni = ifree(i) if ( adj(ni,ni) == maxcolor ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_CAND - Fatal error 6!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = ni end if end do ! ! This should never happen: ! if ( ncan(nopen) == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_CODE_CAND - Fatal error 7!' write ( *, '(a)' ) ' No candidates, but there gotta be some!' stop end if return end subroutine cdg_code_compare ( code1, code2, nnode, npart, result ) !*****************************************************************************80 ! !! CDG_CODE_COMPARE compares two (partial) color graph codes. ! ! Discussion: ! ! CODE1 = CODE2 if every digit of both codes is equal. ! ! Otherwise, traverse the entries in a funny diagonal way, suggested ! by this diagram for the first 16 entries: ! ! 1 2 5 10 ! 3 4 7 12 ! 6 8 9 14 ! 11 13 15 16 ! ! As we do that, we examine the corresponding digits of the two codes. ! For the first entry, (I,J), where the two codes differ, we say: ! ! if ( CODE1(I,J) < CODE2(I,J) ) then we say ! CODE1 < CODE2 ! else ! CODE2 < CODE1 ! ! Modified: ! ! 09 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer CODE1(NNODE,NNODE), CODE2(NNODE,NNODE), ! two codes to be compared. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NPART, specifies the portion of the codes ! to compare. NPART should be between 1 and NNODE. ! ! If NPART = NNODE, then the full codes are compared. ! ! If NPART < NNODE, then only entries corresponding to I and J ! both less than or equal to NPART will be compared. ! ! Output, integer RESULT: ! -1, CODE1 < CODE2; ! 0, CODE1 = CODE2; ! +1, CODE2 < CODE1. ! implicit none integer nnode integer code1(nnode,nnode) integer code2(nnode,nnode) integer i integer j integer npart integer result do j = 1, npart do i = 1, j - 1 if ( code1(i,j) < code2(i,j) ) then result = - 1 return else if ( code2(i,j) < code1(i,j) ) then result = + 1 return else if ( code1(j,i) < code2(j,i) ) then result = - 1 return else if ( code2(j,i) < code1(j,i) ) then result = + 1 return end if end do if ( code1(j,j) < code2(j,j) ) then result = - 1 return else if ( code2(j,j) < code1(j,j) ) then result = + 1 return end if end do result = 0 return end subroutine cdg_code_print ( nnode, code, title ) !*****************************************************************************80 ! !! CDG_CODE_PRINT prints a color digraph code. ! ! Modified: ! ! 06 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer CODE(NNODE,NNODE), the code. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer nnode integer ck integer code(nnode,nnode) integer i integer j character ( len = 80 ) string character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode do j = 1, nnode ck = code(i,j) if ( 0 <= ck .and. ck <= 9 ) then string(j:j) = char ( 48 + ck ) else string(j:j) = '*' end if end do write ( *, '(2x,i4,2x,a)' ) i, string(1:nnode) end do return end subroutine cdg_color_count ( adj, nnode, mcolor, ncolor ) !*****************************************************************************80 ! !! CDG_COLOR_COUNT counts the number of colors in a color digraph. ! ! Modified: ! ! 27 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer MCOLOR, the maximum color index. ! ! Output, integer NCOLOR, the number of colors. ! implicit none integer nnode integer adj(nnode,nnode) integer colors(nnode) integer i integer mcolor integer ncolor mcolor = 0 do i = 1, nnode mcolor = max ( mcolor, adj(i,i) ) end do do i = 1, nnode colors(i) = adj(i,i) end do call i4vec_sort_heap_d ( nnode, colors ) call i4vec_sorted_unique_count ( nnode, colors, ncolor ) return end subroutine cdg_color_sequence ( adj, nnode, seq ) !*****************************************************************************80 ! !! CDG_COLOR_SEQUENCE computes the color sequence of a color digraph. ! ! Discussion: ! ! The color sequence of a color digraph is constructed by computing the ! color of each node, and then ordering these values in decreasing order. ! ! If two color digraphs are isomorphic, they must have the same color ! sequence. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the color sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer seq(nnode) do i = 1, nnode seq(i) = adj(i,i) end do call i4vec_sort_heap_d ( nnode, seq ) return end subroutine cdg_compare ( adj1, nnode1, adj2, nnode2, order1, order2, result ) !*****************************************************************************80 ! !! CDG_COMPARE determines if color digraphs G1 and G2 are isomorphic. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ1(NNODE1,NNODE1), the adjacency information for G1. ! ADJ1(I,I) is the color of node I; otherwise, ADJ1(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE1, the number of nodes in G1. ! ! Input, integer ADJ2(NNODE2,NNODE2), the adjacency information for G2. ! ADJ2(I,I) is the color of node I; otherwise, ADJ2(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE2, the number of nodes in G2. ! ! Output, integer RESULT, is 0 if G1 and G2 are isomorphic, ! -I if G1 < G2 for test #I, and ! +I if G2 < G1 for test #I. ! ! Output, integer ORDER1(NNODE1), ORDER2(NNODE2). If RESULT = 0, then ! ORDER1 and ORDER2 are reorderings of the nodes of G1 and ! G2 which exhibit the isomorphism. ! implicit none integer nnode1 integer nnode2 integer adj1(nnode1,nnode1) integer adj2(nnode2,nnode2) integer code1(nnode1,nnode1) integer code2(nnode2,nnode2) integer in_seq1(nnode1) integer in_seq2(nnode2) integer mcolor1 integer mcolor2 integer ncolor1 integer ncolor2 integer nedge1 integer nedge2 integer order1(nnode1) integer order2(nnode2) integer out_seq1(nnode1) integer out_seq2(nnode2) integer result ! ! Test 1: Count the nodes. ! if ( nnode1 < nnode2 ) then result = - 1 return else if ( nnode2 < nnode1 ) then result = + 1 return end if ! ! Test 2: Count the edges. ! call cdg_edge_count ( adj1, nnode1, nedge1 ) call cdg_edge_count ( adj2, nnode2, nedge2 ) if ( nedge1 < nedge2 ) then result = - 2 return else if ( nedge2 < nedge1 ) then result = + 2 return end if ! ! Tests 3 and 4: Count the colors, and note the maximum color. ! call cdg_color_count ( adj1, nnode1, mcolor1, ncolor1 ) call cdg_color_count ( adj2, nnode2, mcolor2, ncolor2 ) if ( ncolor1 < ncolor2 ) then result = - 3 return else if ( ncolor2 < ncolor1 ) then result = + 3 return end if if ( mcolor1 < mcolor2 ) then result = - 4 return else if ( mcolor2 < mcolor1 ) then result = + 4 return end if ! ! Test 5: Compare the outdegree sequences. ! call cdg_degree_seq ( adj1, nnode1, in_seq1, out_seq1 ) call cdg_degree_seq ( adj2, nnode2, in_seq2, out_seq2 ) call i4vec_compare ( nnode1, out_seq1, out_seq2, result ) if ( result < 0 ) then result = - 5 return else if ( 0 < result ) then result = + 5 return end if ! ! Test 6: Compare the indegree sequences. ! call i4vec_compare ( nnode1, in_seq1, in_seq2, result ) if ( result < 0 ) then result = - 6 return else if ( 0 < result ) then result = + 6 return end if ! ! Test 7: Compare the color sequences. ! call cdg_color_sequence ( adj1, nnode1, in_seq1 ) call cdg_color_sequence ( adj2, nnode2, in_seq2 ) call i4vec_compare ( nnode1, in_seq1, in_seq2, result ) if ( result < 0 ) then result = - 7 return else if ( 0 < result ) then result = + 7 return end if ! ! Test 8: Compare the codes. ! call cdg_code_back ( adj1, nnode1, code1, order1 ) call cdg_code_back ( adj2, nnode2, code2, order2 ) call cdg_code_compare ( code1, code2, nnode1, nnode1, result ) if ( result < 0 ) then result = - 8 return else if ( 0 < result ) then result = + 8 return end if result = 0 return end subroutine cdg_degree ( adj, nnode, indegree, outdegree ) !*****************************************************************************80 ! !! CDG_DEGREE computes the indegree and outdegree of each node. ! ! Discussion: ! ! The indegree of a node is the number of directed edges that ! end at the node. ! ! The outdegree of a node is the number of directed edges that ! begin at the node. ! ! The sum of the indegrees and outdegrees of all the nodes is twice ! the number of edges. ! ! The generalized case, where ADJ(I,J) can be greater than 1, indicating ! the existence of 2 or more distinct edges from node I to node J, ! will be properly handled by this routine. ! ! Modified: ! ! 10 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information for graph 1. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NNODE), ! the indegree and outdegree of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer indegree(nnode) integer j integer outdegree(nnode) indegree(1:nnode) = 0 outdegree(1:nnode) = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then if ( adj(i,j) /= 0 ) then outdegree(i) = outdegree(i) + adj(i,j) indegree(j) = indegree(j) + adj(i,j) end if end if end do end do return end subroutine cdg_degree_seq ( adj, nnode, in_seq, out_seq ) !*****************************************************************************80 ! !! CDG_DEGREE_SEQ computes the degree sequence of a color digraph. ! ! Discussion: ! ! The directed degree sequence of a graph is the sequence of indegrees ! and the sequence of outdegrees, arranged to correspond to nodes of ! successively decreasing total degree. For nodes of equal degree, those ! of higher outdegree take precedence. ! ! Modified: ! ! 04 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer IN_SEQ(NNODE), OUT_SEQ(NNODE), the degree sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer in_seq(nnode) integer out_seq(nnode) call cdg_degree ( adj, nnode, in_seq, out_seq ) call i4vec2_sort_d ( nnode, out_seq, in_seq ) return end subroutine cdg_edge_count ( adj, nnode, nedge ) !*****************************************************************************80 ! !! CDG_EDGE_COUNT counts the number of edges in a color digraph. ! ! Modified: ! ! 26 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE, the number of edges. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer j integer nedge nedge = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then nedge = nedge + adj(i,j) end if end do end do return end subroutine cdg_example_cube ( adj, nnode ) !*****************************************************************************80 ! !! CDG_EXAMPLE_CUBE sets up the cube color digraph. ! ! Diagram: ! ! ! 8B----<-----3B ! |\ /|\ ! | A V | | ! | \ / | | ! | 4R-->-7R | | ! | | | | | ! A A V V A ! | | | | | ! | 5B-<-2G | | ! | / \ | | ! | A A | | ! |/ \|/ ! 1G----->----6B ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Output, integer NNODE, the number of nodes. ! implicit none integer adj(8,8) integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer nnode integer, parameter :: RED = 3 nnode = 8 adj(1:nnode,1:nnode) = 0 adj(1,1) = GREEN adj(1,5) = 1 adj(1,6) = 1 adj(1,8) = 1 adj(2,2) = GREEN adj(2,5) = 1 adj(3,3) = BLUE adj(3,6) = 1 adj(3,7) = 1 adj(3,8) = 1 adj(4,4) = RED adj(4,7) = 1 adj(4,8) = 1 adj(5,5) = BLUE adj(5,4) = 1 adj(6,6) = BLUE adj(6,2) = 1 adj(6,3) = 1 adj(7,7) = RED adj(7,2) = 1 adj(8,8) = BLUE return end subroutine cdg_example_octo ( example, adj, nnode, seed ) !*****************************************************************************80 ! !! CDG_EXAMPLE_OCTO sets up an 8 node example color digraph. ! ! Diagram: ! ! 1---2 ! /| |\ ! 8-+---+-3 ! | | | | ! 7-+---+-4 ! \| |/ ! 6---5 ! ! Graph "A" ! ! There are 8 graphs to choose from. They are all on 8 nodes. The first ! 5 have degree 3 at every node. Graphs 6 and 7 have degree 5 at every ! node. Graph 8 is disconnected. ! ! Modified: ! ! 10 May 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EXAMPLE, the index of the example to choose. ! 1 <= EXAMPLE <= 65. ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information for the graph. ! ADJ(I,I) is the color of node I. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Output, integer NNODE, the number of nodes, which should be 8. ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer adj(8,8) integer, parameter :: BLUE = 1 integer example integer, parameter :: GREEN = 2 integer i integer i4_uniform integer j integer msave integer nnode integer nsave integer, parameter :: RED = 3 integer seed integer, parameter :: YELLOW = 4 if ( example <= 0 ) then nsave = i4_uniform ( 1, 13, seed ) msave = i4_uniform ( 1, 5, seed ) else nnode = mod ( example - 1, 65 ) + 1 msave = ( example - 1 ) / 13 + 1 nsave = mod ( example - 1, 13 ) + 1 end if nnode = 8 adj(1:nnode,1:nnode) = 0 do i = 1, nnode j = i + 1 if ( nnode < j ) then j = j - nnode end if adj(i,j) = 1 end do ! ! Underlying graph 1. ! if ( nsave == 1 ) then adj(1,6) = 1 adj(2,5) = 1 adj(3,8) = 1 adj(4,7) = 1 else if ( nsave == 2 ) then adj(1,6) = 1 adj(5,2) = 1 adj(3,8) = 1 adj(7,4) = 1 ! ! Underlying graph 2. ! Digraphs 3 and 4 have different indegree/outdegree sequences. ! else if ( nsave == 3 ) then adj(1,6) = 1 adj(6,1) = 1 adj(2,8) = 1 adj(8,2) = 1 adj(3,5) = 1 adj(5,3) = 1 adj(4,7) = 1 adj(7,4) = 1 else if ( nsave == 4 ) then adj(1,6) = 1 adj(2,8) = 1 adj(3,5) = 1 adj(4,7) = 1 ! ! Underlying graph 3 ! Digraphs 5 and 6 have the same indegree/outdegree sequences. ! else if ( nsave == 5 ) then adj(1,5) = 1 adj(2,6) = 1 adj(3,7) = 1 adj(4,8) = 1 else if ( nsave == 6 ) then adj(1:nnode,1:nnode) = 0 adj(1,8) = 1 adj(1,5) = 1 adj(2,1) = 1 adj(2,3) = 1 adj(3,4) = 1 adj(3,7) = 1 adj(4,5) = 1 adj(4,8) = 1 adj(5,6) = 1 adj(6,2) = 1 adj(7,6) = 1 adj(8,7) = 1 ! ! Underlying graph 4 ! else if ( nsave == 7 ) then adj(3,1) = 1 adj(4,2) = 1 adj(5,7) = 1 adj(6,8) = 1 else if ( nsave == 8 ) then adj(3,1) = 1 adj(4,2) = 1 adj(5,7) = 1 adj(8,6) = 1 ! ! Underlying graph 5 ! else if ( nsave == 9 ) then adj(1,4) = 1 adj(2,6) = 1 adj(8,3) = 1 adj(5,7) = 1 adj(7,5) = 1 else if ( nsave == 10 ) then adj(1,4) = 1 adj(2,6) = 1 adj(3,8) = 1 adj(5,7) = 1 adj(7,5) = 1 ! ! Underlying graph 6 ! else if ( nsave == 11 ) then adj(1,4) = 1 adj(1,5) = 1 adj(1,6) = 1 adj(2,5) = 1 adj(2,6) = 1 adj(2,7) = 1 adj(3,6) = 1 adj(3,7) = 1 adj(3,8) = 1 adj(4,7) = 1 adj(4,8) = 1 adj(5,8) = 1 ! ! Underlying graph 7 ! else if ( nsave == 12 ) then adj(1,3) = 1 adj(1,5) = 1 adj(1,7) = 1 adj(2,4) = 1 adj(2,6) = 1 adj(2,8) = 1 adj(3,5) = 1 adj(3,7) = 1 adj(4,6) = 1 adj(4,8) = 1 adj(5,7) = 1 adj(6,8) = 1 ! ! Underlying graph 8. ! else if ( nsave == 13 ) then adj(1,2) = 1 adj(3,1) = 1 adj(2,3) = 1 adj(3,4) = 1 adj(5,6) = 1 adj(6,5) = 1 adj(5,7) = 1 adj(6,7) = 1 end if if ( msave == 1 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = BLUE adj(7,7) = GREEN adj(8,8) = GREEN else if ( msave == 2 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = BLUE adj(7,7) = GREEN adj(8,8) = YELLOW else if ( msave == 3 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = BLUE adj(7,7) = YELLOW adj(8,8) = YELLOW else if ( msave == 4 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = GREEN adj(7,7) = GREEN adj(8,8) = GREEN else if ( msave == 5 ) then adj(1,1) = RED adj(2,2) = BLUE adj(3,3) = RED adj(4,4) = GREEN adj(5,5) = BLUE adj(6,6) = RED adj(7,7) = BLUE adj(8,8) = GREEN end if ! ! Now permute the graph. ! call i4mat_perm_random ( nnode, adj, seed ) return end subroutine cdg_order_code ( adj, nnode, npart, code, order ) !*****************************************************************************80 ! !! CDG_ORDER_CODE returns the color digraph code for a specific node ordering. ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NPART, the number of nodes to consider. ! NPART should be between 1 and NNODE. ! ! If NPART is NNODE, then the usual code is returned. ! ! If NPART is less than NNODE, then the code is computed as ! though only NPART nodes existed, namely, those specified in the ! first NPART entries of order. This option is provided so that ! the routine can compute the portion of a code determined ! by an incomplete ordering of the nodes. ! ! Output, integer CODE(NNODE,NNODE), the code for this ordering. ! ! Input, integer ORDER(NNODE), the ordering of the nodes. ORDER(1) ! is the first node, and so on. ! implicit none integer nnode integer adj(nnode,nnode) integer code(nnode,nnode) integer i integer j integer ni integer nj integer npart integer order(nnode) do i = 1, nnode if ( i <= npart ) then ni = order(i) if ( order(i) < 1 .or. nnode < order(i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_ORDER_CODE - Fatal error!' write ( *, '(a)' ) ' ORDER is not a proper permutation.' stop end if else ni = 0 end if do j = 1, nnode if ( j <= npart ) then nj = order(j) if ( order(j) < 1 .or. nnode < order(j) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_ORDER_CODE - Fatal error!' write ( *, '(a)' ) ' ORDER is not a proper permutation.' stop end if else nj = 0 end if if ( ni == 0 .or. nj == 0 ) then code(i,j) = 0 else code(i,j) = adj(ni,nj) end if end do end do return end subroutine cdg_print ( adj, nnode, title ) !*****************************************************************************80 ! !! CDG_PRINT prints out the adjacency matrix of a color digraph. ! ! Modified: ! ! 05 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer j integer k character ( len = 80 ) string character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode do j = 1, nnode k = (j-1) * 3 + 1 write ( string(k:k+2), '(i3)' ) adj(i,j) end do write ( *, '(2x,a)' ) string(1:3*nnode) end do return end subroutine cdg_random ( adj, nnode, ncolor, nedge, seed ) !*****************************************************************************80 ! !! CDG_RANDOM generates a random color graph. ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors. ! Each node is assumed to have an associated color, between 1 and NCOLOR, ! which will be chosen at random. ! ! Input, integer NEDGE, the number of edges, which must be between ! 0 and NNODE*(NNODE-1). ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer ncolor integer nedge integer nnode integer adj(nnode,nnode) integer i integer i4_uniform integer icolor integer iwork(nedge) integer j integer k integer l integer maxedge integer perm(ncolor) integer seed integer subset(ncolor) if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nedge write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if maxedge = nnode * ( nnode - 1 ) if ( nedge < 0 .or. maxedge < nedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDG_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NEDGE = ', nedge write ( *, '(a)') ' but NEDGE must be at least 0, and ' write ( *, '(a,i8)' ) ' no more than ', maxedge stop end if ! ! Start with no edges, no colors. ! adj(1:nnode,1:nnode) = 0 ! ! Choose the colors. ! call ksub_random ( nnode, ncolor, subset, seed ) call perm_random ( ncolor, perm, seed ) do icolor = 1, ncolor i = subset(perm(icolor)) adj(i,i) = icolor end do do i = 1, nnode if ( adj(i,i) == 0 ) then adj(i,i) = i4_uniform ( 1, ncolor, seed ) end if end do ! ! Pick a random NEDGE subset. ! call ksub_random ( maxedge, nedge, iwork, seed ) ! ! Mark the potential edges that were chosen. ! k = 0 l = 1 do i = 1, nnode do j = 1, nnode if ( i /= j ) then k = k + 1 if ( l <= nedge ) then if ( k == iwork(l) ) then adj(i,j) = 1 l = l + 1 end if end if end if end do end do return end subroutine cdmg_adj_max_max ( adj, nnode, adj_max_max ) !*****************************************************************************80 ! !! CDMG_ADJ_MAX_MAX computes the adjacency maximum maximum of a color dimultigraph. ! ! Discussion: ! ! The adjacency maximum maximum of a color dimultigraph may be constructed ! by computing the maximum entry of the off diagonal entries of the ! adjacency matrix, ! ! Example: ! ! ADJ = ! 3 1 2 3 ! 1 9 2 0 ! 2 2 2 1 ! 3 0 1 7 ! ! ADJ_MAX_MAX = 3 ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer ADJ_MAX_MAX, the adjacency maximum maximum. ! implicit none integer nnode integer adj(nnode,nnode) integer adj_max_max integer i integer j adj_max_max = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then adj_max_max = max ( adj_max_max, adj(i,j) ) end if end do end do return end subroutine cdmg_adj_max_seq ( adj, nnode, adj_max_seq ) !*****************************************************************************80 ! !! CDMG_ADJ_MAX_SEQ computes the adjacency maximum sequence of a color dimultigraph. ! ! Discussion: ! ! The adjacency maximum sequence of a color dimultigraph may be ! constructed by computing the maximum entry of each row of the ! off diagonal elements of the adjacency matrix, and then sorting ! these values in descending order. ! ! Example: ! ! ADJ = ! 9 1 2 3 ! 1 8 2 0 ! 2 2 3 1 ! 3 0 1 6 ! ! ADJ_MAX_SEQ = ! ! 3 ! 3 ! 2 ! 2 ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer ADJ_MAX_SEQ(NNODE), the adjacency maximum sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer adj_max_seq(nnode) integer i integer j integer k ! ! Copy the adjacency matrix. ! do i = 1, nnode k = 0 do j = 1, nnode if ( i /= j ) then k = max ( k, adj(i,j) ) end if end do adj_max_seq(i) = k end do ! ! Sort the elements. ! call i4vec_sort_heap_d ( nnode, adj_max_seq ) return end subroutine cdmg_adj_seq_u ( adj, nnode, adj_seq ) !*****************************************************************************80 ! !! CDMG_ADJ_SEQ_U computes the unweighted adjacency sequence of a color dimultigraph. ! ! Discussion: ! ! The unweighted adjacency sequence of a color dimultigraph may be ! constructed by zeroing out the diagonal entries, replacing each nonzero ! off diagonal entry by 1, sorting the entries of each row in descending ! order, and then sorting the rows themselves in descending order. ! ! Example: ! ! ADJ = ! 5 1 2 3 ! 1 7 2 0 ! 2 2 8 1 ! 3 0 1 9 ! ! ADJ_SEQ = ! ! 1 1 1 0 ! 1 1 1 0 ! 1 1 0 0 ! 1 1 0 0 ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer ADJ_SEQ(NNODE,NNODE), the unweighted adjacency sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer adj_seq(nnode,nnode) integer i integer j ! ! Copy the adjacency matrix. ! do i = 1, nnode do j = 1, nnode if ( i == j ) then adj_seq(i,j) = 0 else if ( adj(i,j) == 0 ) then adj_seq(i,j) = 0 else adj_seq(i,j) = 1 end if end do end do ! ! Sort the elements of each row. ! call i4row_sort2_d ( nnode, nnode, adj_seq ) ! ! Sort the rows of the matrix. ! call i4row_sort_d ( nnode, nnode, adj_seq ) return end subroutine cdmg_adj_seq_w ( adj, nnode, adj_seq ) !*****************************************************************************80 ! !! CDMG_ADJ_SEQ_W computes the weighted adjacency sequence of a color dimultigraph. ! ! Discussion: ! ! The adjacency sequence of a color dimultigraph may be constructed by ! zeroing out the diagonal entries, sorting the entries of each row of the ! adjacency matrix in descending order, and then sorting the rows ! themselves in descending order. ! ! Example: ! ! ADJ = ! 8 1 2 3 ! 1 7 2 0 ! 2 2 5 1 ! 3 0 1 6 ! ! ADJ_SEQ = ! ! 3 2 1 0 ! 3 1 0 0 ! 2 2 1 0 ! 2 1 0 0 ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer ADJ_SEQ(NNODE,NNODE), the adjacency sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer adj_seq(nnode,nnode) integer i integer j ! ! Copy the adjacency matrix. ! do i = 1, nnode do j = 1, nnode if ( i == j ) then adj_seq(i,j) = 0 else adj_seq(i,j) = adj(i,j) end if end do end do ! ! Sort the elements of each row. ! call i4row_sort2_d ( nnode, nnode, adj_seq ) ! ! Sort the rows of the matrix. ! call i4row_sort_d ( nnode, nnode, adj_seq ) return end subroutine cdmg_code_back ( adj, nnode, code, order ) !*****************************************************************************80 ! !! CDMG_CODE_BACK computes a color dimultigraph code via backtracking. ! ! Discussion: ! ! The code is the "largest" order code over all possible node ! orderings. The lexicographic ordering is used in comparing codes. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical, parameter :: debug = .false. integer index integer maxstack integer ncan(nnode) integer ncomp integer nopen integer nswap integer nstack integer order(nnode) integer result integer stack(4*nnode) if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_BACK - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if maxstack = 4 * nnode nstack = 0 stack(1) = 0 ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call cdmg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! index = 0 do call i4vec_backtrack ( nnode, order, index, nopen, nstack, stack, & maxstack, ncan ) ! ! If the backtracking routine has returned a complete candidate ordering, then ! compute the resulting code, and see it it is better ! then our current best. Then go back for the next backtrack search. ! if ( index == 1 ) then call cdmg_order_code ( adj, nnode, nnode, code, order ) call cdmg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if ! ! If the backtracking routine has a partial reordering, ! supply candidates for the next item in the ordering. ! else if ( index == 2 ) then call cdmg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) else exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_BACK:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap end if return end subroutine cdmg_code_brute ( adj, nnode, code, order ) !*****************************************************************************80 ! !! CDMG_CODE_BRUTE computes a color dimultigraph code via brute force. ! ! Discussion: ! ! The code is the "largest" order code (in the lexicographic sense) ! over all possible node orderings. The brute force method considers ! every node ordering, computes the corresponding order code, and ! takes the largest one encountered. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical even logical more integer ncomp integer nswap integer order(nnode) integer result ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call cdmg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! more = .false. do call perm_next ( nnode, order, more, even ) call cdmg_order_code ( adj, nnode, nnode, code, order ) call cdmg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if if ( .not. more ) then exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_BRUTE:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap return end subroutine cdmg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) !*****************************************************************************80 ! !! CDMG_CODE_CAND finds candidates for a maximal color dimultigraph code ordering. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer BESTCODE(NNODE,NNODE), the best code so far. ! ! Workspace, integer CODE(NNODE,NNODE). ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer NCOMP, the number of code comparisons. ! This routine updates NCOMP by 1 each time the routine is called. ! ! Input, integer NOPEN, identifies the first open position in ORDER. ! 1 <= NOPEN <= NNODE. ! ! Input, integer ORDER(NNODE), contains in entries 1 through NOPEN-1 ! the elements of the current partial list. ! ! Input/output, integer STACK(MAXSTACK), used to store the new candidates. ! ! Input, integer MAXSTACK, the maximum size of the STACK array. ! A value of NNODE should be sufficient. ! ! Input/output, integer NSTACK, the current length of the stack. ! On output, NSTACK has been increased by the number of ! candidates found. ! ! Input/output, integer NCAN(NNODE), the number of candidates for ! each position. ! implicit none integer maxstack integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer code(nnode,nnode) integer i integer ifree(nnode) integer j integer max_adj integer maxcolor integer ncan(nnode) integer ncomp integer nfree integer ni integer nj integer nopen integer nstack integer order(nnode) integer result integer stack(maxstack) if ( nopen < 1 .or. nnode < nopen ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_CAND - Fatal error 1!' write ( *, '(a)' ) ' 1 <= NOPEN <= NNODE should be true, but' write ( *, '(a,i8)' ) ' NOPEN = ', nopen write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if ! ! Start with no candidates. ! ncan(nopen) = 0 ! ! If we have fixed at least one entry of the list, ! ! Compute the partial code; ! ! Compare the partial code with the corresponding ! part of the the code for the best ordering so far; ! ! If the current incomplete ordering is actually LESS than the ! current best, then bail out now, with zero candidates. ! if ( 1 < nopen ) then call cdmg_order_code ( adj, nnode, nopen-1, code, order ) call cdmg_code_compare ( bestcode, code, nnode, nopen-1, result ) ncomp = ncomp + 1 if ( result == + 1 ) then ncan(nopen) = 0 return end if end if ! ! Get a list of those nodes which have not been used yet. ! nfree = nnode + 1 - nopen call perm_free ( order, nopen-1, ifree, nfree ) ! ! Our preferred candidates will be: ! do i = 1, nopen-1 ncan(nopen) = 0 ni = order(i) ! ! ...note the maximum adjacency FROM NI to any unordered node NJ... ! max_adj = 0 do j = 1, nfree nj = ifree(j) max_adj = max ( max_adj, adj(ni,nj) ) end do ! ! ...and take as candidates all unordered nodes NJ with maximal ! adjacency FROM NI. ! ! (We could weed candidates further by only taking the maximal color.) ! if ( 0 < max_adj ) then do j = 1, nfree nj = ifree(j) if ( adj(ni,nj) == max_adj ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_CAND - Fatal error 2!' write ( *, '(a)' ) ' MAXSTACK < NSTACK !' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = nj end if end do return end if ! ! Else, note the maximum adjacency TO NI from any unordered node NJ... ! max_adj = 0 do j = 1, nfree nj = ifree(j) max_adj = max ( max_adj, adj(nj,ni) ) end do ! ! ...and take as candidates all unordered nodes NJ with maximal ! adjacency TO NI. ! ! (We could weed candidates further by only taking the maximal color.) ! if ( 0 < max_adj ) then do j = 1, nfree nj = ifree(j) if ( adj(nj,ni) == max_adj ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' )'CDMG_CODE_CAND - Fatal error 2!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = nj end if end do return end if end do ! ! NO unordered nodes are connected in any way to ordered nodes. ! This can happen in two ways: ! ! * NOPEN = 1; (the list of used nodes is empty) ! * The graph is disconnected; ! ! In either case, we must now consider ALL free nodes. ! ! Compute the maximal color. ! maxcolor = 0 do i = 1, nfree ni = ifree(i) maxcolor = max ( maxcolor, adj(ni,ni) ) end do ! ! Take as candidates every node of color MAXCOLOR. ! ! We could thin the list down, by looking ahead, and only taking ! candidates of MAXCOLOR who also happen to have at least one free ! out neighbor, and so on. ! ncan(nopen) = 0 do i = 1, nfree ni = ifree(i) if ( adj(ni,ni) == maxcolor ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_CAND - Fatal error 6!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = ni end if end do ! ! This should never happen: ! if ( ncan(nopen) == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_CODE_CAND - Fatal error 7!' write ( *, '(a)' ) ' No candidates, but there gotta be some!' stop end if return end subroutine cdmg_code_compare ( code1, code2, nnode, npart, result ) !*****************************************************************************80 ! !! CDMG_CODE_COMPARE compares two (partial) color dimultigraph codes. ! ! Discussion: ! ! CODE1 = CODE2 if every digit of both codes is equal. ! ! Otherwise, traverse the entries in a funny diagonal way, suggested ! by this diagram for the first 16 entries: ! ! 1 2 5 10 ! 3 4 7 12 ! 6 8 9 14 ! 11 13 15 16 ! ! As we do that, we examine the corresponding digits of the two codes. ! For the first entry, (I,J), where the two codes differ, we say: ! ! if ( CODE1(I,J) < CODE2(I,J) ) then we say ! CODE1 < CODE2 ! else ! CODE2 < CODE1 ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer CODE1(NNODE,NNODE), CODE2(NNODE,NNODE), ! two codes to be compared. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NPART, specifies the portion of the codes ! to compare. NPART should be between 1 and NNODE. ! ! If NPART = NNODE, then the full codes are compared. ! ! If NPART < NNODE, then only entries corresponding to I and J ! both less than or equal to NPART will be compared. ! ! Output, integer RESULT: ! -1, CODE1 < CODE2; ! 0, CODE1 = CODE2; ! +1, CODE2 < CODE1. ! implicit none integer nnode integer code1(nnode,nnode) integer code2(nnode,nnode) integer i integer j integer npart integer result do j = 1, npart do i = 1, j - 1 if ( code1(i,j) < code2(i,j) ) then result = - 1 return else if ( code2(i,j) < code1(i,j) ) then result = + 1 return else if ( code1(j,i) < code2(j,i) ) then result = - 1 return else if ( code2(j,i) < code1(j,i) ) then result = + 1 return end if end do if ( code1(j,j) < code2(j,j) ) then result = - 1 return else if ( code2(j,j) < code1(j,j) ) then result = + 1 return end if end do result = 0 return end subroutine cdmg_code_print ( nnode, code, title ) !*****************************************************************************80 ! !! CDMG_CODE_PRINT prints out a color dimultigraph code. ! ! Modified: ! ! 06 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer CODE(NNODE,NNODE), the code. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer nnode integer code(nnode,nnode) integer i character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(2x,78i1)' ) code(i,1:nnode) end do return end subroutine cdmg_color_count ( adj, nnode, mcolor, ncolor ) !*****************************************************************************80 ! !! CDMG_COLOR_COUNT counts the number of colors in a color dimultigraph. ! ! Modified: ! ! 27 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer MCOLOR, the maximum color index. ! ! Output, integer NCOLOR, the number of colors. ! implicit none integer nnode integer adj(nnode,nnode) integer colors(nnode) integer i integer mcolor integer ncolor mcolor = 0 do i = 1, nnode mcolor = max ( mcolor, adj(i,i) ) end do do i = 1, nnode colors(i) = adj(i,i) end do call i4vec_sort_heap_d ( nnode, colors ) call i4vec_sorted_unique_count ( nnode, colors, ncolor ) return end subroutine cdmg_color_sequence ( adj, nnode, seq ) !*****************************************************************************80 ! !! CDMG_COLOR_SEQUENCE computes the color sequence of a color dimultigraph. ! ! Discussion: ! ! The color sequence of a color dimultigraph is constructed by computing the ! color of each node, and then ordering these values in decreasing order. ! ! If two color dimultigraphs are isomorphic, they must have the same ! color sequence. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the color sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer seq(nnode) do i = 1, nnode seq(i) = adj(i,i) end do call i4vec_sort_heap_d ( nnode, seq ) return end subroutine cdmg_compare ( adj1, nnode1, adj2, nnode2, order1, & order2, result ) !*****************************************************************************80 ! !! CDMG_COMPARE determines if color dimultigraphs G1 and G2 are isomorphic. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ1(NNODE1,NNODE1), the adjacency information for G1. ! ! Input, integer NNODE1, the number of nodes in G1. ! ! Input, integer ADJ2(NNODE2,NNODE2), the adjacency information for G2. ! ! Input, integer NNODE2, the number of nodes in G2. ! ! Output, integer RESULT, is 0 if the dimultigraphs are isomorphic, ! -I if G1 < G2 for test #I, and ! +I if G2 < G1 for test #I. ! ! Output, integer ORDER1(NNODE1), ORDER2(NNODE2). If RESULT = 0, then ORDER1 ! and ORDER2 are reorderings of the nodes of G1 and G2 which ! exhibit the isomorphism. ! implicit none integer nnode1 integer nnode2 integer adj_max_max_1 integer adj_max_max_2 integer adj1(nnode1,nnode1) integer adj2(nnode2,nnode2) integer code1(nnode1,nnode1) integer code2(nnode2,nnode2) integer in_seq1(nnode1) integer in_seq2(nnode2) integer mcolor1 integer mcolor2 integer ncolor1 integer ncolor2 integer nedge_u_1 integer nedge_u_2 integer nedge_w_1 integer nedge_w_2 integer order1(nnode1) integer order2(nnode2) integer out_seq1(nnode1) integer out_seq2(nnode2) integer result integer seq1(nnode1) integer seq2(nnode2) ! ! Test 1: Count the nodes. ! if ( nnode1 < nnode2 ) then result = - 1 return else if ( nnode2 < nnode1 ) then result = + 1 return end if ! ! Test 2: Compare the unweighted edges. ! call cdmg_edge_count ( adj1, nnode1, nedge_u_1, nedge_w_1 ) call cdmg_edge_count ( adj2, nnode2, nedge_u_2, nedge_w_2 ) if ( nedge_u_1 < nedge_u_2 ) then result = - 2 return else if ( nedge_u_2 < nedge_u_1 ) then result = + 2 return end if ! ! Test 3: Compare the weighted edges. ! if ( nedge_w_1 < nedge_w_2 ) then result = - 3 return else if ( nedge_w_2 < nedge_w_1 ) then result = + 3 return end if ! ! Test 4: Compare the number of colors. ! call cdmg_color_count ( adj1, nnode1, mcolor1, ncolor1 ) call cdmg_color_count ( adj2, nnode2, mcolor2, ncolor2 ) if ( ncolor1 < ncolor2 ) then result = - 4 return else if ( ncolor2 < ncolor1 ) then result = + 4 return end if ! ! Test 5: Compare the maximum color. ! if ( mcolor1 < mcolor2 ) then result = - 5 return else if ( mcolor2 < mcolor1 ) then result = + 5 return end if ! ! Test 6: Compare the color sequences. ! call cdmg_color_sequence ( adj1, nnode1, in_seq1 ) call cdmg_color_sequence ( adj2, nnode2, in_seq2 ) call i4vec_compare ( nnode1, in_seq1, in_seq2, result ) if ( result < 0 ) then result = - 6 return else if ( 0 < result ) then result = + 6 return end if ! ! Test 7: Compare the unweighted outdegree sequences. ! call cdmg_degree_seq_u ( adj1, nnode1, in_seq1, out_seq1 ) call cdmg_degree_seq_u ( adj2, nnode2, in_seq2, out_seq2 ) call i4vec_compare ( nnode1, out_seq1, out_seq2, result ) if ( result < 0 ) then result = - 7 return else if ( 0 < result ) then result = + 7 return end if ! ! Test 8: Compare the unweighted indegree sequences. ! call i4vec_compare ( nnode1, in_seq1, in_seq2, result ) if ( result < 0 ) then result = - 8 return else if ( 0 < result ) then result = + 8 return end if ! ! Test 9: Compare the adjacency max max. ! call cdmg_adj_max_max ( adj1, nnode1, adj_max_max_1 ) call cdmg_adj_max_max ( adj2, nnode2, adj_max_max_2 ) if ( adj_max_max_1 < adj_max_max_2 ) then result = - 9 return else if ( adj_max_max_1 < adj_max_max_1 ) then result = + 9 return end if ! ! Test 10: Compare the adjacency max sequences. ! call cdmg_adj_max_seq ( adj1, nnode1, seq1 ) call cdmg_adj_max_seq ( adj2, nnode2, seq2 ) call i4vec_compare ( nnode1, seq1, seq2, result ) if ( result < 0 ) then result = - 10 return else if ( 0 < result ) then result = + 10 return end if ! ! Test 11: Compare the weighted outdegree sequences. ! call cdmg_degree_seq_w ( adj1, nnode1, in_seq1, out_seq1 ) call cdmg_degree_seq_w ( adj2, nnode2, in_seq2, out_seq2 ) call i4vec_compare ( nnode1, out_seq1, out_seq2, result ) if ( result < 0 ) then result = - 11 return else if ( 0 < result ) then result = + 11 return end if ! ! Test 12: Compare the weighted indegree sequences. ! call i4vec_compare ( nnode1, in_seq1, in_seq2, result ) if ( result < 0 ) then result = - 12 return else if ( 0 < result ) then result = + 12 return end if ! ! Test 13: Compare the weighted adjacency sequences. ! call cdmg_adj_seq_w ( adj1, nnode1, code1 ) call cdmg_adj_seq_w ( adj2, nnode2, code2 ) call i4mat_row_compare ( nnode1, nnode1, code1, code2, result ) if ( result < 0 ) then result = - 13 return else if ( 0 < result ) then result = + 13 return end if ! ! Test 14: Compare the codes. ! call cdmg_code_back ( adj1, nnode1, code1, order1 ) call cdmg_code_back ( adj2, nnode2, code2, order2 ) call cdmg_code_compare ( code1, code2, nnode1, nnode1, result ) if ( result < 0 ) then result = - 14 return else if ( 0 < result ) then result = + 14 return end if result = 0 return end subroutine cdmg_degree_seq_u ( adj, nnode, in_seq, out_seq ) !*****************************************************************************80 ! !! CDMG_DEGREE_SEQ_U: unweighted directed degree sequence of color dimultigraph. ! ! Discussion: ! ! The unweighted directed degree sequence is the sequence of indegrees ! and the sequence of outdegrees, ignoring edge multiplicity, arranged ! to correspond to nodes of successively decreasing total degree. For ! nodes of equal degree, those of higher outdegree take precedence. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer IN_SEQ(NNODE), OUT_SEQ(NNODE), ! the unweighted directed degree sequences. ! implicit none integer nnode integer adj(nnode,nnode) integer in_seq(nnode) integer out_seq(nnode) call cdmg_degree_u ( adj, nnode, in_seq, out_seq ) call i4vec2_sort_d ( nnode, out_seq, in_seq ) return end subroutine cdmg_degree_seq_w ( adj, nnode, in_seq, out_seq ) !*****************************************************************************80 ! !! CDMG_DEGREE_SEQ_W: weighted directed degree sequence of a color dimultigraph. ! ! Discussion: ! ! The weighted directed degree sequence is the sequence of indegrees ! and the sequence of outdegrees, with edge multiplicity, arranged ! to correspond to nodes of successively decreasing total degree. For ! nodes of equal degree, those of higher outdegree take precedence. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer IN_SEQ(NNODE), OUT_SEQ(NNODE), ! the weighted directed degree sequences. ! implicit none integer nnode integer adj(nnode,nnode) integer in_seq(nnode) integer out_seq(nnode) call cdmg_degree_w ( adj, nnode, in_seq, out_seq ) call i4vec2_sort_d ( nnode, out_seq, in_seq ) return end subroutine cdmg_degree_u ( adj, nnode, indegree, outdegree ) !*****************************************************************************80 ! !! CDMG_DEGREE_U computes the unweighted degrees of a color dimultigraph. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NNODE), ! the unweighted indegree and outdegree of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer indegree(nnode) integer j integer outdegree(nnode) indegree(1:nnode) = 0 outdegree(1:nnode) = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then if ( adj(i,j) /= 0 ) then outdegree(i) = outdegree(i) + 1 indegree(j) = indegree(j) + 1 end if end if end do end do return end subroutine cdmg_degree_w ( adj, nnode, indegree, outdegree ) !*****************************************************************************80 ! !! CDMG_DEGREE_W computes the weighted degrees of a color dimultigraph. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NNODE), ! the weighted indegree and outdegree of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer indegree(nnode) integer j integer outdegree(nnode) indegree(1:nnode) = 0 outdegree(1:nnode) = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then if ( adj(i,j) /= 0 ) then outdegree(i) = outdegree(i) + adj(i,j) indegree(j) = indegree(j) + adj(i,j) end if end if end do end do return end subroutine cdmg_edge_count ( adj, nnode, nedge_u, nedge_w ) !*****************************************************************************80 ! !! CDMG_EDGE_COUNT counts the number of edges in a color dimultigraph. ! ! Discussion: ! ! The number of "unweighted" edges is the number of edges in the ! underlying digraph, or the number of edges that would be counted ! if each set of multiple edges was replaced by a single edge. ! ! The number of "weighted" edges counts separately each edge of a ! multiple edge. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE_U, the number of unweighted edges. ! ! Output, integer NEDGE_W, the number of weighted edges. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer j integer nedge_u integer nedge_w nedge_u = 0 nedge_w = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then nedge_w = nedge_w + adj(i,j) if ( 0 < adj(i,j) ) then nedge_u = nedge_u + 1 end if end if end do end do return end subroutine cdmg_example_octo ( example, adj, nnode, seed ) !*****************************************************************************80 ! !! CDMG_EXAMPLE_OCTO sets up an 8 node example color dimultigraph. ! ! Modified: ! ! 11 May 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EXAMPLE, chooses the example, and should be between ! 1 and 12. ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information for the graph. ! ADJ(I,I) is the color of node I. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Input, integer NNODE, the number of nodes, which should be 8. ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer nnode integer adj(8,8) integer, parameter :: BLUE = 1 integer example integer, parameter :: GREEN = 2 integer i4_uniform integer nsave integer, parameter :: RED = 3 integer seed integer, parameter :: YELLOW = 5 integer, parameter :: ZIRCON = 4 if ( example <= 0 ) then nsave = i4_uniform ( 1, 12, seed ) else nsave = mod ( example - 1, 12 ) + 1 end if nnode = 8 adj(1:nnode,1:nnode) = 0 ! ! #1. ! if ( nsave == 1 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #2, same NNODE, different number of unweighted edges. ! else if ( nsave == 2 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #3, same NNODE, unweighted edges, different weighted edges. ! else if ( nsave == 3 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 1 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #4, different number of colors ! else if ( nsave == 4 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = GREEN adj(6,7) = 1 adj(7,7) = BLUE adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #5, different maximum color index. ! else if ( nsave == 5 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = ZIRCON ! ! #6, different color sequence. ! else if ( nsave == 6 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = GREEN adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #7, unweighted outdegree sequence. ! else if ( nsave == 7 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(2,6) = 2 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #8, unweighted indegree sequence. ! else if ( nsave == 8 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,7) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #9, adjacency max max ! else if ( nsave == 9 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 3 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 3 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #10, adjacency max sequence. ! else if ( nsave == 10 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 2 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 2 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #11, weighted outdegree sequence ! else if ( nsave == 11 ) then adj(1,1) = BLUE adj(1,2) = 1 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 2 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #12, weighted indegree sequence. ! else if ( nsave == 12 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 1 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 2 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #13: weighted adjacency sequence NOT SET UP YET ! else if ( nsave == 13 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW ! ! #14: code NOT SET UP YET ! else if ( nsave == 14 ) then adj(1,1) = BLUE adj(1,2) = 2 adj(1,6) = 2 adj(2,2) = BLUE adj(2,3) = 3 adj(2,5) = 1 adj(3,3) = BLUE adj(3,4) = 1 adj(3,8) = 4 adj(4,4) = GREEN adj(4,5) = 1 adj(4,7) = 2 adj(5,5) = GREEN adj(5,6) = 1 adj(6,6) = RED adj(6,7) = 1 adj(7,7) = RED adj(7,8) = 2 adj(8,1) = 1 adj(8,8) = YELLOW end if ! ! Now permute the graph. ! call i4mat_perm_random ( nnode, adj, seed ) return end subroutine cdmg_order_code ( adj, nnode, npart, code, order ) !*****************************************************************************80 ! !! CDMG_ORDER_CODE returns the color dimultigraph code for a specific node ordering. ! ! Modified: ! ! 27 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NPART, the number of nodes to consider. ! NPART should be between 1 and NNODE. ! ! If NPART is NNODE, then the usual code is returned. ! ! If NPART is less than NNODE, then the code is computed as ! though only NPART nodes existed, namely, those specified in the ! first NPART entries of order. This option is provided so that ! the routine can compute the portion of a code determined ! by an incomplete ordering of the nodes. ! ! Output, integer CODE(NNODE,NNODE), the code for this ordering. ! ! Input, integer ORDER(NNODE), the ordering of the nodes. ORDER(1) ! is the first node, and so on. ! implicit none integer nnode integer adj(nnode,nnode) integer code(nnode,nnode) integer i integer j integer ni integer nj integer npart integer order(nnode) do i = 1, nnode if ( i <= npart ) then ni = order(i) if ( order(i) < 1 .or. nnode < order(i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_ORDER_CODE - Fatal error!' write ( *, '(a)' ) ' ORDER is not a proper permutation.' stop end if else ni = 0 end if do j = 1, nnode if ( j <= npart ) then nj = order(j) if ( order(j) < 1 .or. nnode < order(j) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CDMG_ORDER_CODE - Fatal error!' write ( *, '(a)' ) ' ORDER is not a proper permutation.' stop end if else nj = 0 end if if ( ni == 0 .or. nj == 0 ) then code(i,j) = 0 else code(i,j) = adj(ni,nj) end if end do end do return end subroutine cdmg_print ( adj, nnode, title ) !*****************************************************************************80 ! !! CDMG_PRINT prints out an adjacency matrix for a color dimultigraph. ! ! Discussion: ! ! Color values between 1 and 10 will be printed as ! 'R', 'G', 'B', 'C', 'M', 'Y', 'K', 'W', 'P', 'O' ! ! Adjacency values between 0 and 9 will be printed as is. ! Other values will be printed as '*'. ! ! Modified: ! ! 06 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is ! the number of edges from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer nnode integer adj(nnode,nnode) character, dimension ( 10 ) :: color = & (/ 'R', 'G', 'B', 'C', 'M', 'Y', 'K', 'W', 'P', '0' /) integer i integer j integer jhi character ( len = 80 ) string character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode jhi = min ( nnode, 80 ) do j = 1, jhi if ( i == j ) then if ( 1 <= adj(i,j) .and. adj(i,j) <= 10 ) then string(j:j) = color ( adj(i,j) ) else string(j:j) = '*' end if else if ( 0 <= adj(i,j) .and. adj(i,j) <= 9 ) then string(j:j) = char ( 48 + adj(i,j) ) else string(j:j) = '*' end if end if end do write ( *, '(2x,a)' ) string(1:jhi) end do return end subroutine cdmg_random ( adj, nnode, ncolor, nedge, seed ) !*****************************************************************************80 ! !! CDMG_RANDOM generates a random color dimultigraph. ! ! Modified: ! ! 10 May 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency matrix. ! ADJ(I,J) is the number of edges from node I to node J. ! ADJ(I,I) will always be 0. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors. ! Each node is assumed to have an associated color, between 1 and NCOLOR, ! which will be chosen at random. ! ! Input, integer NEDGE, the number of edges. ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer ncolor integer nedge integer nnode integer adj(nnode,nnode) integer color_i integer edge_i integer i4_uniform integer node_i integer node_j integer perm(ncolor) integer seed integer subset(ncolor) ! ! Initialize the adjacency matrix. ! adj(1:nnode,1:nnode) = 0 ! ! Choose the colors. ! call ksub_random ( nnode, ncolor, subset, seed ) call perm_random ( ncolor, perm, seed ) do color_i = 1, ncolor node_i = subset(perm(color_i)) adj(node_i,node_i) = color_i end do do node_i = 1, nnode if ( adj(node_i,node_i) == 0 ) then adj(node_i,node_i) = i4_uniform ( 1, ncolor, seed ) end if end do ! ! Essentially, flip a coin NEDGE times to decide where each edge goes. ! do edge_i = 1, nedge node_i = i4_uniform ( 1, nnode, seed ) node_j = i4_uniform ( 1, nnode-1, seed ) if ( node_i <= node_j ) then node_j = node_j + 1 end if adj(node_i,node_j) = adj(node_i,node_j) + 1 end do return end subroutine cg_code_back ( adj, nnode, code, order ) !*****************************************************************************80 ! !! CG_CODE_BACK computes a color graph code via backtracking. ! ! Discussion: ! ! The code is the "largest" order code over all possible node orderings. ! The lexicographic ordering is used in comparing codes. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical, parameter :: debug = .false. integer index integer maxstack integer ncan(nnode) integer ncomp integer nopen integer nstack integer nswap integer order(nnode) integer result integer stack((nnode*(nnode+1))/2) if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_BACK - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if maxstack = ( nnode * ( nnode + 1 ) ) / 2 nstack = 0 stack(1) = 0 ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call cg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! index = 0 do call i4vec_backtrack ( nnode, order, index, nopen, nstack, stack, & maxstack, ncan ) ! ! If the backtrack routine has returned a complete candidate ordering, then ! compute the resulting code, and see it it is better ! then our current best. Then go back for the next backtrack search. ! if ( index == 1 ) then call cg_order_code ( adj, nnode, nnode, code, order ) call cg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if ! ! If the backtrack routine has a partial reordering, ! supply candidates for the next item in the ordering. ! else if ( index == 2 ) then call cg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) else exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_BACK:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap end if return end subroutine cg_code_brute ( adj, nnode, code, order ) !*****************************************************************************80 ! !! CG_CODE_BRUTE computes the color graph code via brute force. ! ! Discussion: ! ! The code is the "largest" order code over all node orderings. ! The lexicographic ordering is used in comparing codes. ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical even logical more integer ncomp integer nswap integer order(nnode) integer result ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call cg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! more = .false. do call perm_next ( nnode, order, more, even ) call cg_order_code ( adj, nnode, nnode, code, order ) call cg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if if ( .not. more ) then exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_BRUTE:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap return end subroutine cg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) !*****************************************************************************80 ! !! CG_CODE_CAND finds candidates for a maximal color graph code ordering. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer BESTCODE(NNODE,NNODE), the best code so far. ! ! Workspace, integer CODE(NNODE,NNODE). ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer NCOMP, the number of code comparisons. ! This routine updates NCOMP by 1 each time it is called. ! ! Input, integer NOPEN, identifies the first open position in ORDER. ! 1 <= NOPEN <= NNODE. ! ! Input, integer ORDER(NNODE), contains in entries 1 through NOPEN-1 ! the elements of the current partial list. ! ! Input/output, integer STACK(MAXSTACK), used to store the new candidates. ! ! Input, integer MAXSTACK, the maximum size of the STACK array. ! A value of NNODE should be sufficient. ! ! Input/output, integer NSTACK, the current length of the stack. ! On output, NSTACK has been increased by the number of ! candidates found. ! ! Input/output, integer NCAN(NNODE), the number of candidates for ! each position. ! implicit none integer maxstack integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer code(nnode,nnode) integer i integer ifree(nnode) integer j integer maxcolor integer ncan(nnode) integer ncomp integer nfree integer ni integer nj integer nopen integer nstack integer order(nnode) integer result integer stack(maxstack) if ( nopen < 1 .or. nnode < nopen ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_CAND - Fatal error 1!' write ( *, '(a)' ) ' 1 <= NOPEN <= NNODE should be true, but' write ( *, '(a,i8)' ) ' NOPEN = ', nopen write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if ! ! Start with no candidates. ! ncan(nopen) = 0 ! ! If we have fixed at least one entry of the list, ! ! Compute the partial code; ! ! Compare the partial code with the corresponding ! part of the the code for the best ordering so far; ! ! If the current incomplete ordering is actually LESS than the ! current best, then bail out now, with zero candidates. ! if ( 1 < nopen ) then call cg_order_code ( adj, nnode, nopen-1, code, order ) call cg_code_compare ( bestcode, code, nnode, nopen-1, result ) ncomp = ncomp + 1 if ( result == + 1 ) then ncan(nopen) = 0 return end if end if ! ! Get a list of those nodes which have not been used yet. ! nfree = nnode + 1 - nopen call perm_free ( order, nopen-1, ifree, nfree ) ! ! Our preferred candidates will be ! * unused neighbors of the LOWEST ordered node possible. ! ncan(nopen) = 0 do i = 1, nopen-1 ni = order(i) do j = 1, nfree nj = ifree(j) if ( adj(ni,nj) /= 0 .or. adj(nj,ni) /= 0 ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_CAND - Fatal error 4!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = nj end if end do ! ! If in the middle of this loop, we found unused neighbors of the ! lowest ordered node possible, then these are the only candidates ! worth considering. ! if ( 0 < ncan(nopen) ) then return end if end do ! ! If we get here, then NO unused nodes are connected in any way to ! used nodes. This can happen in two ways: ! ! * NOPEN = 1; (the list of used nodes is empty) ! * The graph is disconnected; ! ! In either case, we must now consider ALL free nodes. ! ! Compute the maximal color. ! maxcolor = 0 do i = 1, nfree ni = ifree(i) maxcolor = max ( maxcolor, adj(ni,ni) ) end do ! ! Take as candidates every node of color MAXCOLOR. ! ! We could thin the list down, by looking ahead, and only taking ! candidates of MAXCOLOR who also happen to have at least one free ! out neighbor, and so on. ! ncan(nopen) = 0 do i = 1, nfree ni = ifree(i) if ( adj(ni,ni) == maxcolor ) then ncan(nopen) = ncan(nopen) + 1 nstack = nstack + 1 if ( maxstack < nstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_CAND - Fatal error 6!' write ( *, '(a)' ) ' MAXSTACK < NSTACK!' write ( *, '(a,i8)' ) ' NSTACK = ', nstack write ( *, '(a,i8)' ) ' MAXSTACK = ', maxstack stop end if stack(nstack) = ni end if end do ! ! This should never happen: ! if ( ncan(nopen) == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CODE_CAND - Fatal error 7!' write ( *, '(a)' ) ' No candidates, but there gotta be some!' stop end if return end subroutine cg_code_compare ( code1, code2, nnode, npart, result ) !*****************************************************************************80 ! !! CG_CODE_COMPARE compares two (partial) color graph codes. ! ! Discussion: ! ! CODE1 = CODE2 if every digit of both codes is equal. ! ! Otherwise, we consider the entries in a special order: ! ! if ( CODE1(I,J) < CODE2(I,J) ) then we say ! CODE1 < CODE2 ! else ! CODE2 < CODE1 ! ! Modified: ! ! 10 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer CODE1(NNODE,NNODE), CODE2(NNODE,NNODE), codes to compare. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NPART, specifies the portion of the codes ! to compare. NPART should be between 1 and NNODE. ! ! If NPART = NNODE, then the full codes are compared. ! ! If NPART < NNODE, then only entries corresponding to I and J ! both less than or equal to NPART will be compared. ! ! Output, integer RESULT: ! -1, CODE1 < CODE2; ! 0, CODE1 = CODE2; ! +1, CODE2 < CODE1. ! implicit none integer nnode integer code1(nnode,nnode) integer code2(nnode,nnode) integer i integer j integer npart integer result do j = 1, npart do i = 1, j if ( code1(i,j) < code2(i,j) ) then result = - 1 return else if ( code2(i,j) < code1(i,j) ) then result = + 1 return end if end do end do result = 0 return end subroutine cg_code_print ( nnode, code, title ) !*****************************************************************************80 ! !! CG_CODE_PRINT prints a color graph code. ! ! Modified: ! ! 06 September ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer CODE(NNODE,NNODE), the code. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer nnode integer code(nnode,nnode) integer i character ( len = 80 ) string character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode string(i:i) = '.' end do do i = 1, nnode write ( *, '(2x,a,80i1)' ) string(1:i-1), code(i,i:nnode) end do return end subroutine cg_color_count ( adj, nnode, mcolor, ncolor ) !*****************************************************************************80 ! !! CG_COLOR_COUNT counts the number of colors in a color graph. ! ! Modified: ! ! 27 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer MCOLOR, the maximum color index. ! ! Output, integer NCOLOR, the number of colors. ! implicit none integer nnode integer adj(nnode,nnode) integer colors(nnode) integer i integer mcolor integer ncolor mcolor = 0 do i = 1, nnode mcolor = max ( mcolor, adj(i,i) ) end do do i = 1, nnode colors(i) = adj(i,i) end do call i4vec_sort_heap_d ( nnode, colors ) call i4vec_sorted_unique_count ( nnode, colors, ncolor ) return end subroutine cg_color_sequence ( adj, nnode, seq ) !*****************************************************************************80 ! !! CG_COLOR_SEQUENCE computes the color sequence of a color graph. ! ! Discussion: ! ! The color sequence of a color graph is constructed by computing the ! color of each node, and then ordering these values in decreasing order. ! ! If two color graphs are isomorphic, they must have the same color sequence. ! ! Modified: ! ! 02 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the color sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer seq(nnode) do i = 1, nnode seq(i) = adj(i,i) end do call i4vec_sort_heap_d ( nnode, seq ) return end subroutine cg_compare ( adj1, nnode1, adj2, nnode2, order1, & order2, result ) !*****************************************************************************80 ! !! CG_COMPARE determines if color graphs G1 and G2 are isomorphic. ! ! Modified: ! ! 02 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ1(NNODE1,NNODE1), the adjacency information for G1. ! ADJ1(I,I) is the color of node I; otherwise, ADJ1(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE1, the number of nodes in G1. ! ! Input, integer ADJ2(NNODE2,NNODE2), the adjacency information for G2. ! ADJ2(I,I) is the color of node I; otherwise, ADJ2(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE2, the number of nodes in G2. ! ! Output, integer RESULT, is 0 if the color graphs are isomorphic, ! -I if G1 < G2 for test #I, and ! +I if G2 < G1 for test #I. ! ! Output, integer ORDER1(NNODE1), ORDER2(NNODE2). If RESULT = 0, then ! ORDER1 and ORDER2 are reorderings of the nodes of G1 and ! G2 which exhibit the isomorphism. ! implicit none integer nnode1 integer nnode2 integer adj1(nnode1,nnode1) integer adj2(nnode2,nnode2) integer code1(nnode1,nnode1) integer code2(nnode2,nnode2) integer mcolor1 integer mcolor2 integer ncolor1 integer ncolor2 integer nedge1 integer nedge2 integer order1(nnode1) integer order2(nnode2) integer result integer seq1(nnode1) integer seq2(nnode2) ! ! Test 1: Count the nodes. ! if ( nnode1 < nnode2 ) then result = - 1 return else if ( nnode2 < nnode1 ) then result = + 1 return end if ! ! Test 2: Count the edges. ! call cg_edge_count ( adj1, nnode1, nedge1 ) call cg_edge_count ( adj2, nnode2, nedge2 ) if ( nedge1 < nedge2 ) then result = - 2 return else if ( nedge2 < nedge1 ) then result = + 2 return end if ! ! Tests 3 and 4: Count the colors, and note the maximum color. ! call cg_color_count ( adj1, nnode1, mcolor1, ncolor1 ) call cg_color_count ( adj2, nnode2, mcolor2, ncolor2 ) if ( ncolor1 < ncolor2 ) then result = - 3 return else if ( ncolor2 < ncolor1 ) then result = + 3 return end if if ( mcolor1 < mcolor2 ) then result = - 4 return else if ( mcolor2 < mcolor1 ) then result = + 4 return end if ! ! Test 5: Compare the degree sequences. ! call cg_degree_seq ( adj1, nnode1, seq1 ) call cg_degree_seq ( adj2, nnode2, seq2 ) call i4vec_compare ( nnode1, seq1, seq2, result ) if ( result < 0 ) then result = - 5 return else if ( 0 < result ) then result = + 5 return end if ! ! Test 6: Compare the color sequences. ! call cg_color_sequence ( adj1, nnode1, seq1 ) call cg_color_sequence ( adj2, nnode2, seq2 ) call i4vec_compare ( nnode1, seq1, seq2, result ) if ( result < 0 ) then result = - 6 return else if ( 0 < result ) then result = + 6 return end if ! ! Test 7: Compare the codes. ! call cg_code_back ( adj1, nnode1, code1, order1 ) call cg_code_back ( adj2, nnode2, code2, order2 ) call cg_code_compare ( code1, code2, nnode1, nnode1, result ) if ( result < 0 ) then result = - 7 return else if ( 0 < result ) then result = + 7 return end if result = 0 return end subroutine cg_connect_random ( adj, nnode, ncolor, nedge, seed ) !*****************************************************************************80 ! !! CG_CONNECT_RANDOM generates a random connected color graph. ! ! Modified: ! ! 10 May 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors. ! NCOLOR must be at least 1, and no more than NNODE. ! ! Input, integer NEDGE, the number of edges, which must be between ! NNODE-1 and (NNODE*(NNODE-1))/2. ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer ncolor integer nnode integer nedge integer adj(nnode,nnode) integer code(nnode-2) integer i integer i4_uniform integer icolor integer inode(nnode-1) integer iwork(nedge) integer j integer jnode(nnode-1) integer k integer l integer maxedge integer nchoice integer nchoose integer perm(ncolor) integer seed integer subset(ncolor) ! ! Check. ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nedge write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if maxedge = ( nnode * ( nnode - 1 ) ) / 2 if ( nedge < nnode-1 .or. maxedge < nedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i8)' ) ' no more than ', maxedge stop end if if ( ncolor < 1 .or. nnode < ncolor ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NCOLOR = ', ncolor write ( *, '(a)' ) ' but NCOLOR must be at least 1, and ' write ( *, '(a,i8)') ' no more than ', nnode stop end if ! ! Initialize the adjacency matrix. ! adj(1:nnode,1:nnode) = 0 ! ! Choose the colors. ! call ksub_random ( nnode, ncolor, subset, seed ) call perm_random ( ncolor, perm, seed ) do icolor = 1, ncolor i = subset(perm(icolor)) adj(i,i) = icolor end do do i = 1, nnode if ( adj(i,i) == 0 ) then adj(i,i) = i4_uniform ( 1, ncolor, seed ) end if end do ! ! Pick a random tree. ! call tree_arc_random ( nnode, code, inode, jnode, seed ) ! ! Convert information to adjacency form. ! call g_arc_to_g_adj ( nnode-1, inode, jnode, adj, nnode ) ! ! Now we have NEDGE - ( NNODE - 1 ) more edges to add. ! nchoice = ( nnode * ( nnode - 1 ) ) / 2 - ( nnode - 1 ) nchoose = nedge - ( nnode - 1 ) call ksub_random ( nchoice, nchoose, iwork, seed ) k = 0 l = 1 do i = 1, nnode do j = i + 1, nnode if ( adj(i,j) /= 0 ) then k = k + 1 if ( l <= nchoose ) then if ( iwork(l) == k ) then adj(i,j) = 1 adj(j,i) = 1 l = l + 1 end if end if end if end do end do return end subroutine cg_degree ( adj, nnode, degree ) !*****************************************************************************80 ! !! CG_DEGREE computes the degree of each node. ! ! Discussion: ! ! The degree of a node is the number of edges that are incident on it. ! The sum of the degrees of the nodes is twice the number of edges. ! ! The generalized case, where ADJ(I,J) can be greater than 1, indicating ! the existence of 2 or more distinct edges between nodes I and J, ! will be properly handled by this routine. ! ! Modified: ! ! 10 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DEGREE(NNODE), the degree of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer degree(nnode) integer i integer j degree(1:nnode) = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then if ( adj(i,j) /= 0 ) then degree(i) = degree(i) + adj(i,j) end if end if end do end do return end subroutine cg_degree_seq ( adj, nnode, seq ) !*****************************************************************************80 ! !! CG_DEGREE_SEQ computes the degree sequence of a color graph. ! ! Discussion: ! ! The degree sequence of a color graph is constructed by computing the ! degree of each node, and then ordering these values in decreasing order. ! ! If two color graphs are isomorphic, they must have the same ! degree sequence. ! ! Modified: ! ! 10 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the degree sequence. ! implicit none integer nnode integer adj(nnode,nnode) integer seq(nnode) call cg_degree ( adj, nnode, seq ) call i4vec_sort_heap_d ( nnode, seq ) return end subroutine cg_edge_count ( adj, nnode, nedge ) !*****************************************************************************80 ! !! CG_EDGE_COUNT counts the number of edges in a color graph. ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE, the number of edges. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer j integer nedge nedge = 0 do i = 1, nnode do j = 1, nnode if ( i /= j ) then nedge = nedge + adj(i,j) end if end do end do nedge = nedge / 2 return end subroutine cg_example_bush ( adj, nnode ) !*****************************************************************************80 ! !! CG_EXAMPLE_BUSH sets up the bush color graph. ! ! Diagram: ! ! 6G 3R ! | | ! 1B--4G--5W--2R ! | ! 7W ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Output, integer NNODE, the number of nodes. ! implicit none integer adj(7,7) integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer nnode integer, parameter :: RED = 3 integer, parameter :: WHITE = 4 nnode = 7 adj(1:nnode,1:nnode) = 0 adj(1,1) = BLUE adj(1,4) = 1 adj(2,2) = RED adj(2,5) = 1 adj(3,3) = RED adj(3,5) = 1 adj(4,1) = 1 adj(4,4) = GREEN adj(4,5) = 1 adj(4,6) = 1 adj(4,7) = 1 adj(5,2) = 1 adj(5,3) = 1 adj(5,4) = 1 adj(5,5) = WHITE adj(6,4) = 1 adj(6,6) = GREEN adj(7,4) = 1 adj(7,7) = WHITE return end subroutine cg_example_cube ( adj, nnode ) !*****************************************************************************80 ! !! CG_EXAMPLE_CUBE sets up the cube color graph. ! ! Diagram: ! ! 4R----7R ! /| /| ! 8B----3B| ! | | | | ! | 5B--|-2G ! |/ |/ ! 1G----6B ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Output, integer NNODE, the number of nodes, which is 8. ! implicit none integer adj(8,8) integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer nnode integer, parameter :: RED = 3 nnode = 8 adj(1:nnode,1:nnode) = 0 adj(1,1) = GREEN adj(1,5) = 1 adj(1,6) = 1 adj(1,8) = 1 adj(2,2) = GREEN adj(2,5) = 1 adj(2,6) = 1 adj(2,7) = 1 adj(3,3) = BLUE adj(3,6) = 1 adj(3,7) = 1 adj(3,8) = 1 adj(4,4) = RED adj(4,5) = 1 adj(4,7) = 1 adj(4,8) = 1 adj(5,5) = BLUE adj(5,1) = 1 adj(5,2) = 1 adj(5,4) = 1 adj(6,6) = BLUE adj(6,1) = 1 adj(6,2) = 1 adj(6,3) = 1 adj(7,7) = RED adj(7,2) = 1 adj(7,3) = 1 adj(7,4) = 1 adj(8,8) = BLUE adj(8,1) = 1 adj(8,3) = 1 adj(8,4) = 1 return end subroutine cg_example_octo ( example, adj, nnode, seed ) !*****************************************************************************80 ! !! CG_EXAMPLE_OCTO sets up an 8 node example color graph. ! ! Diagram: ! ! 1---2 ! /| |\ ! 8-+---+-3 ! | | | | ! 7-+---+-4 ! \| |/ ! 6---5 ! ! Graph "A" ! ! There are 8 graphs to choose from. They are all on 8 nodes. The first ! 5 have degree 3 at every node. Graphs 6 and 7 have degree 5 at every ! node. Graph 8 is disconnected. ! ! Modified: ! ! 10 May 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EXAMPLE, the index of the example, between 1 and 40. ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Output, integer NNODE, the number of nodes, which should be 8. ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer adj(8,8) integer, parameter :: BLUE = 1 integer example integer, parameter :: GREEN = 2 integer i integer i4_uniform integer j integer msave integer nnode integer nsave integer, parameter :: RED = 3 integer seed integer, parameter :: YELLOW = 4 if ( example <= 0 ) then nsave = i4_uniform ( 1, 8, seed ) msave = i4_uniform ( 1, 5, seed ) else example = mod ( example - 1, 40 ) + 1 msave = ( ( example - 1 ) / 8 ) + 1 nsave = mod ( example - 1, 8 ) + 1 end if nnode = 8 adj(1:nnode,1:nnode) = 0 do i = 1, nnode j = i + 1 if ( nnode < j ) then j = j - nnode end if adj(i,j) = 1 adj(j,i) = 1 end do ! ! Underlying graph 1. ! if ( nsave == 1 ) then adj(1,6) = 1 adj(6,1) = 1 adj(2,5) = 1 adj(5,2) = 1 adj(3,8) = 1 adj(8,3) = 1 adj(4,7) = 1 adj(7,4) = 1 ! ! Underlying graph 2. ! else if ( nsave == 2 ) then adj(1,6) = 1 adj(6,1) = 1 adj(2,8) = 1 adj(8,2) = 1 adj(3,5) = 1 adj(5,3) = 1 adj(4,7) = 1 adj(7,4) = 1 ! ! Underlying graph 3. ! else if ( nsave == 3 ) then adj(1,5) = 1 adj(5,1) = 1 adj(2,6) = 1 adj(6,2) = 1 adj(3,7) = 1 adj(7,3) = 1 adj(4,8) = 1 adj(8,4) = 1 ! ! Underlying graph 4. ! else if ( nsave == 4 ) then adj(1,3) = 1 adj(3,1) = 1 adj(2,4) = 1 adj(4,2) = 1 adj(5,7) = 1 adj(7,5) = 1 adj(6,8) = 1 adj(8,6) = 1 ! ! Underlying graph 5. ! else if ( nsave == 5 ) then adj(1,4) = 1 adj(4,1) = 1 adj(2,6) = 1 adj(6,2) = 1 adj(3,8) = 1 adj(8,3) = 1 adj(5,7) = 1 adj(7,5) = 1 ! ! Underlying graph 6. ! else if ( nsave == 6 ) then adj(1,4) = 1 adj(4,1) = 1 adj(1,5) = 1 adj(5,1) = 1 adj(1,6) = 1 adj(6,1) = 1 adj(2,5) = 1 adj(5,2) = 1 adj(2,6) = 1 adj(6,2) = 1 adj(2,7) = 1 adj(7,2) = 1 adj(3,6) = 1 adj(6,3) = 1 adj(3,7) = 1 adj(7,3) = 1 adj(3,8) = 1 adj(8,3) = 1 adj(4,7) = 1 adj(7,4) = 1 adj(4,8) = 1 adj(8,4) = 1 adj(5,8) = 1 adj(8,5) = 1 ! ! Underlying graph 7. ! else if ( nsave == 7 ) then adj(1,3) = 1 adj(3,1) = 1 adj(1,5) = 1 adj(5,1) = 1 adj(1,7) = 1 adj(7,1) = 1 adj(2,4) = 1 adj(4,2) = 1 adj(2,6) = 1 adj(6,2) = 1 adj(2,8) = 1 adj(8,2) = 1 adj(3,5) = 1 adj(5,3) = 1 adj(3,7) = 1 adj(7,3) = 1 adj(4,6) = 1 adj(6,4) = 1 adj(4,8) = 1 adj(8,4) = 1 adj(5,7) = 1 adj(7,5) = 1 adj(6,8) = 1 adj(8,6) = 1 else if ( nsave == 8 ) then adj(1,2) = 1 adj(2,1) = 1 adj(1,3) = 1 adj(3,1) = 1 adj(2,3) = 1 adj(3,2) = 1 adj(3,4) = 1 adj(4,3) = 1 adj(5,6) = 1 adj(6,5) = 1 adj(5,7) = 1 adj(7,5) = 1 adj(6,7) = 1 adj(7,6) = 1 end if if ( msave == 1 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = BLUE adj(7,7) = GREEN adj(8,8) = GREEN else if ( msave == 2 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = BLUE adj(7,7) = GREEN adj(8,8) = YELLOW else if ( msave == 3 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = BLUE adj(7,7) = YELLOW adj(8,8) = YELLOW else if ( msave == 4 ) then adj(1,1) = RED adj(2,2) = RED adj(3,3) = RED adj(4,4) = BLUE adj(5,5) = BLUE adj(6,6) = GREEN adj(7,7) = GREEN adj(8,8) = GREEN else if ( msave == 5 ) then adj(1,1) = RED adj(2,2) = BLUE adj(3,3) = RED adj(4,4) = GREEN adj(5,5) = BLUE adj(6,6) = RED adj(7,7) = BLUE adj(8,8) = GREEN end if ! ! Now permute the graph. ! call i4mat_perm_random ( nnode, adj, seed ) return end subroutine cg_example_twig ( adj, nnode ) !*****************************************************************************80 ! !! CG_EXAMPLE_TWIG sets up the twig color graph. ! ! Diagram: ! ! 1R---2R---3B ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Output, integer NNODE, the number of nodes. ! implicit none integer adj(3,3) integer, parameter :: BLUE = 1 integer nnode integer, parameter :: RED = 3 nnode = 3 adj(1:nnode,1:nnode) = 0 adj(1,1) = RED adj(1,2) = 1 adj(2,1) = 1 adj(2,2) = RED adj(2,3) = 1 adj(3,2) = 1 adj(3,3) = BLUE return end subroutine cg_order_code ( adj, nnode, npart, code, order ) !*****************************************************************************80 ! !! CG_ORDER_CODE returns the color graph code for a specific node ordering. ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NPART, the number of nodes to consider. ! NPART should be between 1 and NNODE. ! ! If NPART is NNODE, then the full code is returned. ! ! If NPART is less than NNODE, then the code is computed as ! though only NPART nodes existed, namely, those specified in the ! first NPART entries of order. This option is provided so that ! the routine can compute the portion of a code determined ! by an incomplete ordering of the nodes. ! ! Output, integer CODE(NNODE,NNODE), the code for this ordering. ! ! Input, integer ORDER(NNODE), the ordering of the nodes. ORDER(1) ! is the first node, and so on. ! implicit none integer nnode integer adj(nnode,nnode) integer code(nnode,nnode) integer i integer j integer ni integer nj integer npart integer order(nnode) do i = 1, nnode if ( i <= npart ) then ni = order(i) if ( order(i) < 1 .or. nnode < order(i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_ORDER_CODE - Fatal error!' write ( *, '(a)' ) ' ORDER is not a proper permutation.' stop end if else ni = 0 end if do j = i, nnode if ( j <= npart ) then nj = order(j) if ( order(j) < 1 .or. nnode < order(j) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_ORDER_CODE - Fatal error!' write ( *, '(a)' ) ' ORDER is not a proper permutation.' stop end if else nj = 0 end if if ( ni == 0 .or. nj == 0 ) then code(i,j) = 0 else if ( ni <= nj ) then code(i,j) = adj(ni,nj) else code(i,j) = adj(nj,ni) end if end do end do return end subroutine cg_print ( adj, nnode, title ) !*****************************************************************************80 ! !! CG_PRINT prints out the adjacency matrix of a color graph. ! ! Modified: ! ! 06 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title to be printed. ! implicit none integer nnode integer adj(nnode,nnode) integer i integer j integer k character ( len = 80 ) string character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode do j = 1, nnode k = (j-1) * 3 + 1 write ( string(k:k+2), '(i3)' ) adj(i,j) end do write ( *, '(2x,a)' ) string(1:3*nnode) end do return end subroutine cg_random ( adj, nnode, ncolor, nedge, seed ) !*****************************************************************************80 ! !! CG_RANDOM generates a random color graph. ! ! Modified: ! ! 10 May 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive ! if there is an edge between node I and node J. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors. ! NCOLOR must be at least 1, and no more than NNODE. ! ! Input, integer NEDGE, the number of edges, which must be between ! 0 and (NNODE*(NNODE-1))/2. ! ! Input/output, integer SEED, a seed for the random number generator. ! implicit none integer nnode integer nedge integer adj(nnode,nnode) integer i integer i4_uniform integer icolor integer iwork(nedge) integer j integer k integer l integer maxedge integer ncolor integer perm(ncolor) integer seed integer subset(ncolor) if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nedge write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if maxedge = ( nnode * ( nnode - 1 ) ) / 2 if ( nedge < 0 .or. maxedge < nedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i8)' ) ' no more than ', maxedge stop end if if ( ncolor < 1 .or. nnode < ncolor ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CG_RANDOM - Fatal error!' write ( *, '(a)' ) ' Illegal value of NCOLOR.' stop end if ! ! Start out with no edges and no colors. ! adj(1:nnode,1:nnode) = 0 ! ! Choose the colors. ! call ksub_random ( nnode, ncolor, subset, seed ) call perm_random ( ncolor, perm, seed ) do icolor = 1, ncolor i = subset(perm(icolor)) adj(i,i) = icolor end do do i = 1, nnode if ( adj(i,i) == 0 ) then adj(i,i) = i4_uniform ( 1, ncolor, seed ) end if end do ! ! Pick a random NEDGE subset of (N*(N-1))/2. ! call ksub_random ( maxedge, nedge, iwork, seed ) ! ! The (n*(n-1))/2 spots in the superdiagonal are numbered as follows: ! ! * 1 2 3 ... n-1 n ! * * n+1 n+2 ... 2n-2 2n-1 ! ... ! * * * * ... * (n*(n-1))/2 ! * * * * ... * * ! k = 0 l = 1 do i = 1, nnode-1 do j = i+1, nnode k = k + 1 if ( l <= nedge ) then if ( k == iwork(l) ) then adj(i,j) = 1 adj(j,i) = 1 l = l + 1 end if end if end do end do return end subroutine dg_code_back ( adj, nnode, code, order ) !*****************************************************************************80 ! !! DG_CODE_BACK computes a digraph code via backtracking. ! ! Discussion: ! ! The code is the "largest" order code (in the lexicographic ! sense) over all possible node orderings. The backtracking method ! organizes the search of all possible node orderings so that if ! a partial node ordering is sure to generate an order code ! less than the best so far, then all the orderings that begin with ! this partial ordering are immediately dropped from consideration. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical, parameter :: debug = .false. integer index integer maxstack integer ncan(nnode) integer ncomp integer nopen integer nstack integer nswap integer order(nnode) integer result integer stack(4*nnode) if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DG_CODE_BACK - Fatal error!' write ( *, '(a,i8)' ) ' NNODE = ', nnode stop end if maxstack = 4 * nnode nstack = 0 stack(1) = 0 ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call dg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! index = 0 do call i4vec_backtrack ( nnode, order, index, nopen, nstack, stack, & maxstack, ncan ) ! ! If the backtrack routine has returned a complete candidate ordering, then ! compute the resulting code, and see it it is better ! then our current best. Then go back for the next backtrack search. ! if ( index == 1 ) then call dg_order_code ( adj, nnode, nnode, code, order ) call dg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if ! ! If the backtrack routine has a partial reordering, ! supply candidates for the next item in the ordering. ! else if ( index == 2 ) then call dg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) else exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DG_CODE_BACK:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap end if return end subroutine dg_code_brute ( adj, nnode, code, order ) !*****************************************************************************80 ! !! DG_CODE_BRUTE computes a digraph code via brute force. ! ! Discussion: ! ! The code is the "largest" order code in the lexicographic ! sense over all node orderings. The brute force method ! considers every node ordering, computes the corresponding ! order code, and takes the largest one encountered. ! ! Modified: ! ! 28 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer CODE(NNODE,NNODE), the code. ! ! Output, integer ORDER(NNODE), the ordering of the nodes. ! implicit none integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer bestorder(nnode) integer code(nnode,nnode) logical even logical more integer ncomp integer nswap integer order(nnode) integer result ncomp = 0 nswap = 0 ! ! Start with the identity ordering. ! call i4vec_indicator ( nnode, order ) ! ! Compute the corresponding code. ! call dg_order_code ( adj, nnode, nnode, code, order ) ! ! Take this ordering and code as the best so far. ! bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) ! ! Now consider all possible orderings, and their codes. ! more = .false. do call perm_next ( nnode, order, more, even ) call dg_order_code ( adj, nnode, nnode, code, order ) call dg_code_compare ( bestcode, code, nnode, nnode, result ) ncomp = ncomp + 1 if ( result == - 1 ) then nswap = nswap + 1 bestorder(1:nnode) = order(1:nnode) bestcode(1:nnode,1:nnode) = code(1:nnode,1:nnode) end if if ( .not. more ) then exit end if end do ! ! Once we have examined all possibilites, we are done. ! ! Set the output ordering to the best ordering, and the output ! code to the corresponding best code. ! order(1:nnode) = bestorder(1:nnode) code(1:nnode,1:nnode) = bestcode(1:nnode,1:nnode) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DG_CODE_BRUTE:' write ( *, '(a,i8)' ) ' Comparisons: ', ncomp write ( *, '(a,i8)' ) ' Swaps: ', nswap return end subroutine dg_code_cand ( adj, bestcode, code, nnode, ncomp, nopen, & order, stack, maxstack, nstack, ncan ) !*****************************************************************************80 ! !! DG_CODE_CAND finds candidates for a maximal digraph code ordering. ! ! Modified: ! ! 21 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(NNODE,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer BESTCODE(NNODE,NNODE), the best code so far. ! ! Workspace, integer CODE(NNODE,NNODE). ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer NCOMP, the number of code comparisons. ! This routine updates NCOMP by 1 each time the routine is called. ! ! Input, integer NOPEN, identifies the first open position in ORDER. ! ! Input, integer ORDER(NNODE), contains in entries 1 through NOPEN-1 ! the elements of the current partial list. ! ! Input/output, integer STACK(MAXSTACK), used to store the new candidates. ! ! Input, integer MAXSTACK, the maximum size of the STACK array. ! ! Input/output, integer NSTACK, the current length of the stack. ! On output, NSTACK has been increased by the number of ! candidates found. ! ! Input/output, integer NCAN(NNODE), the number of candidates for ! each position. ! implicit none integer maxstack integer nnode integer adj(nnode,nnode) integer bestcode(nnode,nnode) integer code(nnode,nnode) integer i integer ifree(nnode) integer j inte