subroutine balanc ( nm, n, a, low, igh, scale ) ! !******************************************************************************* ! !! BALANC balances a real matrix before eigenvalue calculations. ! ! ! Discussion: ! ! This subroutine balances a real matrix and isolates eigenvalues ! whenever possible. ! ! Suppose that the principal submatrix in rows LOW through IGH ! has been balanced, that P(J) denotes the index interchanged ! with J during the permutation step, and that the elements ! of the diagonal matrix used are denoted by D(I,J). Then ! ! SCALE(J) = P(J), J = 1,...,LOW-1, ! = D(J,J), J = LOW,...,IGH, ! = P(J) J = IGH+1,...,N. ! ! The order in which the interchanges are made is N to IGH+1, ! then 1 to LOW-1. ! ! Note that 1 is returned for LOW if IGH is zero formally. ! ! Reference: ! ! J H Wilkinson and C Reinsch, ! Handbook for Automatic Computation, ! Volume II, Linear Algebra, Part 2, ! Springer Verlag, 1971. ! ! B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler, ! Matrix Eigensystem Routines, EISPACK Guide, ! Lecture Notes in Computer Science, Volume 6, ! Springer Verlag, 1976. ! ! Parameters: ! ! Input, integer NM, the leading dimension of A, which must ! be at least N. ! ! Input, integer N, the order of the matrix. ! ! Input/output, real A(NM,N), the N by N matrix. On output, ! the matrix has been balanced. ! ! Output, integer LOW, IGH, indicate that A(I,J) is equal to zero if ! (1) I is greater than J and ! (2) J=1,...,LOW-1 or I=IGH+1,...,N. ! ! Output, real SCALE(N), contains information determining the ! permutations and scaling factors used. ! implicit none ! integer nm integer n ! real a(nm,n) real b2 real c real f real g integer i integer iexc integer igh integer j integer k integer l integer low integer m logical noconv real r real, parameter :: radix = 16.0E+00 real s real scale(n) ! iexc = 0 j = 0 m = 0 b2 = radix * radix k = 1 l = n go to 100 20 continue scale(m) = j if ( j /= m ) then do i = 1, l call r_swap ( a(i,j), a(i,m) ) end do do i = k, n call r_swap ( a(j,i), a(m,i) ) end do end if 50 continue if ( iexc == 2 ) then go to 130 end if ! ! Search for rows isolating an eigenvalue and push them down. ! 80 continue if ( l == 1 ) then low = k igh = l return end if l = l - 1 100 continue do j = l, 1, -1 do i = 1, l if ( i /= j ) then if ( a(j,i) /= 0.0E+00 ) then go to 120 end if end if end do m = l iexc = 1 go to 20 120 continue end do go to 140 ! ! Search for columns isolating an eigenvalue and push them left. ! 130 continue k = k + 1 140 continue do j = k, l do i = k, l if ( i /= j ) then if ( a(i,j) /= 0.0E+00 ) then go to 170 end if end if end do m = k iexc = 2 go to 20 170 continue end do ! ! Balance the submatrix in rows K to L. ! scale(k:l) = 1.0E+00 ! ! Iterative loop for norm reduction. ! noconv = .true. do while ( noconv ) noconv = .false. do i = k, l c = 0.0E+00 r = 0.0E+00 do j = k, l if ( j /= i ) then c = c + abs ( a(j,i) ) r = r + abs ( a(i,j) ) end if end do ! ! Guard against zero C or R due to underflow. ! if ( c /= 0.0E+00 .and. r /= 0.0E+00 ) then g = r / radix f = 1.0E+00 s = c + r do while ( c < g ) f = f * radix c = c * b2 end do g = r * radix do while ( c >= g ) f = f / radix c = c / b2 end do ! ! Balance. ! if ( ( c + r ) / f < 0.95E+00 * s ) then g = 1.0E+00 / f scale(i) = scale(i) * f noconv = .true. a(i,k:n) = a(i,k:n) * g a(1:l,i) = a(1:l,i) * f end if end if end do end do low = k igh = l return end subroutine ch_cap ( c ) ! !******************************************************************************* ! !! CH_CAP capitalizes a single character. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none ! character c integer itemp ! itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end function ch_eqi ( c1, c2 ) ! !******************************************************************************* ! !! CH_EQI is a case insensitive comparison of two characters for equality. ! ! ! Examples: ! ! C_EQI ( 'A', 'a' ) is .TRUE. ! ! Modified: ! ! 14 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C1, C2, the characters to compare. ! ! Output, logical CH_EQI, the result of the comparison. ! implicit none ! logical ch_eqi character c1 character c2 character cc1 character cc2 ! cc1 = c1 cc2 = c2 call ch_cap ( cc1 ) call ch_cap ( cc2 ) if ( cc1 == cc2 ) then ch_eqi = .true. else ch_eqi = .false. end if return end subroutine ch_to_digit ( c, digit ) ! !******************************************************************************* ! !! CH_TO_DIGIT returns the integer value of a base 10 digit. ! ! ! Example: ! ! C DIGIT ! --- ----- ! '0' 0 ! '1' 1 ! ... ... ! '9' 9 ! ' ' 0 ! 'X' -1 ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character C, the decimal digit, '0' through '9' or blank ! are legal. ! ! Output, integer DIGIT, the corresponding integer value. If C was ! 'illegal', then DIGIT is -1. ! implicit none ! character c integer digit ! if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then digit = ichar ( c ) - 48 else if ( c == ' ' ) then digit = 0 else digit = - 1 end if return end subroutine catalan ( n, c ) ! !******************************************************************************* ! !! CATALAN computes the Catalan numbers, from C(0) to C(N). ! ! ! First values: ! ! C(0) 1 ! C(1) 1 ! C(2) 2 ! C(3) 5 ! C(4) 14 ! C(5) 42 ! C(6) 132 ! C(7) 429 ! C(8) 1430 ! C(9) 4862 ! C(10) 16796 ! ! Formula: ! ! C(N) = (2*N)! / ( (N+1) * (N!) * (N!) ) ! = 1 / (N+1) * COMB ( 2N, N ) ! = 1 / (2N+1) * COMB ( 2N+1, N+1). ! ! Recursion: ! ! C(N) = 2 * (2*N-1) * C(N-1) / (N+1) ! C(N) = SUM ( I = 1 to N-1 ) C(I) * C(N-I) ! ! Comments: ! ! The Catalan number C(N) counts: ! ! 1) the number of binary trees on N vertices; ! 2) the number of ordered trees on N+1 vertices; ! 3) the number of full binary trees on 2N+1 vertices; ! 4) the number of well formed sequences of 2N parentheses; ! 5) number of ways 2N ballots can be counted, in order, ! with N positive and N negative, so that the running sum ! is never negative; ! 6) the number of standard tableaus in a 2 by N rectangular Ferrers diagram; ! 7) the number of monotone functions from [1..N} to [1..N} which ! satisfy f(i) <= i for all i, ! 8) the number of ways to triangulate a polygon with N+2 vertices. ! ! Example: ! ! N = 3 ! ! ()()() ! ()(()) ! (()()) ! (())() ! ((())) ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 14 August 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of Catalan numbers desired. ! ! Output, integer C(0:N), the Catalan numbers from C(0) to C(N). ! implicit none ! integer n ! integer i integer c(0:n) ! c(0) = 1 ! ! The extra parentheses ensure that the integer division is ! done AFTER the integer multiplication. ! do i = 1, n c(i) = ( c(i-1) * 2 * ( 2 * i - 1 ) ) / ( i + 1 ) end do return end subroutine color_digraph_adj_degree ( adj, lda, nnode, indegree, outdegree ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_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(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NNODE), ! the indegree and outdegree of the nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,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 outdegree(i) = outdegree(i) + adj(i,j) indegree(j) = indegree(j) + adj(i,j) end if end do end do return end subroutine color_digraph_adj_degree_seq ( adj, lda, nnode, in_seq, out_seq ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_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(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer IN_SEQ(NNODE), OUT_SEQ(NNODE), ! the degree sequence of the digraph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer in_seq(nnode) integer out_seq(nnode) ! call color_digraph_adj_degree ( adj, lda, nnode, in_seq, out_seq ) call ivec2_sort_d ( nnode, out_seq, in_seq ) return end subroutine color_digraph_adj_edge_count ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_EDGE_COUNT counts the number of edges in a color digraph. ! ! ! Modified: ! ! 26 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE, the number of edges. ! implicit none ! integer lda integer nnode ! integer adj(lda,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 color_digraph_adj_example_cube ( adj, lda, nnode ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_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(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer, parameter :: RED = 3 ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 8 if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_EXAMPLE_CUBE - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if 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 color_digraph_adj_example_octo ( adj, lda, nnode ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example color digraph. ! ! ! Diagram: ! ! 1---2 ! /| |\ ! 8-+---+-3 ! | | | | ! 7-+---+-4 ! \| |/ ! 6---5 ! ! Graph "A" ! ! There are 7 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. ! ! Modified: ! ! 05 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), 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. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input/output, integer NNODE. ! On input, the value of NNODE should be between 1 and 60, and indicates ! which example graph to pick. ! On output, NNODE is the number of nodes, which should be 8. ! implicit none ! integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer, parameter :: RED = 3 integer, parameter :: YELLOW = 4 ! integer lda ! integer adj(lda,lda) integer i integer j integer msave integer nnode integer nsave ! if ( nnode <= 0 ) then call i_random ( 1, 12, nsave ) call i_random ( 1, 5, msave ) else nnode = mod ( nnode - 1, 60 ) + 1 msave = ( nnode - 1 ) / 12 + 1 nsave = mod ( nnode - 1, 12 ) + 1 end if nnode = 8 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 do i = 1, nnode j = i + 1 if ( j > nnode ) 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 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 imat_perm_random ( lda, nnode, adj ) return end subroutine color_digraph_adj_print ( adj, lda, nnode, title ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_PRINT prints out the adjacency matrix of a color digraph. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of ADJ, which must be ! least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k character ( len = 80 ) string character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) 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 ( *, '(i2,2x,a)' ) i, string(1:3*nnode) end do return end subroutine color_digraph_adj_random ( adj, lda, nnode, ncolor, nedge ) ! !******************************************************************************* ! !! COLOR_DIGRAPH_ADJ_RANDOM generates a random color graph. ! ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,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 LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors available. 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). ! implicit none ! integer lda integer ncolor integer nedge integer nnode ! integer adj(lda,nnode) integer i integer icolor integer iwork(nedge) integer j integer k integer l integer maxedge integer perm(ncolor) integer subset(ncolor) ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if maxedge = nnode * ( nnode - 1 ) if ( nedge < 0 .or. nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i6)' ) ' 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 ) call perm_random ( ncolor, perm ) do icolor = 1, ncolor i = subset(perm(icolor)) adj(i,i) = icolor end do do i = 1, nnode if ( adj(i,i) == 0 ) then call i_random ( 1, ncolor, icolor ) adj(i,i) = icolor end if end do ! ! Pick a random NEDGE subset. ! call ksub_random ( maxedge, nedge, iwork ) ! ! 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 color_graph_adj_color_count ( adj, lda, nnode, mcolor, ncolor ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_COLOR_COUNT counts the number of colors in a color graph. ! ! ! Modified: ! ! 27 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer MCOLOR, the maximum color index. ! ! Output, integer NCOLOR, the number of colors. ! implicit none ! integer lda integer nnode ! integer adj(lda,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 ivec_sort_heap_a ( nnode, colors ) call ivec_uniq ( nnode, colors, ncolor ) return end subroutine color_graph_adj_color_sequence ( adj, lda, nnode, seq ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_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. ! ! If two color graphs have different color sequences, they cannot be isomorphic. ! ! Modified: ! ! 02 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the color sequence. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer seq(nnode) ! do i = 1, nnode seq(i) = adj(i,i) end do call ivec_sort_heap_d ( nnode, seq ) return end subroutine color_graph_adj_connect_random ( adj, lda, nnode, nedge, & ncolor ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_CONNECT_RANDOM generates a random connected color graph. ! ! ! Modified: ! ! 29 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,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 LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges, which must be between ! NNODE-1 and (NNODE*(NNODE-1))/2. ! ! Input, integer NCOLOR, the number of colors available to choose for ! the nodes. NCOLOR must be at least 1, and no more than NNODE. ! implicit none ! integer lda integer ncolor integer nnode integer nedge ! integer adj(lda,nnode) integer code(nnode-2) integer i 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 nnode2 integer perm(ncolor) integer subset(ncolor) ! ! Check. ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' LDA = ', lda write ( *, '(a,i6)' ) ' but LDA must be at least NNODE = ', nnode stop end if maxedge = ( nnode * ( nnode - 1 ) ) / 2 if ( nedge < nnode-1 .or. nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i6)' ) ' no more than ', maxedge stop end if if ( ncolor < 1 .or. ncolor > nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NCOLOR = ', ncolor write ( *, '(a)' ) ' but NCOLOR must be at least 1, and ' write ( *, '(a,i6)' ) ' 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 ) call perm_random ( ncolor, perm ) do icolor = 1, ncolor i = subset(perm(icolor)) adj(i,i) = icolor end do do i = 1, nnode if ( adj(i,i) == 0 ) then call i_random ( 1, ncolor, icolor ) adj(i,i) = icolor end if end do ! ! Pick a random tree. ! call tree_arc_random ( nnode, code, inode, jnode ) ! ! Convert information to adjacency form. ! call graph_arc_to_graph_adj ( nnode-1, inode, jnode, adj, lda, nnode2 ) ! ! 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 ) 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 color_graph_adj_degree ( adj, lda, nnode, degree ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_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(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DEGREE(NNODE), the degree of the nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,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 color_graph_adj_degree_seq ( adj, lda, nnode, seq ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_DEGREE_SEQ computes the degree sequence of a color graph. ! ! ! Discussion: ! ! The degree sequence of a graph is constructed by computing the ! degree of each node, and then ordering these values in decreasing order. ! ! If two graphs are isomorphic, they must have the same degree sequence. ! ! If two graphs have different degree sequences, they cannot be isomorphic. ! ! Modified: ! ! 10 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the degree sequence. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer seq(nnode) ! call color_graph_adj_degree ( adj, lda, nnode, seq ) call ivec_sort_heap_d ( nnode, seq ) return end subroutine color_graph_adj_edge_count ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_EDGE_COUNT counts the number of edges in a color graph. ! ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE, the number of edges. ! implicit none ! integer lda integer nnode ! integer adj(lda,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 color_graph_adj_example_bush ( adj, lda, nnode ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_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(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer, parameter :: RED = 3 integer, parameter :: WHITE = 4 ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 7 if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_BUSH - Fatal error!' write ( *, '(a)' ) ' LDA is too small!' stop end if 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 color_graph_adj_example_cube ( adj, lda, nnode ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_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(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer, parameter :: RED = 3 ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 8 if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_CUBE - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if 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 color_graph_adj_example_octo ( adj, lda, nnode ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example color graph. ! ! ! Diagram: ! ! 1---2 ! /| |\ ! 8-+---+-3 ! | | | | ! 7-+---+-4 ! \| |/ ! 6---5 ! ! Graph "A" ! ! There are 7 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. ! ! Modified: ! ! 05 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), 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. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input/output, integer NNODE. ! On input, the value of NNODE should be between 1 and 35, and indicates ! which example graph to pick. ! On output, NNODE is the number of nodes, which should be 8. ! implicit none ! integer, parameter :: BLUE = 1 integer, parameter :: GREEN = 2 integer, parameter :: RED = 3 integer, parameter :: YELLOW = 4 ! integer lda ! integer adj(lda,lda) integer i integer j integer msave integer nnode integer nsave ! if ( nnode <= 0 ) then call i_random ( 1, 7, nsave ) call i_random ( 1, 5, msave ) else nnode = mod ( nnode - 1, 35 ) + 1 msave = ( ( nnode - 1 ) / 7 ) + 1 nsave = mod ( nnode - 1, 7 ) + 1 end if nnode = 8 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 do i = 1, nnode j = i + 1 if ( j > nnode ) 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(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(4,1) = 1 adj(5,8) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(6,1) = 1 adj(6,2) = 1 adj(6,3) = 1 adj(7,2) = 1 adj(7,3) = 1 adj(7,4) = 1 adj(8,3) = 1 adj(8,4) = 1 adj(8,5) = 1 ! ! Underlying graph 7. ! else if ( nsave == 7 ) 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(3,1) = 1 adj(4,6) = 1 adj(4,8) = 1 adj(4,2) = 1 adj(5,7) = 1 adj(5,1) = 1 adj(5,3) = 1 adj(6,8) = 1 adj(6,2) = 1 adj(6,4) = 1 adj(7,1) = 1 adj(7,3) = 1 adj(7,5) = 1 adj(8,2) = 1 adj(8,4) = 1 adj(8,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 imat_perm_random ( lda, nnode, adj ) return end subroutine color_graph_adj_example_twig ( adj, lda, nnode ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_EXAMPLE_TWIG sets up the twig color graph. ! ! ! Diagram: ! ! 1R---2R---3B ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,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 LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer, parameter :: BLUE = 1 integer, parameter :: RED = 3 ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 3 if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_TWIG - Fatal error!' write ( *, '(a)' ) ' LDA is too small!' stop end if 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 color_graph_adj_print ( adj, lda, nnode, title ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_PRINT prints out the adjacency matrix of a color graph. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of ADJ, which must be ! least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k character ( len = 80 ) string character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) 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 ( *, '(i2,2x,a)' ) i, string(1:3*nnode) end do return end subroutine color_graph_adj_random ( adj, lda, nnode, ncolor, nedge ) ! !******************************************************************************* ! !! COLOR_GRAPH_ADJ_RANDOM generates a random color graph. ! ! ! Modified: ! ! 28 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,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 LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors available to choose for ! the nodes. 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. ! implicit none ! integer lda integer nnode integer nedge ! integer adj(lda,nnode) integer i integer icolor integer iwork(nedge) integer j integer k integer l integer maxedge integer ncolor integer perm(ncolor) integer subset(ncolor) ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if maxedge = ( nnode * ( nnode - 1 ) ) / 2 if ( nedge < 0 .or. nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i6)' ) ' no more than ', maxedge stop end if if ( ncolor < 1 .or. ncolor > nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_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 ) call perm_random ( ncolor, perm ) do icolor = 1, ncolor i = subset(perm(icolor)) adj(i,i) = icolor end do do i = 1, nnode if ( adj(i,i) == 0 ) then call i_random ( 1, ncolor, icolor ) adj(i,i) = icolor end if end do ! ! Pick a random NEDGE subset of (N*(N-1))/2. ! call ksub_random ( maxedge, nedge, iwork ) ! ! 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 degree_seq_is_graphic ( nnode, seq, result ) ! !******************************************************************************* ! !! DEGREE_SEQ_IS_GRAPHIC reports whether a degree sequence represents a graph. ! ! ! Discussion: ! ! The degree sequence of a graph is constructed by computing the ! degree of each node, and then ordering these values in decreasing order. ! ! A sequence of NNODE nonnegative integers is said to be "graphic" if ! there exists a graph whose degree sequence is the given sequence. ! ! The Havel Hakimi theorem states that ! ! s t1 t2 ... ts d1 d2 ... dn ! ! is graphic if and only if ! ! t1-1 t2-1 ... ts-1 d1 d2 ... dn ! ! is graphic (after any necessary resorting and dropping of zeroes). ! Definitely, the one thing we cannot have is that any nonzero entry ! is equal to or greater than the number of nonzero entries. ! ! Modified: ! ! 01 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer SEQ(NNODE), the degree sequence to be tested. ! ! Output, integer RESULT, the result. ! 0, SEQ is not graphic. ! 1, SEQ is graphic. ! implicit none ! integer nnode ! integer dmax integer i integer ivec_nonzero integer nonzero integer order integer result integer seq(nnode) ! result = 0 do i = 1, nnode if ( seq(i) < 0 ) then return end if end do ! ! Check that the sequence is decreasing. ! call ivec_order_type ( nnode, seq, order ) if ( order == -1 .or. order == 1 .or. order == 2 ) then return end if ! ! Now apply the Havel Hakimi theorem. ! do nonzero = ivec_nonzero ( nnode, seq ) if ( nonzero == 0 ) then result = 1 exit end if call ivec_sort_heap_d ( nnode, seq ) dmax = seq(1) if ( dmax >= nonzero ) then result = 0 exit end if seq(1) = 0 do i = 2, dmax + 1 seq(i) = seq(i) - 1 end do end do return end subroutine degree_seq_to_graph_adj ( nnode, seq, lda, adj, ierror ) ! !******************************************************************************* ! !! DEGREE_SEQ_TO_GRAPH_ADJ computes a graph with the given degree sequence. ! ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer SEQ(NNODE), the degree sequence. ! ! Input, integer LDA, the leading dimension of ADJ. ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Output, integer IERROR, is nonzero if an error occurred. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer ierror integer indx(nnode) integer j integer nonzero integer s integer seq(nnode) integer seq2(nnode) ! ierror = 0 adj(1:nnode,1:nnode) = 0 seq2(1:nnode) = seq(1:nnode) do call ivec_sort_heap_index_d ( nnode, seq2, indx ) nonzero = 0 do i = 1, nnode if ( seq2(i) /= 0 ) then nonzero = nonzero + 1 end if end do if ( nonzero == 0 ) then exit end if s = seq2(indx(1)) if ( s >= nonzero ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DEGREE_SEQ_TO_GRAPH_ADJ - Fatal error!' write ( *, '(a)' ) ' The degree sequence is not graphic!' return end if seq2(indx(1)) = 0 do i = 2, s+1 adj(indx(i),indx(1)) = 1 adj(indx(1),indx(i)) = 1 seq2(indx(i)) = seq2(indx(i)) - 1 end do end do return end subroutine digraph_adj_closure ( adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_CLOSURE generates the transitive closure of a digraph. ! ! ! Discussion: ! ! The method is due to S Warshall. ! ! Definition: ! ! The transitive closure of a graph is a function REACH(I,J) so that ! ! REACH(I,J) = 0 if node J cannot be reached from node I; ! 1 if node J can be reached from node I. ! ! This is an extension of the idea of adjacency. REACH(I,J)=1 if ! node J is adjacent to node I, or if node J is adjacent to a node ! that is adjacent to node I, etc. ! ! Reference: ! ! Robert Sedgewick, ! Algorithms, ! Addison Wesley, 1983, page 425. ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). ! ! On input, ADJ is the adjacency matrix. ADJ(I,J) ! is nonzero if there is an edge from node I to node J. ! ! On output, ADJ is the transitive closure matrix. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k ! ! You can "reach" a node from itself. ! do i = 1, nnode adj(i,i) = 1 end do do i = 1, nnode do j = 1, nnode if ( adj(j,i) /= 0 ) then do k = 1, nnode if ( adj(i,k) /= 0 ) then adj(j,k) = 1 end if end do end if end do end do return end subroutine digraph_adj_components ( adj, lda, nnode, ncomp, comp, dad, order ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_COMPONENTS finds the strongly connected components of a digraph. ! ! ! Definition: ! ! A digraph is a directed graph. ! ! A strongly connected component of a directed graph is the largest ! set of nodes such that there is a directed path from any node to ! any other node in the same component. ! ! Reference: ! ! K Thulasiraman and M Swamy, ! Graph Theory and Algorithms, ! John Wiley, New York, 1992. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NCOMP, the number of strongly connected components. ! ! Output, integer COMP(NNODE), lists the connected component to which ! each node belongs. ! ! Output, integer DAD(NNODE), the father array for the depth first ! search trees. DAD(I) = 0 means that node I is the root of ! one of the trees. DAD(I) = J means that the search descended ! from node J to node I. ! ! Output, integer ORDER(NNODE), the order in which the nodes were ! traversed, from 1 to NNODE. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer comp(nnode) integer dad(nnode) integer i integer iorder integer j integer lowlink(nnode) integer mark(nnode) integer ncomp integer nstack integer order(nnode) integer point(nnode) integer stack(nnode) integer v integer w integer x ! ! Initialization. ! comp(1:nnode) = 0 dad(1:nnode) = 0 order(1:nnode) = 0 lowlink(1:nnode) = 0 mark(1:nnode) = 0 point(1:nnode) = 0 iorder = 0 nstack = 0 ncomp = 0 ! ! Select any node V not stored in the stack, that is, with MARK(V) = 0. ! do v = 0 do v = v + 1 if ( v > nnode ) then adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) return end if if ( mark(v) /= 1 ) then exit end if end do iorder = iorder + 1 order(v) = iorder lowlink(v) = iorder mark(v) = 1 nstack = nstack + 1 stack(nstack) = v point(v) = 1 30 continue ! ! Consider each node W. ! do w = 1, nnode ! ! Is there an edge (V,W) and has it not been examined yet? ! if ( adj(v,w) > 0 ) then adj(v,w) = - adj(v,w) ! ! Is the node on the other end of the edge undiscovered yet? ! if ( mark(w) == 0 ) then iorder = iorder + 1 order(w) = iorder lowlink(w) = iorder dad(w) = v mark(w) = 1 nstack = nstack + 1 stack(nstack) = w point(w) = 1 v = w else if ( mark(w) == 1 ) then if ( order(w) < order(v) .and. point(w) == 1 ) then lowlink(v) = min ( lowlink(v), order(w) ) end if end if go to 30 end if end do if ( lowlink(v) == order(v) ) then ncomp = ncomp + 1 do if ( nstack <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_COMPONENTS - Fatal error!' write ( *, '(a)' ) ' Illegal stack reference.' stop end if x = stack(nstack) nstack = nstack - 1 point(x) = 0 comp(x) = ncomp if ( x == v ) then exit end if end do end if if ( dad(v) /= 0 ) then lowlink(dad(v)) = min ( lowlink(dad(v)), lowlink(v) ) v = dad(v) go to 30 end if end do return end subroutine digraph_adj_cycle ( adj, lda, nnode, adj2, dad, order ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_CYCLE searches for cycles in a digraph. ! ! ! Modified: ! ! 04 July 2000 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ and ADJ2. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer ADJ2(LDA,NNODE), will be one of the following values ! depending on the role of the edge from node I to node J: ! 0, no edge, ! 1, neither in a search tree, nor needed to disconnect a cycle; ! -1, completes a cycle, ! -2, part of a search tree. ! ! Output, integer DAD(NNODE), the father array for the depth first ! search trees. DAD(I) = 0 means that node I is the root of ! one of the trees. DAD(I) = J means that the search descended ! from node J to node I. ! ! Output, integer ORDER(NNODE), the order in which the nodes were ! traversed, from 1 to NNODE. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer adj2(lda,nnode) integer dad(nnode) integer daddy integer i integer j integer jj integer maxstack integer nstack integer order(nnode) integer rank integer stack(2*(nnode-1)) ! ! Initialization. ! adj2(1:nnode,1:nnode) = adj(1:nnode,1:nnode) dad(1:nnode) = 0 maxstack = 2 * ( nnode - 1 ) order(1:nnode) = 0 rank = 0 do i = 1, nnode if ( order(i) == 0 ) then daddy = i nstack = 0 ! ! Visit the unvisited node DAD. ! 10 continue rank = rank + 1 order(daddy) = rank j = 0 ! ! Consider visiting node J from node DAD. ! 20 continue j = j + 1 ! ! If ! J is a reasonable value, ! J is adjacent to DAD, and ! J is unvisited, ! then ! put DAD into the stack, ! make J the new value of DAD, and ! examine J's neighbors. ! if ( j <= nnode ) then if ( adj2(daddy,j) > 0 ) then if ( order(j) == 0 ) then adj2(daddy,j) = -2 if ( nstack+2 <= maxstack ) then dad(j) = daddy stack(nstack+1) = daddy stack(nstack+2) = j nstack = nstack + 2 daddy = j go to 10 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_CYCLE - Fatal error!' write ( *, '(a)' ) ' Out of stack space.' stop end if ! ! Adjacent node J has already been visited. If J is actually ! in the current stack, then we have a cycle. ! else if ( j == daddy ) then adj2(daddy,j) = - 1 else do jj = 1, nstack-1, 2 if ( stack(jj) == j ) then adj2(daddy,j) = - 1 end if end do end if go to 20 end if ! ! If J is not suitable for a visit, get the next value of J. ! else go to 20 end if ! ! If no more neighbors to consider, back up one node. ! else if ( nstack >= 2 ) then daddy = stack(nstack-1) j = stack(nstack) nstack = nstack - 2 go to 20 ! ! If no more nodes to consider in this tree, bail out. ! else nstack = 0 end if end if end do return end subroutine digraph_adj_degree ( adj, lda, nnode, indegree, outdegree ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_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: ! ! 01 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NNODE), ! the indegree and outdegree of the nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,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 ( adj(i,j) /= 0 ) then outdegree(i) = outdegree(i) + adj(i,j) indegree(j) = indegree(j) + adj(i,j) end if end do end do return end subroutine digraph_adj_degree_max ( adj, lda, nnode, indegree_max, & outdegree_max, degree_max ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_DEGREE_MAX computes the maximum degrees of a digraph. ! ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INDEGREE_MAX, OUTDEGREE_MAX, the maximum indegree ! and outdegree, considered independently, which may occur at different ! nodes. ! ! Output, integer DEGREE_MAX, the maximum value of the sum at each ! node of the indegree and outdegree. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer degree integer degree_max integer i integer indegree integer indegree_max integer j integer outdegree integer outdegree_max ! degree_max = 0 indegree_max = 0 outdegree_max = 0 do i = 1, nnode indegree = sum ( adj(1:nnode,i) ) outdegree = sum ( adj(i,1:nnode) ) degree = indegree + outdegree indegree_max = max ( indegree_max, indegree ) outdegree_max = max ( outdegree_max, outdegree ) degree_max = max ( degree_max, degree ) end do return end subroutine digraph_adj_degree_seq ( adj, lda, nnode, in_seq, out_seq ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_DEGREE_SEQ computes the directed degree sequence. ! ! ! 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: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer IN_SEQ(NNODE), OUT_SEQ(NNODE), ! the degree sequence of the digraph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer in_seq(nnode) integer out_seq(nnode) ! call digraph_adj_degree ( adj, lda, nnode, in_seq, out_seq ) call ivec2_sort_d ( nnode, out_seq, in_seq ) return end subroutine digraph_adj_edge_count ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_EDGE_COUNT counts the number of edges in a digraph. ! ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE, the number of edges in the digraph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer nedge ! nedge = sum ( adj(1:nnode,1:nnode) ) return end subroutine digraph_adj_eigen ( adj, lda, nnode, neigen, eigenr, eigeni ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_EIGEN computes the eigenvalues of a digraph from its adjacency matrix. ! ! ! Modified: ! ! 18 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEIGEN, the number of eigenvalues computed. ! Normally, this would be equal to NNODE, unless the algorithm failed. ! ! Output, real EIGENR(NNODE), EIGENI(NNODE), contains the real ! and imaginary parts of the computed eigenvalues. ! implicit none ! integer lda integer nnode ! real a(nnode,nnode) integer adj(lda,nnode) real eigeni(nnode) real eigenr(nnode) integer i integer igh integer ind(nnode) integer info integer low integer neigen real scale(nnode) ! a(1:nnode,1:nnode) = real ( adj(1:nnode,1:nnode) ) call balanc ( nnode, nnode, a, low, igh, scale ) call elmhes ( nnode, nnode, low, igh, a, ind ) call hqr ( nnode, nnode, low, igh, a, eigenr, eigeni, info ) if ( info == 0 ) then neigen = nnode else neigen = nnode - info do i = 1, neigen eigenr(i) = eigenr(i+info) eigeni(i) = eigeni(i+info) end do end if return end subroutine digraph_adj_example_cycler ( adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_EXAMPLE_CYCLER sets up the adjacency information for the cycler digraph. ! ! ! Diagram: ! ! A ! V ! 9--><--7---<--3--><---4 ! | /| / ! V A | / ! | / | / ! 5----<----1 V A ! | / | / ! V A | / ! | / |/ ! 2-->---8---<--6 ! \------>----/ ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the maximum value of NNODE, which must be at least 9. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 9 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_EXAMPLE_CYCLER - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 adj(1,3) = 1 adj(1,5) = 1 adj(2,6) = 1 adj(2,8) = 1 adj(3,4) = 1 adj(3,6) = 1 adj(3,7) = 1 adj(4,3) = 1 adj(5,2) = 1 adj(6,4) = 1 adj(6,8) = 1 adj(7,7) = 1 adj(7,9) = 1 adj(8,1) = 1 adj(9,5) = 1 adj(9,7) = 1 return end subroutine digraph_adj_example_octo ( adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example digraph. ! ! ! Diagram: ! ! 1---2 ! /| |\ ! 8-+---+-3 ! | | | | ! 7-+---+-4 ! \| |/ ! 6---5 ! ! Graph "A" ! ! There are 12 digraphs to choose from, all on 8 nodes. There are 7 ! underlying graphs. The first 5 underlying graphs have degree 3 at ! every node. Graphs 6 and 7 have degree 5 at every node. ! ! Modified: ! ! 05 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), the adjacency information. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input/output, integer NNODE. ! On input, the value of NNODE should be between 1 and 12, and indicates ! which example graph to pick. ! On output, NNODE is the number of nodes, which should be 8. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode integer nsave ! if ( nnode <= 0 ) then call i_random ( 1, 12, nsave ) else nnode = mod ( nnode - 1, 12 ) + 1 nsave = nnode end if nnode = 8 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 do i = 1, nnode j = i + 1 if ( j > nnode ) 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 end if ! ! Now permute the graph. ! call imat_perm_random ( lda, nnode, adj ) return end subroutine digraph_adj_example_sixty ( adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_EXAMPLE_SIXTY sets the adjacency matrix for the sixty digraph. ! ! ! Discussion: ! ! The nodes of the digraph are divisors of 60. There is a link from I to ! J if divisor I can be divided by divisor J. ! ! Modified: ! ! 11 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the maximum value of NNODE, which must be at least 12. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda ! integer adj(lda,lda) integer d(12) integer i integer j integer nnode ! nnode = 12 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_EXAMPLE_SIXTY - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if d(1:12) = (/ 60, 30, 20, 15, 12, 10, 6, 5, 4, 3, 2, 1 /) do i = 1, nnode do j = 1, nnode if ( i == j ) then adj(i,j) = 0 else if ( mod ( d(i), d(j) ) == 0 ) then adj(i,j) = 1 else adj(i,j) = 0 end if end do end do return end subroutine digraph_adj_ham_cand ( adj, lda, nnode, circuit, k, nstack, & stack, maxstack, ncan ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_HAM_CAND finds candidates for the next node in a Hamiltonian circuit. ! ! ! Discussion: ! ! This routine is used in conjunction with IVEC_BACKTRACK. ! ! Definition: ! ! A Hamiltonian circuit of a digraph is a path that starts at a given node, ! visits every node exactly once, and returns to the starting node. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 16 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE). ADJ(I,J) = 1 if there is ! an edge from node I to node J, 0 otherwise. ! ! Input, integer LDA, the first dimension of ADJ. ! LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes in the digraph. ! ! Input, integer CIRCUIT(NNODE), contains in CIRCUIT(1:K-1) the partial ! candidate circuit being constructed. ! ! Input, integer K, the index of the next node to be determined for ! the circuit. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input, integer STACK(MAXSTACK), candidates for positions 1...K-1. ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Input/output, integer NCAN(NNODE), the number of candidates for each ! position. On input, contains values for steps 1 to K-1. On output, ! the value for position K has been determined. ! implicit none ! integer lda integer nnode integer maxstack ! integer adj(lda,nnode) integer circuit(nnode) integer i integer iwork(nnode) integer k integer ncan(nnode) integer nstack integer stack(maxstack) ! ncan(k) = 0 if ( k == 1 ) then stack(1) = 1 nstack = 1 ncan(k) = 1 return end if iwork(1:nnode) = adj(circuit(k-1),1:nnode) iwork(circuit(1:k-1)) = 0 if ( k /= nnode ) then do i = 1, nnode if ( iwork(i) == 1 ) then if ( nstack >= maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_HAM_CAND - Fatal error!' write ( *, '(a)' ) ' MAXSTACK is too small.' stop end if nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if end do return else if ( k == nnode ) then do i = 1, nnode if ( iwork(i) == 1 ) then if ( adj(i,1) /= 0 ) then if ( nstack >= maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_HAM_CAND - Fatal error!' write ( *, '(a)' ) ' MAXSTACK is too small.' stop end if nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if return end if end do end if return end subroutine digraph_adj_ham_next ( adj, lda, nnode, circuit, stack, & maxstack, ncan, more ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_HAM_NEXT returns the next Hamilton circuit for a digraph. ! ! ! Discussion: ! ! The routine produces all the Hamilton circuits of a digraph, one at a time. ! ! Definition: ! ! A Hamiltonian circuit of a digraph is a path that starts at a given ! node, visits every node exactly once, and returns to the starting node. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 16 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix of the digraph. ! ADJ(I,J) = 1 if there is an edge from node I to node J, 0 otherwise. ! ! Input, integer LDA, the first dimension of ADJ as ! declared in the calling program. LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes in the digraph. ! ! Input/output, integer CIRCUIT(NNODE). On the first call to this routine, ! the contents of CIRCUIT are irrelevant. On return, CIRCUIT contains a ! list of the nodes that form a cirucit. On each subsequent call, ! the input value of CIRCUIT is used to construct the next solution, ! so the user should not alter the contents of CIRCUIT during a computation. ! ! Workspace, integer STACK(MAXSTACK). Candidates for the positions in ! the circuit. ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Workspace, integer NCAN(NNODE), a count of the number of candidates for ! each step. ! ! Input/output, logical MORE. ! On first call, set MORE to .FALSE, and do not alter it after. ! On return, MORE is TRUE if another circuit has been returned in ! IARRAY, and FALSE if there are no more circuits. ! implicit none ! integer lda integer nnode integer maxstack ! integer adj(lda,nnode) integer circuit(nnode) integer, save :: indx = 0 integer, save :: k = 0 logical more integer ncan(nnode) integer, save :: nstack = 0 integer stack(maxstack) ! if ( .not. more ) then indx = 0 k = 0 more = .true. nstack = 0 end if do call ivec_backtrack ( nnode, circuit, indx, k, nstack, stack, maxstack, & ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call digraph_adj_ham_cand ( adj, lda, nnode, circuit, k, nstack, & stack, maxstack, ncan ) else more = .false. exit end if end do return end subroutine digraph_adj_ham_next_brute ( adj, lda, nnode, circuit, iset ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_HAM_NEXT_BRUTE finds the next Hamiltonian circuit in a digraph. ! ! ! Discussion: ! ! This is a brute force algorithm, and not suitable for large problems. ! It is really only useful as a demonstration, and as a check for ! the backtracking algorithm. ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer CIRCUIT(NNODE). ! ! On input, if ISET = 0, then CIRCUIT is not presumed to contain any ! information. If ISET is nonzero, then CIRCUIT contains the circuit ! computed on the previous call. ! ! On output, CIRCUIT contains the circuit computed by this call. ! ! Input/output, integer ISET. ! On input, 0 means this is the first call for this graph. ! Any other value means this is a repeated call for more circuits. ! ! On output, a 0 value means that no more circuits could be computed. ! Otherwise, ISET is incremented by one on each call. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer circuit(nnode) integer i integer ipos integer iset ! ! If ISET is 0, this is a starting call, and we set CIRCUIT ! to the lexically first circuit to check. ! ! Otherwise, we set CIRCUIT to the next permutation. ! if ( iset == 0 ) then ipos = 0 circuit(1:nnode) = 0 else ipos = nnode - 1 end if do call perm_inc ( circuit, ipos, nnode ) if ( ipos <= 0 .or. circuit(1) /= 1 ) then iset = 0 circuit(1:nnode) = 0 return end if ! ! Check whether the entries of CIRCUIT actually form a circuit. ! If we find a break in the circuit, store that location in IPOS ! and move on to try the next permutation. ! ipos = 0 do i = 1, nnode-1 if ( adj(circuit(i),circuit(i+1)) == 0 ) then ipos = i exit end if end do if ( ipos /= 0 ) then cycle end if ! ! If the circuit connects all the nodes, we only have to check whether ! the last node connects back to the first one. ! if ( adj(circuit(nnode),circuit(1)) /= 0 ) then exit end if ipos = nnode - 1 end do iset = iset + 1 return end subroutine digraph_adj_ham_path_next_brute ( adj, lda, nnode, path, iset ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_HAM_PATH_NEXT_BRUTE finds the next path in a digraph that visits all nodes. ! ! ! Discussion: ! ! The path is not required to be a circuit. That is, there is no requirement ! that there be an edge from the last node visited back to the first one. ! ! This is a brute force algorithm, and not suitable for large problems. ! ! Modified: ! ! 20 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer PATH(NNODE). ! ! On input, if ISET = 0, then PATH is not presumed to contain any ! information. If ISET is nonzero, then PATH contains the ! path computed on the previous call. ! ! On output, PATH contains the path computed by this call. ! ! Input/output, integer ISET. ! ! On input, a 0 value means this is the first call for this ! graph. Any other value means this is a repeated call for more paths. ! ! On output, a 0 value means that no more paths could be computed. ! Otherwise, ISET is incremented by one on each call. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer ipos integer iset integer path(nnode) ! ! If ISET is 0, this is a starting call, and we set PATH ! to the lexically first path to check. ! ! Otherwise, we set PATH to the next permutation. ! if ( iset == 0 ) then ipos = 0 path(1:nnode) = 0 else ipos = nnode - 1 end if do call perm_inc ( path, ipos, nnode ) if ( ipos == 0 ) then iset = 0 path(1:nnode) = 0 return end if ! ! Check whether the entries of PATH actually form a path. ! ipos = 0 do i = 1, nnode-1 if ( adj(path(i),path(i+1)) == 0 ) then ipos = i exit end if end do if ( ipos == 0 ) then exit end if end do iset = iset + 1 return end subroutine digraph_adj_is_edge_connected ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_IS_EDGE_CONNECTED determines if a digraph is edgewise connected. ! ! ! Definition: ! ! A digraph is edgewise connected if from any edge it is possible to reach ! any other edge. An edgewise connected digraph may include isolated nodes. ! ! Modified: ! ! 01 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the digraph is not edgewise connected. ! 1, the digraph is edgewise connected. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer found(nnode) integer i integer ihi integer ii integer ilo integer j integer jhi integer jlo integer list(nnode) integer result ! ! FOUND(I) is 1 if edge I has been reached. ! LIST(I) contains a list of the nodes as they are reached. ! list(1:nnode) = 0 found(1:nnode) = 0 ! ! Find an edge. ! ilo = 1 ihi = 0 do i = 1, nnode do j = 1, nnode if ( adj(i,j) > 0 ) then adj(i,j) = - adj(i,j) ihi = ihi + 1 list(ihi) = i found(i) = 1 if ( i /= j ) then ihi = ihi + 1 list(ihi) = j found(j) = 1 end if exit end if end do if ( ihi > 0 ) then exit end if end do ! ! A digraph with NO edges is edgewise connected! ! if ( ihi == 0 ) then result = 1 return end if ! ! From the batch of edge nodes found last time, LIST(ILO:IHI), ! look for unfound neighbors, and store their indices in LIST(JLO:JHI). ! do jlo = ihi + 1 jhi = ihi do ii = ilo, ihi i = list(ii) do j = 1, nnode if ( adj(i,j) > 0 ) then adj(i,j) = - adj(i,j) if ( found(j) == 0 ) then jhi = jhi + 1 list(jhi) = j found(j) = 1 end if end if end do end do if ( jhi < jlo ) then exit end if ilo = jlo ihi = jhi end do ! ! If any edges were unvisited, then the digraph is not edgewise connected. ! result = 1 do i = 1, nnode do j = 1, nnode if ( adj(i,j) > 0 ) then result = 0 end if end do end do ! ! Restore the positive sign of ADJ. ! adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) return end subroutine digraph_adj_is_eulerian ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_IS_EULERIAN determines if a digraph is Eulerian from its adjacency ma ! ! ! Definition: ! ! A digraph is path-Eulerian if there exists a path through the digraph ! which uses every edge once. ! ! A digraph is circuit-Eulerian if there exists a path through the digraph ! which uses every edge once, and which starts and ends on the same node. ! ! Note that it is NOT necessary for the path or circuit to pass through ! every node; simply that all the edges can be used exactly once to ! make a connected path. This means an Eulerian digraph can have isolated ! nodes, for instance. ! ! Discussion: ! ! A digraph is path-Eulerian if and only if it is edge-connected, and ! for all but two nodes, the indegree and outdegree are equal, and ! for those two nodes, the indegree and outdegree, if different, differ ! by 1. ! ! A digraph is circuit-Eulerian if and only if it is edge connected and ! for every node the indegree equals the outdegree. ! ! Modified: ! ! 28 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the digraph is not Eulerian. ! 1, the digraph is path-Eulerian. ! 2, the digraph is circuit-Eulerian. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer indegree(nnode) integer ndiff integer outdegree(nnode) integer result ! ! First check that the digraph is edgewise connected. ! call digraph_adj_is_edge_connected ( adj, lda, nnode, result ) if ( result == 0 ) then return end if ! ! Now look at node degree. ! call digraph_adj_degree ( adj, lda, nnode, indegree, outdegree ) ndiff = 0 do i = 1, nnode if ( indegree(i) /= outdegree(i) ) then ndiff = ndiff + 1 if ( ndiff > 2 ) then result = 0 return end if if ( abs ( indegree(i) - outdegree(i) ) > 1 ) then result = 0 return end if end if end do if ( ndiff == 0 ) then result = 2 else result = 1 end if return end subroutine digraph_adj_is_strong_connected ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_IS_STRONG_CONNECTED determines if a digraph is strongly connected. ! ! ! Modified: ! ! 23 November 1999 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT, ! 0, the digraph is not strongly connected; ! 1, the digraph is strongly connected. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer iorder integer j integer lowlink(nnode) integer mark(nnode) integer ncomp integer nstack integer order(nnode) integer point(nnode) integer result integer stack(nnode) integer v integer w integer x ! ! Initialization. ! dad(1:nnode) = 0 order(1:nnode) = 0 lowlink(1:nnode) = 0 mark(1:nnode) = 0 point(1:nnode) = 0 iorder = 0 nstack = 0 ncomp = 0 ! ! Select any node V not stored in the stack, that is, with MARK(V) = 0. ! do v = 0 do v = v + 1 if ( v > nnode ) then adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) if ( ncomp > 1 ) then result = 0 else result = 1 end if return end if if ( mark(v) /= 1 ) then exit end if end do iorder = iorder + 1 order(v) = iorder lowlink(v) = iorder mark(v) = 1 nstack = nstack + 1 stack(nstack) = v point(v) = 1 30 continue ! ! Consider each node W. ! do w = 1, nnode ! ! Is there an edge (V,W) and has it not been examined yet? ! if ( adj(v,w) > 0 ) then adj(v,w) = - adj(v,w) ! ! Is the node on the other end of the edge undiscovered yet? ! if ( mark(w) == 0 ) then iorder = iorder + 1 order(w) = iorder lowlink(w) = iorder dad(w) = v mark(w) = 1 nstack = nstack + 1 stack(nstack) = w point(w) = 1 v = w else if ( mark(w) == 1 ) then if ( order(w) < order(v) .and. point(w) == 1 ) then lowlink(v) = min ( lowlink(v), order(w) ) end if end if go to 30 end if end do if ( lowlink(v) == order(v) ) then ncomp = ncomp + 1 do if ( nstack <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_IS_STRONG_CONNECTED - Fatal error!' write ( *, '(a)' ) ' Illegal stack reference.' stop end if x = stack(nstack) nstack = nstack - 1 point(x) = 0 if ( x == v ) then exit end if end do end if if ( dad(v) /= 0 ) then lowlink(dad(v)) = min ( lowlink(dad(v)), lowlink(v) ) v = dad(v) go to 30 end if end do return end subroutine digraph_adj_is_tournament ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_IS_TOURNAMENT determines if a digraph is a tournament from its adjacency matrix. ! ! ! Definition: ! ! A digraph is a tournament if every pair of distinct nodes is connected by ! exactly one directed edge. ! ! Modified: ! ! 07 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the digraph is not a tournament. ! 1, the digraph is a tournament. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer result ! result = 0 ! ! No self links. ! do i = 1, nnode if ( adj(i,i) /= 0 ) then return end if end do ! ! Distinct I and J must have exactly one connection. ! do i = 1, nnode do j = i+1, nnode if ( .not. ( adj(i,j) == 0 .and. adj(j,i) == 1 ) .and. & .not. ( adj(i,j) == 1 .and. adj(j,i) == 0 ) ) then return end if end do end do result = 1 return end subroutine digraph_adj_is_transitive ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_IS_TRANSITIVE determines if a digraph is transitive. ! ! ! Definition: ! ! A digraph is transitive if whenever there's a long way between two ! nodes, there's an immediate way. Formally: ! ! ADJ(I,J) and ADJ(J,K) nonzero imply ADJ(I,K) nonzero. ! ! Modified: ! ! 01 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the digraph is not transitive. ! 1, the digraph is transitive. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k integer result ! result = 0 do i = 1, nnode do j = 1, nnode if ( adj(i,j) /= 0 ) then do k = 1, nnode if ( adj(j,k) /= 0 ) then if ( adj(i,k) == 0 ) then return end if end if end do end if end do end do result = 1 return end subroutine digraph_adj_is_weak_connected ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_IS_WEAK_CONNECTED determines if a digraph is weakly connected. ! ! ! Definition: ! ! A digraph is weakly connected if the underlying graph is node connected. ! In other words, if a graph is constructed from the digraph by replacing ! every directed edge by an undirected edge, and the it is possible to ! travel from any node to any other node, then the digraph is weakly ! connected. ! ! Modified: ! ! 04 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the digraph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the digraph is not weakly connected. ! 1, the digraph is weakly connected. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer result ! call graph_adj_is_node_connected ( adj, lda, nnode, result ) return end subroutine digraph_adj_print ( adj, lda, nnode, title ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_PRINT prints out an adjacency matrix for a digraph. ! ! ! Discussion: ! ! This routine actually allows the entries of ADJ to have ANY value. ! Values between 0 and 9 will be printed as is. Other values will ! be printed as '*'. ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix of a digraph. ! ADJ(I,J) is 1 if there is a direct connection FROM node I TO node J, ! and is 0 otherwise. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer jhi character ( len = 80 ) string character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode jhi = min ( nnode, 80 ) do j = 1, jhi 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 do write ( *, '(i2,2x,a)' ) i, string(1:jhi) end do return end subroutine digraph_adj_random ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_RANDOM generates a random digraph. ! ! ! Definition: ! ! A digraph is a directed graph. ! ! Discussion: ! ! The user specifies the number of nodes and edges in the digraph. ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges, which must be between ! 0 and NNODE*(NNODE-1). ! implicit none ! integer lda integer nnode integer nedge ! integer adj(lda,nnode) integer i integer iwork(nedge) integer j integer k integer l integer maxedge ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if maxedge = nnode * ( nnode - 1 ) if ( nedge < 0 .or. nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i6)' ) ' no more than ', maxedge stop end if adj(1:nnode,1:nnode) = 0 ! ! Pick a random NEDGE subset of NNODE*(NNODE-1). ! call ksub_random ( maxedge, nedge, iwork ) ! ! The usable spots in the matrix are numbered as follows: ! ! * 1 2 3 ... n-2 n-1 ! n * n+1 n+2 ... 2n-1 2(n-1) ! 2n-1 2n * ... ... ........ .......... ! .... ... ... ... ... * (n-1)(n-1) ! .... ... ... ... ... n(n-1) * ! 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 digraph_adj_reduce ( adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_REDUCE generates a transitive reduction of a digraph. ! ! ! Discussion: ! ! This routine is given an adjacency matrix B, which might be a ! transitive closure of a graph G. ! ! The transitive closure graph is generated from a graph G by the ! following procedure: ! ! B(I,J) = 0 if node J cannot be reached from node I in graph G; ! 1 if node J can be reached from node I in graph G. ! ! The purpose of this routine is to try to find the original, sparser ! graph G which generated the given transitive closure graph. Such a ! graph G is known as a transitive reduction.. In general, ! there is no unique solution. In particular, any graph is a transitive ! reduction of itself. ! ! Hence, the real task is to drop as many redundant edges as possible ! from the given graph, arriving at a graph from which no more edges ! may be removed. ! ! Method: ! ! One way of explaining the algorithm is based on the adjacency matrix: ! ! * Zero out the diagonals of the adjacency matrix. ! ! * Consider row 1. Any other row that can "reach" row 1 doesn't ! need a 1 if row 1 has it. So "subtract" all the 1's in row 1 ! from such rows. We are done with row 1 and column 1. ! ! * Repeat for the other rows. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). ! ! On input, the adjacency matrix of the transitive closure graph H. ! ! On output, the adjacency matrix of a transitive reduction graph G ! of the graph H. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k ! ! First discard those useless self-edges. ! do i = 1, nnode adj(i,i) = 0 end do ! ! If you can get from J to I and I to K, you don't need a direct ! edge from J to K. ! do i = 1, nnode do j = 1, nnode if ( adj(j,i) /= 0 ) then do k = 1, nnode if ( adj(i,k) /= 0 ) then adj(j,k) = 0 end if end do end if end do end do return end subroutine digraph_adj_to_digraph_arc ( adj, lda, nnode, maxedge, nedge, & inode, jnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_TO_DIGRAPH_ARC converts a digraph from adjacency to arc list form. ! ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer MAXEDGE, the maximum number of edges. ! ! Output, integer NEDGE, the number of edges. ! ! Output, integer INODE(MAXEDGE), JNODE(MAXEDGE), the arc list of the ! digraph. ! implicit none ! integer lda integer maxedge integer nnode ! integer adj(lda,nnode) integer i integer inode(maxedge) integer j integer jnode(maxedge) integer nedge ! nedge = 0 inode(1:maxedge) = 0 jnode(1:maxedge) = 0 do j = 1, nnode do i = 1, nnode if ( adj(i,j) /= 0 ) then nedge = nedge + 1 if ( nedge <= maxedge ) then inode(nedge) = i jnode(nedge) = j else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_TO_DIGRAPH_ARC - Fatal error!' write ( *, '(a)' ) ' MAXEDGE exceeded.' stop end if end if end do end do return end subroutine digraph_adj_to_digraph_inc ( adj, lda, nnode, maxarc, narc, inc ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_TO_DIGRAPH_INC converts an adjacency digraph to an incidence digraph. ! ! ! Discussion: ! ! INC(node,arc) = 0 if NODE is not the beginning or end of ARC, or ! if ARC is a loop; ! 1 if NODE is the beginning of ARC; ! -1 if NODE is the end of ARC. ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer MAXARC, the maximum number of arcs. ! ! Output, integer NARC, the number of arcs. ! ! Output, integer INC(LDA,MAXARC), the incidence matrix. ! implicit none ! integer lda integer maxarc integer nnode ! integer adj(lda,nnode) integer i integer inc(lda,maxarc) integer j integer narc ! narc = 0 do j = 1, nnode do i = 1, nnode if ( i == j ) then else if ( adj(i,j) /= 0 ) then narc = narc + 1 if ( narc <= maxarc ) then inc(i,narc) = 1 inc(j,narc) = -1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_TO_DIGRAPH_INC - Fatal error!' write ( *, '(a)' ) ' MAXARC exceeded.' stop end if end if end do end do return end subroutine digraph_adj_top_sort ( adj, lda, nnode, dad, visit, node_list ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_TOP_SORT finds a reverse topological sorting of a directed acyclic graph. ! ! ! Discussion: ! ! The routine performs a depth first search of the DAG and returns: ! ! * a list of the order in which the nodes were visited; ! * a list of the parents of each node in the search trees; ! * a list of the nodes, in a reverse topological order. ! ! Definition: ! ! In a reverse topological sorting of the nodes of a directed ! acyclic graph, nodes are listed "lowest" first. That is, ! if node A precedes node B in the list, then there may or may ! not be an edge or indirect path from B to A, but there ! is neither an edge or indirect path from A to B. ! ! Reference: ! ! Robert Sedgewick, ! Algorithms, ! Addison Wesley, 1983, page 426. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), the father array for the depth first ! search trees. DAD(I) = 0 means that node I is the root of ! one of the trees. DAD(I) = J means that the search descended ! from node J to node I. ! ! Output, integer VISIT(NNODE), the order in which the nodes were ! visited, from 1 to NNODE. ! ! Output, integer NODE_LIST(NNODE), a list of the nodes, in reverse ! topological order. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer daddy integer i integer j integer maxstack integer nsort integer nstack integer node_list(nnode) integer rank integer stack(2*(nnode-1)) integer visit(nnode) ! dad(1:nnode) = 0 maxstack = 2 * ( nnode - 1 ) visit(1:nnode) = 0 node_list(1:nnode) = 0 rank = 0 nsort = 0 do i = 1, nnode ! ! Find the next unused node and begin a new search tree. ! if ( visit(i) == 0 ) then daddy = i dad(daddy) = 0 nstack = 0 ! ! Visit node DAD. ! 10 continue rank = rank + 1 visit(daddy) = rank j = 0 ! ! Consider visiting node J from node DAD. ! 20 continue j = j + 1 ! ! If J is a reasonable value, adjacent to DAD, and unvisited, ! then put DAD into the stack, make J the new value of DAD, ! and go to 10. ! if ( j <= nnode ) then if ( adj(daddy,j) /= 0 .and. visit(j) == 0 ) then if ( nstack+2 <= maxstack ) then dad(j) = daddy stack(nstack+1) = daddy stack(nstack+2) = j nstack = nstack + 2 daddy = j go to 10 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_TOP_SORT - Fatal error!' write ( *, '(a)' ) ' Out of stack space.' stop end if ! ! If J is not suitable for a visit, get the next value of J. ! else go to 20 end if ! ! If no more neighbors to consider, back up one node. ! else if ( nstack >= 2 ) then nsort = nsort + 1 node_list(nsort) = daddy daddy = stack(nstack-1) j = stack(nstack) nstack = nstack - 2 go to 20 ! ! If no more nodes to consider in this tree, bail out. ! else nsort = nsort + 1 node_list(nsort) = daddy nstack = 0 end if end if end do return end subroutine digraph_adj_tournament_random ( adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ADJ_TOURNAMENT_RANDOM generates a random tournament digraph. ! ! ! Definition: ! ! A tournament is a directed graph in which every pair of nodes are joined ! by exactly one directed edge. ! ! Discussion: ! ! The user specifies the number of nodes in the digraph. The number of ! edges will be (NNODE*(NNODE-1))/2. ! ! Modified: ! ! 07 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ADJ_TOURNAMENT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if adj(1:nnode,1:nnode) = 0 do i = 1, nnode do j = i+1, nnode call i_random ( 1, 2, k ) if ( k == 1 ) then adj(i,j) = 1 else adj(j,i) = 1 end if end do end do return end subroutine digraph_arc_degree ( nnode, nedge, inode, jnode, indegree, & outdegree ) ! !******************************************************************************* ! !! DIGRAPH_ARC_DEGREE determines the degree of the nodes of a digraph. ! ! ! Definition: ! ! The degree of a node is the number of edges that include the node. ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the pairs of nodes ! that form the edges. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NNODE), the indegree ! and outdegree of each node, that is, the number of edges that end ! with the node, and the number of edges that begin with it. ! implicit none ! integer nedge integer nnode ! integer i integer indegree(nnode) integer inode(nedge) integer jnode(nedge) integer n integer outdegree(nnode) ! indegree(1:nnode) = 0 outdegree(1:nnode) = 0 do i = 1, nedge n = inode(i) if ( 1 <= n .and. n <= nnode ) then outdegree(n) = outdegree(n) + 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ARC_DEGREE - Fatal error!' write ( *, '(a,i6)' ) ' Out-of-range node value = ', n stop end if n = jnode(i) if ( 1 <= n .and. n <= nnode ) then indegree(n) = indegree(n) + 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ARC_DEGREE - Fatal error!' write ( *, '(a,i6)' ) ' Out-of-range node value = ', n stop end if end do return end subroutine digraph_arc_edge_sort ( nedge, inode, jnode ) ! !******************************************************************************* ! !! DIGRAPH_ARC_EDGE_SORT sorts the edge array of a graph. ! ! ! Comment: ! ! The edges are sorted in dictionary order. ! ! Example: ! ! Input: ! ! INODE JNODE ! ! 3 2 ! 4 3 ! 2 1 ! 1 4 ! ! Output: ! ! INODE JNODE ! ! 1 4 ! 2 1 ! 3 2 ! 4 3 ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input/output, integer INODE(NEDGE), JNODE(NEDGE), the edge array. ! The I-th edge connects nodes INODE(I) and JNODE(I). ! ! On output, the INODE and JNODE arrays have been sorted as described. ! implicit none ! integer nedge ! integer iedge integer indx integer inode(nedge) integer isgn integer jedge integer jnode(nedge) ! if ( nedge <= 1 ) then return end if ! ! Sort the edges using an external heap sort. ! iedge = 0 jedge = 0 indx = 0 isgn = 0 do call sort_heap_external ( nedge, indx, iedge, jedge, isgn ) ! ! Interchange edges IEDGE and JEDGE. ! if ( indx > 0 ) then call i_swap ( inode(iedge), inode(jedge) ) call i_swap ( jnode(iedge), jnode(jedge) ) ! ! Compare edges IEDGE and JEDGE. ! else if ( indx < 0 ) then if ( ( inode(iedge) < inode(jedge) ) .or. & ( inode(iedge) == inode(jedge) .and. & jnode(iedge) < jnode(jedge) ) ) then isgn = -1 else isgn = +1 end if else if ( indx == 0 ) then exit end if end do return end subroutine digraph_arc_euler_circ_cand ( nedge, inode, jnode, circuit, k, & nstack, stack, maxstack, ncan, iwork, lwork ) ! !******************************************************************************* ! !! DIGRAPH_ARC_EULER_CIRC_CAND finds candidates for the K-th edge of an Euler circuit. ! ! ! Discussion: ! ! This routine is used in conjunction with IVEC_BACKTRACK, which directs the ! search for a complete Euler circuit. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 17 August 2000 ! ! Parameters: ! ! Input, integer NEDGE, the number of edges in the digraph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array of the digraph. ! The I-th edge extends from node INODE(I) to JNODE(I). ! ! Input, integer CIRCUIT(NEDGE), CIRCUIT(I) is the I-th edge in the circuit. ! A full circuit will have NEDGE edges, but on input we only have K-1. ! ! Input, integer K, the index of the next edge to be determined in circuit. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input, integer STACK(MAXSTACK), as yet unused candidates for positions ! 1 to K-1. ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Workspace, integer IWORK(NEDGE). ! ! Workspace, logical LWORK(NEDGE). ! implicit none ! integer nedge integer maxstack ! integer circuit(nedge) integer i integer inode(nedge) integer it integer iwork(nedge) integer jnode(nedge) integer k logical lwork(nedge) integer ncan(nedge) integer nstack integer stack(maxstack) ! ncan(k) = 0 if ( k == 1 ) then iwork(1) = jnode(1) stack(1) = 1 nstack = 1 ncan(k) = 1 return end if if ( k > 2 ) then iwork(k-1) = inode(circuit(k-1)) + jnode(circuit(k-1)) - iwork(k-2) end if it = iwork(k-1) do i = 1, nedge lwork(i) = it == inode(i) end do lwork(circuit(1:k-1)) = .false. do i = 1, nedge if ( lwork(i) ) then if ( nstack >= maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ARC_EULER_CIRC_CAND - Fatal error!' write ( *, '(a)' ) ' Stack size exceeded.' stop end if nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if end do return end subroutine digraph_arc_euler_circ_next ( nedge, inode, jnode, circuit, stack, & maxstack, ncan, more ) ! !******************************************************************************* ! !! DIGRAPH_ARC_EULER_CIRC_NEXT returns the next Euler circuit for a digraph. ! ! ! Discussion: ! ! The routine produces all the Euler circuits of a digraph, one at a time. ! ! Definition: ! ! An Euler circuit of a digraph is a path starting at some node, ! using all the edges of the digraph exactly once, and returning ! to the starting node. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 17 August 2000 ! ! Parameters: ! ! Input, integer NEDGE, the number of edges in the digraph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array of the digraph. ! The I-th edge extends from node INODE(I) to JNODE(I). ! ! Output, integer CIRCUIT(NEDGE). If MORE = TRUE on output, then IARRAY ! contains the edges, in order, that constitute this circuit. ! ! Workspace, integer STACK(MAXSTACK). ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Input/output, logical MORE. ! On first call, set MORE to .FALSE, and do not alter it after. ! On return, MORE is TRUE if another circuit has been returned in ! IARRAY, and FALSE if there are no more circuits. ! implicit none ! integer nedge integer maxstack ! integer circuit(nedge) integer inode(nedge) integer, save :: indx = 0 integer iwork(nedge) integer jnode(nedge) integer, save :: k = 0 logical lwork(nedge) logical more integer ncan(nedge) integer, save :: nstack = 0 integer stack(maxstack) ! if ( .not. more ) then indx = 0 k = 0 more = .true. nstack = 0 end if do call ivec_backtrack ( nedge, circuit, indx, k, nstack, stack, maxstack, & ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call digraph_arc_euler_circ_cand ( nedge, inode, jnode, circuit, k, & nstack, stack, maxstack, ncan, iwork, lwork ) else more = .false. exit end if end do return end subroutine digraph_arc_example_cycler ( maxedge, nedge, inode, jnode ) ! !******************************************************************************* ! !! DIGRAPH_ARC_EXAMPLE_CYCLER sets up the arc list information for the cycler digraph. ! ! ! Diagram: ! ! A ! | ! V ! 9--><--7---<--3--><---4 ! | /| / ! V A | / ! | / | / ! 5----<----1 V A ! | / | / ! V A | / ! | / |/ ! 2-->---8---<--6 ! \------>----/ ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXEDGE, the maximum number of edges. ! ! Output, integer NEDGE, the number of edges. ! ! Output, integer INODE(MAXEDGE), JNODE(MAXEDGE), the arc list ! for the digraph. ! implicit none ! integer maxedge ! integer inode(maxedge) integer jnode(maxedge) integer nedge ! nedge = 16 if ( nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ARC_EXAMPLE_CYCLER - Fatal error!' write ( *, '(a)' ) ' MAXEDGE is too small.' stop end if inode(1) = 1 jnode(1) = 3 inode(2) = 1 jnode(2) = 5 inode(3) = 2 jnode(3) = 6 inode(4) = 2 jnode(4) = 8 inode(5) = 3 jnode(5) = 4 inode(6) = 3 jnode(6) = 6 inode(7) = 3 jnode(7) = 7 inode(8) = 4 jnode(8) = 3 inode(9) = 5 jnode(9) = 2 inode(10) = 6 jnode(10) = 4 inode(11) = 6 jnode(11) = 8 inode(12) = 7 jnode(12) = 7 inode(13) = 7 jnode(13) = 9 inode(14) = 8 jnode(14) = 1 inode(15) = 9 jnode(15) = 5 inode(16) = 9 jnode(16) = 7 return end subroutine digraph_arc_is_eulerian ( nnode, nedge, inode, jnode, indegree, & outdegree, result ) ! !******************************************************************************* ! !! DIGRAPH_ARC_IS_EULERIAN determines if a digraph is Eulerian from its edge list. ! ! ! Definition: ! ! A digraph is Eulerian if there exists a circuit through the graph ! which uses every edge once. ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the pairs of nodes ! that form the edges. ! ! Output, integer INDEGREE(NNODE), OUTDEGREE(NODE), the indegree and ! outdegree of each node, that is, the number of edges that end with ! the node, and that begin the node. ! ! Output, integer RESULT. ! 0, the digraph is not Eulerian. ! 1, the digraph is Eulerian, but the starting and ending nodes differ. ! 2, the digraph is Eulerian, and there is a closed Euler circuit. ! implicit none ! integer nedge integer nnode ! integer i integer indegree(nnode) integer inode(nedge) integer jnode(nedge) integer n_minus integer n_plus integer outdegree(nnode) integer result ! call digraph_arc_degree ( nnode, nedge, inode, jnode, indegree, outdegree ) n_plus = 0 n_minus = 0 do i = 1, nnode if ( indegree(i) == outdegree(i) ) then else if ( n_plus == 0 .and. indegree(i) == outdegree(i) + 1 ) then n_plus = 1 else if ( n_minus == 0 .and. indegree(i) == outdegree(i) - 1 ) then n_minus = 1 else result = 0 return end if end do if ( n_plus == 0 .and. n_minus == 0 ) then result = 2 else if ( n_plus == 1 .and. n_minus == 1 ) then result = 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ARC_IS_EULERIAN - Fatal error!' write ( *, '(a)' ) ' The algorithm failed.' stop end if return end subroutine digraph_arc_print ( nedge, inode, jnode, title ) ! !******************************************************************************* ! !! DIGRAPH_ARC_PRINT prints out a digraph from an edge list. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the beginning and end ! nodes of the edges. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer nedge ! integer i integer inode(nedge) integer jnode(nedge) character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nedge write ( *, '(i6,4x,2i6)' ) i, inode(i), jnode(i) end do return end subroutine digraph_arc_to_digraph_adj ( nedge, inode, jnode, adj, lda, nnode ) ! !******************************************************************************* ! !! DIGRAPH_ARC_TO_DIGRAPH_ADJ converts an arc list digraph to an adjacency digraph. ! ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array. ! The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ! Input, integer LDA, the leading dimension of ADJ. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nedge ! integer adj(lda,*) integer i integer inode(nedge) integer j integer jnode(nedge) integer k integer mnode integer nnode ! ! Determine the number of nodes. ! call graph_arc_node_count ( nedge, inode, jnode, mnode, nnode ) if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIGRAPH_ARC_TO_DIGRAPH_ADJ - Fatal error!' write ( *, '(a)' ) ' Number of nodes exceeds LDA.' stop end if adj(1:nnode,1:nnode) = 0 do k = 1, nedge i = inode(k) j = jnode(k) adj(i,j) = 1 end do return end subroutine digraph_arc_to_digraph_star ( nnode, nedge, inode, jnode, arcfir, & fwdarc ) ! !******************************************************************************* ! !! DIGRAPH_ARC_TO_DIGRAPH_STAR sets up the forward star representation of a digraph. ! ! ! Modified: ! ! 04 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE); the I-th edge ! extends from node INODE(I) to JNODE(I). ! ! Output, integer ARCFIR(NNODE+1); ARCFIR(I) is the number of the first ! edge starting at node I in the forward star representation. ! ! Output, integer FWDARC(NEDGE); FWDARC(I) is the ending node of ! the I-th edge in the forward star representation. ! implicit none ! integer nedge integer nnode ! integer arcfir(nnode+1) integer fwdarc(nedge) integer i integer inode(nedge) integer j integer jnode(nedge) integer k ! ! Set up the forward star representation. ! k = 0 do i = 1, nnode arcfir(i) = k + 1 do j = 1, nedge if ( inode(j) == i ) then k = k + 1 fwdarc(k) = jnode(j) end if end do end do arcfir(nnode+1) = k + 1 return end subroutine digraph_arc_weight_print ( nedge, inode, jnode, wnode, title ) ! !******************************************************************************* ! !! DIGRAPH_ARC_WEIGHT_PRINT prints out a weighted digraph from an edge list. ! ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the beginning and end ! nodes of the edges. ! ! Input, real WNODE(NEDGE), the weights of the edges. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer nedge ! integer i integer inode(nedge) integer jnode(nedge) character ( len = * ) title real wnode(nedge) ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nedge write ( *, '(i6,4x,2i6,g14.6)' ) i, inode(i), jnode(i), wnode(i) end do return end subroutine digraph_dist_print ( dist, lda, nnode, title ) ! !******************************************************************************* ! !! DIGRAPH_DIST_PRINT prints the distance matrix defining a digraph. ! ! ! Modified: ! ! 22 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real DIST(LDA,NNODE), the distance matrix. ! DIST(I,J) is the distance from node I to node J. ! ! Input, integer LDA, the leading dimension of DIST, which must be at ! least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer nnode ! real dist(lda,nnode) integer ihi integer ilo integer jhi integer jlo integer ncol integer nrow character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' ilo = 1 ihi = nnode jlo = 1 jhi = nnode ncol = nnode nrow = nnode call rmat_print ( dist, ihi, ilo, jhi, jlo, lda, ncol, nrow ) return end subroutine digraph_inc_print ( lda, nnode, narc, inc, title ) ! !******************************************************************************* ! !! DIGRAPH_INC_PRINT prints the incidence matrix of a digraph. ! ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NARC, the number of arcs. ! ! Input, integer INC(LDA,NARC), the NNODE by NARC incidence matrix. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer narc ! integer i integer inc(lda,narc) integer nedge integer nnode character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode write ( *, '(20i3)' ) inc(i,1:narc) end do return end subroutine edge_add_nodes ( edge, max_edge, num_edge, iface, n1, n2, ierror ) ! !******************************************************************************* ! !! EDGE_ADD_NODES adds the edge defined by two nodes to the edge list. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input/output, integer NUM_EDGE, the number of edges. ! ! Input, integer IFACE, the face to which the nodes belong. ! ! Input, integer N1, N2, two nodes which form an edge. ! ! Output, integer IERROR, error flag, 0 = no error, nonzero = error. ! implicit none ! integer max_edge ! integer edge(4,max_edge) integer ierror integer iface integer n1 integer n2 integer num_edge ! if ( num_edge < max_edge ) then num_edge = num_edge + 1 edge(1,num_edge) = n1 edge(2,num_edge) = n2 edge(3,num_edge) = iface edge(4,num_edge) = 0 ierror = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EDGE_ADD_NODES - Fatal error!' write ( *, '(a,i6)' ) ' Exceeding MAX_EDGE = ', max_edge ierror = 1 end if return end subroutine edge_bound ( edge, max_edge, num_edge ) ! !******************************************************************************* ! !! EDGE_BOUND reports the edges which are part of the boundary. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input, integer NUM_EDGE, the number of edges. ! implicit none ! integer max_edge ! integer edge(4,max_edge) integer iedge integer num_bound integer num_edge ! num_bound = 0 do iedge = 1, num_edge if ( ( edge(3,iedge) /= 0 .and. edge(4,iedge) == 0 ) .or. & ( edge(3,iedge) == 0 .and. edge(4,iedge) /= 0 ) ) then num_bound = num_bound + 1 end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'EDGE_BOUND' write ( *, '(a,i6)' ) ' Number of boundary edges = ', num_bound return end subroutine edge_match_face ( edge, max_edge, num_edge, facelist, n, index ) ! !******************************************************************************* ! !! EDGE_MATCH_FACE seeks an edge common to a face and the edge list. ! ! ! Note: ! ! If a common edge is found, then the information in the face node ! list is adjusted so that the first two entries correspond to the ! matching edge in EDGE, but in reverse order. ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input, integer NUM_EDGE, the number of edges. ! ! Input/output, integer FACELIST(N), the list of nodes making a face. ! ! Input, integer N, the number of nodes in the face. ! ! Output, integer INDEX, the results of the search. ! 0, there is no edge common to the face and the EDGE array. ! nonzero, edge INDEX is common to the face and the EDGE array. ! implicit none ! integer n integer max_edge ! integer edge(4,max_edge) integer facelist(n) integer iedge integer index integer j integer jp1 integer n1 integer n2 integer num_edge ! index = 0 if ( n <= 0 ) then return end if if ( num_edge <= 0 ) then return end if do j = 1, n if ( j == n ) then jp1 = 1 else jp1 = j + 1 end if n1 = facelist(j) n2 = facelist(jp1) do iedge = 1, num_edge if ( edge(1,iedge) == n2 .and. edge(2,iedge) == n1 ) then call ivec_rotate ( n, 1 - j, facelist ) index = iedge return else if ( edge(1,iedge) == n1 .and. edge(2,iedge) == n2 ) then call ivec_rotate ( n, n - jp1, facelist ) call ivec_reverse ( n, facelist ) index = iedge return end if end do end do return end subroutine edge_match_nodes ( edge, max_edge, num_edge, n1, n2, iedge ) ! !******************************************************************************* ! !! EDGE_MATCH_NODES seeks an edge of the form (N1,N2) or (N2,N1) in EDGE. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input, integer NUM_EDGE, the number of edges. ! ! Input, integer N1, N2, two nodes that form an edge. ! ! Output, integer IEDGE, the results of the search. ! 0, no matching edge was found. ! nonzero, edge IEDGE of the EDGE array matches (N1,N2) or (N2,N1). ! implicit none ! integer max_edge ! integer edge(4,max_edge) integer i integer iedge integer n1 integer n2 integer num_edge ! iedge = 0 do i = 1, num_edge if ( ( n1 == edge(1,i) .and. n2 == edge(2,i) ) .or. & ( n2 == edge(1,i) .and. n1 == edge(2,i) ) ) then iedge = i return end if end do return end subroutine edges_to_ps ( plotxmin2, plotymin2, alpha, iunit, inode, jnode, & nedge, nnode, x, y, xmin, ymin ) ! !******************************************************************************* ! !! EDGES_TO_PS writes subplot edges to a PostScript file. ! ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PLOTXMIN2, PLOTYMIN2, the Postscript origin. ! ! Input, real ALPHA, the physical-to-Postscript scale factor. ! ! Input, integer IUNIT, the output FORTRAN unit. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array. ! The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real X(NNODE), Y(NNODE), the X and Y components of points. ! ! Input, real XMIN, YMIN, the physical origin. ! implicit none ! integer nedge integer nnode ! real alpha integer i integer inode(nedge) integer iunit integer jnode(nedge) integer node integer plotxmin2 integer plotymin2 integer px1 integer px2 integer py1 integer py2 real x(nnode) real xmin real y(nnode) real ymin ! ! Draw lines. ! do i = 1, nedge node = inode(i) px1 = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) py1 = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) node = jnode(i) px2 = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) py2 = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) write ( iunit, '(2i4,a,2i4,a)' ) px1, py1, ' moveto ', px2, py2, & ' lineto stroke' end do return end subroutine elmhes ( nm, n, low, igh, a, ind ) ! !******************************************************************************* ! !! ELMHES transforms a real general matrix to upper Hessenberg form. ! ! ! Discussion: ! ! Given a real general matrix, this subroutine reduces a submatrix ! situated in rows and columns LOW through IGH to upper Hessenberg ! form by stabilized elementary similarity transformations. ! ! Reference: ! ! Martin and Wilkinson, ! ELMHES, ! Numerische Mathematik, ! Volume 12, pages 349-368, 1968. ! ! J H Wilkinson and C Reinsch, ! Handbook for Automatic Computation, ! Volume II, Linear Algebra, Part 2, ! Springer Verlag, 1971. ! ! B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler, ! Matrix Eigensystem Routines, EISPACK Guide, ! Lecture Notes in Computer Science, Volume 6, ! Springer Verlag, 1976. ! ! Parameters: ! ! Input, integer NM, the leading dimension of the array A. ! NM must be at least N. ! ! Input, integer N, the order of the matrix. ! ! Input, integer LOW, IGH, are determined by the balancing routine ! BALANC. If BALANC has not been used, set LOW = 1, IGH = N. ! ! Input/output, real A(NM,N). On input, the matrix to be reduced. ! On output, the Hessenberg matrix. The multipliers ! which were used in the reduction are stored in the ! remaining triangle under the Hessenberg matrix. ! ! Output, integer IND(N), contains information on the rows and columns ! interchanged in the reduction. Only elements LOW through IGH are used. ! implicit none ! integer igh integer n integer nm ! real a(nm,n) integer i integer ind(igh) integer j integer la integer low integer m integer mm1 real x real y ! la = igh - 1 do m = low + 1, la mm1 = m - 1 x = 0.0E+00 i = m do j = m, igh if ( abs ( a(j,mm1) ) > abs ( x ) ) then x = a(j,mm1) i = j end if end do ind(m) = i ! ! Interchange rows and columns of the matrix. ! if ( i /= m ) then do j = mm1, n call r_swap ( a(i,j), a(m,j) ) end do do j = 1, igh call r_swap ( a(j,i), a(j,m) ) end do end if if ( x /= 0.0E+00 ) then do i = m+1, igh y = a(i,mm1) if ( y /= 0.0E+00 ) then y = y / x a(i,mm1) = y do j = m, n a(i,j) = a(i,j) - y * a(m,j) end do do j = 1, igh a(j,m) = a(j,m) + y * a(j,i) end do end if end do end if end do return end subroutine face_check ( edge, face, face_object, face_order, face_rank, & face_tier, max_edge, max_order, num_edge, num_face, num_object ) ! !******************************************************************************* ! !! FACE_CHECK checks and analyzes a set of faces. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, or 0 if the edge is used once. ! ! Input, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Output, integer FACE_OBJECT(NUM_FACE), describes the objects. ! FACE_OBJECT(I) is the index of the edge-connected "object" to ! which face I belongs. ! ! Input, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Output, integer FACE_RANK(NUM_FACE), is an ordered list of faces. ! FACE_RANK(1) is the index of the face in the first tier of the ! first object, followed by second tier faces, and so on until ! object one is complete. Object two follows, and so on. ! ! Output, integer FACE_TIER(NUM_FACE). FACE_TIER(I) is the "tier" ! of face I in its object. The seed of the object has tier 1, ! the neighbors of the seed have tier 2, and so on. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer NUM_EDGE, the number of edges. ! ! Input, integer NUM_FACE, the number of faces. ! ! Output, integer NUM_OBJECT, the number of objects. ! implicit none ! integer max_edge integer max_order integer num_face ! integer edge(4,max_edge) integer face(max_order,num_face) integer face_object(num_face) integer face_order(num_face) integer face_rank(num_face) integer face_tier(num_face) integer i integer ierror integer j integer num_edge integer num_fix integer num_object ! ! Organize the faces into layered objects. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Determine edge-connected objects.' call object_build ( face, face_object, face_order, face_rank, face_tier, & max_order, num_face, num_object ) write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'Number of objects = ', num_object write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Object, Tier' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(3i8)' ) i, face_object(i), face_tier(i) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Preferred order:' write ( *, '(a)' ) ' Order, Face' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(2i8)' ) i, face_rank(i) end do ! ! Reorder the faces by object and tier. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Reorder the faces.' call face_sort ( face, face_object, face_order, face_tier, max_order, & num_face ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Label, Object, Tier' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(4i8)' ) i, face_rank(i), face_object(i), face_tier(i) end do ! ! Construct the edge list. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Construct the edge list.' write ( *, '(a)' ) '(While doing so, check for edges used more' write ( *, '(a)' ) 'than twice.)' call face_to_edge ( edge, face, face_order, ierror, max_edge, max_order, & num_edge, num_face ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_CHECK - Fatal error!' write ( *, '(a)' ) ' FACE_TO_EDGE failed.' return end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Edge, Node1, Node2, Face1, Face2, Tier, Object' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I, node1(i), node2(i), face1(i), face2(i)' write ( *, '(a)' ) ' ' do i = 1, num_edge write ( *, '(10i3)' ) i, ( edge(j,i), j = 1, 4 ) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Order, Nodes' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(10i3)' ) i, face_order(i), ( face(j,i), j = 1, face_order(i) ) end do ! ! Now force faces to have a consistent orientation. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Force faces to consistent orientation.' call face_flip ( edge, face, face_order, max_edge, max_order, num_edge, & num_face, num_fix ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Face, Order, Nodes' write ( *, '(a)' ) ' ' do i = 1, num_face write ( *, '(10i3)' ) i, face_order(i), ( face(j,i), j = 1, face_order(i) ) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'List boundary edges.' call edge_bound ( edge, max_edge, num_edge ) return end subroutine face_example_box ( face, face_order, max_face, max_order, num_face ) ! !******************************************************************************* ! !! FACE_EXAMPLE_BOX returns the faces of a simple box. ! ! ! Diagram: ! ! 1---------------------------4 ! |\ /| ! | \ / | ! | \ 1 / | ! | \ / | ! | 2-----------------3 | ! | | | | ! | | | | ! | 3 | 4 | 5 | ! | | | | ! | | | | ! | 6-----------------7 | ! | / \ | ! | / \ | ! | / 2 \ | ! |/ \| ! 5---------------------------8 ! ! Discussion: ! ! This routine is used to supply some very simple data for the ! face checking routines. ! ! This is "almost" a cube, except that one face is missing. ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Output, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Input, integer MAX_FACE, the maximum number of faces allowed. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer NUM_FACE, the number of faces. ! implicit none ! integer max_order integer max_face ! integer face(max_order,max_face) integer face_order(max_face) integer iface integer num_face ! num_face = 5 if ( num_face > max_face ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_EXAMPLE_OPEN_BOX - Fatal error!' write ( *, '(a,i6)' ) ' Increase MAX_FACE to ', num_face stop end if face(1,1) = 1 face(2,1) = 2 face(3,1) = 3 face(4,1) = 4 face(1,2) = 5 face(2,2) = 6 face(3,2) = 7 face(4,2) = 8 face(1,3) = 1 face(2,3) = 2 face(3,3) = 6 face(4,3) = 5 face(1,4) = 6 face(2,4) = 7 face(3,4) = 3 face(4,4) = 2 face(1,5) = 3 face(2,5) = 4 face(3,5) = 8 face(4,5) = 7 face_order(1:num_face) = 4 return end subroutine face_example_pieces ( face, face_order, max_face, max_order, & num_face ) ! !******************************************************************************* ! !! FACE_EXAMPLE_PIECES returns the faces of a set of three objects. ! ! ! Diagram: ! ! 1---------------------------4 ! |\ /| ! | \ / | 9--------10 ! | \ 7 / | | | ! | \ / | | 1 | ! | 2-----------------3 | | | ! | | | | | | ! | | | | 11-------12 ! | 3 | 4 | 5 | \ / ! | | | | \ 6 / ! | | | | \ / ! | 6-----------------7 | \ / ! | / \ | 13 ! | / \ | / \ ! | / 8 \ | / \ ! |/ \| / 2 \ ! 5---------------------------8 / \ ! 14-------15 ! ! Note: ! ! THREE_PIECE is used to supply some very simple data for the ! face checking routines. ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer FACE(MAX_ORDER,MAX_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Output, integer FACE_ORDER(MAX_FACE), is the number of nodes ! making up each face. ! ! Input, integer MAX_FACE, the maximum number of faces allowed. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer NUM_FACE, the number of faces. ! implicit none ! integer max_order integer max_face ! integer face(max_order,max_face) integer face_order(max_face) integer num_face ! num_face = 8 if ( num_face > max_face ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_EXAMPLE_PIECES - Fatal error!' write ( *, '(a)' ) ' NUM_FACE > MAX_FACE!' write ( *, '(a,i6)' ) ' NUM_FACE = ', num_face write ( *, '(a,i6)' ) ' MAX_FACE = ', max_face stop end if face(1,1) = 9 face(2,1) = 10 face(3,1) = 12 face(4,1) = 11 face(1,2) = 14 face(2,2) = 13 face(3,2) = 15 face(1,3) = 1 face(2,3) = 2 face(3,3) = 6 face(4,3) = 5 face(1,4) = 6 face(2,4) = 7 face(3,4) = 3 face(4,4) = 2 face(1,5) = 3 face(2,5) = 4 face(3,5) = 8 face(4,5) = 7 face(1,6) = 13 face(2,6) = 12 face(3,6) = 11 face(1,7) = 1 face(2,7) = 2 face(3,7) = 3 face(4,7) = 4 face(1,8) = 5 face(2,8) = 6 face(3,8) = 7 face(4,8) = 8 face_order(1) = 4 face_order(2) = 3 face_order(3) = 4 face_order(4) = 4 face_order(5) = 4 face_order(6) = 3 face_order(7) = 4 face_order(8) = 4 return end subroutine face_flip ( edge, face, face_order, max_edge, max_order, & num_edge, num_face, num_fix ) ! !******************************************************************************* ! !! FACE_FLIP flips faces to achieve a consistent orientation. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, if any. ! ! Input, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Input, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input, integer MAX_ORDER, the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer NUM_EDGE, the number of edges. ! ! Input, integer NUM_FACE, the number of faces. ! ! Output, integer NUM_FIX, the number of bad faces that were found. ! implicit none ! integer max_edge integer max_order integer num_face ! integer edge(4,max_edge) integer f1 integer f2 integer face(max_order,num_face) integer face_order(num_face) integer iedge integer j integer jp1 integer m1 integer m2 integer n1 integer n2 integer num_edge integer num_fix ! num_fix = 0 do iedge = 1, num_edge n1 = edge(1,iedge) n2 = edge(2,iedge) f1 = edge(3,iedge) f2 = edge(4,iedge) ! ! For now, just whine unless (N1,N2) is positive in F1 and negative in F2. ! if ( f1 /= 0 ) then do j = 1, face_order(f1) if ( j < face_order(f1) ) then jp1 = j + 1 else jp1 = j end if m1 = face(j,f1) m2 = face(jp1,f1) if ( m1 == n1 .and. m2 == n2 ) then exit end if if ( m1 == n2 .and. m2 == n1 ) then num_fix = num_fix + 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_FLIP - Warning!' write ( *, '(a)' ) 'Bad orientation' write ( *, '(a,i6)' ) ' Face = ', f1 write ( *, '(a,i6)' ) ' Side = ', j exit end if end do end if if ( f2 /= 0 ) then do j = 1, face_order(f2) if ( j < face_order(f2) ) then jp1 = j + 1 else jp1 = j end if m1 = face(j,f2) m2 = face(jp1,f2) if ( m1 == n2 .and. m2 == n1 ) then exit end if if ( m1 == n1 .and. m2 == n2 ) then num_fix = num_fix + 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_FLIP - Warning!' write ( *, '(a)' ) 'Bad orientation' write ( *, '(a,i6)' ) ' Face = ', f2 write ( *, '(a,i6)' ) ' Side = ', j exit end if end do end if end do if ( num_fix > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_FLIP - Warning:' write ( *, '(a,i6)' ) ' Number of badly oriented faces = ', num_fix end if return end subroutine face_to_iv ( file_name, face, face_order, inode, jnode, nedge, & maxnode, maxface, maxorder, nnode, nface, x, y, z ) ! !******************************************************************************* ! !! FACE_TO_IV writes some simple graphics data to an Inventor file. ! ! ! Example: ! ! #Inventor V2.0 ascii ! ! Separator { ! Separator { ! LightModel { ! model PHONG ! } ! Material { ! ambientColor 0.2 0.2 0.2 ! diffuseColor 0.8 0.8 0.8 ! emissiveColor 0.0 0.0 0.0 ! specularColor 0.0 0.0 0.0 ! shininess 0.2 ! transparency 0.0 ! } ! Coordinate3 { ! point [ ! 8.59816 5.55317 -3.05561, ! 8.59816 2.49756 0.000000E+00, ! ...etc... ! 2.48695 2.49756 -3.05561, ! ] ! } ! IndexedFaceSet { ! coordIndex [ ! 0, 1, 2, -1, 3, 4, 5, -1, 7, 8, 9, ! ...etc... ! 191, -1, ! ] ! } ! } ! } ! ! Modified: ! ! 10 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the file name. ! ! Input, integer FACE(MAX_ORDER,MAX_FACE), the nodes making faces. ! ! Input, integer FACE_ORDER(MAX_FACE), the number of nodes per face. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), node pairs for edges. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer MAXNODE, the maximum number of nodes. ! ! Input, integer MAXFACE, the maximum number of faces. ! ! Input, integer MAXORDER, the maximum number of nodes per face. ! ! Input, integer NNODE, the number of points. ! ! Input, integer NFACE, the number of faces. ! ! Input, real X(MAXNODE), Y(MAXNODE), Z(MAXNODE), the coordinates of points. ! implicit none ! integer, parameter :: OFFSET = 1 integer maxnode integer maxface integer maxorder integer nedge ! integer face(maxorder,maxface) integer face_order(maxface) character ( len = * ) file_name integer i integer icor3 integer iface integer inode(nedge) integer ios integer itemp integer iunit integer ivert integer j integer jnode(nedge) integer length integer nnode integer nface character ( len = 200 ) text character ( len = 20 ) word real x(maxnode) real y(maxnode) real z(maxnode) ! call get_unit ( iunit ) open ( unit = iunit, file = file_name, status = 'replace', iostat = ios ) if ( ios /= 0 ) then return end if write ( iunit, '(a)' ) '#Inventor V2.0 ascii' write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) 'Separator {' write ( iunit, '(a)' ) ' Separator {' ! ! LightModel: ! ! BASE_COLOR ignores light sources, and uses only diffuse color ! and transparency. Even without normal vector information, ! the object will show up. However, you won't get shadow ! and lighting effects. ! ! PHONG uses the Phong lighting model, accounting for light sources ! and surface orientation. This is the default. I believe ! you need accurate normal vector information in order for this ! option to produce nice pictures. ! ! DEPTH ignores light sources, and calculates lighting based on ! the location of the object within the near and far planes ! of the current camera's view volume. ! write ( iunit, '(a)' ) ' LightModel {' write ( iunit, '(a)' ) ' model PHONG' write ( iunit, '(a)' ) ' }' ! ! Material ! write ( iunit, '(a)' ) ' Material {' write ( iunit, '(a)' ) ' ambientColor 0.5 0.2 0.2' write ( iunit, '(a)' ) ' diffuseColor 0.5 0.2 0.3' write ( iunit, '(a)' ) ' emissiveColor 0.5 0.0 0.0' write ( iunit, '(a)' ) ' specularColor 0.5 0.0 0.0' write ( iunit, '(a)' ) ' shininess 0.5' write ( iunit, '(a)' ) ' transparency 0.0' write ( iunit, '(a)' ) ' }' ! ! Point coordinates. ! write ( iunit, '(a)' ) ' Coordinate3 {' write ( iunit, '(a)' ) ' point [' do icor3 = 1, nnode write ( text, '(3f12.4,'','')' ) x(icor3), y(icor3), z(icor3) call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' write ( iunit, '(a)' ) ' IndexedLineSet {' ! ! IndexedLineSet coordIndex ! write ( iunit, '(a)' ) ' coordIndex [' do j = 1, nedge write ( iunit, '(8x,i8,'','',i8,'','',i8,'','')' ) & inode(j) - OFFSET, jnode(j)-offset, -1 end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' ! ! IndexedFaceSet. ! if ( nface > 0 ) then write ( iunit, '(a)' ) ' IndexedFaceSet {' ! ! IndexedFaceSet coordIndex ! write ( iunit, '(a)' ) ' coordIndex [' text = ' ' length = 0 do iface = 1, nface do ivert = 1, face_order(iface) + 1 if ( ivert <= face_order(iface) ) then itemp = face(ivert,iface) - OFFSET else itemp = 0 - OFFSET end if write ( word, '(i8,'','')' ) itemp call s_cat ( text, word, text ) length = length + 1 if ( itemp == -1 .or. length >= 10 .or. & ( iface == nface .and. ivert == face_order(iface) + 1 ) ) then call s_blanks_delete ( text ) write ( iunit, '(8x,a)' ) trim ( text ) text = ' ' length = 0 end if end do end do write ( iunit, '(a)' ) ' ]' write ( iunit, '(a)' ) ' }' end if ! ! Close up the Separator node. ! write ( iunit, '(a)' ) ' }' ! ! Close up the Separator node. ! write ( iunit, '(a)' ) '}' close ( unit = iunit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_TO_IV:' write ( *, '(a)' ) ' The data was written to the file: ' & // trim ( file_name ) return end subroutine face_sort ( face, face_object, face_order, face_tier, max_order, & num_face ) ! !******************************************************************************* ! !! FACE_SORT renumbers the faces in order of object and tier. ! ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Input/output, integer FACE_OBJECT(NUM_FACE), describes the objects. ! FACE_OBJECT(I) is the index of the edge-connected "object" to ! which face I belongs. ! ! Input/output, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Input/output, integer FACE_TIER(NUM_FACE). FACE_TIER(I) is the "tier" ! of face I in its object. The seed of the object has tier 1, ! the neighbors of the seed have tier 2, and so on. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer NUM_FACE, the number of faces. ! implicit none ! integer max_order integer num_face ! integer face(max_order,num_face) integer face_object(num_face) integer face_order(num_face) integer face_tier(num_face) integer i integer iface integer indx integer isgn integer jface ! iface = 0 jface = 0 indx = 0 isgn = 0 do call sort_heap_external ( num_face, indx, iface, jface, isgn ) ! ! Interchange faces IFACE and JFACE. ! if ( indx > 0 ) then do i = 1, max_order call i_swap ( face(i,iface), face(i,jface) ) end do call i_swap ( face_object(iface), face_object(jface) ) call i_swap ( face_order(iface), face_order(jface) ) call i_swap ( face_tier(iface), face_tier(jface) ) ! ! Compare faces IFACE and JFACE. ! else if ( indx < 0 ) then if ( ( face_object(iface) < face_object(jface) ) .or. & ( face_object(iface) == face_object(jface) .and. & face_tier(iface) < face_tier(jface) ) ) then isgn = -1 else isgn = +1 end if else exit end if end do return end subroutine face_to_edge ( edge, face, face_order, ierror, max_edge, & max_order, num_edge, num_face ) ! !******************************************************************************* ! !! FACE_TO_EDGE converts face data to edge data. ! ! ! Discussion: ! ! The computation will fail if: ! ! * More than two faces claim to share an edge (Node1,Node2). ! * Not enough storage is set aside by MAX_EDGE. ! ! If is expected that the edge (Node1,Node2) in Face1 is traversed in ! the opposite sense, as (Node2,Node1), in Face2. If this is not the ! case, then some faces may need to be reoriented, but that will not ! affect the computation. ! ! Modified: ! ! 12 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer EDGE(4,MAX_EDGE), edge information. ! EDGE(1,I) is the starting node of edge I; ! EDGE(2,I) is the ending node of edge I; ! EDGE(3,I) is the positive face; ! EDGE(4,I) is the negative face, or 0 if the edge is used once. ! ! Input, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Input, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Output, integer IERROR, error flag: 0 = no error, nonzero = error. ! ! Input, integer MAX_EDGE, the maximum number of edges. ! ! Input, integer MAX_ORDER, the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Output, integer NUM_EDGE, the number of edges. ! ! Input, integer NUM_FACE, the number of faces. ! implicit none ! integer max_edge integer max_order integer num_face ! integer edge(4,max_edge) integer face(max_order,num_face) integer face_order(num_face) integer i integer iedge integer ierror integer iface integer index integer j integer jp1 integer n1 integer n2 integer num_edge ! ! Initialize. ! ierror = 0 edge(1:4,1:max_edge) = 0 num_edge = 0 ! ! Consider face #I. ! do iface = 1, num_face ! ! Seek an edge of face IFACE that already occurs in the edge list. ! If there is one, then slide and reverse the entries in FACE(*,IFACE) ! so that that edge occurs first, and in the opposite sense to its ! occurrence in the edge list. ! call edge_match_face ( edge, max_edge, num_edge, face(1,iface), & face_order(iface), index ) ! ! Now, in any case, we know that the first two nodes in FACE(*,IFACE) ! are the negative of an existing edge, or no nodes in FACE(*,IFACE) ! occur in any existing edge. ! do j = 1, face_order(iface) n1 = face(j,iface) if ( j == face_order(iface) ) then jp1 = 1 else jp1 = j + 1 end if n2 = face(jp1,iface) call edge_match_nodes ( edge, max_edge, num_edge, n1, n2, iedge ) if ( iedge == 0 ) then call edge_add_nodes ( edge, max_edge, num_edge, iface, n1, n2, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_TO_EDGE - Fatal error!' write ( *, '(a)' ) ' EDGE_ADD_NODES failed.' ierror = 1 return end if else if ( edge(4,iedge) == 0 ) then edge(4,iedge) = iface else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'FACE_TO_EDGE - Fatal error!' write ( *, '(a,2i6)' ) ' Edge between nodes ', & edge(1,iedge), edge(2,iedge) write ( *, '(a)' ) ' is used at least 3 times, by faces:' write ( *, '(3i6)' ) edge(3,iedge), edge(4,iedge), iface ierror = 1 return end if end do end do return end subroutine face_touch ( face, face_order, max_order, num_face, iface, jface, & touch ) ! !******************************************************************************* ! !! FACE_TOUCH reports whether two polygonal faces touch. ! ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Input, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer NUM_FACE, the number of faces. ! ! Input, integer IFACE, JFACE, the faces to be checked. ! ! Output, integer TOUCH: ! 0, the faces do not touch; ! +1, the faces touch, both using an arc in the same direction; ! -1, the faces touch, using an arc in opposite directions. ! implicit none ! integer max_order integer num_face ! integer face(max_order,num_face) integer face_order(num_face) integer i integer iface integer j integer jface integer m integer mp1 integer mm1 integer n integer np1 integer touch ! touch = 0 ! ! Arc N1-N2 on IFACE must be matched by arc N1-N2 or N2-N1 on JFACE. ! do i = 1, face_order(iface) n = face(i,iface) if ( i < face_order(iface) ) then np1 = face(i+1,iface) else np1 = face(1,iface) end if do j = 1, face_order(jface) m = face(j,jface) if ( j < face_order(jface) ) then mp1 = face(j+1,jface) else mp1 = face(1,jface) end if if ( j > 1 ) then mm1 = face(j-1,jface) else mm1 = face(face_order(jface),jface) end if if ( n == m ) then if ( np1 == mp1 ) then touch = + 1 return else if ( np1 == mm1 ) then touch = - 1 return end if end if end do end do return end subroutine get_unit ( iunit ) ! !******************************************************************************* ! !! GET_UNIT returns a free FORTRAN unit number. ! ! ! Discussion: ! ! A "free" FORTRAN unit number is an integer between 1 and 99 which ! is not currently associated with an I/O device. A free FORTRAN unit ! number is needed in order to open a file with the OPEN command. ! ! Modified: ! ! 02 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IUNIT. ! ! If IUNIT = 0, then no free FORTRAN unit could be found, although ! all 99 units were checked (except for units 5 and 6). ! ! Otherwise, IUNIT is an integer between 1 and 99, representing a ! free FORTRAN unit. Note that GET_UNIT assumes that units 5 and 6 ! are special, and will never return those values. ! implicit none ! integer i integer ios integer iunit logical lopen iunit = 0 do i = 1, 99 if ( i /= 5 .and. i /= 6 ) then inquire ( unit = i, opened = lopen, iostat = ios ) if ( ios == 0 ) then if ( .not. lopen ) then iunit = i return end if end if end if end do ! ! No free unit was found. ! iunit = 0 return end subroutine graph_adj_bfs ( adj, lda, nnode, dad, deep, order ) ! !******************************************************************************* ! !! GRAPH_ADJ_BFS carries out a breadth-first traversal of a graph. ! ! ! Reference: ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985, ! ISBN 0-521-28881-9. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), is the adjacency information. ! ADJ(I,J) is nonzero if there is an edge from node ! I to node J, and 0 otherwise. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), DAD(I) is the node from which ! node I is visited. Node 1 is the first node in the search, ! and has no predecessor, so DAD(1) is zero. If there is ! more than one connected component, then there ! will be other nodes with DAD equal to zero. ! ! Output, integer DEEP(NNODE), records the "depth" of the node. ! The first node, node 1, has depth 1. All the nodes that ! can be reached in one step from node 1 have depth 2. All ! nodes that can be reached in one step from any of those nodes ! have depth 3. If there is more than one connected component, ! then the depth of nodes in the second component will begin ! one greater than the greatest depth of the first component, ! and so on. ! ! Output, integer ORDER(NNODE). ORDER(I) is the step at which ! node I is visited in the search. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer deep(nnode) integer i integer order(nnode) integer iput integer queue(nnode) integer itake integer j integer jdeep integer k integer nudeep ! deep(1:nnode) = 0 order(1:nnode) = 0 dad(1:nnode) = 0 k = 0 i = 1 iput = 1 itake = 1 nudeep = iput queue(iput) = i jdeep = 1 deep(i) = jdeep k = k + 1 order(i) = k dad(i) = 0 ! ! Find all sons of this father. ! Store all sons in the son stack. ! 10 continue do j = 1, nnode if ( ( adj(i,j) /= 0 .or. adj(j,i) /= 0 ) .and. order(j) == 0 ) then iput = iput + 1 if ( iput > nnode ) then iput = 1 end if queue(iput) = j k = k + 1 dad(j) = i order(j) = k deep(j) = jdeep + 1 end if end do ! ! Are there more fathers whose sons are to be searched for? ! if ( iput /= itake ) then if ( itake == nudeep ) then jdeep = jdeep + 1 nudeep = iput end if i = queue(itake) itake = itake + 1 if ( itake > nnode ) then itake = 1 end if go to 10 ! ! No more fathers, no more sons. Is there an unvisited component? ! else do i = 1, nnode if ( order(i) == 0 ) then itake = 1 iput = 1 queue(iput) = i jdeep = jdeep + 1 nudeep = 1 k = k + 1 order(i) = k deep(i) = jdeep dad(i) = 0 go to 10 end if end do end if return end subroutine graph_adj_bipartite_random ( adj, lda, nedge, nnode1, nnode2 ) ! !******************************************************************************* ! !! GRAPH_ADJ_BIPARTITE_RANDOM generates a random bipartite graph. ! ! ! Definition: ! ! A bipartite graph has the property that its nodes may be divided ! into two groups, NODE1 and NODE2, with the property that the only ! edges in the graph are between a node in NODE1 and a node in NODE2. ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE1+NNODE2), the adjacency matrix. ADJ(I,J) is ! nonzero if there is an edge from node I to node J. ADJ(I,I) will ! always be 0. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE1+NNODE2. ! ! Output, integer NEDGE, the number of edges. ! ! Input, integer NNODE1, NNODE2, the number of nodes in the first and ! second groups of nodes. ! implicit none ! integer lda integer nnode1 integer nnode2 integer nedge ! integer adj(lda,nnode1+nnode2) integer i integer j integer k integer nnode real r ! if ( nnode1 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_BIPARTITE_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE1 = ', nnode1 write ( *, '(a)' ) ' but NNODE1 must be at least 1.' stop end if if ( nnode2 <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_BIPARTITE_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE2 = ', nnode2 write ( *, '(a)' ) ' but NNODE2 must be at least 1.' stop end if nnode = nnode1 + nnode2 nedge = 0 adj(1:nnode,1:nnode) = 0 ! ! For each node in the NODE1 group, ! consider a edge to each node in the NODE2 group. ! do i = 1, nnode1 do j = nnode1+1, nnode1+nnode2 call i_random ( 0, 1, k ) adj(i,j) = k adj(j,i) = k nedge = nedge + k end do end do ! ! Now perform a random permutation of the rows and columns. ! call imat_perm_random ( lda, nnode, adj ) return end subroutine graph_adj_block ( adj, lda, nnode, dad, order, stack, nblock ) ! !******************************************************************************* ! !! GRAPH_ADJ_BLOCK finds the blocks of an undirected graph from its adjacency list. ! ! ! Definition: ! ! A component of a graph is a connected subset of the graph. If a node ! is in the component, then all nodes to which it is connected are also ! in the component. ! ! An articulation point of a component of a graph is a node whose ! removal causes the component to no longer be connected. ! ! A component with no articulation points is called a block. ! ! Reference: ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985, ! ISBN 0-521-28881-9. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). ! ! On input, ADJ is the adjacency matrix. ADJ(I,J) is ! positive if there is an edge from node I to node J, and 0 otherwise. ! ! On output, each positive entry of ADJ has been replaced ! by the number of the block that the corresponding edge belongs to. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), DAD(I) is the node from which ! node I is visited. Node 1 is the first node in the search, ! and has no predecessor, so DAD(1) is zero. If there is ! more than one connected component in the graph, then there ! will be other nodes with DAD equal to zero. ! ! Output, integer ORDER(NNODE). ORDER(I) records the order ! in which the node was visited during the depth-first search. ! The first node, node 1, has ORDER(1) = 1. ! ! Note, however, that any node which is an articulation point ! will have the value of ORDER negated. ! ! Workspace, integer STACK(NNODE). ! ! Output, integer NBLOCK, the number of blocks. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer idir integer ii integer inode(nnode) integer order(nnode) integer iroot integer j integer jedge integer jj integer jnode(nnode) integer k integer l integer label(nnode) integer lstack integer nblock integer stack(nnode) ! dad(1:nnode) = 0 inode(1:nnode) = 0 order(1:nnode) = 0 stack(1:nnode) = 0 jnode(1:nnode) = 0 label(1:nnode) = 0 nblock = 0 k = 0 i = 1 lstack = 0 jedge = 0 ! ! Find all descendants of the parent node in this connected component ! of the graph. ! 10 continue iroot = i k = k + 1 order(i) = k label(i) = k lstack = lstack + 1 stack(lstack) = i idir = + 1 30 continue j = 0 ! ! Check the next neighbor. ! 40 continue j = j + 1 if ( j > nnode ) then go to 50 end if if ( adj(i,j) /= 0 .or. adj(j,i) /= 0 ) then if ( adj(i,j) > 0 .or. adj(j,i) > 0 ) then jedge = jedge + 1 inode(jedge) = i jnode(jedge) = j end if if ( order(j) == 0 ) then dad(j) = i lstack = lstack + 1 stack(lstack) = j idir = + 1 k = k + 1 i = j order(i) = k label(i) = k go to 30 else if ( idir == +1 ) then label(i) = min ( label(i), abs ( order(j) ) ) else label(i) = min ( label(i), label(j) ) end if end if end if go to 40 ! ! Searched all directions from current node. Back up one node, ! or, if stack is exhausted, look for a node we haven't visited, ! which therefore belongs to a new connected component. ! 50 continue lstack = lstack - 1 idir = -1 if ( lstack > 0 ) then j = i i = stack(lstack) if ( label(j) >= abs ( order(i) ) ) then if ( order(i) > 0 ) then if ( i /= iroot ) then order(i) = - order(i) else iroot = 0 end if end if nblock = nblock + 1 do ii = inode(jedge) jj = jnode(jedge) jedge = jedge - 1 adj(ii,jj) = - nblock adj(jj,ii) = - nblock if ( ii == i .and. jj == j ) then exit end if end do end if go to 40 else lstack = 0 do l = 1, nnode if ( order(l) == 0 ) then i = l go to 10 end if end do end if ! ! Restore the positive sign of the adjacency matrix. ! adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) return end subroutine graph_adj_closure ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_CLOSURE generates the transitive closure of a graph. ! ! ! Discussion: ! ! The method is due to S Warshall. ! ! Definition: ! ! The transitive closure of a graph is a function REACH(I,J) so that ! ! REACH(I,J) = 0 if node J cannot be reached from node I; ! 1 if node J can be reached from node I. ! ! This is an extension of the idea of adjacency. REACH(I,J)=1 if ! node J is adjacent to node I, or if node J is adjacent to a node ! that is adjacent to node I, etc. ! ! Note that if a graph is (node) connected, then its transitive closure ! is the matrix that is 1 everywhere. ! ! Reference: ! ! Robert Sedgewick, ! Algorithms, ! Addison Wesley, 1983, page 425. ! ! Modified: ! ! 22 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). ! ! On input, ADJ is the adjacency matrix for the graph. ADJ(I,J) ! is nonzero if there is an edge from node I to node J. ! ! On output, ADJ is the transitive closure matrix of the graph. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k ! do i = 1, nnode adj(i,i) = 1 end do do i = 1, nnode do j = 1, nnode if ( adj(j,i) /= 0 .or. adj(i,j) /= 0 ) then do k = 1, nnode if ( adj(i,k) /= 0 .or. adj(k,i) /= 0 ) then adj(j,k) = 1 adj(k,j) = 1 end if end do end if end do end do return end subroutine graph_adj_color_cand ( adj, lda, nnode, ncolor, color, k, nstack, & stack, maxstack, ncan ) ! !******************************************************************************* ! !! GRAPH_ADJ_COLOR_CAND finds possible colors for a node during a graph coloring. ! ! ! Discussion: ! ! This routine is given a partial coloring of the graph. ! The total coloring of the graph must be done in such a way that no ! two nodes joined by an edge have the same color. ! ! This routine must be used in conjunction with IVEC_BACKTRACK. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 16 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix. ADJ(I,J) is ! nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the first dimension of ADJ as declared in ! the calling program. LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors available. ! ! Input, integer COLOR(NNODE). COLOR(I) is the color of node I. ! ! Input, integer K, node whose possible colors are to be found. ! ! Input/output, integer NSTACK, current length of stack. ! ! Workspace, integer STACK(MAXSTACK), candidates for the colors of the nodes. ! ! Input, integer MAXSTACK, dimension of STACK. ! ! input, integer NCAN(NNODE), the number of candidates for each position. ! implicit none ! integer lda integer nnode integer maxstack ! integer adj(lda,nnode) integer color(nnode) integer i logical lwork(nnode) integer k integer ncan(nnode) integer nstack integer ncolor integer stack(maxstack) ! ncan(k) = 0 if ( k <= 1 ) then stack(1) = 1 nstack = 1 ncan(k) = 1 else lwork(1:ncolor) = .true. do i = 1, k-1 if ( adj(i,k) /= 0 .or. adj(k,i) /= 0 ) then lwork(color(i)) = .false. end if end do do i = 1, ncolor if ( lwork(i) ) then nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if end do end if return end subroutine graph_adj_color_next ( adj, lda, nnode, ncolor, color, stack, & maxstack, ncan, more ) ! !******************************************************************************* ! !! GRAPH_ADJ_COLOR_NEXT returns possible colorings of a graph, one at a time. ! ! ! Definition: ! ! A coloring of a graph using NCOLOR colors is an assignment to each ! node of a label between 1 and NCOLOR, in such a way that no two ! neighboring nodes have the same label. ! ! Method: ! ! This routine uses the backtracking method to produce the colorings. ! Routine GRAPH_ADJ_COLOR_CAND produces candidates for a partial solution, ! and routine IVEC_BACKTRACK assembles the total solution. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 27 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix. ADJ(I,J) is nonzero ! if there is an edge between node I to node J. ! ! Input, integer LDA, the first dimension of ADJ as declared in ! the calling program. LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NCOLOR, the number of colors available. ! ! Output, integer COLOR(NNODE). On return with MORE = TRUE, COLOR(I) ! is the color of node I. ! ! Workspace, integer STACK(MAXSTACK), candidates for the colors of nodes ! 1 through K-1. ! ! Input, integer MAXSTACK, dimension of STACK. ! ! Workspace, integer NCAN(NNODE), the number of candidates for each position. ! ! Input/output, logical MORE. ! On first call, set MORE to .FALSE, and do not alter it after. ! On return, MORE is TRUE if another coloring has been returned in ! IARRAY, and FALSE if there are no more colorings. ! implicit none ! integer nnode integer lda integer maxstack ! integer adj(lda,nnode) integer color(nnode) integer, save :: indx = 0 integer, save :: k = 0 logical more integer ncan(nnode) integer, save :: nstack = 0 integer ncolor integer stack(maxstack) ! ! First call. ! if ( .not. more ) then indx = 0 k = 0 more = .true. nstack = 0 end if do call ivec_backtrack ( nnode, color, indx, k, nstack, stack, maxstack, & ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call graph_adj_color_cand ( adj, lda, nnode, ncolor, color, k, nstack, & stack, maxstack, ncan ) else more = .false. exit end if end do return end subroutine graph_adj_complement ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_COMPLEMENT returns the adjacency matrix of the complement of a graph. ! ! ! Definition: ! ! This routine can also handle a directed graph. ! ! The complement of a graph G is a graph H with the property that ! nodes u and v are connected in H if and only if they are not ! connected in G. However, edges from a node to itself are not ! allowed. ! ! Modified: ! ! 05 August 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). On input, the ! adjacency information for the graph G. On output, ADJ ! the adjacency information for the complement of G. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! NNODE or greater. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j ! ! Force the adjacency graph to be symmetric. ! call graph_adj_symmetrize ( adj, lda, nnode ) do i = 1, nnode do j = 1, nnode if ( i == j ) then adj(i,j) = 0 else if ( adj(i,j) /= 0 ) then adj(i,j) = 0 else if ( adj(i,j) == 0 ) then adj(i,j) = 1 end if end do end do return end subroutine graph_adj_connect_random ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! GRAPH_ADJ_CONNECT_RANDOM generates a random connected graph. ! ! ! Modified: ! ! 25 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE), the adjacency matrix. ADJ(I,J) is ! nonzero if there is an edge from node I to node J. ADJ(I,I) will ! always be 0. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges, which must be between ! NNODE-1 and (NNODE*(NNODE-1))/2. ! implicit none ! integer lda integer nnode integer nedge ! integer adj(lda,nnode) integer code(nnode-2) integer i integer inode(nnode-1) integer iwork(nedge) integer j integer jnode(nnode-1) integer k integer l integer maxedge integer nchoice integer nchoose integer nnode2 ! ! Check. ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' LDA = ', lda write ( *, '(a,i6)' ) ' but LDA must be at least NNODE = ', nnode stop end if maxedge = ( nnode * ( nnode - 1 ) ) / 2 if ( nedge < nnode-1 .or. nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i6)' ) ' no more than ', maxedge stop end if ! ! Initialize the adjacency matrix. ! adj(1:nnode,1:nnode) = 0 ! ! Pick a random tree. ! call tree_arc_random ( nnode, code, inode, jnode ) ! ! Convert information to adjacency form. ! call graph_arc_to_graph_adj ( nnode-1, inode, jnode, adj, lda, nnode2 ) ! ! 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 ) k = 0 l = 1 do i = 1, nnode do j = i + 1, nnode if ( adj(i,j) /= 0 .or. adj(j,i) /= 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 graph_adj_cycle ( adj, lda, nnode, dad, order, maxstack, stack ) ! !******************************************************************************* ! !! GRAPH_ADJ_CYCLE searches for cycles in a graph. ! ! ! Modified: ! ! 22 February 1999 ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE), the adjacency matrix for ! the graph. ADJ(I,J) is 0 if there is no edge from node I to node J. ! ! On input, ADJ(I,J) should be 1 if there is an edge from node I to node J. ! ! On output, ADJ(I,J) will be one of the following values: ! -1 if the edge from node I to node J is part of at least one cycle; ! -2 if the edge from node I to node J is part of the depth first ! search trees. ! ! Input, integer LDA, the leading dimension of ADJ, which must ! be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), the father array for the depth first ! search trees. DAD(I) = 0 means that node I is the root of ! one of the trees. DAD(I) = J means that the search descended ! from node J to node I. ! ! Output, integer ORDER(NNODE), the order in which the nodes were ! traversed, from 1 to NNODE. ! ! Input, integer MAXSTACK, the amount of stack space available. ! The absolute maximum needed would be 2*(NNODE-1) though less ! is likely. ! ! Workspace, integer STACK(MAXSTACK). ! implicit none ! integer lda integer maxstack integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer daddy integer i integer j integer nstack integer order(nnode) integer rank integer stack(maxstack) ! dad(1:nnode) = 0 order(1:nnode) = 0 rank = 0 do i = 1, nnode if ( order(i) == 0 ) then daddy = i nstack = 0 ! ! Visit node DAD. ! 10 continue rank = rank + 1 order(daddy) = rank j = 0 ! ! Consider visiting node J from node DAD. ! 20 continue j = j + 1 ! ! If J is a reasonable value, adjacent to DAD, and unvisited, ! then put DAD into the stack, make J the new value of DAD, ! and go to 10. ! if ( j <= nnode ) then if ( adj(daddy,j) > 0 .or. adj(j,daddy) > 0 ) then if ( order(j) == 0 ) then adj(daddy,j) = - 2 adj(j,daddy) = - 2 if ( nstack+2 <= maxstack ) then dad(j) = daddy stack(nstack+1) = daddy stack(nstack+2) = j nstack = nstack + 2 daddy = j go to 10 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_CYCLE - Fatal error!' write ( *, '(a)' ) ' Out of stack space.' stop end if ! ! An adjacent node has already been visited. This constitutes a cycle. ! else adj(j,daddy) = - 1 adj(daddy,j) = - 1 go to 20 end if ! ! If J is not suitable for a visit, get the next value of J. ! else go to 20 end if ! ! If no more neighbors to consider, back up one node. ! else if ( nstack >= 2 ) then daddy = stack(nstack-1) j = stack(nstack) nstack = nstack - 2 go to 20 ! ! If no more nodes to consider in this tree, bail out. ! else nstack = 0 end if end if end do return end subroutine graph_adj_degree ( adj, lda, nnode, degree ) ! !******************************************************************************* ! !! GRAPH_ADJ_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: ! ! 01 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DEGREE(NNODE), the degree of the nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer degree(nnode) integer i integer j ! degree(1:nnode) = 0 do i = 1, nnode do j = 1, nnode if ( adj(i,j) /= 0 ) then degree(i) = degree(i) + adj(i,j) end if end do end do return end subroutine graph_adj_degree_max ( adj, lda, nnode, degree_max ) ! !******************************************************************************* ! !! GRAPH_ADJ_DEGREE_MAX computes the maximum node degree. ! ! ! Discussion: ! ! The maximum node degree of a graph is the maximum value of the ! degree of the nodes of the graph. ! ! If two graphs are isomorphic, they must have the same maximum node degree. ! ! If two graphs have different maximum node degrees, they cannot be isomorphic. ! ! Modified: ! ! 21 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DEGREE_MAX, the maximum node degree of the graph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer degree integer degree_max integer i integer j ! degree_max = 0 do i = 1, nnode degree = 0 do j = 1, nnode if ( adj(i,j) /= 0 ) then degree = degree + adj(i,j) end if end do degree_max = max ( degree_max, degree ) end do return end subroutine graph_adj_degree_seq ( adj, lda, nnode, seq ) ! !******************************************************************************* ! !! GRAPH_ADJ_DEGREE_SEQ computes the degree sequence of a graph. ! ! ! Discussion: ! ! The degree sequence of a graph is constructed by computing the ! degree of each node, and then ordering these values in decreasing order. ! ! If two graphs are isomorphic, they must have the same degree sequence. ! ! If two graphs have different degree sequences, they cannot be isomorphic. ! ! Modified: ! ! 21 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer SEQ(NNODE), the degree sequence of the graph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer seq(nnode) ! seq(1:nnode) = 0 do i = 1, nnode do j = 1, nnode seq(i) = seq(i) + adj(i,j) end do end do call ivec_sort_heap_d ( nnode, seq ) return end subroutine graph_adj_dfs ( adj, lda, nnode, dad, order ) ! !******************************************************************************* ! !! GRAPH_ADJ_DFS does a depth first search of a graph. ! ! ! Discussion: ! ! The routine returns: ! ! * a list of the order in which the nodes were visited, ! * a list of the parents of each node in the search tree, ! ! Reference: ! ! Robert Sedgewick, ! Algorithms, ! Addison Wesley, 1983, page 382. ! ! Modified: ! ! 04 July 2000 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is 0 if node J is not adjacent to node I, and nonzero ! otherwise. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), the father array for the depth first ! search trees. DAD(I) = 0 means that node I is the root of ! one of the trees. DAD(I) = J means that the search descended ! from node J to node I. ! ! Output, integer ORDER(NNODE), the order in which the nodes were ! traversed, from 1 to NNODE. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer daddy integer i integer j integer maxstack integer nstack integer order(nnode) integer rank integer stack(2*(nnode-1)) ! dad(1:nnode) = 0 maxstack = 2 * ( nnode - 1 ) order(1:nnode) = 0 rank = 0 do i = 1, nnode if ( order(i) == 0 ) then daddy = i nstack = 0 ! ! Visit node DAD. ! 10 continue rank = rank + 1 order(daddy) = rank j = 0 ! ! Consider visiting node J from node DAD. ! 20 continue j = j + 1 ! ! If J is a reasonable value, adjacent to DAD, and unvisited, ! then put DAD into the stack, make J the new value of DAD, ! and go to 10. ! if ( j <= nnode ) then if ( adj(daddy,j) /= 0 .and. order(j) == 0 ) then if ( nstack+2 <= maxstack ) then dad(j) = daddy stack(nstack+1) = daddy stack(nstack+2) = j nstack = nstack + 2 daddy = j go to 10 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_DFS - Fatal error!' write ( *, '(a)' ) ' Out of stack space.' stop end if ! ! If J is not suitable for a visit, get the next value of J. ! else go to 20 end if ! ! If no more neighbors to consider, back up one node. ! else if ( nstack >= 2 ) then daddy = stack(nstack-1) j = stack(nstack) nstack = nstack - 2 go to 20 ! ! If no more nodes to consider in this tree, bail out. ! else nstack = 0 end if end if end do return end subroutine graph_adj_dfs_2 ( adj, lda, nnode, dad, order ) ! !******************************************************************************* ! !! GRAPH_ADJ_DFS_2 does a depth-first search of a graph. ! ! ! Reference: ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985, ! ISBN 0-521-28881-9. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), is the adjacency matrix of ! the graph. ADJ(I,J) is nonzero if there is an edge from node ! I to node J. ! ! Input, integer LDA, the leading dimension of ADJ, which must ! be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), DAD(I) is the node from which ! node I is visited. Node 1 is the first node in the search, ! and has no predecessor, so DAD(1) is zero. If there is ! more than one connected component in the graph, then there ! will be other nodes with DAD equal to zero. ! ! Output, integer ORDER(NNODE). ORDER(I) is the step at which ! node I is visited in the search. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer dad(nnode) integer i integer order(nnode) integer j integer kount integer l integer lstack integer stack(nnode) ! order(1:nnode) = 0 dad(1:nnode) = 0 stack(1:nnode) = 0 kount = 0 i = 1 lstack = 0 ! ! Find all descendents of the parent node I in this connected component ! of the graph. ! 10 continue kount = kount + 1 dad(i) = 0 order(i) = kount lstack = lstack + 1 stack(lstack) = i ! ! Check to see if each node, J, is a "descendant" of node I. ! 30 continue j = 0 ! ! Check next neighbor, J. ! 40 continue j = j + 1 if ( j <= nnode ) then if ( adj(i,j) /= 0 .and. order(j) == 0 ) then lstack = lstack + 1 stack(lstack) = j dad(j) = i kount = kount + 1 order(j) = kount i = j if ( kount == nnode ) then return end if go to 30 end if go to 40 end if ! ! Searched all directions from current node. Back up one node. ! lstack = lstack - 1 if ( lstack > 0 ) then j = i i = stack(lstack) go to 40 end if ! ! The stack is exhausted. It's time to look for another connected ! component. ! lstack = 0 do l = 1, nnode if ( order(l) == 0 ) then i = l go to 10 end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_DFS2 - Fatal error!' stop end subroutine graph_adj_edge_count ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! GRAPH_ADJ_EDGE_COUNT counts the number of edges in a graph. ! ! ! Modified: ! ! 01 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEDGE, the number of edges in the graph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer nedge ! nedge = 0 do i = 1, nnode do j = 1, nnode if ( i == j ) then nedge = nedge + 2 * adj(i,j) else nedge = nedge + adj(i,j) end if end do end do nedge = nedge / 2 return end subroutine graph_adj_eigen ( adj, lda, nnode, neigen, eigen ) ! !******************************************************************************* ! !! GRAPH_ADJ_EIGEN computes the eigenvalues of a graph from its adjacency matrix. ! ! ! Modified: ! ! 15 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer NEIGEN, the number of eigenvalues computed. ! Normally, this would be equal to NNODE, unless the algorithm failed. ! ! Output, real EIGEN(NNODE), contains the computed eigenvalues. ! implicit none ! integer lda integer nnode ! real a(nnode,nnode) integer adj(lda,nnode) real e(nnode) real e2(nnode) real eigen(nnode) integer ierr integer neigen ! a(1:nnode,1:nnode) = real ( adj(1:nnode,1:nnode) ) call tred1 ( nnode, nnode, a, eigen, e, e2 ) call tqlrat ( nnode, eigen, e2, ierr ) if ( ierr == 0 ) then neigen = nnode else neigen = ierr - 1 end if return end subroutine graph_adj_example_bush ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_EXAMPLE_BUSH sets up the adjacency information for the bush graph. ! ! ! Diagram: ! ! 6 3 ! | | ! 1---4---5---2 ! | ! 7 ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), the adjacency information for the graph. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 7 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_EXAMPLE_BUSH - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 adj(1,4) = 1 adj(2,5) = 1 adj(3,5) = 1 adj(4,1) = 1 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(6,4) = 1 adj(7,4) = 1 return end subroutine graph_adj_example_cube ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_EXAMPLE_CUBE sets up the adjacency information for the cube graph. ! ! ! Diagram: ! ! 4-----7 ! /| /| ! 8-----3 | ! | | | | ! | 5---|-2 ! |/ |/ ! 1-----6 ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), the adjacency information for the graph. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 8 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_EXAMPLE_CUBE - Fatal error!' write ( *, '(a)' ) ' LDA < NNODE.' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a,i6)' ) ' LDA = ', lda stop end if adj(1:nnode,1:nnode) = 0 adj(1,5) = 1 adj(1,6) = 1 adj(1,8) = 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,5) = 1 adj(4,7) = 1 adj(4,8) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(5,4) = 1 adj(6,1) = 1 adj(6,2) = 1 adj(6,3) = 1 adj(7,2) = 1 adj(7,3) = 1 adj(7,4) = 1 adj(8,1) = 1 adj(8,3) = 1 adj(8,4) = 1 return end subroutine graph_adj_example_dodecahedron ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_EXAMPLE_DODECAHEDRON sets up the adjacency information for the dodecahedron graph. ! ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), the adjacency information for the graph. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 20 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_EXAMPLE_DODECAHEDRON - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(1,5) = 1 adj(1,6) = 1 adj(2,1) = 1 adj(2,3) = 1 adj(2,8) = 1 adj(3,2) = 1 adj(3,4) = 1 adj(3,10) = 1 adj(4,3) = 1 adj(4,5) = 1 adj(4,12) = 1 adj(5,1) = 1 adj(5,4) = 1 adj(5,14) = 1 adj(6,1) = 1 adj(6,7) = 1 adj(6,15) = 1 adj(7,6) = 1 adj(7,8) = 1 adj(7,17) = 1 adj(8,7) = 1 adj(8,9) = 1 adj(8,2) = 1 adj(9,8) = 1 adj(9,10) = 1 adj(9,16) = 1 adj(10,3) = 1 adj(10,9) = 1 adj(10,11) = 1 adj(11,10) = 1 adj(11,12) = 1 adj(11,20) = 1 adj(12,4) = 1 adj(12,11) = 1 adj(12,13) = 1 adj(13,12) = 1 adj(13,14) = 1 adj(13,19) = 1 adj(14,13) = 1 adj(14,15) = 1 adj(14,5) = 1 adj(15,6) = 1 adj(15,14) = 1 adj(15,18) = 1 adj(16,9) = 1 adj(16,17) = 1 adj(16,20) = 1 adj(17,16) = 1 adj(17,18) = 1 adj(17,7) = 1 adj(18,15) = 1 adj(18,17) = 1 adj(18,19) = 1 adj(19,13) = 1 adj(19,18) = 1 adj(19,20) = 1 adj(20,11) = 1 adj(20,16) = 1 adj(20,19) = 1 return end subroutine graph_adj_example_octo ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example graph. ! ! ! Diagram: ! ! 1---2 ! /| |\ ! 8-+---+-3 ! | | | | ! 7-+---+-4 ! \| |/ ! 6---5 ! ! Graph "A" ! ! There are 7 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. ! ! Modified: ! ! 05 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), the adjacency information for the graph. ! ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input/output, integer NNODE. ! On input, the value of NNODE should be between 1 and 7, and indicates ! which example graph to pick. ! On output, NNODE is the number of nodes, which should be 8. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode integer nsave ! if ( nnode <= 0 ) then call i_random ( 1, 7, nsave ) else nnode = mod ( nnode - 1, 7 ) + 1 nsave = nnode end if nnode = 8 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 do i = 1, nnode j = i + 1 if ( j > nnode ) then j = j - nnode end if adj(i,j) = 1 adj(j,i) = 1 end do 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 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 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 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 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 else if ( nsave == 6 ) 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(4,1) = 1 adj(5,8) = 1 adj(5,1) = 1 adj(5,2) = 1 adj(6,1) = 1 adj(6,2) = 1 adj(6,3) = 1 adj(7,2) = 1 adj(7,3) = 1 adj(7,4) = 1 adj(8,3) = 1 adj(8,4) = 1 adj(8,5) = 1 else if ( nsave == 7 ) 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(3,1) = 1 adj(4,6) = 1 adj(4,8) = 1 adj(4,2) = 1 adj(5,7) = 1 adj(5,1) = 1 adj(5,3) = 1 adj(6,8) = 1 adj(6,2) = 1 adj(6,4) = 1 adj(7,1) = 1 adj(7,3) = 1 adj(7,5) = 1 adj(8,2) = 1 adj(8,4) = 1 adj(8,6) = 1 end if ! ! Now permute the graph. ! call imat_perm_random ( lda, nnode, adj ) return end subroutine graph_adj_example_twig ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_EXAMPLE_TWIG sets up the adjacency information for the twig graph. ! ! ! Diagram: ! ! 1---2---3 ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,LDA), the adjacency information for the graph. ! ADJ(I,J) is 1 if nodes I and J are adjacent. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda ! integer adj(lda,lda) integer i integer j integer nnode ! nnode = 3 if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_EXAMPLE_TWIG - Fatal error!' write ( *, '(a)' ) ' LDA is too small.' stop end if adj(1:nnode,1:nnode) = 0 adj(1,2) = 1 adj(2,1) = 1 adj(2,3) = 1 adj(3,2) = 1 return end subroutine graph_adj_ham_cand ( adj, lda, nnode, circuit, k, nstack, & stack, maxstack, ncan ) ! !******************************************************************************* ! !! GRAPH_ADJ_HAM_CAND finds candidates for the next node in a Hamiltonian circuit. ! ! ! Discussion: ! ! This routine is used in conjunction with IVEC_BACKTRACK. ! ! Definition: ! ! A Hamiltonian circuit of a graph is a path that starts at a given node, ! visits every node exactly once, and returns to the starting node. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 17 August 2000 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE). ADJ(I,J) = 1 if there is ! an edge from node I to node J, 0 otherwise. ! ! Input, integer LDA, the first dimension of ADJ as ! declared in the calling program. LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes in the graph. ! ! Input, integer CIRCUIT(NNODE), the nodes forming the circuit. ! ! Input, integer K, index of the next node to be determined for the circuit. ! ! Input/output, integer NSTACK, the current length of stack. ! ! Input, integer STACK(MAXSTACK), candidates for steps 1...K-1. ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Workspace, integer NCAN(NNODE), the number of candidates for ! positions in the circuit. ! implicit none ! integer lda integer nnode integer maxstack ! integer adj(lda,nnode) integer circuit(nnode) integer i integer iwork(nnode) integer k integer ncan(nnode) integer nstack integer stack(maxstack) ! ncan(k) = 0 if ( k == 1 ) then stack(1) = 1 nstack = 1 ncan(k) = 1 return end if iwork(1:nnode) = adj(circuit(k-1),1:nnode) iwork(circuit(1:k-1)) = 0 if ( k /= nnode ) then do i = 1, nnode if ( iwork(i) == 1 ) then if ( nstack >= maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_HAM_CAND - Fatal error!' write ( *, '(a)' ) ' Stack size exceeded.' stop end if nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if end do return else if ( k == nnode ) then do i = 1, nnode if ( iwork(i) == 1 ) then if ( i > circuit(2) .or. adj(i,1) == 0 ) then else if ( nstack >= maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_HAM_CAND - Fatal error!' write ( *, '(a)' ) ' Stack size exceeded.' stop end if nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if return end if end do end if return end subroutine graph_adj_ham_next ( adj, lda, nnode, circuit, stack, maxstack, & ncan, more ) ! !******************************************************************************* ! !! GRAPH_ADJ_HAM_NEXT returns the next Hamilton circuit for a graph. ! ! ! Discussion: ! ! The routine produces all the Hamilton circuits of a graph, one at a time. ! ! Definition: ! ! A Hamiltonian circuit of a graph is a path that starts at a given ! node, visits every node exactly once, and returns to the starting node. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 16 August 2000 ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE). ADJ(I,J) = 1 if there is ! an edge from node I to node J, 0 otherwise. ! ! Input, integer LDA, the first dimension of ADJ as ! declared in the calling program. LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes in graph. ! ! Input, integer CIRCUIT(NNODE). CIRCUIT(I) is the I-th node ! in the circuit. ! ! Input, integer K, the index of the next node to be determined ! for circuit. ! ! Input/output, integer NSTACK, the current length of stack. ! ! Input, integer STACK(MAXSTACK). Candidates for steps 1...K-1. ! ! Input, integer MAXSTACK, dimension of STACK. ! ! Workspace, integer NCAN(NNODE), the number of candidates for each ! position in the circuit. ! ! Input/output, logical MORE. ! On first call, set MORE to .FALSE, and do not alter it after. ! On return, MORE is TRUE if another circuit has been returned in ! IARRAY, and FALSE if there are no more circuits. ! implicit none ! integer lda integer nnode integer maxstack ! integer adj(lda,nnode) integer circuit(nnode) integer, save :: indx = 0 integer, save :: k = 0 logical more integer ncan(nnode) integer, save :: nstack = 0 integer stack(maxstack) ! if ( .not. more ) then indx = 0 k = 0 more = .true. nstack = 0 end if do call ivec_backtrack ( nnode, circuit, indx, k, nstack, stack, maxstack, & ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call graph_adj_ham_cand ( adj, lda, nnode, circuit, k, nstack, & stack, maxstack, ncan ) else more = .false. exit end if end do return end subroutine graph_adj_ham_next_brute ( adj, lda, nnode, circuit, iset ) ! !******************************************************************************* ! !! GRAPH_ADJ_HAM_NEXT_BRUTE finds the next Hamiltonian circuit in a graph. ! ! ! Discussion: ! ! This is a brute force algorithm, and not suitable for large problems. ! It is really only useful as a demonstration, and as a check for ! the backtracking algorithm. ! ! Modified: ! ! 17 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is a direct link between nodes I and J. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input/output, integer CIRCUIT(NNODE). ! ! On input, if ISET = 0, then CIRCUIT is not presumed to contain any ! information. If ISET is nonzero, then CIRCUIT contains the circuit ! computed on the previous call. ! ! On output, CIRCUIT contains the circuit computed by this call. ! ! Input/output, integer ISET. ! On input, 0 means this is the first call for this graph. ! Any other value means this is a repeated call for more circuits. ! ! On output, a 0 value means that no more circuits could be computed. ! Otherwise, ISET is incremented by one on each call. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer circuit(nnode) integer i integer ipos integer iset ! ! If ISET is 0, this is a starting call, and we set CIRCUIT ! to the lexically first circuit to check. ! ! Otherwise, we set CIRCUIT to the next permutation. ! if ( iset == 0 ) then ipos = 0 circuit(1:nnode) = 0 else ipos = nnode - 1 end if 10 continue call perm_inc ( circuit, ipos, nnode ) if ( ipos <= 0 .or. circuit(1) /= 1 ) then iset = 0 circuit(1:nnode) = 0 return end if ! ! Check whether the entries of CIRCUIT actually form a circuit. ! If we find a break in the circuit, store that location in IPOS ! and move on to try the next permutation. ! do i = 1, nnode-1 ipos = i if ( adj(circuit(i),circuit(i+1)) == 0 ) then go to 10 end if end do ! ! If the circuit connects all the nodes, we only have to check whether ! the last node connects back to the first one. ! ! To cut down the pairs of equivalent circuits created by going one ! way or the other over the same set of nodes, we also require that, ! for NNODE > 2, the last node be numbered higher than the second one. ! if ( adj(circuit(nnode),circuit(1)) == 0 ) then go to 10 end if if ( nnode > 2 ) then if ( circuit(nnode) < circuit(2) ) then go to 10 end if end if iset = iset + 1 return end subroutine graph_adj_is_bipartite ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! GRAPH_ADJ_IS_BIPARTITE determines if a graph is bipartite. ! ! ! Definition: ! ! A graph is bipartite if its nodes can be divided into two subsets ! in such a way that every edge joins a node from each subset. ! ! Modified: ! ! 25 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the graph is not bipartite. ! 1, the graph is bipartite. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k integer khi integer klo integer lhi integer list(nnode) integer oldset integer result integer set integer subset(nnode) ! result = 1 subset(1:nnode) = -1 ! ! Node 1 is put in subset 1. ! set = 1 list(1) = 1 subset(1) = set klo = 1 khi = 1 ! ! Working from the set of nodes found on the previous step, look ! for all in and out neighbors. ! 10 continue oldset = set set = 1 - set lhi = khi ! ! Consider each node I in the previously found set. ! do k = klo, khi i = list(k) ! ! Look at all in and out neighbors J. ! do j = 1, nnode if ( adj(i,j) /= 0 .or. adj(j,i) /= 0 ) then ! ! If the node is not in any subset, put it in the other one. ! if ( subset(j) == -1 ) then lhi = lhi + 1 list(lhi) = j subset(j) = set ! ! But if the node is in the same subset, bipartiteness has failed. ! else if ( subset(j) == oldset ) then result = 0 return end if end if end do end do ! ! Assuming we found more nodes, on this sweep, then ... ! if ( lhi > khi ) then klo = khi + 1 khi = lhi go to 10 end if ! ! Assuming we found no new nodes on this sweep, see if there are any ! nodes we have missed. These will be completely isolated from all the ! nodes we have found so far. ! do i = 1, nnode if ( subset(i) == -1 ) then klo = khi + 1 khi = klo subset(i) = set list(klo) = i go to 10 end if end do result = 1 return end subroutine graph_adj_is_edge_connected ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! GRAPH_ADJ_IS_EDGE_CONNECTED determines if a graph is edgewise connected. ! ! ! Definition: ! ! A graph is edgewise connected if from any edge it is possible to reach ! any other edge. An edgewise connected graph may include isolated nodes. ! ! Modified: ! ! 25 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the graph is not edgewise connected. ! 1, the graph is edgewise connected. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer found(nnode) integer i integer ihi integer ii integer ilo integer j integer jhi integer jlo integer list(nnode) integer result ! ! FOUND(I) is 1 if edge I has been reached. ! LIST(I) contains a list of the nodes as they are reached. ! list(1:nnode) = 0 found(1:nnode) = 0 ! ! Find an edge. ! ilo = 1 ihi = 0 do i = 1, nnode do j = 1, nnode if ( adj(i,j) > 0 .or. adj(j,i) > 0 ) then adj(i,j) = - abs ( adj(i,j) ) adj(j,i) = - abs ( adj(j,i) ) ihi = ihi + 1 list(ihi) = i found(i) = 1 if ( i /= j ) then ihi = ihi + 1 list(ihi) = j found(j) = 1 end if go to 10 end if end do end do ! ! A graph with NO edges is edgewise connected! ! result = 1 return 10 continue ! ! From the batch of edge nodes found last time, LIST(ILO:IHI), ! look for unfound neighbors, and store their indices in LIST(JLO:JHI). ! jlo = ihi + 1 jhi = ihi do ii = ilo, ihi i = list(ii) do j = 1, nnode if ( adj(i,j) > 0 ) then adj(i,j) = - adj(i,j) if ( adj(j,i) > 0 ) then adj(j,i) = - adj(j,i) end if if ( found(j) == 0 ) then jhi = jhi + 1 list(jhi) = j found(j) = 1 end if end if end do end do ! ! If any neighbors were found, go back and find THEIR neighbors. ! if ( jhi >= jlo ) then ilo = jlo ihi = jhi go to 10 end if ! ! If any edges were unvisited, then the graph is not edgewise connected. ! result = 1 do i = 1, nnode do j = 1, nnode if ( adj(i,j) > 0 ) then result = 0 end if end do end do ! ! Restore the positive sign of ADJ. ! adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) return end subroutine graph_adj_is_eulerian ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! GRAPH_ADJ_IS_EULERIAN determines if a graph is Eulerian from its adjacency matrix. ! ! ! Definition: ! ! A graph is path-Eulerian if there exists a path through the graph ! which uses every edge once. ! ! A graph is circuit-Eulerian if there exists a path through the graph ! which uses every edge once, and which starts and ends on the same node. ! ! Note that it is NOT necessary for the path or circuit to pass through ! every node; simply that all the edges can be used exactly once to ! make a connected path. This means an Eulerian graph can have isolated ! nodes, for instance. ! ! Discussion: ! ! A graph is path-Eulerian if and only if it is edge connected, and all ! but two nodes are of even degree. ! ! A graph is circuit-Eulerian if and only if it is edge connected and ! all nodes are of even degree. ! ! Modified: ! ! 11 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the graph is not Eulerian. ! 1, the graph is path-Eulerian. ! 2, the graph is circuit-Eulerian. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer degree integer i integer j integer nodd integer result ! ! First check that the graph is edgewise connected. ! call graph_adj_is_edge_connected ( adj, lda, nnode, result ) if ( result == 0 ) then return end if ! ! Now look at node degree. ! nodd = 0 do i = 1, nnode degree = 0 do j = 1, nnode if ( adj(i,j) /= 0 ) then if ( i == j ) then degree = degree + 2 else degree = degree + 1 end if end if end do if ( mod ( degree, 2 ) == 1 ) then nodd = nodd + 1 end if end do if ( nodd == 0 ) then result = 2 else if ( nodd == 2 ) then result = 1 else result = 0 end if return end subroutine graph_adj_is_node_connected ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! GRAPH_ADJ_IS_NODE_CONNECTED determines if a graph is nodewise connected. ! ! ! Definition: ! ! A graph is nodewise connected if, from every node, there is a path ! to any other node. ! ! Modified: ! ! 25 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the graph is not nodewise connected. ! 1, the graph is nodewise connected. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer found(nnode) integer i integer ihi integer ii integer ilo integer j integer jhi integer jlo integer list(nnode) integer result ! ! FOUND(I) is 1 if node I has been reached. ! LIST(I) contains a list of the nodes as they are reached. ! list(1:nnode) = 0 found(1:nnode) = 0 ! ! Start at node 1. ! found(1) = 1 list(1) = 1 ilo = 1 ihi = 1 ! ! From the batch of nodes found last time, LIST(ILO:IHI), ! look for unfound neighbors, and store their indices in LIST(JLO:JHI). ! 10 continue jlo = ihi + 1 jhi = ihi do ii = ilo, ihi i = list(ii) do j = 1, nnode if ( adj(i,j) /= 0 .or. adj(j,i) /= 0 ) then if ( found(j) == 0 ) then jhi = jhi + 1 list(jhi) = j found(j) = 1 end if end if end do end do ! ! If any neighbors were found, go back and find THEIR neighbors. ! if ( jhi >= jlo ) then ilo = jlo ihi = jhi go to 10 end if ! ! No more neighbors were found. Have we reached all nodes? ! if ( ihi == nnode ) then result = 1 else result = 0 end if return end subroutine graph_adj_is_tree ( adj, lda, nnode, result ) ! !******************************************************************************* ! !! GRAPH_ADJ_IS_TREE determines whether a graph is a tree. ! ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer RESULT. ! 0, the graph is not a tree. ! 1, the graph is a tree. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer nedge integer result ! if ( nnode <= 1 ) then result = 1 return end if ! ! Every node must be connected to every other node. ! call graph_adj_is_node_connected ( adj, lda, nnode, result ) if ( result == 0 ) then return end if ! ! There must be exactly NNODE-1 edges. ! call graph_adj_edge_count ( adj, lda, nnode, nedge ) if ( nedge == nnode - 1 ) then result = 1 else result = 0 end if return end subroutine graph_adj_print ( adj, lda, nnode, title ) ! !******************************************************************************* ! !! GRAPH_ADJ_PRINT prints out an adjacency matrix for a graph. ! ! ! Discussion: ! ! This routine actually allows the entries of ADJ to have ANY value. ! Values between 0 and 9 will be printed as is. Other values will ! be printed as '*'. ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix of a graph. ! ADJ(I,J) is 1 if there is a direct connection FROM node I TO node J, ! and is 0 otherwise. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer jhi character ( len = 80 ) string character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nnode jhi = min ( nnode, 80 ) do j = 1, jhi 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 do write ( *, '(i2,2x,a)' ) i, string(1:jhi) end do return end subroutine graph_adj_random ( adj, lda, nnode, nedge ) ! !******************************************************************************* ! !! GRAPH_ADJ_RANDOM generates a random graph on NNODE nodes with NEDGE edges. ! ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ADJ(LDA,NNODE), the adjacency matrix. ADJ(I,J) is ! nonzero if there is an edge from node I to node J. ADJ(I,I) will ! always be 0. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges, which must be between ! 0 and (NNODE*(NNODE-1))/2. (Note that each edge will be listed ! twice in the adjacency matrix). ! implicit none ! integer lda integer nnode integer nedge ! integer adj(lda,nnode) integer i integer iwork(nedge) integer j integer k integer l integer maxedge ! ! Check. ! if ( nnode <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NNODE = ', nnode write ( *, '(a)' ) ' but NNODE must be at least 1.' stop end if if ( lda < nnode ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' LDA = ', lda write ( *, '(a,i6)' ) ' but LDA must be at least NNODE = ', nnode stop end if maxedge = ( nnode * ( nnode - 1 ) ) / 2 if ( nedge < 0 .or. nedge > maxedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' NEDGE = ', nedge write ( *, '(a)' ) ' but NEDGE must be at least 0, and ' write ( *, '(a,i6)' ) ' no more than ', maxedge stop end if ! ! Initialize the adjacency matrix. ! adj(1:nnode,1:nnode) = 0 ! ! Pick a random NEDGE subset of MAXEDGE. ! call ksub_random ( maxedge, nedge, iwork ) ! ! The usable spots in the superdiagonal are numbered as follows: ! ! * 1 2 3 ... n-1 ! * * n+1 n+2 ... 2n-3 ! ... ! * * * * ... (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 graph_adj_reduce ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_REDUCE generates a transitive reduction of a graph. ! ! ! Discussion: ! ! This routine is given an adjacency matrix B, which might be a ! transitive closure of a graph G. ! ! The transitive closure graph is generated from a graph G by the ! following procedure: ! ! B(I,J) = 0 if node J cannot be reached from node I in graph G; ! 1 if node J can be reached from node I in graph G. ! ! The purpose of this routine is to try to find the original, sparser ! graph G which generated the given transitive closure graph. Such a ! graph G is known as a transitive reduction.. In general, ! there is no unique solution. In particular, any graph is a transitive ! reduction of itself. ! ! Hence, the real task is to drop as many redundant edges as possible ! from the given graph, arriving at a graph from which no more edges ! may be removed. ! ! Method: ! ! One way of explaining the algorithm is based on the adjacency matrix: ! ! * Zero out the diagonals of the adjacency matrix. ! ! * Consider row 1. Any other row that can "reach" row 1 doesn't ! need a 1 if row 1 has it. So "subtract" all the 1's in row 1 ! from such rows. We are done with row 1 and column 1. ! ! * Repeat for the other rows. ! ! Modified: ! ! 04 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). ! ! On input, the adjacency matrix of the transitive closure graph H. ! ! On output, the adjacency matrix of a transitive reduction graph G ! of the graph H. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j integer k ! ! First discard those useless self-edges. ! do i = 1, nnode adj(i,i) = 0 end do ! ! If you can get from J to I and I to K, you don't need an ! edge from J to K. ! do i = 1, nnode do j = 1, nnode if ( adj(j,i) /= 0 .or. adj(i,j) /= 0 ) then do k = 1, nnode if ( adj(i,k) /= 0 .or. adj(k,i) /= 0 ) then adj(j,k) = 0 adj(k,j) = 0 end if end do end if end do end do return end subroutine graph_adj_span_tree ( adj, lda, nnode, inode, jnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_SPAN_TREE finds a spanning tree of a graph. ! ! ! Discussion: ! ! If the graph is connected, NNODE-1 edges comprise the spanning tree. ! ! If the graph is not connected, but divided into NCOMP components, then ! NNODE-NCOMP edges will comprise the spanning "forest", and the other ! edges will be zero. ! ! Modified: ! ! 30 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is 0 if there is no edge from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ, which must ! be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer INODE(NNODE-1), JNODE(NNODE-1), the edge list for the ! spanning tree or forest. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer inode(nnode-1) integer j integer jnode(nnode-1) integer label(nnode) integer level integer nedge integer nfound integer nlabel ! label(1:nnode) = 0 inode(1:nnode-1) = 0 jnode(1:nnode-1) = 0 level = 0 nedge = 0 nlabel = 0 ! ! Find an unvisited node. ! do i = 0 do i = i + 1 if ( label(i) == 0 ) then exit end if end do label(i) = level + 1 nlabel = nlabel + 1 ! ! Search for all nodes reachable from the node. ! do level = level + 1 nfound = 0 do i = 1, nnode if ( label(i) == level ) then do j = 1, nnode if ( label(j) == 0 ) then if ( adj(i,j) /= 0 .or. adj(j,i) /= 0 ) then label(j) = level + 1 nlabel = nlabel + 1 nfound = nfound + 1 nedge = nedge + 1 inode(nedge) = i jnode(nedge) = j end if end if end do end if end do if ( nfound <= 0 ) then exit end if end do ! ! If we have labeled all nodes, exit. ! if ( nlabel >= nnode ) then exit end if end do return end subroutine graph_adj_span_tree_enum ( adj, lda, nnode, tree_num ) ! !******************************************************************************* ! !! GRAPH_ADJ_SPAN_TREE_ENUM enumerates the spanning trees of a graph. ! ! ! Discussion: ! ! If ADJ is the adjacency matrix of the graph, let A be the matrix ! A = DEG - ADJ ! where DEG is the diagonal matrix with DEG(I,I) = degree of node I. ! Then the number of spanning trees of the graph is equal to the ! determinant of any cofactor of A. A cofactor of A is obtained by ! deleting a row and column of A. ! ! Modified: ! ! 03 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is 0 if there is no edge from node I to node J. ! ! Input, integer LDA, the leading dimension of ADJ, which must ! be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer TREE_NUM, the number of spanning trees. ! implicit none ! integer lda integer nnode ! real a(nnode,nnode) integer adj(lda,nnode) integer degree(nnode) real det integer i integer info integer ipivot(nnode) integer tree_num ! ! Construct the matrix. ! call graph_adj_degree ( adj, lda, nnode, degree ) a(1:nnode,1:nnode) = - real ( adj(1:nnode,1:nnode) ) do i = 1, nnode a(i,i) = a(i,i) + real ( degree(i) ) end do ! ! Factor the NNODE-1 order matrix. ! call sge_fa ( nnode, nnode-1, a, ipivot, info ) if ( info /= 0 ) then tree_num = 0 return end if ! ! Get the determinant. ! call sge_det ( nnode, nnode-1, a, ipivot, det ) tree_num = nint ( det ) return end subroutine graph_adj_symmetrize ( adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_SYMMETRIZE symmetrizes an adjacency matrix. ! ! ! Discussion: ! ! For a graph, if there is an edge from I to J, there is an edge from ! J to I. Therefore, the adjacency matrix should be symmetric. ! This routine enforces that condition. If either ADJ(I,J) or ADJ(J,I) ! is nonzero, the output adjacency matrix will have both entries nonzero. ! ! Modified: ! ! 04 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ADJ(LDA,NNODE). On output, the adjacency information ! has been symmetrized. ! ! Input, integer LDA, the leading dimension of ADJ, which must be ! NNODE or greater. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer i integer j ! ! While not perfect, this method does not assume that 1 is the only ! legal nonzero value in ADJ. ! do i = 1, nnode do j = i+1, nnode if ( adj(i,j) /= 0 ) then adj(j,i) = adj(i,j) else if ( adj(j,i) /= 0 ) then adj(i,j) = adj(j,i) end if end do end do return end subroutine graph_adj_to_graph_arc ( adj, lda, nnode, maxedge, nedge, inode, & jnode ) ! !******************************************************************************* ! !! GRAPH_ADJ_TO_GRAPH_ARC converts an adjacency graph to an arc list graph. ! ! ! Modified: ! ! 01 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency matrix for the graph. ! ADJ(I,J) is nonzero if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of LDA, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer MAXEDGE, the maximum number of edges. ! ! Output, integer NEDGE, the number of edges. ! ! Output, integer INODE(MAXEDGE), JNODE(MAXEDGE), the arc list of the ! graph. ! implicit none ! integer lda integer maxedge integer nnode ! integer adj(lda,nnode) integer i integer inode(maxedge) integer j integer jnode(maxedge) integer nedge ! nedge = 0 inode(1:maxedge) = 0 jnode(1:maxedge) = 0 do j = 1, nnode do i = j, nnode if ( adj(i,j) /= 0 .or. adj(j,i) /= 0 ) then nedge = nedge + 1 if ( nedge <= maxedge ) then inode(nedge) = i jnode(nedge) = j else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ADJ_TO_GRAPH_ARC - Fatal error!' write ( *, '(a)' ) ' MAXEDGE exceeded.' stop end if end if end do end do return end subroutine graph_arc_complement ( inode, jnode, inode2, jnode2, maxedge, & nedge, nedge2, nnode ) ! !******************************************************************************* ! !! GRAPH_ARC_COMPLEMENT returns the edge list of the complement of a graph. ! ! ! Discussion: ! ! This routine can also handle a directed graph. ! ! Definition: ! ! The complement of a graph G is a graph H with the property that ! nodes U and V are connected in H if and only if they are not ! connected in G. However, edges from a node to itself are not ! allowed. ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer INODE(NEDGE), JNODE(NEDGE). INODE(I) and JNODE(I) ! are the start and end nodes of the I-th edge of the graph G. On ! output, the data in INODE and JNODE will have been sorted, but not ! otherwise disrupted. ! ! Output, integer INODE2(MAXEDGE), JNODE2(MAXEDGE). INODE2(I) and JNODE2(I) ! are the start and end nodes of the I-th edge of the complement graph H. ! ! Input, integer MAXEDGE, the amount of storage available in INODE2 ! and JNODE2. MAXEDGE only needs to be as large as NEDGE2, and NEDGE2 ! can be precomputed, assuming that the input value of NEDGE does not ! count any self edges (edges from a node to itself), and does not ! count an edge twice (that is, counting the edge from I to J, and ! the edge from J to I, as distinct). If this is so, then you can ! set MAXEDGE = NEDGE2 = 0.5 * ( NNODE * ( NNODE - 1 ) ) - NEDGE. ! ! Input, integer NEDGE, the number of edges in the graph G. ! ! Output, integer NEDGE2, the number of edges in the complement graph H. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer maxedge integer nedge ! integer i integer i1 integer i2 integer inedge integer inode(nedge) integer inode2(maxedge) integer j integer j1 integer j2 integer jnode(nedge) integer jnode2(maxedge) integer nedge2 integer nnode ! ! Sort the input edge array. ! call graph_arc_edge_sort ( nedge, inode, jnode ) ! ! Compute the complementary edges. ! nedge2 = 0 inedge = 0 i2 = 1 j2 = 1 do while ( inedge < nedge ) inedge = inedge + 1 i1 = i2 j1 = j2 if ( inedge <= nedge ) then i2 = inode(inedge) j2 = jnode(inedge) else i2 = nnode j2 = nnode end if if ( i1 == i2 ) then do j = j1+1, j2-1 if ( i1 < j ) then nedge2 = nedge2 + 1 inode2(nedge2) = i2 jnode2(nedge2) = j end if end do else do j = j1+1, nnode if ( i1 < j ) then nedge2 = nedge2 + 1 inode2(nedge2) = i1 jnode2(nedge2) = j end if end do do i = i1+1, i2-1 do j = 1, nnode if ( i < j ) then nedge2 = nedge2 + 1 inode2(nedge2) = i jnode2(nedge2) = j end if end do end do do j = 1, j2-1 if ( i2 < j ) then nedge2 = nedge2 + 1 inode2(nedge2) = i2 jnode2(nedge2) = j end if end do end if end do return end subroutine graph_arc_degree ( nnode, nedge, inode, jnode, degree ) ! !******************************************************************************* ! !! GRAPH_ARC_DEGREE determines the degree of the nodes of a graph. ! ! ! Definition: ! ! The degree of a node is the number of edges that include the node. ! ! Modified: ! ! 24 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the pairs of nodes ! that form the edges. ! ! Output, integer DEGREE(NNODE), the degree of each node, that is, ! the number of edges that include the node. ! implicit none ! integer nedge integer nnode ! integer degree(nnode) integer i integer inode(nedge) integer jnode(nedge) integer n ! degree(1:nnode) = 0 do i = 1, nedge n = inode(i) if ( 1 <= n .and. n <= nnode ) then degree(n) = degree(n) + 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_DEGREE - Fatal error!' write ( *, '(a,i6)' ) ' Out-of-range node value = ', n stop end if n = jnode(i) if ( 1 <= n .and. n <= nnode ) then degree(n) = degree(n) + 1 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_DEGREE - Fatal error!' write ( *, '(a,i6)' ) ' Out-of-range node value = ', n stop end if end do return end subroutine graph_arc_edge_con2 ( nnode, nedge, inode, jnode, edge_con ) ! !******************************************************************************* ! !! GRAPH_ARC_EDGE_CON2 finds the edge-connectivity of a connected graph. ! ! ! Method: ! ! A graph G has edge connectivity K if, given any pair of distinct nodes ! I and J, there are K paths from I to J, no two of which use a common edge. ! ! Thus, in particular, if a graph G is Hamiltonian, it must have ! edge connectivity at least 2. For we can simply take the Hamiltonian ! circuit, and use the part from I to J as the first path, and the ! part from J to I as the second, simply reversing the direction ! of traversal. ! ! To determine the edge connectivity, for each J from 2 to NNODE do ! the following: ! ! Take node 1 as the source, node J as the sink in G, assign a unit ! capacity to all edges in both directions, and find the value of the ! maximum flow G(J) in the resulting network. ! ! The edge-connectivity is then equal to the minimum of G(2:NNODE). ! ! This routine finds the edge-connectivity of a given undirected graph with ! the help of a maximum flow algorithm. ! ! The maximum network flow algorithm requires O(NNODE**3) operations. The ! edge-connectivity of a graph will therefore be found in O(NNODE**4) ! operations. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the end nodes of the edges. ! ! Output, integer EDGE_CON, the edge-connectivity of the graph. ! implicit none ! integer nedge integer nnode ! integer capflo(2,2*nedge) integer edge_con integer flow(2*nedge) integer i integer icut(nnode) integer iendpt(2,2*nedge) integer inode(nedge) integer isink integer isorce integer j integer jnode(nedge) integer node_flow(nnode) ! ! Create the network from the graph. ! j = 0 do i = 1, nedge j = j + 1 iendpt(1,j) = inode(i) iendpt(2,j) = jnode(i) capflo(1,j) = 1 capflo(2,j) = 0 j = j + 1 iendpt(1,j) = jnode(i) iendpt(2,j) = inode(i) capflo(1,j) = 1 capflo(2,j) = 0 end do ! ! Call the network flow algorithm. ! edge_con = nnode isorce = 1 do isink = 2, nnode call network_flow_max ( nnode, 2*nedge, iendpt, capflo, isorce, isink, & icut, node_flow ) if ( node_flow(isorce) < edge_con ) then edge_con = node_flow(isorce) end if end do return end subroutine graph_arc_edge_sort ( nedge, inode, jnode ) ! !******************************************************************************* ! !! GRAPH_ARC_EDGE_SORT sorts the edge array of a graph. ! ! ! Comment: ! ! The pair of nodes (I,J) representing an edge is reordered so ! that the smaller node is listed first. ! ! Then the edges are sorted in dictionary order. ! ! Example: ! ! Input: ! ! INODE JNODE ! ! 3 2 ! 4 3 ! 2 1 ! 1 4 ! ! Output: ! ! INODE JNODE ! ! 1 2 ! 1 4 ! 2 3 ! 3 4 ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input/output, integer INODE(NEDGE), JNODE(NEDGE), the edge array of a ! graph. The I-th edge of the graph connects nodes INODE(I) and ! JNODE(I). ! ! On output, the INODE and JNODE arrays have been sorted as described. ! implicit none ! integer nedge ! integer i integer iedge integer indx integer inode(nedge) integer isgn integer jedge integer jnode(nedge) ! if ( nedge <= 1 ) then return end if ! ! Sort the node pairs. ! do i = 1, nedge if ( jnode(i) < inode(i) ) then call i_swap ( inode(i), jnode(i) ) end if end do ! ! Sort the edges using an external heap sort. ! iedge = 0 jedge = 0 indx = 0 isgn = 0 do call sort_heap_external ( nedge, indx, iedge, jedge, isgn ) ! ! Interchange edges IEDGE and JEDGE. ! if ( indx > 0 ) then call i_swap ( inode(iedge), inode(jedge) ) call i_swap ( jnode(iedge), jnode(jedge) ) ! ! Compare edges IEDGE and JEDGE. ! else if ( indx < 0 ) then if ( ( inode(iedge) < inode(jedge) ) .or. & ( inode(iedge) == inode(jedge) .and. & jnode(iedge) < jnode(jedge) ) ) then isgn = -1 else isgn = +1 end if else exit end if end do return end subroutine graph_arc_euler_circ ( nnode, nedge, inode, jnode, circuit ) ! !******************************************************************************* ! !! GRAPH_ARC_EULER_CIRC finds an Euler circuit in an Eulerian graph. ! ! ! Discussion: ! ! An Euler circuit of a graph is a path that uses each edge exactly once. ! ! A graph is Eulerian if it has an Euler circuit. ! ! An Eulerian graph may have many circuits; this routine only finds one. ! ! Reference: ! ! H T Lau, ! Combinatorial Heuristic Algorithms in FORTRAN, ! Springer Verlag, 1986. ! ! Modified: ! ! 21 July 2000 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes in the graph. ! ! Input, integer NEDGE, the number of edges in the graph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the two end nodes of each edge. ! ! Output, integer CIRCUIT(NEDGE), the Euler circuit, as a series of nodes. ! implicit none ! integer nedge integer nnode ! integer circuit(nedge) logical copyon logical found integer i integer ibase integer iforwd integer inode(nedge) integer insert integer ipivot integer iwork1(nedge) integer iwork2(nedge) integer iwork3(nnode) integer iwork4(nnode) integer iwork5(nnode) integer iwork6(nnode) integer j integer jnode(nedge) integer k integer l integer locbas integer nbreak integer ncopy integer numarc integer numnode ! ! The number of times each node has been visited begins at 0. ! iwork3(1:nnode) = 0 circuit(1:nedge) = 0 iwork1(1:nedge) = 0 iwork2(1:nedge) = 0 ! ! Begin the Euler circuit with the edge INODE(1), JNODE(1). ! numarc = 1 iwork2(1) = 1 numnode = 1 i = inode(1) iwork1(numnode) = i iwork3(i) = 1 numnode = numnode + 1 j = jnode(1) iwork1(numnode) = j iwork3(j) = 1 ibase = j nbreak = 0 ! ! Look for the next arc. ! 30 continue do i = 2, nedge if ( iwork2(i) == 0 ) then if ( inode(i) == ibase ) then found = .true. ibase = jnode(i) else if ( jnode(i) == ibase ) then found = .true. ibase = inode(i) else found = .false. end if if ( found ) then iwork2(i) = 1 numarc = numarc + 1 numnode = numnode + 1 if ( numnode <= nedge ) then iwork1(numnode) = ibase end if iwork3(ibase) = 1 go to 30 end if end if end do ! ! A cycle has been found. ! if ( nbreak > 0 ) then numnode = numnode - 1 iwork5(nbreak) = numnode end if if ( numarc < nedge ) then iwork1(numnode) = ibase ! ! Find a node in the current Euler circuit. ! do i = 2, nedge if ( iwork2(i) == 0 ) then if ( iwork3(inode(i)) /= 0 ) then found = .true. j = inode(i) k = jnode(i) else if ( iwork3(jnode(i)) /= 0 ) then found = .true. j = jnode(i) k = inode(i) else found = .false. end if ! ! Identify a path which will be added to the circuit. ! if ( found ) then nbreak = nbreak + 1 iwork6(nbreak) = j ibase = k iwork3(k) = 1 numnode = numnode + 1 iwork4(nbreak) = numnode iwork1(numnode) = ibase iwork2(i) = 1 numarc = numarc + 1 go to 30 end if end if end do end if ! ! Form the Euler circuit. ! if ( nbreak == 0 ) then numnode = numnode - 1 circuit(1:numnode) = iwork1(1:numnode) return end if insert = 1 ipivot = iwork6(insert) iforwd = 0 do ncopy = 1 ibase = iwork1(1) locbas = 1 circuit(ncopy) = ibase ! ! A path identified before is added to the circuit. ! 80 continue if ( ibase == ipivot ) then j = iwork4(insert) + iforwd k = iwork5(insert) + iforwd do l = j, k ncopy = ncopy + 1 circuit(ncopy) = iwork1(l) iwork1(l) = 0 end do ncopy = ncopy + 1 ! ! Add the intersecting node to the circuit. ! circuit(ncopy) = ibase iforwd = iforwd + 1 if ( ncopy < numnode ) then do if ( ncopy >= nedge ) then exit end if locbas = locbas + 1 if ( locbas >= nedge ) then exit end if ibase = iwork1(locbas) if ( ibase /= 0 ) then ncopy = ncopy + 1 circuit(ncopy) = ibase end if end do end if else ncopy = ncopy + 1 if ( ncopy <= numnode ) then locbas = locbas + 1 ibase = iwork1(locbas) circuit(ncopy) = ibase go to 80 end if end if ! ! Check if more paths are to be added to the circuit. ! copyon = .false. insert = insert + 1 if ( insert <= nbreak ) then copyon = .true. ipivot = iwork6(insert) end if if ( .not. copyon ) then exit end if iwork1(1:nedge) = circuit(1:nedge) end do return end subroutine graph_arc_euler_circ_cand ( nedge, inode, jnode, circuit, k, & nstack, stack, maxstack, ncan, iwork ) ! !******************************************************************************* ! !! GRAPH_ARC_EULER_CIRC_CAND finds candidates for the K-th edge of an Euler circuit. ! ! ! Discussion: ! ! This routine is used in conjunction with IVEC_BACKTRACK, which directs the ! search for a complete Euler circuit. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 04 July 2000 ! ! Parameters: ! ! Input, integer NEDGE, the number of edges in the graph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array of the graph. ! The I-th edge extends from node INODE(I) to JNODE(I). ! ! Input, integer CIRCUIT(NEDGE), CIRCUIT(I) is the I-th edge in the circuit. ! A full circuit will have NEDGE edges, but on input we only have K-1. ! ! Input, integer K, the index of the next edge to be determined in circuit. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input, integer STACK(MAXSTACK). As yet unused candidates for positions ! 1 to K-1. ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Input/output, integer NCAN(NEDGE), the number of candidates for each ! position. ! ! Workspace, integer IWORK(NEDGE). ! implicit none ! integer nedge integer maxstack ! integer circuit(nedge) integer i integer inode(nedge) integer it integer iwork(nedge) integer jnode(nedge) integer k logical lwork(nedge) integer ncan(nedge) integer nstack integer stack(maxstack) ! ncan(k) = 0 if ( k == 1 ) then iwork(1) = jnode(1) stack(1) = 1 nstack = 1 ncan(k) = 1 return end if if ( k > 2 ) then iwork(k-1) = inode(circuit(k-1)) + jnode(circuit(k-1)) - iwork(k-2) end if it = iwork(k-1) do i = 1, nedge lwork(i) = it == inode(i) .or. it == jnode(i) end do lwork(circuit(1:k-1)) = .false. do i = 1, nedge if ( lwork(i) ) then if ( nstack >= maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_EULER_CIRC_CAND - Fatal error!' write ( *, '(a)' ) ' Stacksize exceeded!' stop end if nstack = nstack + 1 stack(nstack) = i ncan(k) = ncan(k) + 1 end if end do return end subroutine graph_arc_euler_circ_next ( nedge, inode, jnode, circuit, stack, & maxstack, ncan, more ) ! !******************************************************************************* ! !! GRAPH_ARC_EULER_CIRC_NEXT returns the next Euler circuit for a graph. ! ! ! Discussion: ! ! The routine produces all the Euler circuits of a graph, one at a time. ! ! Definition: ! ! An Euler circuit of a graph is a path starting at some node, ! using all the edges of the graph exactly once, and returning ! to the starting node. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 16 August 2000 ! ! Parameters: ! ! Input, integer NEDGE, the number of edges in the graph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array of the graph. ! The I-th edge extends from node INODE(I) to JNODE(I). ! ! Output, integer CIRCUIT(NEDGE). If MORE = TRUE on output, then CIRCUIT ! contains the edges, in order, that constitute this circuit. ! ! Workspace, integer STACK(MAXSTACK). ! ! Input, integer MAXSTACK, the dimension of STACK. ! ! Workspace, integer NCAN(NEDGE), the number of candidates for each position. ! ! Input/output, logical MORE. ! On first call, set MORE to .FALSE, and do not alter it after. ! On return, MORE is TRUE if another circuit has been returned in ! IARRAY, and FALSE if there are no more circuits. ! implicit none ! integer nedge integer maxstack ! integer circuit(nedge) integer inode(nedge) integer, save :: indx = 0 integer iwork(nedge) integer jnode(nedge) integer, save :: k = 0 logical more integer ncan(nedge) integer, save :: nstack = 0 integer stack(maxstack) ! if ( .not. more ) then indx = 0 k = 0 more = .true. nstack = 0 end if do call ivec_backtrack ( nedge, circuit, indx, k, nstack, stack, maxstack, & ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call graph_arc_euler_circ_cand ( nedge, inode, jnode, circuit, k, & nstack, stack, maxstack, ncan, iwork ) else more = .false. exit end if end do return end subroutine graph_arc_example_diamond ( inode, jnode, maxedge, nedge, nnode, & x, y, z ) ! !******************************************************************************* ! !! GRAPH_ARC_EXAMPLE_DIAMOND returns the graph of a "diamond" 3D shape. ! ! ! Example: ! ! 1 ! /| |\ ! / | | \ ! 2--3-4--5--(2) ! | | | | ! 6--7-8--9--(6) ! \ | | / ! \| |/ ! 10 ! ! Modified: ! ! 10 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Output, integer INODE(MAXEDGE), JNODE(MAXEDGE), the NEDGE ! edges of the graph. The I-th edge connects nodes INODE(I) and ! JNODE(I). ! ! Input, integer MAXEDGE, the maximum number of edges allocated ! in the EDGE array. MAXEDGE should be at least 20. ! ! Output, integer NEDGE, the number of edges, which is 20. ! ! Output, integer NNODE, the number of nodes, which is 10. ! ! Output, real X(NNODE), Y(NNODE), Z(NNODE), the locations for the nodes. ! implicit none ! integer maxedge ! integer inode(maxedge) integer jnode(maxedge) integer nedge integer nnode real x(10) real y(10) real z(10) ! nedge = 20 nnode = 10 if ( maxedge < nedge ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_EXAMPLE_DIAMOND - Fatal error!' write ( *, '(a,i6)' ) ' Increase MAXEDGE to at least ', nedge stop end if inode(1) = 1 jnode(1) = 2 inode(2) = 1 jnode(2) = 3 inode(3) = 1 jnode(3) = 4 inode(4) = 1 jnode(4) = 5 inode(5) = 2 jnode(5) = 6 inode(6) = 3 jnode(6) = 7 inode(7) = 4 jnode(7) = 8 inode(8) = 5 jnode(8) = 9 inode(9) = 6 jnode(9) = 10 inode(10) = 7 jnode(10) = 10 inode(11) = 8 jnode(11) = 10 inode(12) = 9 jnode(12) = 10 inode(13) = 2 jnode(13) = 3 inode(14) = 3 jnode(14) = 4 inode(15) = 4 jnode(15) = 5 inode(16) = 5 jnode(16) = 2 inode(17) = 6 jnode(17) = 7 inode(18) = 7 jnode(18) = 8 inode(19) = 8 jnode(19) = 9 inode(20) = 9 jnode(20) = 6 x(1) = 0.0E+00 y(1) = 0.0E+00 z(1) = 2.0E+00 x(2) = 0.5E+00 y(2) = -0.5E+00 z(2) = 1.0E+00 x(3) = 0.5E+00 y(3) = 0.5E+00 z(3) = 1.0E+00 x(4) = -0.5E+00 y(4) = 0.5E+00 z(4) = 1.0E+00 x(5) = -0.5E+00 y(5) = -0.5E+00 z(5) = 1.0E+00 x(6) = 0.5E+00 y(6) = -0.5E+00 z(6) = -1.0E+00 x(7) = 0.5E+00 y(7) = 0.5E+00 z(7) = -1.0E+00 x(8) = -0.5E+00 y(8) = 0.5E+00 z(8) = -1.0E+00 x(9) = -0.5E+00 y(9) = -0.5E+00 z(9) = -1.0E+00 x(10) = 0.0E+00 y(10) = 0.0E+00 z(10) = -2.0E+00 return end subroutine graph_arc_face ( face, face_count, face_order, iface, jface, & inode, jnode, maxface, maxorder, nedge, nface, nnode ) ! !******************************************************************************* ! !! GRAPH_ARC_FACE constructs a set of faces for a plane graph. ! ! ! Warning: ! ! This is an experimental code. ! ! Comments: ! ! The reason this routine was written was to handle the problem of ! converting certain forms of 3D graphics data from a point and line ! representation to a list of faces. While at first glance, this ! seemed an easy task, it turned out to be one of those problems ! that becomes harder the longer it is considered. Particularly ! vexing was the idea that it might be possible to do this reconstruction ! without using any of the geometric data supplied with the connectivity ! data. ! ! The guiding idea was that a face ought to be a "short" cycle of ! the graph, and that every edge ought to appear in two separate faces. ! The resulting method should work for a connected graph which is ! planar, or merely orientable. A planar graph will result from a ! reasonable "triangulation" (meaning decomposition into arbitrary ! polygons) of the surface of a 3D object that has no holes. ! ! This algorithm will also handle the case where the graph is not planar, ! but results from the triangulation of a more complicated 3D object, ! such as one that includes holes. Even a Klein bottle, which is ! a manifold, but not orientable, can be handled, although it may not ! be possible then to assign a consistent orientation to the faces. ! ! By the way, this problem is MUCH easier if we can assume that all ! the faces use the same number of edges, such as in a triangular ! decomposition. This algorithm makes no such assumption. ! ! If the graph is planar, then the decomposition into ! faces allows us to define the dual graph. The dual graph H of the ! planar graph G comprises: ! ! * nodes V(I), each of which corresponds to a face F(I) of G; ! ! * edges (V(I), V(J)). V(I) and V(J) share an edge in H if and only ! if the faces F(I) and F(J) share an edge in G. (Thus G and H ! have the same number of edges). ! ! In the terminology of this routine, the dual graph has NFACE nodes, ! NEDGE edges, and the corresponding edge arrays are simply IFACE and ! JFACE. ! ! Formula: ! ! If the graph is actually planar, we can regard it as the flattened ! triangulation of a connected solid shape, and so we can apply Euler's ! formula: ! ! Faces + Vertices = Edges + 2 ! ! This means that we can predict beforehand that the number of faces ! produced by this routine will be ! ! NFACE = NEDGE + 2 - NNODE. ! ! Notes: ! ! The faces produced by this routine may actually overlap. Without ! geometric data, this is surely a possibility, since a graph may ! have more than one embedding. For instance, consider the following ! two embeddings of the same graph: ! ! A-----B A-----B ! | | | | ! | E | D-----C ! | / \ | \ / ! |/ \| \ / ! D-----C E ! ! This routine will report the two faces (A,B,C,D) and (C,D,E), ! although in the first embedding one face seems to be part of ! another. This is not as bad as it might seem, since the routine ! prefers the "smaller" face (A,B,C,D) over (A,B,C,E,D). ! ! ! A second problem is best illustrated with a simple example. ! Suppose we have a thin triangular rod, and that we have triangulated ! the surface of this rod, so that the cross section of the rod ! is a triangular graph, and the sides are made up of, say, squares. ! Then this routine will report all the "internal" triangles as ! faces. It will still find the "true" faces on the sides, but ! since it is possible to go around the diameter of the object ! in a very few steps, the algorithm produces faces we would not ! expect. ! ! Restrictions: ! ! The algorithm will fail if the graph cannot be regarded, at least ! locally, as the triangulation of a smooth surface. Smoothness ! problems will not occur if the graph is planar, or results from ! the triangulation of a 3D object, which might include holes. ! ! The graph should be connected. ! ! There should be no nodes of degree 1. ! ! Method: ! ! We have no geometric data from which to deduce physical positions ! of the nodes. We are only given that the graph is planar, so that ! there is at least one embedding of the graph in the plane. ! ! Our data structure for the method will use arrays called IFACE and JFACE. ! For each edge I, IFACE(I) and JFACE(I) will eventually hold the ! indices of the two faces that the edge is part of. We begin ! the algorithm by setting all entries of IFACE and JFACE to 0. ! ! The second step is to find one cycle in the graph, of the shortest ! length possible. This cycle constitutes our first face. We update ! the appropriate entries of IFACE or JFACE, marking each edge as having ! been used once. ! ! The third step is to add one more face to our collection of faces. ! The new face will be adjacent to the current collection of faces, ! but will include at least one completely unused edge, if possible. ! ! To guarantee this, we consider every edge that is part of our ! collection of faces, and that has only been used once. We look ! at the endpoints of each of these edges., and ! ! We search for an adjacent edge that has not been used. ! If we find such an edge, then the first two edges of our next face ! are the edge that was already part of the set of faces, and the ! unused edge. ! ! If we cannot find such an edge, then we repeat the search, starting ! with an edge in the face set that has been used once. But now ! when we search for adjacent edges, we will consider using one that ! has already been used once. ! ! We then search for a path that will return us to the initial ! node of the first edge. Using a breadth-first search, we expect ! to find the shortest path back to that node, and we assume that ! this represents a face. Again, we update the IFACE and JFACE arrays. ! ! We repeat the third step until there are no more edges in the ! collection of faces that have not been used twice. Assuming the ! graph is connected, this means that every face has been found. ! ! Improvements: ! ! It shouldn't be hard to modify the code to handle graphs that are ! not connected. ! ! If the edge arrays INODE and JNODE were sorted and indexed, some ! operations could be done more efficiently. ! ! Modified: ! ! 02 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer FACE(MAXORDER,MAXFACE), contains the list of edges ! which make up each face. Face I is made up of the edges ! FACE(1,I) through FACE(FACE_ORDER(I),I). ! ! Output, integer FACE_COUNT(NEDGE). For each edge I, FACE_COUNT(I) ! is the number of faces to which the edge belongs. This value should ! be 0, 1 or 2. ! ! Output, integer IFACE(NEDGE), JFACE(NEDGE). IFACE(I) and JFACE(I) ! are the two faces to which edge I belongs. Either or both may be zero ! if the algorithm fails. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge list for the graph. ! The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Input, integer MAXFACE, the maximum number of faces for which storage ! has been set aside in FACE and FACE_ORDER. ! ! Input, integer MAXORDER, the maximum number of edges for which storage ! has been set aside in FACE. ! ! Input, integer NEDGE, the number of edges. ! ! Output, integer NFACE, the number of faces found by the algorithm. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer FACE_ORDER(MAXFACE). The number of edges used ! in constructing face I is stored in FACE_ORDER(I). ! implicit none ! logical, parameter :: debug = .false. integer maxface integer maxorder integer nedge integer nnode ! integer face(maxorder,maxface) integer face_count(nedge) integer face_order(maxface) integer faceval integer i integer iedge integer iface(nedge) integer inode(nedge) integer j integer jface(nedge) integer jnode(nedge) integer k integer length integer nface integer nface_old integer nodes(3) integer nstart ! ! Initialization. No arc belongs to any face. ! if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Debug:' write ( *, '(a)' ) ' Initialization' end if nface = 0 face_count(1:nedge) = 0 iface(1:nedge) = 0 jface(1:nedge) = 0 face_order(1:maxface) = 0 face(1:maxorder,1:maxface) = 0 ! ! We start here. We may also jump back here if we have used up all the ! connected parts of a graph, and need to jump to a new piece. ! ! Find one new face of minimal length. ! 5 continue nface_old = nface do length = 3, nnode do iedge = 1, nedge nodes(1) = inode(iedge) nodes(2) = jnode(iedge) nstart = 2 call graph_arc_face_next ( face, face_count, face_order, iface, jface, & inode, jnode, maxface, maxorder, nedge, nface, nnode, nodes, nstart ) if ( nface > nface_old ) then go to 10 end if end do end do if ( nface == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Note.' write ( *, '(a)' ) ' Could not find any starting face.' end if go to 60 ! ! Find an edge that is in one face, but not two. ! 10 continue if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Debug:' write ( *, '(a,i6)' ) ' Found starting face #:', nface write ( *, '(a,i6)' ) ' Order is ', face_order(nface) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Vertices:' write ( *, '(a)' ) ' ' do i = 1, face_order(nface) write ( *, '(6i8)' ) face(i,nface) end do end if iedge = 0 ! ! Look for an edge with FACE_COUNT of 1. ! 20 continue iedge = iedge + 1 if ( face_count(iedge) == 1 ) then go to 30 else if ( iedge < nedge ) then go to 20 else if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Debug:' write ( *, '(a)' ) ' No more nearby edges to try.' end if ! ! Here, I'd like to be able to jump back and scrounge for other ! islands of edges, but something's not right. ! ! go to 5 go to 60 end if ! ! The face will start with the two nodes of edge IEDGE. ! 30 continue if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Debug:' write ( *, '(a)' ) ' Found a starting edge:' write ( *, '(i6)' ) inode(iedge) write ( *, '(i6)' ) jnode(iedge) end if nodes(1) = inode(iedge) nodes(2) = jnode(iedge) ! ! Look for an edge incident to JNODE(IEDGE). This new edge should have ! been used just FACEVAL times already. (FACEVAL is preferably 0, but if ! we can't find any at that rate, we'll try FACEVAL = 1). ! faceval = 0 40 continue do i = 1, nedge if ( face_count(i) == faceval ) then if ( inode(i) == nodes(2) .and. jnode(i) /= nodes(1) ) then nodes(3) = jnode(i) go to 50 else if ( jnode(i) == nodes(2) .and. inode(i) /= nodes(1) ) then nodes(3) = inode(i) go to 50 end if end if end do ! ! If we "fell through" with FACEVAL = 0, then try the search again ! with FACEVAL = 1. ! if ( faceval == 0 ) then faceval = 1 go to 40 ! ! If we fell through with FACEVAL = 1, then we couldn't find any ! way to use this edge. Mark it as though it were used, and move on. ! else if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Debug:' write ( *, '(a)' ) ' Failure.' write ( *, '(a,i6)' ) ' Cannot hook up to edge IEDGE:', iedge write ( *, '(2i6)' ) nodes(1), nodes(2) end if face_count(iedge) = 2 go to 20 end if ! ! Now call FACENEXT to search for the shortest cycle that begins ! NODES(1), NODES(2), NODES(3), and which involves only edges that ! have been used once or less. ! 50 continue nface_old = nface nstart = 3 call graph_arc_face_next ( face, face_count, face_order, iface, jface, & inode, jnode, maxface, maxorder, nedge, nface, nnode, nodes, nstart ) if ( nface > nface_old ) then if ( debug ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Debug' write ( *, '(a,i6)' ) ' NFACE_OLD = ', nface_old write ( *, '(a,i6)' ) ' NFACE = ', nface write ( *, '(a,i6)' ) ' Order is ', face_order(nface) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Vertices:' write ( *, '(a)' ) ' ' do i = 1, face_order(nface) write ( *, '(6i8)' ) face(i,nface) end do write ( *, '(a)' ) ' Trying the big loop again.' end if go to 10 end if ! ! The algorithm has failed. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_FACE - Error!' write ( *, '(a)' ) ' The algorithm has failed.' write ( *, '(a)' ) ' Only some of the faces were found.' ! ! Cleanup ! 60 continue do i = 1, nface face_order(i) = min ( face_order(i), maxorder ) end do do i = 1, nface do j = 1, face_order(i) k = face(j,i) if ( k < 0 ) then face(j,i) = jnode(-k) else face(j,i) = inode(k) end if end do end do return end subroutine graph_arc_face_next ( face, face_count, face_order, iface, jface, & inode, jnode, maxface, maxorder, nedge, nface, nnode, nodes, nstart ) ! !******************************************************************************* ! !! GRAPH_ARC_FACE_NEXT tries to complete the next face, given a few starting nod ! ! ! Discussion: ! ! This is a utility routine, called by GRAPH_ARC_FACE, which ! constructs all the faces of a graph. GRAPH_ARC_FACE finds the first ! two or three nodes of a face, and then calls this routine, which ! attempts to complete the face by using a breadth-first search ! from the final given node of the face. ! ! Modified: ! ! 01 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer FACE(MAXORDER,MAXFACE), contains the list of edges ! which make up each face. Face I is made up of the edges ! FACE(1,I) through FACE(FACE_ORDER(I),I). If a new face is found, this ! array is updated. ! ! Input/output, integer FACE_COUNT(NEDGE). For each edge I, FACE_COUNT(I) ! is the number of faces to which the edge belongs. This value will ! be 0, 1 or 2. If a new face is found, this data is updated. ! ! Input/output, integer FACE_ORDER(MAXFACE). The number of edges used ! in constructing face I is stored in FACE_ORDER(I). ! ! Input/output, integer IFACE(NEDGE), JFACE(NEDGE). IFACE(I) and JFACE(I) ! are the two faces to which edge I belongs. Either or both may be zero ! if the algorithm fails. If a new face is found, this data is updated. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge list for the graph. ! The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Input, integer MAXFACE, the maximum number of faces for which storage ! has been set aside in FACE and FACE_ORDER. ! ! Input, integer MAXORDER, the maximum number of edges for which storage ! has been set aside in FACE. ! ! Input, integer NEDGE, the number of edges. ! ! Input/output, integer NFACE. NFACE is the number of faces found so far. ! This value will be updated by this routine if a new face is found. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NODES(NSTART), the first few nodes in the partial cycle. ! ! Input, integer NSTART, the number of nodes in the partial cycle. ! ! Workspace: ! ! Workspace, integer DAD(NNODE), used during the breadth first search ! of the graph, to point backwards from each node to its predecessor ! in a path. ! ! Workspace, integer INDEX(NNODE), used during the breadth first search ! to label nodes that have been visited. ! implicit none ! integer maxface integer maxorder integer nedge integer nnode integer nstart ! integer dad(nnode) integer face(maxorder,maxface) integer face_count(nedge) integer face_order(maxface) integer i integer iedge2 integer iface(nedge) integer index(nnode) integer inode(nedge) integer istart1 integer istart2 integer itemp integer jface(nedge) integer jnode(nedge) integer kedge integer kk integer nadd integer nface integer nodei integer nodej integer npath integer nodes(nstart) ! ! Initialization. ! index(1:nnode) = 0 dad(1:nnode) = 0 istart1 = nodes(1) istart2 = nodes(2) do i = 1, nstart npath = i if ( i == 1 ) then dad(nodes(i)) = -1 else dad(nodes(i)) = nodes(i-1) end if index(nodes(i)) = i end do ! ! From the nodes with INDEX = NPATH, consider all neighbors. ! 10 continue npath = npath + 1 nadd = 0 do iedge2 = 1, nedge if ( index(inode(iedge2)) == npath-1 .and. index(jnode(iedge2)) == 0 ) then nodei = inode(iedge2) nodej = jnode(iedge2) else if ( index(jnode(iedge2)) == npath-1 .and. & index(inode(iedge2)) == 0 ) then nodei = jnode(iedge2) nodej = inode(iedge2) else if ( index(inode(iedge2)) == npath-1 .and. & jnode(iedge2) == istart1 ) then nodei = inode(iedge2) nodej = jnode(iedge2) else if ( index(jnode(iedge2)) == npath-1 .and. & inode(iedge2) == istart1 ) then nodei = jnode(iedge2) nodej = inode(iedge2) else nodei = 0 nodej = 0 end if if ( nodei /= 0 .and. nodej /= istart1 ) then nadd = nadd + 1 index(nodej) = npath dad(nodej) = nodei ! ! Success if the marked node is the starting point (except when ! using the edge (ISTART2,ISTART1)). ! else if ( nodej == istart1 .and. nodei == istart2 ) then else if ( nodej == istart1 .and. nodei /= istart2 ) then nface = nface + 1 20 continue ! ! Find the edge KK which joins NODEI and NODEJ. ! do kk = 1, nedge if ( ( inode(kk) == nodei .and. jnode(kk) == nodej ) .or. & ( jnode(kk) == nodei .and. inode(kk) == nodej ) ) then face_count(kk) = face_count(kk) + 1 itemp = face_count(kk) if ( itemp == 1 ) then iface(kk) = nface else if ( itemp == 2 ) then jface(kk) = nface end if if ( inode(kk) == nodei ) then kedge = kk else kedge = -kk end if exit end if end do nodej = nodei ! ! Add the edge to the face-to-edge list. ! if ( nface <= maxface ) then if ( face_order(nface) < maxorder ) then face_order(nface) = face_order(nface) + 1 end if if ( face_order(nface) <= maxorder ) then face(face_order(nface),nface) = kedge end if end if if ( nodej /= istart1 ) then nodei = dad(nodej) go to 20 end if return end if end do ! ! If we were able to proceed another step, and we haven't exceeded ! our limit, then go back and take another step. ! if ( nadd > 0 .and. npath <= nnode ) then go to 10 end if return end subroutine graph_arc_is_eulerian ( nnode, nedge, inode, jnode, degree, result ) ! !******************************************************************************* ! !! GRAPH_ARC_IS_EULERIAN determines if a graph is Eulerian from its edge list. ! ! ! Definition: ! ! A graph is Eulerian if there exists a circuit through the graph ! which uses every edge once. ! ! Modified: ! ! 11 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the pairs of nodes ! that form the edges. ! ! Output, integer DEGREE(NNODE), the degree of each node, that is, ! the number of edges that include the node. ! ! Output, integer RESULT. ! 0, the graph is not Eulerian. ! 1, the graph is Eulerian, but the starting and ending nodes are different. ! 2, the graph is Eulerian, and there is a closed Euler circuit. ! implicit none ! integer nedge integer nnode ! integer degree(nnode) integer i integer inode(nedge) integer jnode(nedge) integer nodd integer result ! call graph_arc_degree ( nnode, nedge, inode, jnode, degree ) nodd = 0 do i = 1, nnode if ( mod ( degree(i), 2 ) == 1 ) then nodd = nodd + 1 end if end do if ( nodd == 0 ) then result = 2 else if ( nodd == 2 ) then result = 1 else result = 0 end if return end subroutine graph_arc_match ( nnode, nedge, inode, jnode, type, match ) ! !******************************************************************************* ! !! GRAPH_ARC_MATCH finds a maximum matching in a bipartite graph. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Discussion: ! ! The nodes of the graph are assumed to be divided into two groups, ! and it is desired to determine as matching that is as large as possible. ! The matching is a set of pairs ( NODE(I), NODE(J) ) with the properties: ! ! * NODE(I) is in group 1 and NODE(J) is in group 2; ! * there is an edge between NODE(I) and NODE(J); ! * NODE(I) and NODE(J) are not used in any other pairing in the matching. ! ! The user inputs the edge list that defines the graph, and a set of ! labels that classify the nodes as being in one group or the other. ! It is not necessary that the graph actually be bipartite; edges between ! nodes in the same group are allowed, but they will not affect the ! outcome in any way. ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the end nodes of the edges. ! ! Input, integer TYPE(NNODE), labels the two types of nodes in the graph. ! Normally, TYPE(I) would be 0 or 1, but any two distinct values will do. ! ! Output, integer MATCH(NNODE), the matching node for each node, or 0 ! if no match was assigned. ! implicit none ! integer nedge integer nnode ! integer capflo(2,2*nedge+2*nnode) integer flow(2*nedge+2*nnode) integer i integer icut(nnode+2) integer iendpt(2,2*nedge+2*nnode) integer in integer inode(nedge) integer isink integer isorce integer j integer jn integer jnode(nedge) integer match(nnode) integer nedge2 integer nnode2 integer node_flow(nnode+2) integer type(nnode) ! match(1:nnode) = 0 ! ! Create a network from the graph, with two extra nodes. ! isorce = nnode + 1 isink = nnode + 2 nnode2 = nnode + 2 j = 0 do i = 1, nedge in = inode(i) jn = jnode(i) if ( type(in) /= type(jn) ) then j = j + 1 iendpt(1,j) = inode(i) iendpt(2,j) = jnode(i) capflo(1,j) = 1 capflo(2,j) = 0 j = j + 1 iendpt(1,j) = jnode(i) iendpt(2,j) = inode(i) capflo(1,j) = 1 capflo(2,j) = 0 end if end do ! ! Nodes of type 1 are connected to the source, ! and nodes of type 2 are connected to the sink. ! do i = 1, nnode if ( type(i) == type(1) ) then j = j + 1 iendpt(1,j) = isorce iendpt(2,j) = i capflo(1,j) = 1 capflo(2,j) = 0 j = j + 1 iendpt(1,j) = i iendpt(2,j) = isorce capflo(1,j) = 1 capflo(2,j) = 0 else j = j + 1 iendpt(1,j) = i iendpt(2,j) = isink capflo(1,j) = 1 capflo(2,j) = 0 j = j + 1 iendpt(1,j) = isink iendpt(2,j) = i capflo(1,j) = 1 capflo(2,j) = 0 end if end do ! ! Determine the maximum flow on the network. ! ! Then a pair of nodes connected by an edge that has a network flow of 1 ! are part of the maximal matching. ! nedge2 = j call network_flow_max ( nnode2, nedge2, iendpt, capflo, isorce, isink, & icut, node_flow ) do i = 1, nedge2 if ( iendpt(1,i) <= nnode .and. & iendpt(2,i) <= nnode .and. & capflo(1,i) > 0 .and. & capflo(2,i) == 1 ) then in = iendpt(1,i) jn = iendpt(2,i) match(in) = jn match(jn) = in end if end do return end subroutine graph_arc_min_path ( nnode, nedge, inode, jnode, arcost, & istart, last, num_path, ispath, xlen ) ! !******************************************************************************* ! !! GRAPH_ARC_MIN_PATH finds the shortest path between two nodes. ! ! ! Reference: ! ! H T Lau, ! Combinatorial Heuristic Algorithms in FORTRAN, ! Springer Verlag, 1986. ! ! Modified: ! ! 11 September 1999 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes in the graph. ! ! Input, integer NEDGE, the number of edges in the graph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edges of the graph, ! describe by pairs of nodes. ! ! Input, real ARCOST(NEDGE), the distance or cost of each edge. ! ! Input, integer ISTART, LAST, are the two nodes between which a ! shortest path is desired. ! ! Output, integer NUM_PATH, the number of nodes in the shortest path. ! NUM_PATH is zero if no path could be found. ! ! Output, integer ISPATH(NNODE), lists the nodes in the shortest path, ! from ISPATH(1) to ISPATH(NUM_PATH). ! ! Output, real XLEN, the length of the shortest path from ISTART to LAST. ! implicit none ! integer nedge integer nnode ! real arcost(nedge) real d integer i integer ic integer ient logical ifin integer ij integer inode(nedge) integer ispath(nnode) integer istart logical iwork1(nnode) integer iwork2(nnode) integer iwork3(nedge) integer j integer jnode(nedge) integer k integer l integer last integer num_path real wk4(nnode) real xlen ! wk4(1:nnode) = huge ( wk4(1) ) iwork1(1:nnode) = .true. iwork2(1:nnode) = 0 wk4(istart) = 0.0E+00 i = istart iwork1(istart) = .false. xlen = 0 ! ! For each forward arc originating at node I calculate ! the length of the path to node I. ! 10 continue ic = 0 do k = 1, nedge if ( inode(k) == i ) then ic = ic + 1 iwork3(ic) = k ispath(ic) = jnode(k) end if if ( jnode(k) == i ) then ic = ic + 1 iwork3(ic) = k ispath(ic) = inode(k) end if end do if ( ic > 0 ) then do l = 1, ic k = iwork3(l) j = ispath(l) if ( iwork1(j) ) then d = wk4(i) + arcost(k) if ( d < wk4(j) ) then wk4(j) = d iwork2(j) = k end if end if end do end if ! ! Find the minimum potential. ! d = huge ( d ) ient = 0 ifin = .false. do i = 1, nnode if ( iwork1(i) ) then ifin = .true. if ( wk4(i) < d ) then d = wk4(i) ient = i end if end if end do ! ! Include the node in the current path. ! if ( d < huge ( d ) ) then iwork1(ient) = .false. if ( ient /= last ) then i = ient go to 10 end if else if ( ifin ) then num_path = 0 return end if end if ij = last num_path = 1 ispath(1) = last do k = iwork2(ij) if ( inode(k) == ij ) then ij = jnode(k) else ij = inode(k) end if num_path = num_path + 1 ispath(num_path) = ij if ( ij == istart ) then exit end if end do l = num_path / 2 j = num_path do i = 1, l call i_swap ( ispath(i), ispath(j) ) j = j - 1 end do xlen = wk4(last) return end subroutine graph_arc_min_span_tree ( nnode, nedge, inode, jnode, cost, & itree, jtree, tree_cost ) ! !******************************************************************************* ! !! GRAPH_ARC_MIN_SPAN_TREE finds a minimum spanning tree of a graph. ! ! ! Discussion: ! ! The input graph is represented by a list of edges. ! ! Reference: ! ! H T Lau, ! Combinatorial Heuristic Algorithms in FORTRAN, ! Springer Verlag, 1986. ! ! Modified: ! ! 21 July 2000 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes in the graph. ! ! Input, integer NEDGE, the number of edges in the graph. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the start and end nodes ! of the edges. ! ! Input, real COST(NEDGE), the cost or length of each edge. ! ! Output, integer ITREE(NNODE-1), JTREE(NNODE-1), the pairs of nodes that ! form the edges of the spanning tree. ! ! Output, real TREE_COST, the total cost or length of the spanning tree. ! implicit none ! integer nedge integer nnode ! integer best real cost(nedge) real d logical free(nnode) integer i integer ic integer ij integer inode(nedge) integer itr integer itree(nnode-1) integer iwork1(nnode) integer iwork2(nnode) integer iwork4(nedge) integer iwork5(nedge) integer j integer jnode(nedge) integer jtree(nnode-1) integer jj integer k integer kk integer l real tree_cost real wk6(nnode) ! wk6(1:nnode) = huge ( wk6(1) ) free(1:nnode) = .true. iwork1(1:nnode) = 0 iwork2(1:nnode) = 0 itree(1:nnode-1) = 0 jtree(1:nnode-1) = 0 ! ! Find the first non-zero arc. ! do ij = 1, nedge if ( inode(ij) /= 0 ) then i = inode(ij) exit end if end do wk6(i) = 0.0E+00 free(i) = .false. tree_cost = 0.0E+00 do jj = 1, nnode - 1 wk6(1:nnode) = huge ( wk6(1) ) do i = 1, nnode ! ! For each forward arc originating at node I ! calculate the length of the path to node I. ! if ( .not. free(i) ) then ic = 0 do k = 1, nedge if ( inode(k) == i ) then ic = ic + 1 iwork5(ic) = k iwork4(ic) = jnode(k) end if if ( jnode(k) == i ) then ic = ic + 1 iwork5(ic) = k iwork4(ic) = inode(k) end if end do if ( ic > 0 ) then do l = 1, ic k = iwork5(l) j = iwork4(l) if ( free(j) ) then d = tree_cost + cost(k) if ( d < wk6(j) ) then wk6(j) = d iwork1(j) = i iwork2(j) = k end if end if end do end if end if end do ! ! Identify the free node of minimum potential. ! d = huge ( d ) best = 0 do i = 1, nnode if ( free(i) ) then if ( wk6(i) < d ) then d = wk6(i) best = i itr = iwork1(i) kk = iwork2(i) end if end if end do ! ! Add that node to the tree. ! if ( d < huge ( d ) ) then free(best) = .false. tree_cost = tree_cost + cost(kk) itree(jj) = itr jtree(jj) = best end if end do return end subroutine graph_arc_ncolor_print ( nedge, inode, jnode, nnode, color, title ) ! !******************************************************************************* ! !! GRAPH_ARC_NCOLOR_PRINT prints out a node-colored graph from an edge list. ! ! ! Discussion: ! ! The printout is arranged to emphasize the colors of the neighboring nodes. ! ! Modified: ! ! 23 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the beginning and end ! nodes of the edges. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer COLOR(NNODE), the color of each node. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer nedge integer nnode ! integer color(nnode) integer i integer in integer inode(nedge) integer jn integer jnode(nedge) character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Edge Node 1 Node 2 Color 1 Color 2' write ( *, '(a)' ) ' ' do i = 1, nedge in = inode(i) jn = jnode(i) write ( *, '(i6,2x,i6,2x,i6,2x,i6,2x,i6)' ) i, in, jn, color(in), color(jn) end do return end subroutine graph_arc_node_count ( nedge, inode, jnode, mnode, nnode ) ! !******************************************************************************* ! !! GRAPH_ARC_NODE_COUNT counts the number of nodes in a graph. ! ! ! Modified: ! ! 24 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE). INODE(I) and JNODE(I) ! are the start and end nodes of the I-th edge. ! ! Output, integer MNODE, the maximum node index. ! ! Output, integer NNODE, the number of distinct nodes. ! implicit none ! integer nedge ! integer iedge integer inode(nedge) integer jnode(nedge) integer knode(2*nedge) integer mnode integer nnode ! mnode = max ( maxval ( inode(1:nedge) ), maxval ( jnode(1:nedge) ) ) ! ! Copy all the node labels into KNODE, ! sort KNODE, ! count the unique entries. ! ! That's NNODE. ! knode(1:nedge) = inode(1:nedge) do iedge = 1, nedge knode(nedge+iedge) = jnode(iedge) end do call ivec_sort_heap_a ( 2*nedge, knode ) call ivec_uniq ( 2*nedge, knode, nnode ) return end subroutine graph_arc_print ( nedge, inode, jnode, title ) ! !******************************************************************************* ! !! GRAPH_ARC_PRINT prints out a graph from an edge list. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the beginning and end ! nodes of the edges. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer nedge ! integer i integer inode(nedge) integer jnode(nedge) character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nedge write ( *, '(i6,4x,2i6)' ) i, inode(i), jnode(i) end do return end subroutine graph_arc_to_ps ( file_name, inode, jnode, nedge, nnode, x, y ) ! !******************************************************************************* ! !! GRAPH_ARC_TO_PS writes graph information to a PostScript file. ! ! ! Modified: ! ! 10 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the output file. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array. ! The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real X(NNODE), Y(NNODE), the X and Y components of points. ! implicit none ! integer nedge integer nnode ! real alpha real blue character ( len = 8 ) date character ( len = * ) file_name real green integer i integer inode(nedge) integer ios integer iunit integer jnode(nedge) integer margin integer node integer pagexmax integer pagexmin integer pageymax integer pageymin integer plotxmax integer plotxmin integer plotxmin2 integer plotymax integer plotymin integer plotymin2 integer px1 integer px2 integer py1 integer py2 real red real x(nnode) real xmax real xmin real y(nnode) real ymax real ymin ! ! Bounding box. ! xmin = minval ( x(1:nnode) ) xmax = maxval ( x(1:nnode) ) ymin = minval ( y(1:nnode) ) ymax = maxval ( y(1:nnode) ) if ( xmin == xmax ) then xmin = x(1) - 0.5E+00 xmax = x(1) + 0.5E+00 end if if ( ymin == ymax ) then ymin = y(1) - 0.5E+00 ymax = y(1) + 0.5E+00 end if ! ! Compute the scale factor. ! pagexmax = 612 pagexmin = 0 pageymax = 792 pageymin = 0 margin = 36 plotxmax = pagexmax - margin plotxmin = pagexmin + margin plotymax = pageymax - margin plotymin = pageymin + margin alpha = min ( ( plotxmax - plotxmin ) / ( xmax - xmin ), & ( plotymax - plotymin ) / ( ymax - ymin ) ) ! ! Adjust PLOTXMIN and PLOTYMIN to center the image. ! plotxmin2 = 0.5E+00 * ( plotxmin + plotxmax - alpha * ( xmax - xmin ) ) plotymin2 = 0.5E+00 * ( plotymin + plotymax - alpha * ( ymax - ymin ) ) call get_unit ( iunit ) open ( unit = iunit, file = file_name, status = 'replace', iostat = ios ) if ( ios /= 0 ) then return end if ! ! Write the prolog. ! write ( iunit, '(a)' ) '%!PS-Adobe-3.0' write ( iunit, '(a)' ) '%%Document-Fonts: Times-Roman' write ( iunit, '(a,a)' ) '%%Title: ' , trim ( file_name ) write ( iunit, '(a)' ) '%%Creator: GRAFPACK(graph_arc_to_ps)' call date_and_time ( date ) write ( iunit, '(a)' ) '%%CreationDate: ' // trim ( date ) write ( iunit, '(a,4i5)' ) '%%BoundingBox', plotxmin, plotymin, plotxmax, & plotymax write ( iunit, '(a)' ) '%%LanguageLevel: 2' write ( iunit, '(a)' ) '%%EndComments' write ( iunit, '(a)' ) '%%BeginProlog' write ( iunit, '(a)' ) '%%EndProlog' ! ! Set the line color. ! red = 0.0E+00 green = 0.0E+00 blue = 0.0E+00 write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' ! ! Draw lines. ! call edges_to_ps ( plotxmin2, plotymin2, alpha, iunit, inode, jnode, & nedge, nnode, x, y, xmin, ymin ) ! ! Set the fill color. ! red = 0.1 green = 0.1 blue = 0.7 write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' ! ! Draw points. ! call nodes_to_ps ( plotxmin2, plotymin2, alpha, iunit, nnode, x, y, & xmin, ymin ) write ( iunit, '(a)' ) 'showpage' ! ! Write the epilog. ! write ( iunit, '(a)' ) 'grestore' write ( iunit, '(a)' ) '%%Trailer' write ( iunit, '(a,i2)' ) '%%Pages: 1' close ( iunit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_TO_PS' write ( *, '(a)' ) ' The data was written to the file: ' & // trim ( file_name ) return end subroutine graph_arc_span_forest ( nnode, nedge, inode, jnode, ncomp, & component ) ! !******************************************************************************* ! !! GRAPH_ARC_SPAN_FOREST determines a graph's connectivity and spanning forest. ! ! ! Definition: ! ! A (connected) component of a graph is a maximal subgraph which ! is connected. ! ! A tree is a connected graph containing no cycles. ! ! A spanning tree of a connected graph is a subgraph which is a ! maximal tree. ! ! A forest is a collection of trees, no two of which share a node. ! ! A spanning forest of a possibly unconnected graph is a collection ! containing a single spanning tree for each component of the graph. ! ! Comments: ! ! The input graph may be connected or unconnected. ! ! If the input graph is connected, this routine simply returns a ! spanning tree for the graph. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 29 October 1999 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges in the graph. ! ! Input/output, integer INODE(NEDGE), JNODE(NEDGE), the edge list ! of the graph. On output, this array has been rearranged. Edges ! belonging to the spanning tree of component 1 are first, followed ! by edges belonging to the other spanning trees, followed last by ! edges that were not used in any spanning tree. ! ! Output, integer NCOMP, the number of connected components of the graph. ! ! Input/output, integer IENDPT(2,NEDGE), the edge array of the graph. ! IENDPT(1,I) and IENDPT(2,I) are the two nodes that make up edge I. ! ! On input, IENDPT describes the graph. ! ! On output, the input entries of IENDPT have been reordered, so that ! edges belonging to the spanning forest come first, followed by those ! edges which are not part of the spanning forest. ! ! Output, integer NCOMP, the number of connected components of the graph. ! ! Output, integer IARRAY(NNODE). IARRAY(I) is the component to which ! node I belongs, and will take on values between 1 and NCOMP. ! implicit none ! integer nedge integer nnode ! integer component(nnode) integer i integer inode(nedge) integer inode2(nedge) integer j integer jnode(nedge) integer jnode2(nedge) integer left integer ncomp integer nstack integer num integer prev integer r integer right integer stack_node(nnode) integer stack_prev(nnode) integer v integer x_num(nnode) ! left = 0 right = nedge + 1 inode2(1:nedge) = 0 jnode2(1:nedge) = 0 ! ! Part A: ! component(1:nnode) = 0 x_num(1:nnode) = 0 ncomp = 0 v = 1 num = 0 nstack = 0 ! ! Part B: ! Scan next V. ! 10 continue if ( v > nnode ) then inode(1:nedge) = inode2(1:nedge) jnode(1:nedge) = jnode2(1:nedge) return end if if ( component(v) /= 0 ) then v = v + 1 go to 10 end if ! ! Begin the NCOMP-th component at V. ! ncomp = ncomp + 1 num = num + 1 component(v) = ncomp x_num(v) = num nstack = nstack + 1 stack_node(nstack) = v stack_prev(nstack) = 0 ! ! Part C: ! Is component NCOMP finished? ! do if ( nstack <= 0 ) then v = v + 1 go to 10 end if j = stack_node(nstack) prev = stack_prev(nstack) nstack = nstack - 1 ! ! Examine each vertex R that is adjacent to node J. ! do i = 1, nedge if ( inode(i) == j ) then r = jnode(i) else if ( jnode(i) == j ) then r = inode(i) else r = 0 end if if ( r /= 0 ) then if ( component(r) == 0 ) then num = num + 1 component(r) = ncomp x_num(r) = num nstack = nstack + 1 stack_node(nstack) = r stack_prev(nstack) = j left = left + 1 inode2(left) = j jnode2(left) = r else if ( r == prev .or. x_num(r) > x_num(j) ) then else right = right - 1 inode2(right) = j jnode2(right) = r end if end if end if end do end do return end subroutine graph_arc_span_tree ( nedge, inode, jnode, nnode, dad ) ! !******************************************************************************* ! !! GRAPH_ARC_SPAN_TREE constructs the spanning tree of a graph. ! ! ! Discussion: ! ! If the graph is connected, then exactly one node will have no ! parent, and a DAD value of -1. ! ! If the graph is not connected, but divided into NCOMP components, then ! NCOMP nodes will have a DAD value of -1. ! ! If the graph is connected, then once the tree is computed, the ! addition to the tree of any edge not included in the tree will ! form a cycle. Since there are NNODE-1 edges in the tree, this will ! normally mean that there are NEDGE-(NNODE-1) "fundamental" cycles ! that can be generated in this way. ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array of the graph. ! The I-th edge joins nodes INODE(I) and JNODE(I). ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer DAD(NNODE), the "father" array. If node I is the ! root of the tree spanning a given component of the graph, then ! DAD(I) = -1. Otherwise, DAD(I) is the index of another node J in ! the same component, such that the edge (I,J) is the first step ! in the path along the tree from node I to the root of its component. ! implicit none ! integer nedge integer nnode ! integer dad(nnode) integer i integer iedge integer inode(nedge) integer jnode(nedge) integer nodei integer nodej integer nstacki integer nstackj integer stack(nnode) ! ! Initialize. ! nstacki = 0 nstackj = 0 dad(1:nnode) = 0 stack(1:nnode) = 0 ! ! Start at an unvisited node. ! do i = 0 do i = i + 1 if ( i > nnode ) then return end if if ( dad(i) == 0 ) then exit end if end do nodei = i dad(nodei) = - 1 nstacki = 1 stack(nstacki) = nodei ! ! Search for unvisited neighbors of the last set of nodes. ! do do i = 1, nstacki nodei = stack(i) do iedge = 1, nedge if ( inode(iedge) == nodei ) then nodej = jnode(iedge) else if ( jnode(iedge) == nodei ) then nodej = inode(iedge) else nodej = 0 end if ! ! Store unvisited neighbors in STACK. ! if ( nodej /= 0 ) then if ( dad(nodej) == 0 ) then dad(nodej) = nodei nstackj = nstackj + 1 stack(nstacki+nstackj) = nodej end if end if end do end do ! ! If you picked up new neighbors on this pass, then we need to ! search for THEIR neighbors. ! if ( nstackj <= 0 ) then exit end if stack(1:nstackj) = stack(nstacki+1:nstacki+nstackj) nstacki = nstackj nstackj = 0 end do end do return end subroutine graph_arc_to_digraph_arc ( iarc, jarc, inode, jnode, maxarc, narc, & nedge ) ! !******************************************************************************* ! !! GRAPH_ARC_TO_DIGRAPH_ARC converts an undirected to a directed graph. ! ! ! Discussion: ! ! The intent is that every edge (I,J) of the undirected graph will ! become two directed edges or "arcs" (I,J) and (J,I) of the directed ! graph. An "arc" (I,J) is a path FROM I TO J, and does not allow ! passage back from J to I. ! ! An edge (I,I) results in a single arc (I,I). ! ! If the input data already includes edges (I,J) and (J,I), then ! the code will catch this fact, and will produce two arcs, not four. ! ! As part of the processing, edges (I,J) in the input array are ! reordered if necessary so that I <= J. Then the edge array is ! sorted, and duplicates are removed. Only then are the arcs ! generated. ! ! Modified: ! ! 01 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IARC(MAXARC), JARC(MAXARC), the arcs of a ! directed graph, with the property that every edge (I,J) in the undirected ! graph corresponds to a pair of arcs (I,J) and (J,I) in the directed ! graph, with the exception that an edge (I,I) corresponds to a single ! arc (I,I). The I-th arc goes from IARC(I) to JARC(I). ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array for an ! undirected graph. The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Input, integer MAXARC, the maximum number of arcs for which storage ! has been set aside. MAXARC = 2*NEDGE is always enough, but less ! space may be required if there are many duplicate edges, or ! edges of the form (I,I). ! ! Output, integer NARC, the actual number of arcs constructed for ! the directed graph. ! ! Input, integer NEDGE, the number of edges in the undirected graph. ! implicit none ! integer maxarc integer nedge ! integer i integer iarc(maxarc) integer inode(nedge) integer jarc(maxarc) integer jnode(nedge) integer narc integer nuniq ! ! Copy the edge array into the initial part of the arc array. ! narc = nedge iarc(1:narc) = inode(1:narc) jarc(1:narc) = jnode(1:narc) ! ! Sort the edge array as though it were undirected. ! call graph_arc_edge_sort ( narc, iarc, jarc ) ! ! Eliminate duplicates. ! call ivec2_uniq ( narc, iarc, jarc, nuniq ) ! ! Generate the extra arcs. ! narc = nuniq do i = 1, nuniq if ( iarc(i) /= jarc(i) ) then narc = narc + 1 if ( narc <= maxarc ) then iarc(narc) = jarc(i) jarc(narc) = iarc(i) end if end if end do ! ! Now sort the digraph edge array. ! call digraph_arc_edge_sort ( narc, iarc, jarc ) return end subroutine graph_arc_to_graph_adj ( nedge, inode, jnode, adj, lda, nnode ) ! !******************************************************************************* ! !! GRAPH_ARC_TO_GRAPH_ADJ converts an arc list graph to an adjacency graph. ! ! ! Modified: ! ! 01 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the edge array for an ! undirected graph. The I-th edge connects nodes INODE(I) and JNODE(I). ! ! Output, integer ADJ(LDA,NNODE), the adjacency information. ! ! Input, integer LDA, the leading dimension of ADJ. ! ! Output, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nedge ! integer adj(lda,*) integer i integer inode(nedge) integer j integer jnode(nedge) integer k integer mnode integer nnode ! ! Determine the number of nodes. ! call graph_arc_node_count ( nedge, inode, jnode, mnode, nnode ) if ( nnode > lda ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_ARC_TO_GRAPH_ADJ - Fatal error!' write ( *, '(a)' ) ' Number of nodes exceeds LDA.' stop end if adj(1:nnode,1:nnode) = 0 do k = 1, nedge i = inode(k) j = jnode(k) adj(i,j) = 1 adj(j,i) = 1 end do return end subroutine graph_arc_to_graph_star ( nnode, nedge, inode, jnode, arcfir, & fwdarc ) ! !******************************************************************************* ! !! GRAPH_ARC_TO_GRAPH_STAR sets up the forward star representation of an undirected gr ! ! ! Modified: ! ! 04 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE); the I-th edge of the graph ! extends from node INODE(I) to JNODE(I). ! ! Output, integer ARCFIR(NNODE+1); ARCFIR(I) is the number of the first ! edge starting at node I in the forward star representation of the graph. ! ! Output, integer FWDARC(2*NEDGE); FWDARC(I) is the ending node of ! the I-th edge in the forward star representation of the graph. ! implicit none ! integer nedge integer nnode ! integer arcfir(nnode+1) integer fwdarc(2*nedge) integer i integer inode(nedge) integer j integer jnode(nedge) integer k ! ! Set up the forward star representation of the graph. ! k = 0 do i = 1, nnode arcfir(i) = k + 1 do j = 1, nedge if ( inode(j) == i ) then k = k + 1 fwdarc(k) = jnode(j) end if if ( jnode(j) == i ) then k = k + 1 fwdarc(k) = inode(j) end if end do end do arcfir(nnode+1) = k + 1 return end subroutine graph_arc_weight_print ( nedge, inode, jnode, wnode, title ) ! !******************************************************************************* ! !! GRAPH_ARC_WEIGHT_PRINT prints out a weighted graph from an edge list. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the beginning and end ! nodes of the edges. ! ! Input, real WNODE(NEDGE), the weights of the edges. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer nedge ! integer i integer inode(nedge) integer jnode(nedge) character ( len = * ) title real wnode(nedge) ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nedge write ( *, '(i6,4x,2i6,g14.6)' ) i, inode(i), jnode(i), wnode(i) end do return end subroutine graph_chro ( nnode, nedge, iendpt, iarray, jarray, karray, stack, & maxstack ) ! !******************************************************************************* ! !! GRAPH_CHRO calculates the chromatic polynomial of a connected graph. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer IENDPT(2,NEDGE). IENDPT(1,I) and IENDPT(2,I) are ! the two nodes which define edge I. On output, IENDPT has ! been overwritten. ! ! Output, integer IARRAY(NNODE). Coefficients of the chromatic ! polynomial in power form: ! ! P(X) = ! IARRAY(N) * X**NNODE ! - IARRAY(N-1) * X**NNODE-1 ! + IARRAY(N-2) * X**NNODE-2 ! ... ! +-IARRAY(1) * X ! ! Output, integer JARRAY(NNODE). Coefficients of the chromatic ! polynomial using the Tutte or tree form: ! ! P(X) = SUM ( I = 1 TO NNODE ) ! (-1)**(NNODE-I) * IARRAY(I) * X * (X-1)**(I-1) ! ! Output, integer KARRAY(NNODE). The Stirling or factorial form of ! chromatic polynomial. ! ! P(X) = SUM ( I = 1 TO NNODE ) KARRAY(I) * (X)(I) ! ! Here (X)(I) is meant to represent X*(X-1)*(X-2)...*(X-I+1). ! ! Workspace, integer STACK(2,MAXSTACK). ! ! Input, integer MAXSTACK, dimension of working storage. An upper ! estimate for the amount of storage required is ! NNODE * ( IE - 0.5*(NNODE-1)). ! implicit none ! integer nedge integer nnode integer maxstack ! integer i integer iarray(nnode) integer nedge1 integer ien(2) integer iendpt(2,nedge) integer is integer iu integer iv integer j integer jarray(nnode) integer jhi integer k integer karray(nnode) integer l integer nnode1 integer stack(2,maxstack) ! is = 0 jarray(1:nnode) = 0 nedge1 = nedge nnode1 = nnode 10 continue if ( nnode1 > 0 .and. nedge1 > 0 ) then call span_forest ( nnode1, nedge1, iendpt, k, karray ) else k = 0 end if if ( k /= 1 ) then go to 50 end if if ( nedge1 < nnode1 ) then go to 40 end if if ( nedge1 == nnode1 ) then jarray(nnode1) = jarray(nnode1) + 1 else do i = 1, nedge1 is = is + 1 stack(1,is) = iendpt(1,i) stack(2,is) = iendpt(2,i) end do stack(1,is) = nnode1 stack(2,is) = nedge1 - 1 end if 20 continue iarray(1:nnode) = 0 iu = min ( iendpt(1,nedge1), iendpt(2,nedge1) ) iv = iendpt(1,nedge1) + iendpt(2,nedge1) - iu jhi = nedge1 - 1 nedge1 = 0 do j = 1, jhi do l = 1, 2 ien(l) = iendpt(l,j) if ( ien(l) == iv ) then ien(l) = iu end if if ( ien(l) == nnode1 ) then ien(l) = iv end if end do do l = 1, 2 if ( ien(l) == iu ) then if ( iarray(ien(3-l)) /= 0 ) then go to 30 end if iarray(ien(3-l)) = 1 end if end do nedge1 = nedge1 + 1 iendpt(1,nedge1) = ien(1) iendpt(2,nedge1) = ien(2) 30 continue end do nnode1 = nnode1 - 1 go to 10 40 continue jarray(nnode1) = jarray(nnode1) + 1 if ( is /= 0 ) then nnode1 = stack(1,is) nedge1 = stack(2,is) is = is - nedge1 - 1 do i = 1, nedge1 iendpt(1,i) = stack(1,is+i) iendpt(2,i) = stack(2,is+i) end do if ( nedge1 == nnode1 ) then jarray(nnode1) = jarray(nnode1) + 1 else is = is + nedge1 stack(1,is) = nnode1 stack(2,is) = nedge1 - 1 end if go to 20 end if 50 continue do i = 1, nnode iarray(i) = jarray(i) karray(i) = ( 1 - 2 * mod ( nnode-i, 2 ) ) * jarray(i) end do call poly ( nnode, iarray, 1, nnode, iv ) call poly ( nnode, karray, 0, -2, iv ) return end subroutine graph_dist_all ( dist, dinfin, lda, nnode, path_dist ) ! !******************************************************************************* ! !! GRAPH_DIST_ALL finds the distance from every node to every other node. ! ! ! Reference: ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985, ! ISBN 0-521-28881-9. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real DIST(LDA,NNODE). ! ! On input, DIST(I,J) is the length of the edge FROM node I TO node J. ! DIST(I,J) = DINFIN if there is no direct edge from I to J. ! ! On output, DIST has been overwritten by other information. ! ! Input, real DINFIN, is a "large" number, larger than any entry in ! DIST, which is taken to be "infinity". DIST(I,J) = DINFIN means there ! is no direct edge from node I to node J. On output, ! DIST(I,J) = DINFIN means there is no path from node I to node J. ! ! Input, integer LDA, the leading dimension of DIST and PATH_DIST, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, real PATH_DIST(LDA,NNODE). This array contains the ! lengths of the shortest paths from each node to another node. ! PATH_DIST(I,J) is the length of the shortest path from node I ! to node J. If PATH_DIST(I,J) = DINFIN, there is no path from node ! I to node J. ! implicit none ! integer lda integer nnode ! real dist(lda,nnode) real dinfin real path_dist(lda,nnode) integer i integer j integer k ! do k = 1, nnode do i = 1, nnode do j = 1, nnode path_dist(i,j) = dist(i,j) if ( dist(i,k) /= dinfin .and. dist(k,j) /= dinfin ) then path_dist(i,j) = min ( path_dist(i,j), dist(i,k) + dist(k,j) ) end if end do end do dist(1:nnode,1:nnode) = path_dist(1:nnode,1:nnode) end do return end subroutine graph_dist_check ( dist, lda, nnode, ierror ) ! !******************************************************************************* ! !! GRAPH_DIST_CHECK checks a distance matrix for consistency. ! ! ! Discussion: ! ! The checks made are: ! ! 1): DIST(I,I) = 0 ! 2): DIST(I,J) > 0 for I different from J ! 3): DIST(I,J) = DIST(J,I) for I different from J. ! 4): DIST(I,J) + DIST(J,K) >= DIST(I,K). ! ! Modified: ! ! 10 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real DIST(LDA,NNODE), the distance matrix. ! DIST(I,J) is the distance FROM node I TO node J. ! ! Input, integer LDA, the leading dimension of DIST, which must be at ! least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer IERROR, error flag. ! 0, no errors. ! 1, DIST(I,I) is nonzero for some I; ! 2, DIST(I,J) <= 0 for some distinct I, J ! 3, DIST(I,J) not equal to DIST(J,I) for some distinct I, J. ! 4, DIST(I,J) + DIST(J,K) < DIST(I,K) for some I, J, K. ! implicit none ! integer lda integer nnode ! real dist(lda,nnode) integer i integer ierror integer j integer k ! ierror = 1 do i = 1, nnode if ( dist(i,i) /= 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_DIST_CHECK - Failed test #1:' write ( *, '(a,i6)' ) ' DIST(I,I) nonzero for I = ', i return end if end do ierror = 2 do i = 1, nnode do j = 1, nnode if ( i /= j ) then if ( dist(i,j) <= 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_DIST_CHECK - Failed test #2:' write ( *, '(a,2i6)' ) ' DIST(I,J) <= 0 for I, J = ', i, j return end if end if end do end do ierror = 3 do i = 1, nnode do j = 1, i - 1 if ( dist(i,j) /= dist(j,i) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_DIST_CHECK - Failed test #3:' write ( *, '(a)' ) ' DIST(I,J) is not equal to DIST(J,I)' write ( *, '(a,2i6)' ) ' for I, J = ', i, j return end if end do end do ierror = 4 do i = 1, nnode do j = 1, nnode do k = 1, i - 1 if ( dist(i,j) + dist(j,k) < dist(i,k) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRAPH_DIST_CHECK - Failed test #4:' write ( *, '(a)' ) ' DIST(I,J) + DIST(J,K) < DIST(I,K)' write ( *, '(a,3i6)' ) ' I, J, K = ', i, j, k write ( *, '(a,g14.6)' ) ' DIST(I,J) = ', dist(i,j) write ( *, '(a,g14.6)' ) ' DIST(J,K) = ', dist(j,k) write ( *, '(a,g14.6)' ) ' DIST(I,K) = ', dist(i,k) return end if end do end do end do ierror = 0 return end subroutine graph_dist_min_span_tree ( lda, nnode, dist, itree, jtree ) ! !******************************************************************************* ! !! GRAPH_DIST_MIN_SPAN_TREE computes a spanning tree of minimal length. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 21 July 2000 ! ! Parameters: ! ! Input, integer LDA, first dimension of DIST in calling program. ! LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real DIST(LDA,NNODE). DIST(I,J) = distance from node I ! to node J. ! ! Output, integer ITREE(NNODE-1), JTREE(NNODE-1), the pairs of nodes ! that form the edges of the tree. ! implicit none ! integer lda integer nnode ! real d real dist(lda,nnode) real dmin integer i integer imin integer it integer itree(nnode-1) integer j integer jtree(nnode-1) ! call ivec_identity ( nnode-1, itree ) jtree(1:nnode-1) = -nnode do j = 1, nnode-1 ! ! Choose the node IMIN whose tree edge ( ITREE(IMIN)=IMIN, JTREE(IMIN) ) ! will be set. ! dmin = huge ( dmin ) do i = 1, nnode-1 it = jtree(i) if ( it < 0 ) then d = dist(-it,i) if ( d < dmin ) then dmin = d imin = i end if end if end do jtree(imin) = - jtree(imin) do i = 1, nnode-1 it = jtree(i) if ( it < 0 ) then if ( dist(i,imin) < dist(i,-it) ) then jtree(i) = - imin end if end if end do end do return end subroutine graph_dist_min_span_tree2 ( lda, nnode, dist, class, itree, jtree ) ! !******************************************************************************* ! !! GRAPH_DIST_MIN_SPAN_TREE2 computes a spanning tree of minimal length. ! ! ! Modified: ! ! 03 September 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, first dimension of DIST in calling program. ! LDA must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real DIST(LDA,NNODE). DIST(I,J) = distance from node I ! to node J. ! ! Output, integer CLASS(NNODE), lists the nodes in the order in ! which they joined the tree. ! ! Output, integer ITREE(NNODE-1), JTREE(NNODE-1), the pairs of nodes ! that form the edges of the tree. ! implicit none ! integer lda integer nnode ! integer class(nnode) real dist(lda,nnode) real dmin integer i integer ii integer imin integer itree(nnode-1) integer j integer jj integer jjmin integer jmin integer jtree(nnode-1) integer k integer npos logical smaller logical unset ! if ( nnode <= 1 ) then return end if ! ! All the nodes start out in the negative class. ! npos = 0 call ivec_identity ( nnode, class ) ! ! Find the shortest edge (I,J). ! unset = .true. dmin = 0.0E+00 do i = 1, nnode do j = i+1, nnode if ( unset ) then smaller = .true. else if ( dist(i,j) < dmin ) then smaller = .true. else smaller = .false. end if if ( smaller ) then imin = i jmin = j dmin = dist(i,j) unset = .false. end if end do end do ! ! Carry nodes IMIN and JMIN into the positive class. ! npos = npos + 1 call i_swap ( class(npos), class(imin) ) npos = npos + 1 call i_swap ( class(npos), class(jmin) ) itree(1) = imin jtree(1) = jmin ! ! Now, repeatedly, find the shortest edge connecting a negative ! and positive node. Move the negative node to the positive class and ! repeat. ! do k = 2, nnode-1 unset = .true. dmin = 0.0E+00 imin = - 99 jmin = - 99 do ii = 1, npos i = class(ii) do jj = npos + 1, nnode j = class(jj) if ( unset ) then smaller = .true. else if ( dist(i,j) < dmin ) then smaller = .true. else smaller = .false. end if if ( smaller ) then imin = i jmin = j jjmin = jj dmin = dist(i,j) unset = .false. end if end do end do npos = npos + 1 call i_swap ( class(npos), class(jjmin) ) itree(k) = imin jtree(k) = jmin end do return end subroutine graph_dist_min_span_tree3 ( lda, nnode, dist, inode, jnode ) ! !******************************************************************************* ! !! GRAPH_DIST_MIN_SPAN_TREE3 finds a minimum spanning tree. ! ! ! Discussion: ! ! The input graph is represented by a distance matrix. ! ! Reference: ! ! H T Lau, ! Combinatorial Heuristic Algorithms in FORTRAN, ! Springer Verlag, 1986. ! ! Modified: ! ! 21 July 2000 ! ! Parameters: ! ! Input, integer LDA, the leading dimension of DIST, which should be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real DIST(LDA,NNODE), an NNODE by NNODE distance matrix. ! DIST(I,J) is the distance from node I to node J. The matrix ! should be symmetric. If there is no arc from node I to node J, ! set DIST(I,J) = HUGE(1.0). ! ! Output, integer INODE(NNODE), JNODE(NNODE); entries 1 through NNODE-1 ! describe the edges of the spanning tree as pairs of nodes. ! implicit none ! integer lda integer nnode ! real d real dist(lda,nnode) integer i integer ient integer ij integer inode(nnode) integer itr integer iwork1(nnode) integer iwork2(nnode) integer j integer jj integer jnode(nnode) integer k integer kj integer kk4 real tree_length real work(nnode) ! work(1:nnode) = huge ( work(1) ) iwork1(1:nnode) = 0 iwork2(1:nnode) = 0 ! ! Find the first non-zero arc. ! do ij = 1, nnode do kj = 1, nnode if ( dist(ij,kj) < huge ( dist(1,1) ) ) then i = ij go to 10 end if end do end do 10 continue work(i) = 0 iwork1(i) = 1 tree_length = 0.0E+00 kk4 = nnode - 1 do jj = 1, kk4 work(1:nnode) = huge ( work(1) ) do i = 1, nnode ! ! For each forward arc originating at node I calculate ! the length of the path to node I ! if ( iwork1(i) == 1 ) then do j = 1, nnode if ( dist(i,j) < huge ( dist(1,1) ) .and. iwork1(j) == 0 ) then d = tree_length + dist(i,j) if ( d < work(j) ) then work(j) = d iwork2(j) = i end if end if end do end if end do ! ! Find the minimum potential. ! d = huge ( d ) ient = 0 do i = 1, nnode if ( iwork1(i) == 0 .and. work(i) < d ) then d = work(i) ient = i itr = iwork2(i) end if end do ! ! Include the node in the current path. ! if ( d < huge ( d ) ) then iwork1(ient) = 1 tree_length = tree_length + dist(itr,ient) inode(jj) = itr jnode(jj) = ient end if end do return end subroutine graph_dist_one ( dist, dinfin, path_dist, dad, inode, path, & lda, nnode ) ! !******************************************************************************* ! !! GRAPH_DIST_ONE computes the distance from one node to all others in a graph. ! ! ! Discussion: ! ! This routine can handle both ordinary graphs and directed graphs. ! ! In an ordinary graph, a connection between two nodes is always guaranteed ! to be "symmetric". That is, if node I is connected to node J by ! an edge of length D, then node J is connected to node I, and the ! distance is again D. ! ! In a directed graph, if node I is connect to node J by an edge of ! length D, then nothing is known about a possible connection from ! node J back to node I. In particular, it is possible that: ! ! * there is no direct edge from node J to node I; ! * the edge from node J to node I exists, but is a different "length" ! than the edge from node I to node J. ! ! The program computes: ! ! * PATH_DIST, an array of distances from node INODE to all other nodes; ! ! * DAD, an array which can be used to determine the path from ! node INODE to any particular node. ! ! Reference: ! ! Alan Gibbons, ! Algorithmic Graph Theory, ! Cambridge University Press, 1985, ! ISBN 0-521-28881-9. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, real DIST(LDA,NNODE). DIST contains the weighted adjacency ! information defining the graph, or directed graph. ! ! The diagonal entries of DIST, that is, DIST(I,I), should be set to 0. ! ! The value of the typical off diagonal element DIST(I,J) should ! represent the length, or weight, of the edge from node I to ! node J. If the graph is undirected, then DIST(I,J) should always ! equal DIST(J,I). For a directed graph, these quantities may differ. ! ! If there is no edge from node I to node J, then it would be natural ! to set DIST(I,J) to "infinity". Since this is not computationally ! possible, the user must specify a special value, called DINFIN, ! that will be used to mark such entries. The most natural thing ! to do would simply be to pick DINFIN to be "very large", such ! as DINFIN = 10,000. ! ! All the entries in DIST should be non-negative. The algorithm will ! NOT work correctly if negative edge lengths are input. ! ! Off-diagonal elements DIST(I,J) may be set to zero. This simply ! means that two nodes are "very close", like St Paul and Minneapolis. ! ! Input, real DINFIN, is a "large" number, which should be larger than ! the length of any edge in the graph, and in fact larger than the ! length of any reasonable path along the edges of the graph. ! ! The user should have set the DIST matrix so that DIST(I,J) = DINFIN whenever ! there is no edge from node I to node J. The program has to know the ! value of DINFIN so it can understand this information stored in DIST. ! ! Output, real PATH_DIST(NNODE). On output, for every value of I from 1 ! to NNODE, PATH_DIST(I) contains the distance from node INODE to node I ! in the graph. Of course, PATH_DIST(INODE) is zero. Moreover, if ! PATH_DIST(I) = DINFIN, then this is the program's way of reporting that ! there is NO path from node INODE to node I. ! ! Output, integer DAD(NNODE), information defining the shortest ! path from node INODE to any node I, which presumably will be of ! total distance PATH_DIST(I). ! ! The path from node I to node INODE, is recorded "in reverse" ! in DAD. The last node is INODE, of course. The previous node ! is DAD(INODE). The next node is DAD(DAD(INODE)) and ! so on, until INODE itself is reached. ! ! If the distance from node I to node INODE is "infinity", then ! DAD will still record a path; it's just probably of no interest. ! ! Input, integer INODE, the base node, from which distances to the ! other nodes are to be calculated. ! ! Output, integer PATH(NNODE). The value of PATH(I) records ! the step on which the distance from INODE to node I was ! determined. There will be NNODE steps, and on each step ! just one such distance is computed. ! ! Input, integer LDA, the leading dimension of DIST, which must be ! at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! implicit none ! integer lda integer nnode ! integer dad(nnode) real dist(lda,nnode) real dinfin real dmin real dtemp integer i integer imin integer inode integer istep integer j integer path(nnode) real path_dist(nnode) ! ! Initialize the data. ! dad(1:nnode) = inode path(1:nnode) = 0 path_dist(1:nnode) = dist(inode,1:nnode) ! ! On step 1, we connect node INODE itself. ! dad(inode) = inode path(inode) = 1 ! ! On steps ISTEP = 2 through NNODE, we try to add just one more node. ! ! Of all the nodes which are not yet connected to INODE (because PATH ! is 0 for this node), choose the one whose distance is least. ! do istep = 2, nnode dmin = dinfin imin = 0 do j = 1, nnode if ( path(j) == 0 ) then if ( path_dist(j) <= dmin ) then dmin = path_dist(j) imin = j end if end if end do ! ! If we found no new node to add, then any remaining nodes cannot ! be connected. ! if ( dmin == dinfin ) then return end if ! ! Now add the closest node, labeled IMIN, to the list. ! path(imin) = istep ! ! Update the distances of the remaining unconnected nodes. ! do j = 1, nnode if ( path(j) == 0 ) then dtemp = path_dist(imin) + dist(imin,j) if ( dtemp < path_dist(j) ) then path_dist(j) = dtemp dad(j) = imin end if end if end do end do return end subroutine graph_dist_print ( dist, lda, nnode, title ) ! !******************************************************************************* ! !! GRAPH_DIST_PRINT prints a distance matrix. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real DIST(LDA,NNODE), the distance matrix. ! DIST(I,J) is the distance from node I to node J. ! ! Input, integer LDA, the leading dimension of DIST, which must be at ! least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer lda integer nnode ! real dist(lda,nnode) integer ihi integer ilo integer jhi integer jlo integer ncol integer nrow character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' ilo = 1 ihi = nnode jlo = 1 jhi = nnode ncol = nnode nrow = nnode call rmat_print ( dist, ihi, ilo, jhi, jlo, lda, ncol, nrow ) return end subroutine greedy ( maxit, nodeb, noder, nnode, tol, xb, xr, yb, yr ) ! !******************************************************************************* ! !! GREEDY pairs two sets of nodes using the least total distance. ! ! ! Discussion: ! ! The method is iterative, and is not guaranteed to find the best ! possible arrangement. This is particulary true because it is a ! "local" method, which only considers pairwise switches of the ! red nodes that reduce the total distance. This means that a ! "locally minimizing" pairing might be found which is not the ! global minimizer. ! ! On the other hand, in the absence of a theoretical plan for how ! to reach the global minimizer, the brute force search would ! require that EVERY possible pairing be considered, and its total ! distance computed. This means that a total of NNODE! ! graphs would have to be generated. ! ! The approach used here, on each iterative step, looks at a ! maximum of NNODE * (NNODE-1) graphs, which represents a ! significantly more efficient method. ! ! ! It would not be hard to extend this approach to a method which ! considers switches of THREE red nodes at a time, though the ! work there involve looking at NNODE * (NNODE-1) * (NNODE-2) ! graphs, and as we increase the number of graphs we examine, ! we begin to approach the NNODE! rate for the brute force ! algorithm. ! ! It also would not be hard to extend this method to a case where ! there are three sets of nodes, arranged in triples, and again ! the total distance is to be minimized. ! ! ! If it is suspected that the pairing returned by GREEDY is only ! a local minimizer, then the user is advised to restart the ! calculation after randomly permuting the entries of NODER, so that ! the routine starts from a different point in the space of graphs. ! ! The routine is given: ! ! an initial ordering of the black and red nodes, so that ! ( NODEB(I), NODER(I) ) represents the I-th pair, ! ! the X and Y coordinates of the black and red nodes, ! ! a maximum number of iterations, and a relative distance ! decrease requirement, ! ! and computes: ! ! a new ordering of the red nodes, contained in NODER, which should ! reduce the total distance between corresponding red and black ! nodes. ! ! ! GREEDY can be applied to a variety of problems including: ! ! 1) We are given two sets of NNODE points, which we will call the ! "red" and "black " groups, and the (X,Y) coordinates of each ! point. We may imagine these points as forming the two sets of ! nodes of a bipartite graph lying in the (X,Y) plane. We wish ! to choose a pairing of red and black nodes which results in ! the shortest total arc length. ! ! 2) We are given two sets of NNODE complex quantities, which we ! believe are approximations to the same (unknown) set of ! quantities. We wish to arrange this data into NNODE pairs, ! each containing a unique element from each set of data, which ! minimizes the sum of squares of the discrepancies between the ! pairs. In particular, the two sets of data might be two ! separate estimates of the complex eigenvalues of a matrix. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXIT, the maximum number of iterations allowed. ! Each iteration considers, one at a time, each black node, and ! seeks to switch its red neighbor for another red neighbor that ! reduces the total distance. ! ! Input, integer NODEB(NNODE), the "labels" of the black nodes. ! You probably want to just set NODEB(I) = I, for i = 1 to NNODE. ! The entries in NODEB will not be changed. ! ! Input/output, integer NODER(NNODE), the "labels" of the red nodes. ! You probably want to just set the input value of NODER(I) = I, ! for i = 1 to NNODE. The entries in NODER WILL be changed. ! ! At all times, the values of ( NODEB(I), NODER(I) ) contain the ! labels of the I-th pair of black and red nodes. ! ! On output, if GREEDY has found a better pairing of the nodes, ! this will be reflected in the newly permuted values of NODER. ! ! Input, integer NNODE, the number of nodes in the black, and in the ! red sets. ! ! Input, real TOL. ! TOL is the relative decrease that the user demands in the ! total distance, after each iterative step. If we denote ! the distance before the iterative step as OLDTOT, and the ! distance after the iterative step as TOTAL, then the ! routine will try another iterative step as long as "enough" ! progress was made on this step. Enough progress was made ! whenever: ! ! OLDTOT - TOTAL < TOL * TOTAL ! ! Input, real XB(NNODE), the X coordinates of the black nodes. ! ! Input, real XR(NNODE), the X coordinates of the red nodes. ! ! Input, real YB(NNODE), the Y coordinates of the black nodes. ! ! Input, real YR(NNODE), the Y coordinates of the red nodes. ! implicit none ! integer nnode ! real dist1 real dist2 integer indx integer indx1 integer indx2 integer it integer maxit integer nodeb(nnode) integer nodeb1 integer nodeb2 integer noder(nnode) integer noder1 integer noder2 integer nswap real oldtot real temp real tol real total real xb(nnode) real xr(nnode) real yb(nnode) real yr(nnode) ! ! Compute the total distance of the starting pairing. ! total = 0.0E+00 do indx = 1, nnode nodeb1 = nodeb(indx) noder1 = noder(indx) total = total + sqrt ( & ( xb(nodeb1) - xr(noder1) )**2 + ( yb(nodeb1) - yr(noder1) )**2 ) end do write ( *, '(a)' ) ' ' ! ! Begin the iterations. ! do it = 1, maxit if ( total == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GREEDY - Early termination.' write ( *, '(a)' ) ' Total discrepancy is low enough.' return end if ! ! Save the current total distance for comparison at the end of the ! iteration. ! oldtot = total nswap = 0 ! ! Consider each black node, by running through indices INDX1 = 1 ! through NNODE of the NODEB array. ! do indx1 = 1, nnode ! ! Get the actual labels of the current INDX1-th pair of black and ! red nodes. ! nodeb1 = nodeb(indx1) noder1 = noder(indx1) ! ! Now look at the black node with INDX2 = 1 through NNODE, but ignore ! the case where INDX1 = INDX2. ! do indx2 = 1, nnode ! ! Get the labels of the current INDX2-th pair of black and red nodes. ! nodeb2 = nodeb(indx2) noder2 = noder(indx2) if ( indx2 /= indx1 ) then ! ! Compute the total distance between (NODEB1,NODER1) and ! (NODEB2,NODER2), and compare it to the total where we switch the ! red nodes. ! dist1 = sqrt ( ( xb(nodeb1) - xr(noder1) )**2 & + ( yb(nodeb1) - yr(noder1) )**2 ) & + sqrt ( ( xb(nodeb2) - xr(noder2) )**2 & + ( yb(nodeb2) - yr(noder2) )**2 ) dist2 = sqrt ( ( xb(nodeb1) - xr(noder2) )**2 & + ( yb(nodeb1) - yr(noder2) )**2 ) & + sqrt ( ( xb(nodeb2) - xr(noder1) )**2 & + ( yb(nodeb2) - yr(noder1) )**2 ) ! ! If the new arrangement is any shorter, take it, by shuffling the ! red nodes only, and update the total distance. ! if ( dist2 < dist1 ) then call i_swap ( noder(indx1), noder(indx2) ) nswap = nswap + 1 end if end if end do end do ! ! Now that we've checked all pairs of nodes, ! print the new total distance, and see if we may ! continue, or should give up. ! total = 0.0E+00 do indx1 = 1, nnode nodeb1 = nodeb(indx1) noder1 = noder(indx1) total = total + sqrt ( ( xb(nodeb1) - xr(noder1) )**2 & + ( yb(nodeb1) - yr(noder1) )**2 ) end do write ( *, '(a,i6)' ) ' On step ', it write ( *, '(a,g14.6)' ) ' discrepancy =', total write ( *, '(a,i6)' ) ' Swaps made was ', nswap if ( oldtot - total <= tol * oldtot ) then temp = ( oldtot - total ) / oldtot write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GREEDY - Warning:' write ( *, '(a)' ) ' The relative change in the discrepancy ' write ( *, '(a,g14.6)' ) ' was only ', temp write ( *, '(a,g14.6)' ) ' which is less than the tolerance TOL =',tol write ( *, '(a)' ) ' Bailing out of the iteration.' write ( *, '(a)' ) ' ' return end if end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GREEDY - Note:' write ( *, '(a)' ) ' The discrepancy has decreased by at least the' write ( *, '(a)' ) ' tolerance on every step.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Increasing the number of iterations might ' write ( *, '(a)' ) ' provide further improvement at this rate.' return end subroutine grf_read ( file_name, inode, jnode, maxedge, maxnode, nedge, nnode, & x, y ) ! !******************************************************************************* ! !! GRF_READ reads a GRF file containing a 2D representation of a graph. ! ! ! Example: ! ! # A graph where every node has 3 neighbors. ! # ! 1 0.546 0.956 5 6 2 ! 2 0.144 0.650 7 3 1 ! 3 0.326 0.188 8 4 2 ! 4 0.796 0.188 9 5 3 ! 5 0.988 0.646 10 4 1 ! 6 0.552 0.814 11 12 1 ! 7 0.264 0.616 11 15 2 ! 8 0.404 0.296 15 14 3 ! 9 0.752 0.298 14 13 4 ! 10 0.846 0.624 13 12 5 ! 11 0.430 0.692 16 6 7 ! 12 0.682 0.692 17 10 6 ! 13 0.758 0.492 18 9 10 ! 14 0.566 0.358 19 8 9 ! 15 0.364 0.484 20 7 8 ! 16 0.504 0.602 11 20 17 ! 17 0.608 0.602 12 18 16 ! 18 0.634 0.510 13 19 17 ! 19 0.566 0.444 14 20 18 ! 20 0.480 0.510 15 16 19 ! ! Discussion: ! ! The original GRF format has been modified so that a line starting ! with a # is considered a comment line. ! ! Modified: ! ! 17 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the file name. ! ! Output, integer INODE(MAXEDGE), JNODE(MAXEDGE), the edges. ! The I-th edge joins nodes INODE(I) and JNODE(I). ! ! Input, integer IUNIT, the FORTRAN unit number associated with the ! graph file, which should already have been opened by the user. ! ! Input, integer MAXEDGE, the maximum number of edges. ! ! Input, integer MAXNODE, the maximum number of nodes. ! ! Output, integer NEDGE, the number of edges that were read. ! ! Output, integer NNODE, the number of nodes that were read. ! ! Output, real X(MAXNODE), Y(MAXNODE), the X and Y coordinates of the ! nodes. ! implicit none ! integer, parameter :: maxchr = 200 ! integer maxedge integer maxnode ! character ( len = * ) file_name integer ierror integer inode(maxedge) integer ios integer istring integer iunit integer jnode(maxedge) integer lchar integer nbad integer nedge integer nnode integer nodei integer nodej integer ntext character ( len = maxchr ) string real x(maxnode) real xval real y(maxnode) real yval ! nbad = 0 nedge = 0 nnode = 0 ntext = 0 call get_unit ( iunit ) open ( unit = iunit, file = file_name, status = 'old', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Fatal error!' write ( *, '(a)' ) ' Could not open the input file.' return end if ! ! Read information about each node. ! do read ( iunit, '(a)', iostat = ios ) string if ( ios /= 0 ) then exit end if ntext = ntext + 1 if ( len ( string ) <= 0 ) then cycle end if if ( string(1:1) == '#' ) then cycle end if istring = 1 ! ! Extract the node index, NODEI. ! call s_to_i ( string(istring:), nodei, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Fatal error!' write ( *, '(a)' ) ' Unreadable node index value.' nbad = nbad + 1 cycle end if istring = istring + lchar if ( nodei < 1 .or. maxnode < nodei ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Fatal error!' write ( *, '(a,i6)' ) ' Illegal node index value, NODEI = ', nodei cycle end if if ( nodei == nnode + 1 ) then nnode = nnode + 1 else if ( nodei > nnode ) then nnode = nodei end if ! ! Extract the X, Y coordinates of the node. ! call s_to_r ( string(istring:), xval, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Fatal error!' write ( *, '(a)' ) ' Unreadable X coordinate for node.' nbad = nbad + 1 cycle end if istring = istring + lchar call s_to_r ( string(istring:), yval, ierror, lchar ) if ( ierror /= 0 .or. lchar == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Fatal error!' write ( *, '(a)' ) ' Unreadable Y coordinate for node.' nbad = nbad + 1 cycle end if istring = istring + lchar x(nodei) = xval y(nodei) = yval ! ! Read the indices of the nodes to which NODEI is connected. ! do call s_to_i ( string(istring:), nodej, ierror, lchar ) if ( ierror /= 0 .and. ierror /= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Fatal error!' write ( *, '(a)' ) ' Unreadable node neighbor value.' nbad = nbad + 1 cycle end if istring = istring + lchar if ( lchar <= 0 ) then exit end if if ( 1 <= nodej .and. nodej <= maxnode ) then if ( nedge < maxedge ) then nedge = nedge + 1 inode(nedge) = nodei jnode(nedge) = nodej end if end if if ( istring > maxchr ) then exit end if end do end do close ( unit = iunit ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GRF_READ - Input file statistics:' write ( *, '(a,i6)' ) ' Text lines: ', ntext write ( *, '(a,i6)' ) ' Bad text lines: ', nbad write ( *, '(a,i6)' ) ' Nodes: ', nnode write ( *, '(a,i6)' ) ' Edges: ', nedge return end subroutine hqr ( nm, n, low, igh, h, wr, wi, ierr ) ! !******************************************************************************* ! !! HQR computes all eigenvalues of a real upper Hessenberg matrix. ! ! ! Discussion: ! ! This subroutine finds the eigenvalues of a real ! upper Hessenberg matrix by the QR method. ! ! Reference: ! ! Martin, Peters, and Wilkinson, ! HQR, ! Numerische Mathematik, ! Volume 14, pages 219-231, 1970. ! ! J H Wilkinson and C Reinsch, ! Handbook for Automatic Computation, ! Volume II, Linear Algebra, Part 2, ! Springer Verlag, 1971. ! ! B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler, ! Matrix Eigensystem Routines, EISPACK Guide, ! Lecture Notes in Computer Science, Volume 6, ! Springer Verlag, 1976. ! ! Parameters: ! ! Input, integer NM, the leading dimension of H, which must ! be at least N. ! ! Input, integer N, the order of the matrix. ! ! Input, integer LOW, IGH, two integers determined by the routine ! BALANC. If BALANC is not used, set LOW=1, IGH=N. ! ! Input/output, real H(NM,N), the N by N upper Hessenberg matrix. ! Information about the transformations used in the reduction to ! Hessenberg form by ELMHES or ORTHES, if performed, is stored ! in the remaining triangle under the Hessenberg matrix. ! On output, the information in H has been destroyed. ! ! Output, real WR(N), WI(N), the real and imaginary parts of the ! eigenvalues. The eigenvalues are unordered, except that complex ! conjugate pairs of values appear consecutively, with the eigenvalue ! having positive imaginary part listed first. If an error exit ! occurred, then the eigenvalues should be correct for indices ! IERR+1 through N. ! ! Output, integer IERR, error flag. ! 0, no error. ! J, the limit of 30*N iterations was reached while searching for ! the J-th eigenvalue. ! implicit none ! integer n integer nm ! integer en integer enm2 real h(nm,n) integer i integer ierr integer igh integer itn integer its integer j integer k integer l integer ll integer low integer m integer mm integer na real norm logical notlas real p real q real r real s real t real tst1 real tst2 real w real wi(n) real wr(n) real x real y real zz ! ierr = 0 norm = 0.0E+00 k = 1 ! ! Store roots isolated by BALANC and compute matrix norm. ! do i = 1, n do j = k, n norm = norm + abs ( h(i,j) ) end do k = i if (i < low .or. i > igh ) then wr(i) = h(i,i) wi(i) = 0.0E+00 end if end do en = igh t = 0.0E+00 itn = 30 * n ! ! Search for next eigenvalues. ! 60 continue if ( en < low ) then return end if its = 0 na = en - 1 enm2 = na - 1 ! ! Look for a single small sub-diagonal element. ! 70 continue do ll = low, en l = en + low - ll if ( l == low ) then exit end if s = abs ( h(l-1,l-1) ) + abs ( h(l,l) ) if ( s == 0.0E+00 ) then s = norm end if tst1 = s tst2 = tst1 + abs ( h(l,l-1)) if ( tst2 == tst1 ) then exit end if end do ! ! Form shift. ! x = h(en,en) if ( l == en ) go to 270 y = h(na,na) w = h(en,na) * h(na,en) if ( l == na ) go to 280 if ( itn == 0 ) then ierr = en return end if ! ! Form an exceptional shift. ! if ( its == 10 .or. its == 20 ) then t = t + x do i = low, en h(i,i) = h(i,i) - x end do s = abs ( h(en,na) ) + abs ( h(na,enm2) ) x = 0.75 * s y = x w = -0.4375 * s * s end if its = its + 1 itn = itn - 1 ! ! Look for two consecutive small sub-diagonal elements. ! do mm = l, enm2 m = enm2 + l - mm zz = h(m,m) r = x - zz s = y - zz p = ( r * s - w ) / h(m+1,m) + h(m,m+1) q = h(m+1,m+1) - zz - r - s r = h(m+2,m+1) s = abs ( p ) + abs ( q ) + abs ( r ) p = p / s q = q / s r = r / s if ( m == l ) then exit end if tst1 = abs ( p ) * ( abs ( h(m-1,m-1) ) + abs ( zz ) + abs ( h(m+1,m+1) ) ) tst2 = tst1 + abs ( h(m,m-1) ) * ( abs ( q ) + abs ( r ) ) if ( tst2 == tst1 ) then exit end if end do do i = m+2, en h(i,i-2) = 0.0E+00 if ( i /= m+2 ) then h(i,i-3) = 0.0E+00 end if end do ! ! Double QR step involving rows l to EN and columns M to EN. ! do k = m, na notlas = k /= na if ( k == m ) go to 170 p = h(k,k-1) q = h(k+1,k-1) if ( notlas ) then r = h(k+2,k-1) else r = 0.0E+00 end if x = abs ( p ) + abs ( q ) + abs ( r ) if ( x == 0.0E+00 ) go to 260 p = p / x q = q / x r = r / x 170 continue s = sign ( sqrt ( p**2 + q**2 + r**2 ), p ) if ( k /= m ) then h(k,k-1) = - s * x else if ( l /= m ) then h(k,k-1) = - h(k,k-1) end if p = p + s x = p / s y = q / s zz = r / s q = q / p r = r / p if ( notlas ) go to 225 ! ! Row modification. ! do j = k, n p = h(k,j) + q * h(k+1,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y end do j = min ( en, k+3 ) ! ! Column modification. ! do i = 1, j p = x * h(i,k) + y * h(i,k+1) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q end do go to 255 225 continue ! ! Row modification. ! do j = k, n p = h(k,j) + q * h(k+1,j) + r * h(k+2,j) h(k,j) = h(k,j) - p * x h(k+1,j) = h(k+1,j) - p * y h(k+2,j) = h(k+2,j) - p * zz end do j = min ( en, k+3 ) ! ! Column modification. ! do i = 1, j p = x * h(i,k) + y * h(i,k+1) + zz * h(i,k+2) h(i,k) = h(i,k) - p h(i,k+1) = h(i,k+1) - p * q h(i,k+2) = h(i,k+2) - p * r end do 255 continue 260 continue end do go to 70 ! ! One root found. ! 270 continue wr(en) = x + t wi(en) = 0.0E+00 en = na go to 60 ! ! Two roots found. ! 280 continue p = ( y - x ) / 2.0E+00 q = p * p + w zz = sqrt ( abs ( q ) ) x = x + t ! ! Real root, or complex pair. ! if ( q >= 0.0E+00 ) then zz = p + sign ( zz, p ) wr(na) = x + zz if ( zz == 0.0E+00 ) then wr(en) = wr(na) else wr(en) = x - w / zz end if wi(na) = 0.0E+00 wi(en) = 0.0E+00 else wr(na) = x + p wr(en) = x + p wi(na) = zz wi(en) = -zz end if en = enm2 go to 60 end function i_modp ( i, j ) ! !******************************************************************************* ! !! I_MODP returns the nonnegative remainder of integer division. ! ! ! Formula: ! ! If ! NREM = I_MODP ( I, J ) ! NMULT = ( I - NREM ) / J ! then ! I = J * NMULT + NREM ! where NREM is always nonnegative. ! ! Comments: ! ! The MOD function computes a result with the same sign as the ! quantity being divided. Thus, suppose you had an angle A, ! and you wanted to ensure that it was between 0 and 360. ! Then mod(A,360.0) would do, if A was positive, but if A ! was negative, your result would be between -360 and 0. ! ! On the other hand, IMODP(A,360.0) is between 0 and 360, always. ! ! Examples: ! ! I J MOD IMODP IMODP Factorization ! ! 107 50 7 7 107 = 2 * 50 + 7 ! 107 -50 7 7 107 = -2 * -50 + 7 ! -107 50 -7 43 -107 = -3 * 50 + 43 ! -107 -50 -7 43 -107 = 3 * -50 + 43 ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the number to be divided. ! ! Input, integer J, the number that divides I. ! ! Output, integer I_MODP, the nonnegative remainder when I is divided by J. ! implicit none ! integer i integer j integer i_modp ! if ( j == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_MODP - Fatal error!' write ( *, '(a,i6)' ) ' I_MODP ( I, J ) called with J = ', j stop end if i_modp = mod ( i, j ) if ( i_modp < 0 ) then i_modp = i_modp + abs ( j ) end if return end subroutine i_random ( ilo, ihi, i ) ! !******************************************************************************* ! !! I_RANDOM returns a random integer in a given range. ! ! ! Modified: ! ! 23 September 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ILO, IHI, the minimum and maximum acceptable values. ! ! Output, integer I, the randomly chosen integer. ! implicit none ! logical, save :: seed = .false. integer i integer ihi integer ilo real r real rhi real rlo ! if ( .not. seed ) then call random_seed seed = .true. end if ! ! Pick a random number in (0,1). ! call random_number ( harvest = r ) ! ! Set a real interval [RLO,RHI] which contains the integers [ILO,IHI], ! each with a "neighborhood" of width 1. ! rlo = real ( ilo ) - 0.5E+00 rhi = real ( ihi ) + 0.5E+00 ! ! Set I to the integer that is nearest the scaled value of R. ! i = nint ( ( 1.0E+00 - r ) * rlo + r * rhi ) ! ! In case of oddball events at the boundary, enforce the limits. ! i = max ( i, ilo ) i = min ( i, ihi ) return end subroutine i_swap ( i, j ) ! !******************************************************************************* ! !! I_SWAP switches two integer values. ! ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J. On output, the values of I and ! J have been interchanged. ! implicit none ! integer i integer j integer k ! k = i i = j j = k return end subroutine icol_compare ( lda, m, n, a, i, j, isgn ) ! !******************************************************************************* ! !! ICOL_COMPARE compares columns I and J of a integer array. ! ! ! Example: ! ! Input: ! ! M = 3, N = 4, I = 2, J = 4 ! ! A = ( ! 1 2 3 4 ! 5 6 7 8 ! 9 10 11 12 ) ! ! Output: ! ! ISGN = -1 ! ! Modified: ! ! 30 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, which must ! be at least M. ! ! Input, integer M, N, the number of rows and columns. ! ! Input, integer A(LDA,N), an array of N columns of vectors of length M. ! ! Input, integer I, J, the columns to be compared. ! I and J must be between 1 and N. ! ! Output, integer ISGN, the results of the comparison: ! -1, column I < column J, ! 0, column I = column J, ! +1, column I > column J. ! implicit none ! integer lda integer n ! integer a(lda,n) integer i integer isgn integer j integer k integer m ! ! Check. ! if ( i < 1 .or. i > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ICOL_COMPARE - Fatal error!' write ( *, '(a)' ) ' Column index I is out of bounds.' stop end if if ( j < 1 .or. j > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ICOL_COMPARE - Fatal error!' write ( *, '(a)' ) ' Column index J is out of bounds.' stop end if isgn = 0 if ( i == j ) then return end if k = 1 do while ( k <= m ) if ( a(k,i) < a(k,j) ) then isgn = - 1 return else if ( a(k,i) > a(k,j) ) then isgn = + 1 return end if k = k + 1 end do return end subroutine icol_sort_a ( nrow, ncol, ia ) ! !******************************************************************************* ! !! ICOL_SORT_A ascending sorts an integer array of columns. ! ! ! Definition: ! ! In lexicographic order, the statement "X < Y", applied to two real ! vectors X and Y of length NROW, means that there is some index I, with ! 1 <= I <= NROW, with the property that ! ! X(J) = Y(J) for J < I, and ! X(I) < Y(I). ! ! In other words, the first time they differ, X is smaller. ! ! Modified: ! ! 22 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NROW, the number of rows of A, and the length of ! a vector of data. ! ! Input, integer NCOL, the number of columns of A. ! ! Input/output, integer IA(NROW,NCOL). ! On input, the array of NCOL columns of NROW-vectors. ! On output, the columns of A have been sorted in lexicographic order. ! implicit none ! integer ncol integer nrow ! integer ia(nrow,ncol) integer i integer indx integer isgn integer j ! ! Initialize. ! i = 0 indx = 0 isgn = 0 j = 0 ! ! Call the external heap sorter. ! do call sort_heap_external ( ncol, indx, i, j, isgn ) ! ! Interchange the I and J objects. ! if ( indx > 0 ) then call icol_swap ( nrow, ncol, ia, i, j ) ! ! Compare the I and J objects. ! else if ( indx < 0 ) then call icol_compare ( nrow, nrow, ncol, ia, i, j, isgn ) else exit end if end do return end subroutine icol_swap ( nrow, ncol, ia, i, j ) ! !******************************************************************************* ! !! ICOL_SWAP swaps columns I and J of a integer array of column data. ! ! ! Example: ! ! Input: ! ! NROW = 3, NCOL = 4, I = 2, J = 4 ! ! IA = ( ! 1 2 3 4 ! 5 6 7 8 ! 9 10 11 12 ) ! ! Output: ! ! IA = ( ! 1 4 3 2 ! 5 8 7 6 ! 9 12 11 10 ) ! ! Modified: ! ! 22 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NROW, NCOL, the number of rows and columns in ! the table. ! ! Input, integer IA(NROW,NCOL), a table of numbers, regarded as ! NCOL columns of vectors of length NROW. ! ! Input, integer I, J, the columns to be swapped. ! implicit none ! integer ncol integer nrow ! integer i integer ia(nrow,ncol) integer itemp integer j integer k ! if ( 1 <= i .and. i <= ncol .and. 1 <= j .and. j <= ncol ) then do k = 1, nrow call i_swap ( ia(k,k), ia(k,j) ) end do else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ICOL_SWAP - Fatal error!' write ( *, '(a)' ) ' I or J is out of bounds.' write ( *, '(a,i6)' ) ' I = ', i write ( *, '(a,i6)' ) ' J = ', j write ( *, '(a,i6)' ) ' NCOL = ', ncol stop end if return end subroutine icol_uniq ( lda, m, n, a, nuniq ) ! !******************************************************************************* ! !! ICOL_UNIQ keeps the unique elements in a sorted integer array of columns. ! ! ! Discussion: ! ! The array can be sorted into ascending or descending order. ! The important point is that identical elements must be stored ! in adjacent positions. ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, which ! must be at least M. ! ! Input, integer M, the number of rows of A, and the length of ! a vector of data. ! ! Input, integer N, the number of columns of A. ! ! Input/output, real A(LDA,N). ! On input, the sorted array of N columns of M-vectors. ! On output, a sorted array of NUNIQ columns of M-vectors. ! ! Output, integer NUNIQ, the number of unique columns of A. ! implicit none ! integer lda integer n ! integer a(lda,n) integer i integer isgn integer itest integer m integer nuniq ! nuniq = 0 if ( n <= 0 ) then return end if nuniq = 1 do itest = 2, n call icol_compare ( lda, m, n, a, itest, nuniq, isgn ) if ( isgn /= 0 ) then nuniq = nuniq + 1 a(1:m,nuniq) = a(1:m,itest) end if end do return end subroutine imat_perm ( matrix, lda, n, p ) ! !******************************************************************************* ! !! IMAT_PERM permutes the rows and columns of a square integer matrix. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 27 July 2000 ! ! Parameters: ! ! Input/output, integer MATRIX(LDA,N). ! On input, the matrix to be permuted. ! On output, the permuted matrix. ! ! Input, integer LDA, the declared first dimension of MATRIX. ! LDA must be at least N. ! ! Input, integer N, the order of the matrix. ! ! Input, integer P(N), the permutation. P(I) is the new number of row ! and column I. ! implicit none ! integer lda integer n ! integer i integer i1 integer is integer it integer j integer j1 integer j2 integer k integer lc integer matrix(lda,n) integer nc integer p(n) ! call perm_cycle ( n, p, is, nc, 1 ) do i = 1, n i1 = - p(i) if ( i1 > 0 ) then lc = 0 do i1 = p(i1) lc = lc + 1 if ( i1 <= 0 ) then exit end if end do i1 = i do j = 1, n if ( p(j) <= 0 ) then j2 = j k = lc do j1 = j2 it = matrix(i1,j1) do i1 = abs ( p(i1) ) j1 = abs ( p(j1) ) call i_swap ( matrix(i1,j1), it ) if ( j1 /= j2 ) then cycle end if k = k - 1 if ( i1 == i ) then exit end if end do j2 = abs ( p(j2) ) if ( k == 0 ) then exit end if end do end if end do end if end do ! ! Restore the positive signs of the data. ! p(1:n) = abs ( p(1:n) ) return end subroutine imat_perm_random ( lda, n, a ) ! !******************************************************************************* ! !! IMAT_PERM_RANDOM selects a random permutation of an integer matrix. ! ! ! Discussion: ! ! The matrix is assumed to be square. A single permutation is ! applied to both rows and columns. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, ! which must be at least N. ! ! Input, integer N, the number of rows and columns in the array. ! ! Input/output, integer A(LDA,N), the N by N array to be permuted. ! implicit none ! integer lda integer n ! integer a(lda,n) integer i integer i2 integer j real r ! call random_seed ! ! Permute the rows and columns together. ! do i = 1, n call i_random ( i, n, i2 ) i2 = i + int ( r * ( n + 1 - i ) ) do j = 1, n call i_swap ( a(i2,j), a(i,j) ) end do do j = 1, n call i_swap ( a(j,i2), a(j,i) ) end do end do return end subroutine imat_print ( lda, m, n, a, title ) ! !******************************************************************************* ! !! IMAT_PRINT prints an integer matrix. ! ! ! Modified: ! ! 08 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of A. ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A. ! ! Input, integer A(LDA,N), the matrix to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer lda integer n ! integer a(lda,n) integer i integer j integer jhi integer jlo integer m character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) title end if do jlo = 1, n, 10 jhi = min ( jlo + 9, n ) write ( *, '(a)' ) ' ' write ( *, '(6x,10(i7))' ) ( j, j = jlo, jhi ) write ( *, '(a)' ) ' ' do i = 1, m write ( *, '(i6,10i7)' ) i, a(i,jlo:jhi) end do end do return end subroutine imat_row_compare ( lda, m, n, a, row1, row2, result ) ! !******************************************************************************* ! !! IMAT_ROW_COMPARE compares two rows of an integer matrix. ! ! ! Discussion: ! ! The rows are compared in the lexicographic sense. They are equal ! if every entry is equal. Otherwise, let I be the first index ! where they differ. Row 1 is less or greater than row 2 as ! the corresponding indexed values are less or greater. ! ! Modified: ! ! 12 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of A. ! LDA must be at least M. ! ! Input, integer M, number of rows in the matrix. ! ! Input, integer N, number of columns in the matrix. ! ! Input, integer A(LDA,N), the matrix. ! ! Input, integer ROW1, ROW2, the indices of the two rows to compare. ! ! Output, integer RESULT: ! -1, ROW1 < ROW2, ! 0, ROW1 = ROW2, ! +1, ROW1 > ROW2. ! implicit none ! integer lda integer n ! integer a(lda,n) integer j integer m integer result integer row1 integer row2 ! if ( row1 < 1 .or. row1 > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IMAT_ROW_COMPARE - Fatal error!' write ( *, '(a)' ) ' ROW1 index out of bounds.' stop end if if ( row2 < 1 .or. row2 > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IMAT_ROW_COMPARE - Fatal error!' write ( *, '(a)' ) ' ROW2 index out of bounds.' stop end if result = 0 do j = 1, n if ( a(row1,j) < a(row2,j) ) then result = -1 return else if ( a(row1,j) > a(row2,j) ) then result = + 1 return end if end do return end subroutine imat_row_sort_d ( lda, m, n, a ) ! !******************************************************************************* ! !! IMAT_ROW_SORT_D sorts the rows of an integer matrix into descending order. ! ! ! Discussion: ! ! Rows are compared lexicographically. ! ! Modified: ! ! 12 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of A, which must be ! at least M. ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A. ! ! Input/output, integer A(LDA,N). On input, the M by N matrix to ! be row sorted. On output, the row-sorted matrix. ! implicit none ! integer lda integer n ! integer a(lda,n) integer indx integer isgn integer m integer row1 integer row2 ! ! Initialize. ! indx = 0 isgn = 0 row1 = 0 row2 = 0 ! ! Call the external heap sorter. ! do call sort_heap_external ( m, indx, row1, row2, isgn ) ! ! Interchange the objects. ! if ( indx > 0 ) then call imat_row_swap ( lda, m, n, a, row1, row2 ) ! ! Compare the objects. ! else if ( indx < 0 ) then call imat_row_compare ( lda, m, n, a, row1, row2, isgn ) isgn = - isgn else exit end if end do return end subroutine imat_row_swap ( lda, m, n, a, row1, row2 ) ! !******************************************************************************* ! !! IMAT_ROW_SWAP swaps two rows of an integer matrix. ! ! ! Modified: ! ! 12 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of A. ! LDA must be at least M. ! ! Input, integer M, number of rows in the matrix. ! ! Input, integer N, number of columns in the matrix. ! ! Input/output, integer A(LDA,N), the matrix. ! ! Input, integer ROW1, ROW2, the indices of the two rows to swap. ! implicit none ! integer lda integer n ! integer a(lda,n) integer j integer m integer row1 integer row2 ! if ( row1 < 1 .or. row1 > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IMAT_ROW_SWAP - Fatal error!' write ( *, '(a)' ) ' ROW1 index out of bounds.' stop end if if ( row2 < 1 .or. row2 > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IMAT_ROW_SWAP - Fatal error!' write ( *, '(a)' ) ' ROW2 index out of bounds.' stop end if do j = 1, n call i_swap ( a(row1,j), a(row2,j) ) end do return end subroutine irow_compare ( lda, m, n, a, i, j, isgn ) ! !******************************************************************************* ! !! IROW_COMPARE compares two rows of a integer array. ! ! ! Example: ! ! Input: ! ! M = 3, N = 4, I = 2, J = 3 ! ! A = ( ! 1 2 3 4 ! 5 6 7 8 ! 9 10 11 12 ) ! ! Output: ! ! ISGN = -1 ! ! Modified: ! ! 14 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, which must ! be at least M. ! ! Input, integer M, N, the number of rows and columns. ! ! Input, integer A(LDA,N), an array of M rows of vectors of length N. ! ! Input, integer I, J, the rows to be compared. ! I and J must be between 1 and M. ! ! Output, integer ISGN, the results of the comparison: ! -1, row I < row J, ! 0, row I = row J, ! +1, row I > row J. ! implicit none ! integer lda integer n ! integer a(lda,n) integer i integer isgn integer j integer k integer m ! ! Check that I and J are legal. ! if ( i < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IROW_COMPARE - Fatal error!' write ( *, '(a)' ) ' Row index I is less than 1.' write ( *, '(a,i6)' ) ' I = ', i stop else if ( i > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IROW_COMPARE - Fatal error!' write ( *, '(a)' ) ' Row index I is out of bounds.' write ( *, '(a,i6)' ) ' I = ', i write ( *, '(a,i6)' ) ' Maximum legal value is M = ', m stop end if if ( j < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IROW_COMPARE - Fatal error!' write ( *, '(a)' ) ' Row index J is less than 1.' write ( *, '(a,i6)' ) ' J = ', j stop else if ( j > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IROW_COMPARE - Fatal error!' write ( *, '(a)' ) ' Row index J is out of bounds.' write ( *, '(a,i6)' ) ' J = ', j write ( *, '(a,i6)' ) ' Maximum legal value is M = ', m stop end if isgn = 0 if ( i == j ) then return end if k = 1 do while ( k <= n ) if ( a(i,k) < a(j,k) ) then isgn = - 1 return else if ( a(i,k) > a(j,k) ) then isgn = + 1 return end if k = k + 1 end do return end subroutine irow_sort_d ( lda, m, n, a ) ! !******************************************************************************* ! !! IROW_SORT_D descending sorts the rows of an integer array. ! ! ! Definition: ! ! In lexicographic order, the statement "X < Y", applied to two real ! vectors X and Y of length M, means that there is some index I, with ! 1 <= I <= M, with the property that ! ! X(J) = Y(J) for J < I, ! and ! X(I) < Y(I). ! ! In other words, the first time they differ, X is smaller. ! ! Modified: ! ! 25 September 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, ! which must be at least M. ! ! Input, integer M, the number of rows and columns of A. ! ! Input/output, integer A(LDA,N). ! On input, the array of M rows of N-vectors. ! On output, the rows of A have been sorted in descending ! lexicographic order. ! implicit none ! integer lda integer n ! integer a(lda,n) integer i integer indx integer isgn integer j integer m ! if ( m <= 1 ) then return end if if ( n <= 0 ) then return end if ! ! Initialize. ! i = 0 indx = 0 isgn = 0 j = 0 ! ! Call the external heap sorter. ! do call sort_heap_external ( m, indx, i, j, isgn ) ! ! Interchange the I and J objects. ! if ( indx > 0 ) then call irow_swap ( lda, m, n, a, i, j ) ! ! Compare the I and J objects. ! else if ( indx < 0 ) then call irow_compare ( lda, m, n, a, i, j, isgn ) isgn = - isgn else if ( indx == 0 ) then exit end if end do return end subroutine irow_swap ( lda, m, n, a, irow1, irow2 ) ! !******************************************************************************* ! !! IROW_SWAP swaps two rows of an integer array. ! ! ! Modified: ! ! 04 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, ! which must be at least M. ! ! Input, integer M, N, the number of rows and columns. ! ! Input/output, integer A(LDA,N), an array of data. ! ! Input, integer IROW1, IROW2, the two rows to swap. ! implicit none ! integer lda integer n ! integer a(lda,n) integer m integer irow1 integer irow2 integer row(n) ! ! Check. ! if ( irow1 < 1 .or. irow1 > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IROW_SWAP - Fatal error!' write ( *, '(a)' ) ' IROW1 is out of range.' stop end if if ( irow2 < 1 .or. irow2 > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IROW_SWAP - Fatal error!' write ( *, '(a)' ) ' IROW2 is out of range.' stop end if if ( irow1 == irow2 ) then return end if row(1:n) = a(irow1,1:n) a(irow1,1:n) = a(irow2,1:n) a(irow2,1:n) = row(1:n) return end function iset2_compare ( x1, y1, x2, y2 ) ! !******************************************************************************* ! !! ISET2_COMPARE compares two I2 sets. ! ! ! Discussion: ! ! The I2 set (X1,Y1) < (X2,Y2) if ! ! min ( X1, Y1 ) < min ( X2, Y2 ) or ! min ( X1, Y1 ) = min ( X2, Y2 ) and max ( X1, Y1 ) < max ( X2, Y2 ) ! ! The I2 set (X1,Y1) = (X2,Y2) if ! ! min ( X1, Y1 ) = min ( X2, Y2 ) and max ( X1, Y1 ) = max ( X2, Y2 ) ! ! Modified: ! ! 11 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer X1, Y1, the first I2 set. ! ! Input, integer X2, Y2, the second I2 set. ! ! Output, character ISET2_COMPARE: '<', '>' or '=' if the first I2 set ! is less, greater or equal to the second. ! implicit none ! integer a1 integer a2 integer b1 integer b2 character c character iset2_compare integer x1 integer x2 integer y1 integer y2 ! a1 = min ( x1, y1 ) b1 = max ( x1, y1 ) a2 = min ( x2, y2 ) b2 = max ( x2, y2 ) if ( a1 < a2 ) then c = '<' else if ( a1 > a2 ) then c = '>' else if ( b1 < b2 ) then c = '<' else if ( b1 > b2 ) then c = '>' else c = '=' end if iset2_compare = c return end subroutine iset2_index_insert_unique ( maxn, n, x, y, indx, & xval, yval, ival, ierror ) ! !******************************************************************************* ! !! ISET2_INDEX_INSERT_UNIQUE inserts a unique I2 set value in an indexed sorted list. ! ! ! Modified: ! ! 11 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXN, the maximum size of the list. ! ! Input/output, integer N, the size of the list. ! ! Input/output, integer X(N), Y(N), the list of I2 sets. ! ! Input, integer INDX(N), the sort index of the list. ! ! Input, integer XVAL, YVAL, the value to be inserted if it is ! not already in the list. ! ! Output, integer IVAL, the index in INDX corresponding to the ! value XVAL, YVAL. ! ! Output, integer IERROR, 0 for no error, 1 if an error occurred. ! implicit none ! integer maxn ! integer equal integer ierror integer indx(maxn) integer ival integer less integer more integer n integer x(maxn) integer xval integer y(maxn) integer yval ! ierror = 0 if ( n <= 0 ) then if ( maxn <= 0 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ISET2_INDEX_INSERT_UNIQUE - Fatal error!' write ( *, '(a)' ) ' Not enough space to store new data.' return end if n = 1 x(1) = min ( xval, yval ) y(1) = max ( xval, yval ) indx(1) = 1 ival = 1 return end if ! ! Does ( XVAL, YVAL ) already occur in the list? ! call iset2_index_search ( maxn, n, x, y, indx, xval, yval, & less, equal, more ) if ( equal == 0 ) then if ( n >= maxn ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ISET2_INDEX_INSERT_UNIQUE - Fatal error!' write ( *, '(a)' ) ' Not enough space to store new data.' return end if x(n+1) = min ( xval, yval ) y(n+1) = max ( xval, yval ) ival = more indx(n+1:more+1:-1) = indx(n:more:-1) indx(more) = n + 1 n = n + 1 else ival = equal end if return end subroutine iset2_index_search ( maxn, n, x, y, indx, xval, yval, & less, equal, more ) ! !******************************************************************************* ! !! ISET2_INDEX_SEARCH searches for an I2 set value in an indexed sorted list. ! ! ! Modified: ! ! 11 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXN, the maximum size of the list. ! ! Input, integer N, the size of the current list. ! ! Input, integer X(N), Y(N), the list. ! ! Input, integer INDX(N), the sort index of the list. ! ! Input, integer XVAL, YVAL, the value to be sought. ! ! Output, integer LESS, EQUAL, MORE, the indexes in INDX of the ! list entries that are just less than, equal to, and just greater ! than the test value. If the test value does not occur in the list, ! then EQUAL is zero. If the test value is the minimum entry of the ! list, then LESS is 0. If the test value is the greatest entry of ! the list, then MORE is N+1. ! implicit none ! integer maxn ! character c integer equal integer hi integer indx(maxn) integer less integer lo integer mid integer more integer n character iset2_compare integer x(maxn) integer xhi integer xlo integer xmid integer xval integer y(maxn) integer yhi integer ylo integer ymid integer yval ! if ( n <= 0 ) then less = 0 equal = 0 more = 0 return end if lo = 1 hi = n xlo = x(indx(lo)) ylo = y(indx(lo)) xhi = x(indx(hi)) yhi = y(indx(hi)) c = iset2_compare ( xval, yval, xlo, ylo ) if ( c == '<' ) then less = 0 equal = 0 more = 1 return else if ( c == '=' ) then less = 0 equal = 1 more = 2 return end if c = iset2_compare ( xval, yval, xhi, yhi ) if ( c == '>' ) then less = n equal = 0 more = n + 1 return else if ( c == '=' ) then less = n - 1 equal = n more = n + 1 return end if do if ( lo + 1 == hi ) then less = lo equal = 0 more = hi return end if mid = ( lo + hi ) / 2 xmid = x(indx(mid)) ymid = y(indx(mid)) c = iset2_compare ( xval, yval, xmid, ymid ) if ( c == '=' ) then equal = mid less = equal - 1 more = equal + 1 return else if ( c == '<' ) then hi = mid else if ( c == '>' ) then lo = mid end if end do return end subroutine ivec_backtrack ( n, x, indx, k, nstack, stack, maxstack, ncan ) ! !******************************************************************************* ! !! IVEC_BACKTRACK supervises a backtrack search for an integer vector. ! ! ! Discussion: ! ! The routine tries to construct an integer vector one index at a time, ! using possible candidates as supplied by the user. ! ! At any time, the partially constructed vector may be discovered to be ! unsatisfactory, but the routine records information about where the ! last arbitrary choice was made, so that the search can be ! carried out efficiently, rather than starting out all over again. ! ! First, call the routine with INDX = 0 so it can initialize itself. ! ! Now, on each return from the routine, if INDX is: ! 1, you've just been handed a complete candidate vector; ! Admire it, analyze it, do what you like. ! 2, please determine suitable candidates for position X(K). ! Return the number of candidates in NCAN(K), adding each ! candidate to the end of STACK, and increasing NSTACK. ! 3, you're done. Stop calling the routine; ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 24 July 2000 ! ! Parameters: ! ! Input, integer N, the number of positions to be filled in the vector. ! ! Input/output, integer X(N), the partial or complete candidate vector. ! ! Input/output, integer INDX, a communication flag. ! On input, ! 0 to start a search. ! On output: ! 1, a complete output vector has been determined and returned in X(1:N); ! 2, candidates are needed for position X(K); ! 3, no more possible vectors exist. ! ! Output, integer K, if INDX=2, the current vector index being considered. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input, integer STACK(MAXSTACK), a list of all current candidates for ! all positions 1 through K. ! ! Input, integer MAXSTACK, the maximum length of the stack. ! ! Input/output, integer NCAN(N), lists the current number of candidates for ! positions 1 through K. ! implicit none ! integer n integer maxstack ! integer indx integer k integer ncan(n) integer nstack integer stack(maxstack) integer x(n) ! ! If this is the first call, request a candidate for position 1. ! if ( indx == 0 ) then k = 1 nstack = 0 indx = 2 return end if ! ! Examine the stack. ! do ! ! If there are candidates for position K, take the first available ! one off the stack, and increment K. ! ! This may cause K to reach the desired value of N, in which case ! we need to signal the user that a complete set of candidates ! is being returned. ! if ( ncan(k) > 0 ) then x(k) = stack(nstack) nstack = nstack - 1 ncan(k) = ncan(k) - 1 if ( k /= n ) then k = k + 1 indx = 2 else indx = 1 end if exit ! ! If there are no candidates for position K, then decrement K. ! If K is still positive, repeat the examination of the stack. ! else k = k - 1 if ( k <= 0 ) then indx = 3 exit end if end if end do return end subroutine ivec_compare ( n, a, b, isgn ) ! !******************************************************************************* ! !! IVEC_COMPARE compares two integer vectors. ! ! ! Discussion: ! ! The lexicographic ordering is used. ! ! Example: ! ! Input: ! ! A = ( 2, 6, 2 ) ! B = ( 2, 8, 12 ) ! ! Output: ! ! ISGN = -1 ! ! Modified: ! ! 23 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input, integer A(N), B(N), the vectors to be compared. ! ! Output, integer ISGN, the results of the comparison: ! -1, A is lexicographically less than B, ! 0, A is equal to B, ! +1, A is lexicographically greater than B. ! implicit none ! integer n ! integer a(n) integer b(n) integer isgn integer k ! isgn = 0 do k = 1, n if ( a(k) < b(k) ) then isgn = - 1 return else if ( a(k) > b(k) ) then isgn = + 1 return end if end do return end subroutine ivec_heap_a ( n, a ) ! !******************************************************************************* ! !! IVEC_HEAP_A reorders an array of integers into an ascending heap. ! ! ! Definition: ! ! An ascending heap is an array A with the property that, for every index J, ! A(J) <= A(2*J) and A(J) <= A(2*J+1), (as long as the indices ! 2*J and 2*J+1 are legal). ! ! Diagram: ! ! A(1) ! / \ ! A(2) A(3) ! / \ / \ ! A(4) A(5) A(6) A(7) ! / \ / \ ! A(8) A(9) A(10) A(11) ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the input array. ! ! Input/output, integer A(N). ! On input, an unsorted array. ! On output, the array has been reordered into a heap. ! implicit none ! integer n ! integer a(n) integer i integer ifree integer key integer m ! ! Only nodes N/2 down to 1 can be "parent" nodes. ! do i = n/2, 1, -1 ! ! Copy the value out of the parent node. ! Position IFREE is now "open". ! key = a(i) ifree = i 10 continue ! ! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position ! IFREE. (One or both may not exist because they exceed N.) ! m = 2 * ifree ! ! Does the first position exist? ! if ( m <= n ) then ! ! Does the second position exist? ! if ( m + 1 <= n ) then ! ! If both positions exist, take the smaller of the two values, ! and update M if necessary. ! if ( a(m+1) < a(m) ) then m = m + 1 end if end if ! ! If the small descendant is smaller than KEY, move it up, ! and update IFREE, the location of the free position, and ! consider the descendants of THIS position. ! if ( a(m) < key ) then a(ifree) = a(m) ifree = m go to 10 end if end if ! ! Once there is no more shifting to do, the value KEY ! moves into the free spot IFREE. ! a(ifree) = key end do return end subroutine ivec_heap_d ( n, a ) ! !******************************************************************************* ! !! IVEC_HEAP_D reorders an array of integers into an descending heap. ! ! ! Definition: ! ! A descending heap is an array A with the property that, for every index J, ! A(J) >= A(2*J) and A(J) >= A(2*J+1), (as long as the indices ! 2*J and 2*J+1 are legal). ! ! Diagram: ! ! A(1) ! / \ ! A(2) A(3) ! / \ / \ ! A(4) A(5) A(6) A(7) ! / \ / \ ! A(8) A(9) A(10) A(11) ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the input array. ! ! Input/output, integer A(N). ! On input, an unsorted array. ! On output, the array has been reordered into a heap. ! implicit none ! integer n ! integer a(n) integer i integer ifree integer key integer m ! ! Only nodes N/2 down to 1 can be "parent" nodes. ! do i = n/2, 1, -1 ! ! Copy the value out of the parent node. ! Position IFREE is now "open". ! key = a(i) ifree = i 10 continue ! ! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position ! IFREE. (One or both may not exist because they exceed N.) ! m = 2 * ifree ! ! Does the first position exist? ! if ( m <= n ) then ! ! Does the second position exist? ! if ( m + 1 <= n ) then ! ! If both positions exist, take the larger of the two values, ! and update M if necessary. ! if ( a(m+1) > a(m) ) then m = m + 1 end if end if ! ! If the large descendant is larger than KEY, move it up, ! and update IFREE, the location of the free position, and ! consider the descendants of THIS position. ! if ( a(m) > key ) then a(ifree) = a(m) ifree = m go to 10 end if end if ! ! Once there is no more shifting to do, the value KEY ! moves into the free spot IFREE. ! a(ifree) = key end do return end subroutine ivec_identity ( n, a ) ! !******************************************************************************* ! !! IVEC_IDENTITY sets an integer vector to the identity vector A(I)=I. ! ! ! Modified: ! ! 09 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Output, integer A(N), the array to be initialized. ! implicit none ! integer n ! integer a(n) integer i ! do i = 1, n a(i) = i end do return end function ivec_nonzero ( n, a ) ! !******************************************************************************* ! !! IVEC_NONZERO counts the nonzero entries in an integer vector ! ! ! Modified: ! ! 01 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the input array. ! ! Input, integer A(N), an array. ! ! Output, integer IVEC_NONZERO, the number of nonzero entries. ! implicit none ! integer n ! integer a(n) integer i integer ivec_nonzero ! ivec_nonzero = 0 do i = 1, n if ( a(i) /= 0 ) then ivec_nonzero = ivec_nonzero + 1 end if end do return end subroutine ivec_order_type ( n, a, order ) ! !******************************************************************************* ! !! IVEC_ORDER_TYPE determines if an integer array is (non)strictly ascending/descending. ! ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries of the array. ! ! Input, integer A(N), the array to be checked. ! ! Output, integer ORDER, order indicator: ! -1, no discernable order; ! 0, all entries are equal; ! 1, ascending order; ! 2, strictly ascending order; ! 3, descending order; ! 4, strictly descending order. ! implicit none ! integer n ! integer a(n) integer i integer order ! ! Search for the first value not equal to A(1). ! i = 1 do i = i + 1 if ( i > n ) then order = 0 return end if if ( a(i) > a(1) ) then if ( i == 2 ) then order = 2 else order = 1 end if exit else if ( a(i) < a(1) ) then if ( i == 2 ) then order = 4 else order = 3 end if exit end if end do ! ! Now we have a "direction". Examine subsequent entries. ! do while ( i < n ) i = i + 1 if ( order == 1 ) then if ( a(i) < a(i-1) ) then order = -1 exit end if else if ( order == 2 ) then if ( a(i) < a(i-1) ) then order = -1 exit else if ( a(i) == a(i-1) ) then order = 1 end if else if ( order == 3 ) then if ( a(i) > a(i-1) ) then order = -1 exit end if else if ( order == 4 ) then if ( a(i) > a(i-1) ) then order = -1 exit else if ( a(i) == a(i-1) ) then order = 3 end if end if end do return end subroutine ivec_perm_random ( n, a ) ! !******************************************************************************* ! !! IVEC_PERM_RANDOM selects a random permutation of an integer vector. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Input/output, integer A(N), the vector to be permuted. ! implicit none ! integer n ! integer a(n) integer i integer j ! do i = 1, n call i_random ( i, n, j ) call i_swap ( a(i), a(j) ) end do return end subroutine ivec_print ( n, a, title ) ! !******************************************************************************* ! !! IVEC_PRINT prints an integer vector. ! ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! integer a(n) integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,i10)' ) i, a(i) end do return end subroutine ivec_random ( n, a, alo, ahi ) ! !******************************************************************************* ! !! IVEC_RANDOM returns a random integer vector in a given range. ! ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Output, integer A(N), the vector of randomly chosen integers. ! ! Input, integer ALO, AHI, the range allowed for the entries. ! implicit none ! integer n ! integer a(n) integer ahi integer alo integer i ! do i = 1, n call i_random ( alo, ahi, a(i) ) end do return end subroutine ivec_reverse ( n, a ) ! !******************************************************************************* ! !! IVEC_REVERSE reverses the elements of an integer vector. ! ! ! Example: ! ! Input: ! ! N = 5, A = ( 11, 12, 13, 14, 15 ). ! ! Output: ! ! A = ( 15, 14, 13, 12, 11 ). ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer A(N), the array to be reversed. ! implicit none ! integer n ! integer a(n) integer i ! do i = 1, n/2 call i_swap ( a(i), a(n+1-i) ) end do return end subroutine ivec_rotate ( n, m, a ) ! !******************************************************************************* ! !! IVEC_ROTATE rotates an object in place. ! ! ! Example: ! ! Input: ! ! N = 5, M = 2 ! A = ( 1, 2, 3, 4, 5 ) ! ! Output: ! ! A = ( 4, 5, 1, 2, 3 ). ! ! Modified: ! ! 07 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects. ! ! Input, integer M, the number of positions to the right that ! each element should be moved. Elements that shift pass position ! N "wrap around" to the beginning of the array. ! ! Input/output, integer A(N), the array to be rotated. ! implicit none ! integer n ! integer a(n) integer i_modp integer iget integer iput integer istart integer m integer mcopy integer nset integer temp ! ! Force M to be positive, between 0 and N-1. ! mcopy = i_modp ( m, n ) if ( mcopy == 0 ) then return end if istart = 0 nset = 0 do istart = istart + 1 if ( istart > n ) then exit end if temp = a(istart) iget = istart ! ! Copy the new value into the vacated entry. ! do iput = iget iget = iget - mcopy if ( iget < 1 ) then iget = iget + n end if if ( iget == istart ) then exit end if a(iput) = a(iget) nset = nset + 1 end do a(iput) = temp nset = nset + 1 if ( nset >= n ) then exit end if end do return end subroutine ivec_sort_heap_a ( n, a ) ! !******************************************************************************* ! !! IVEC_SORT_HEAP_A ascending sorts an integer array using heap sort. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer A(N). ! On input, the array to be sorted; ! On output, the array has been sorted. ! implicit none ! integer n ! integer a(n) integer n1 ! if ( n <= 1 ) then return end if ! ! 1: Put A into descending heap form. ! call ivec_heap_d ( n, a ) ! ! 2: Sort A. ! ! The largest object in the heap is in A(1). ! Move it to position A(N). ! call i_swap ( a(1), a(n) ) ! ! Consider the diminished heap of size N1. ! do n1 = n-1, 2, -1 ! ! Restore the heap structure of A(1) through A(N1). ! call ivec_heap_d ( n1, a ) ! ! Take the largest object from A(1) and move it to A(N1). ! call i_swap ( a(1), a(n1) ) end do return end subroutine ivec_sort_heap_d ( n, a ) ! !******************************************************************************* ! !! IVEC_SORT_HEAP_D descending sorts an integer array using heap sort. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer A(N). ! On input, the array to be sorted; ! On output, the array has been sorted. ! implicit none ! integer n ! integer a(n) integer n1 ! if ( n <= 1 ) then return end if ! ! 1: Put A into ascending heap form. ! call ivec_heap_a ( n, a ) ! ! 2: Sort A. ! ! The smallest object in the heap is in A(1). ! Move it to position A(N). ! call i_swap ( a(1), a(n) ) ! ! Consider the diminished heap of size N1. ! do n1 = n-1, 2, -1 ! ! Restore the heap structure of A(1) through A(N1). ! call ivec_heap_a ( n1, a ) ! ! Take the smallest object from A(1) and move it to A(N1). ! call i_swap ( a(1), a(n1) ) end do return end subroutine ivec_sort_heap_index_d ( n, a, indx ) ! !******************************************************************************* ! !! IVEC_SORT_HEAP_INDEX_D does an indexed heap descending sort of an integer vector. ! ! ! Discussion: ! ! The sorting is not actually carried out. Rather an index array is ! created which defines the sorting. This array may be used to sort ! or index the array, or to sort or index related arrays keyed on the ! original array. ! ! Once the index array is computed, the sorting can be carried out ! "implicitly: ! ! A(INDX(I)), I = 1 to N is sorted, ! ! or explicitly, by the call ! ! call IVEC_PERMUTE ( N, A, INDX ) ! ! after which A(I), I = 1 to N is sorted. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, integer A(N), an array to be index-sorted. ! ! Output, integer INDX(N), contains the sort index. The ! I-th element of the sorted array is A(INDX(I)). ! implicit none ! integer n ! integer a(n) integer aval integer i integer indx(n) integer indxt integer ir integer j integer l ! call ivec_identity ( n, indx ) l = n / 2 + 1 ir = n do if ( l > 1 ) then l = l - 1 indxt = indx(l) aval = a(indxt) else indxt = indx(ir) aval = a(indxt) indx(ir) = indx(1) ir = ir - 1 if ( ir == 1 ) then indx(1) = indxt return end if end if i = l j = l + l do while ( j <= ir ) if ( j < ir ) then if ( a(indx(j)) > a(indx(j+1)) ) then j = j + 1 end if end if if ( aval > a(indx(j)) ) then indx(i) = indx(j) i = j j = j + j else j = ir + 1 end if end do indx(i) = indxt end do return end subroutine ivec_uniq ( n, a, nuniq ) ! !******************************************************************************* ! !! IVEC_UNIQ finds the number of unique elements in a sorted integer array. ! ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements in A. ! ! Input/output, integer A(N). On input, the sorted ! integer array. On output, the unique elements in A. ! ! Output, integer NUNIQ, the number of unique elements in A. ! implicit none ! integer n ! integer a(n) integer itest integer nuniq ! nuniq = 0 if ( n <= 0 ) then return end if nuniq = 1 do itest = 2, n if ( a(itest) /= a(nuniq) ) then nuniq = nuniq + 1 a(nuniq) = a(itest) end if end do return end subroutine ivec2_compare ( n, ivec, jvec, i, j, isgn ) ! !******************************************************************************* ! !! IVEC2_COMP compares pairs of integers stored in two vectors. ! ! ! Modified: ! ! 22 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of data items. ! ! Input, integer IVEC(N), JVEC(N), contain the two components of each item. ! ! Input, integer I, J, the items to be compared. ! ! Output, integer ISGN, the results of the comparison: ! -1, item I is less than item J, ! 0, item I is equal to item J, ! +1, item I is greater than item J. ! implicit none ! integer n ! integer i integer isgn integer ivec(n) integer j integer jvec(n) ! isgn = 0 if ( ivec(i) < ivec(j) ) then isgn = -1 else if ( ivec(i) == ivec(j) ) then if ( jvec(i) < jvec(j) ) then isgn = -1 else if ( jvec(i) < jvec(j) ) then isgn = 0 else if ( jvec(i) > jvec(j) ) then isgn = +1 end if else if ( ivec(i) > ivec(j) ) then isgn = +1 end if return end subroutine ivec2_print ( n, a, b, title ) ! !******************************************************************************* ! !! IVEC2_PRINT prints a pair of integer vectors. ! ! ! Modified: ! ! 09 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), B(N), the vectors to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! integer a(n) integer b(n) integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,2i10)' ) i, a(i), b(i) end do return end subroutine ivec2_sort_a ( n, a1, a2 ) ! !******************************************************************************* ! !! IVEC2_SORT_A ascending sorts a vector of pairs of integers. ! ! ! Discussion: ! ! Each item to be sorted is a pair of integers (I,J), with the I ! and J values stored in separate vectors A1 and A2. ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items of data. ! ! Input/output, integer A1(N), A2(N), the data to be sorted.. ! implicit none ! integer n ! integer a1(n) integer a2(n) integer i integer indx integer isgn integer j ! ! Initialize. ! i = 0 indx = 0 isgn = 0 j = 0 ! ! Call the external heap sorter. ! do call sort_heap_external ( n, indx, i, j, isgn ) ! ! Interchange the I and J objects. ! if ( indx > 0 ) then call i_swap ( a1(i), a1(j) ) call i_swap ( a2(i), a2(j) ) ! ! Compare the I and J objects. ! else if ( indx < 0 ) then call ivec2_compare ( n, a1, a2, i, j, isgn ) else if ( indx == 0 ) then exit end if end do return end subroutine ivec2_sort_d ( n, a1, a2 ) ! !******************************************************************************* ! !! IVEC2_SORT_D descending sorts a vector of pairs of integers. ! ! ! Discussion: ! ! Each item to be sorted is a pair of integers (I,J), with the I ! and J values stored in separate vectors A1 and A2. ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items of data. ! ! Input/output, integer A1(N), A2(N), the data to be sorted.. ! implicit none ! integer n ! integer a1(n) integer a2(n) integer i integer indx integer isgn integer j ! ! Initialize. ! i = 0 indx = 0 isgn = 0 j = 0 ! ! Call the external heap sorter. ! do call sort_heap_external ( n, indx, i, j, isgn ) ! ! Interchange the I and J objects. ! if ( indx > 0 ) then call i_swap ( a1(i), a1(j) ) call i_swap ( a2(i), a2(j) ) ! ! Compare the I and J objects. ! else if ( indx < 0 ) then call ivec2_compare ( n, a1, a2, i, j, isgn ) isgn = - isgn else if ( indx == 0 ) then exit end if end do return end subroutine ivec2_uniq ( n, a1, a2, nuniq ) ! !******************************************************************************* ! !! IVEC2_UNIQ keeps the unique elements in a array of pairs of integers. ! ! ! Discussion: ! ! Item I is stored as the pair A1(I), A2(I). ! ! The items must have been sorted, or at least it must be the ! case that equal items are stored in adjacent vector locations. ! ! If the items were not sorted, then this routine will only ! replace a string of equal values by a single representative. ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items. ! ! Input/output, integer A1(N), A2(N). ! On input, the array of N items. ! On output, an array of NUNIQ unique items. ! ! Output, integer NUNIQ, the number of unique items. ! implicit none ! integer n ! integer a1(n) integer a2(n) integer itest integer nuniq ! nuniq = 0 if ( n <= 0 ) then return end if nuniq = 1 do itest = 2, n if ( a1(itest) /= a1(nuniq) .or. a2(itest) /= a2(nuniq) ) then nuniq = nuniq + 1 a1(nuniq) = a1(itest) a2(nuniq) = a2(itest) end if end do return end subroutine ksub_random ( n, k, iarray ) ! !******************************************************************************* ! !! KSUB_RANDOM selects a random subset of size K from a set of size N. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 01 December 2000 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! ! Input, integer K, number of elements in desired subsets. K must ! be between 0 and N. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th element of the ! output set. The elements of IARRAY are in order. ! implicit none ! integer k ! integer i integer iarray(k) integer ids integer ihi integer ip integer ir integer is integer ix integer l integer ll integer m integer m0 integer n real r ! if ( k < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop else if ( k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' K <= N is required!' stop end if if ( k == 0 ) then return end if do i = 1, k iarray(i) = ( ( i - 1 ) * n ) / k end do do i = 1, k do call i_random ( 1, n, ix ) l = 1 + ( ix * k - 1 ) / n if ( ix > iarray(l) ) then exit end if end do iarray(l) = iarray(l) + 1 end do ip = 0 is = k do i = 1, k m = iarray(i) iarray(i) = 0 if ( m /= ( (i-1) * n ) / k ) then ip = ip + 1 iarray(ip) = m end if end do ihi = ip do i = 1, ihi ip = ihi + 1 - i l = 1 + ( iarray(ip) * k - 1 ) / n ids = iarray(ip) - ( ( l - 1 ) * n ) / k iarray(ip) = 0 iarray(is) = l is = is - ids end do do ll = 1, k l = k + 1 - ll if ( iarray(l) /= 0 ) then ir = l m0 = 1 + ( ( iarray(l) - 1 ) * n ) / k m = ( iarray(l) * n ) / k - m0 + 1 end if call i_random ( m0, m0+m-1, ix ) i = l + 1 do while ( i <= ir ) if ( ix < iarray(i) ) then exit end if ix = ix + 1 iarray(i-1) = iarray(i) i = i + 1 end do iarray(i-1) = ix m = m - 1 end do return end subroutine m_graph_adj_edge_seq ( adj, lda, nnode, edge_seq ) ! !******************************************************************************* ! !! M_GRAPH_ADJ_EDGE_SEQ computes the edge sequence of a multigraph. ! ! ! Discussion: ! ! The edge sequence of a multigraph may be constructed by sorting the ! entries of each row of the adjacency matrix in descending order, and ! then sorting the rows themselves in descending order. ! ! If two multigraphs are isomorphic, they must have the same edge sequence. ! ! If two multigraphs have different edge sequences, they cannot be isomorphic. ! ! Example: ! ! ADJ = ! 0 1 2 3 ! 1 0 2 0 ! 2 2 0 1 ! 3 0 1 0 ! ! EDGE_SEQ = ! ! 3 2 1 0 ! 3 1 0 0 ! 2 2 1 0 ! 2 1 0 0 ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ADJ(LDA,NNODE), the adjacency information. ! ADJ(I,J) is 1 if there is an edge from node I to node J. ! ! Input, integer LDA, the leading dimension of the ADJ array, ! which must be at least NNODE. ! ! Input, integer NNODE, the number of nodes. ! ! Output, integer EDGE_SEQ(LDA,NNODE), the degree sequence of the graph. ! implicit none ! integer lda integer nnode ! integer adj(lda,nnode) integer edge_seq(lda,nnode) integer i integer j ! ! Copy the adjacency matrix. ! edge_seq(1:nnode,1:nnode) = adj(1:nnode,1:nnode) ! ! Descending sort the elements of each row. ! call irow_sort_d ( lda, nnode, nnode, edge_seq ) ! ! Sort the rows of the matrix. ! call imat_row_sort_d ( lda, nnode, nnode, edge_seq ) return end subroutine maze_diam ( bar, degree, diam, flat, m, n, path, istart, jstart, & istop, jstop ) ! !******************************************************************************* ! !! MAZE_DIAM computes the "diameter" of a maze that has no circuits. ! ! ! Discussion: ! ! The routine also returns two cells, (ISTART,JSTART), and (ISTOP,JSTOP) ! which are separated by a path of length DIAM. ! ! Definition: ! ! The diameter is the length of the longest path that never passes ! through the same cell twice. ! ! Modified: ! ! 17 August 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer BAR(M,N+1), records the vertical "bars" in the maze. ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! ! Output, integer DEGREE(M,N), the degree of each node. ! ! Output, integer DIAM, the length of the longest path in the tree. ! ! Input, integer FLAT(M+1,N), records the horizontal "flats" in the maze. ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! ! Input, integer M, N, the number of rows and columns of cells. ! ! Output, integer PATH(M,N), marks the path between the cells ! (ISTART,JSTART) and (ISTOP,JSTOP). A cell (I,J) is in the path ! if PATH(I,J) is 1. ! ! Output, integer ISTART, JSTART, are the I and J cell coordinates of the ! starting cell. ! ! Output, integer ISTOP, JSTOP, are the I and J cell coordinates of the ! goal cell. ! implicit none ! integer, parameter :: OPEN = 1 integer, parameter :: SHUT = 2 ! integer m integer n ! integer bar(m,n+1) integer degree(m,n) integer diam integer flat(m+1,n) integer i integer i2 integer invals integer istart integer istop integer j integer j2 integer jstart integer jstop integer k integer kstep integer n1 integer n2 integer path(m,n) ! if ( m * n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_DIAM - Fatal error!' write ( *, '(a)' ) ' M*N <= 0.' stop else if ( m * n == 1 ) then diam = 0 return end if k = 0 do j = 1, n do i = 1, m k = k + 1 path(i,j) = k end do end do ! ! On step KSTEP: ! ! Identify the terminal and interior nodes. ! ! If there are no interior nodes left, ! ! then there are just two nodes left at all. The diameter is 2*K-1, ! and a maximal path extends between the nodes whose labels are ! contained in the two remaining terminal nodes. ! ! Else ! ! The label of each terminal node is passed to its interior neighbor. ! If more than one label arrives, take any one. ! ! The terminal nodes are removed. ! kstep = 0 10 continue kstep = kstep + 1 ! ! Compute the degree of each node. ! do j = 1, n do i = 1, m degree(i,j) = 0 if ( flat(i,j) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if if ( flat(i+1,j) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if if ( bar(i,j) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if if ( bar(i,j+1) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if end do end do ! ! Count the number of interior nodes. ! invals = 0 do j = 1, n do i = 1, m if ( degree(i,j) > 1 ) then invals = invals + 1 end if end do end do ! ! If there are at least two interior nodes, then chop off the ! terminal nodes and pass their labels inward. ! if ( invals >= 2 ) then k = 0 do j = 1, n do i = 1, m k = k + 1 if ( degree(i,j) == 1 ) then if ( flat(i,j) == OPEN ) then i2 = i - 1 j2 = j flat(i,j) = SHUT else if ( flat(i+1,j) == OPEN ) then i2 = i + 1 j2 = j flat(i+1,j) = SHUT else if ( bar(i,j) == OPEN ) then i2 = i j2 = j - 1 bar(i,j) = SHUT else if ( bar(i,j+1) == OPEN ) then i2 = i j2 = j + 1 bar(i,j+1) = SHUT end if path(i2,j2) = path(i,j) end if end do end do go to 10 ! ! But if there are 1 or 0 interior nodes, it's time to stop. ! else if ( invals == 1 ) then diam = 2 * kstep + 2 else if ( invals == 0 ) then diam = 2 * kstep + 1 end if ! ! Now get the labels from two of the remaining terminal nodes. ! The nodes represented by these labels will be a diameter apart. ! n1 = 0 n2 = 0 do j = 1, n do i = 1, m if ( degree(i,j) == 1 ) then if ( n1 == 0 ) then n1 = path(i,j) else if ( n2 == 0 ) then n2 = path(i,j) end if end if end do end do ! ! Set the labels of the interior node (if any) and nodes marked ! N1 and N2 to 1, and all others to 0. This will label the nodes on the path. ! if ( invals == 1 ) then do j = 1, n do i = 1, m if ( degree(i,j) > 1 ) then path(i,j) = 1 end if end do end do end if do j = 1, n do i = 1, m if ( path(i,j) == n1 .or. path(i,j) == n2 ) then path(i,j) = 1 else path(i,j) = 0 end if end do end do ! ! Translate N1 and N2 to row, column. ! jstart = ( n1 - 1 ) / m + 1 istart = n1 - ( jstart - 1 ) * m jstop = ( n2 - 1 ) / m + 1 istop = n2 - ( jstop - 1 ) * m ! ! Clean up the DEGREE and LINKS arrays. ! do i = 1, m do j = 1, n+1 if ( bar(i,j) == SHUT ) then bar(i,j) = OPEN end if end do end do do i = 1, m+1 do j = 1, n if ( flat(i,j) == SHUT ) then flat(i,j) = OPEN end if end do end do do j = 1, n do i = 1, m degree(i,j) = 0 if ( flat(i,j) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if if ( flat(i+1,j) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if if ( bar(i,j) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if if ( bar(i,j+1) == OPEN ) then degree(i,j) = degree(i,j) + 1 end if end do end do return end subroutine maze_path ( bar, flat, m, n, istart, jstart, istop, jstop ) ! !******************************************************************************* ! !! MAZE_PATH finds a path through a maze. ! ! ! Warning: ! ! This routine has some stupid internal limits which could ! be fixed by reprogramming. (Use the BAR and FLAT arrays to record ! the tentative path, for instance.) ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer BAR(M,N+1), records the vertical "bars" in the maze, ! and on output, the path through open bars: ! ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! 2, means the path goes through this open bar. ! ! Input/output, integer FLAT(M+1,N), records the horizontal "flats" in the ! maze, and on output, the path through open flats: ! ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! 2, means the path goes through this open flat. ! ! Input, integer M, N, the number of rows and columns of cells. ! ! Input, integer ISTART, JSTART, are the I and J cell coordinates of the ! starting cell. ! ! Input, integer ISTOP, JSTOP, are the I and J cell coordinates of the ! goal cell, which will be required to be a terminal node of the tree. ! implicit none ! integer, parameter :: maxpath = 200 integer, parameter :: maxstack = 500 integer, parameter :: maxused = 500 integer, parameter :: OPEN = 1 integer, parameter :: PATH = 2 ! integer m integer n ! integer bar(m,n+1) integer flat(m+1,n) integer ipath integer istart integer istop integer ival integer ival2 integer jstart integer jstop integer jval integer jval2 integer k integer kval integer kval2 integer ncan integer npath integer nstack integer pathlist(maxpath) integer stack(maxstack) integer used(maxused) ! if ( istart < 1 .or. istart > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a,i6)' ) ' ISTART out of range, = ', istart write ( *, '(a,i6)' ) ' Must be between 1 and ', m stop else if ( jstart < 1 .or. jstart > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a,i6)' ) ' JSTART out of range, = ', jstart write ( *, '(a,i6)' ) ' Must be between 1 and ', n stop else if ( istop < 1 .or. istop > m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a,i6)' ) ' ISTOP out of range, = ', istop write ( *, '(a,i6)' ) ' Must be between 1 and ', m stop else if ( jstop < 1 .or. jstop > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a,i6)' ) ' JSTOP out of range, = ', jstop write ( *, '(a,i6)' ) ' Must be between 1 and ', n stop end if if ( m * n > maxused ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a)' ) ' M * N greater than internal limit MAXUSED.' stop end if used(1:m*n) = 0 pathlist(1:m*n) = 0 ! ! Begin the path at (ISTART,JSTART). ! npath = 1 ival = istart jval = jstart kval = ( jval - 1 ) * m + ival pathlist(npath) = kval used(kval) = npath ncan = 0 nstack = 1 stack(nstack) = ncan ! ! Try to take a new step. ! 10 continue ! ! Find all the accessible never-used neighbors of the current endpoint. ! Add them to the stack, and set NCAN to the number of candidates. ! ncan = 0 if ( ival /= 1 ) then if ( flat ( ival, jval ) == OPEN ) then ival2 = ival - 1 jval2 = jval kval2 = ( jval2 - 1 ) * m + ival2 if ( used(kval2) == 0 ) then ncan = ncan + 1 nstack = nstack + 1 if ( nstack > maxstack ) then go to 100 end if stack(nstack) = kval2 end if end if end if if ( jval /= n ) then if ( bar ( ival, jval+1 ) == OPEN ) then ival2 = ival jval2 = jval + 1 kval2 = ( jval2 - 1 ) * m + ival2 if ( used(kval2) == 0 ) then ncan = ncan + 1 nstack = nstack + 1 if ( nstack > maxstack ) then go to 100 end if stack(nstack) = kval2 end if end if end if if ( jval /= 1 ) then if ( bar ( ival, jval ) == OPEN ) then ival2 = ival jval2 = jval - 1 kval2 = ( jval2 - 1 ) * m + ival2 if ( used(kval2) == 0 ) then ncan = ncan + 1 nstack = nstack + 1 if ( nstack > maxstack ) then go to 100 end if stack(nstack) = kval2 end if end if end if if ( ival /= m ) then if ( flat ( ival+1, jval ) == OPEN ) then ival2 = ival + 1 jval2 = jval kval2 = ( jval2 - 1 ) * m + ival2 if ( used(kval2) == 0 ) then ncan = ncan + 1 nstack = nstack + 1 if ( nstack > maxstack ) then go to 100 end if stack(nstack) = kval2 end if end if end if ! ! Add NCAN to the stack. ! nstack = nstack + 1 if ( nstack > maxstack ) then go to 100 end if stack(nstack) = ncan 20 continue ! ! If NCAN=0, then... ! if ( ncan == 0 ) then ! ! ...if the current cell is the starting point, we've failed. ! if ( npath == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Note' write ( *, '(a)' ) ' Could not find a path to the goal.' return ! ! ...Else drop the current endpoint, going back to previous cell ! on the path, pop the stack one level, (getting new value of NCAN), ! go to 20. ! else used(kval) = - used(kval) npath = npath - 1 kval = pathlist(npath) ival = mod ( kval, m ) jval = 1 + ( kval - ival ) / m nstack = nstack - 1 ncan = stack(nstack) go to 20 end if ! ! Else, take one candidate off the stack, add it to the path, ! mark it as used, set NCAN = NCAN-1. ! else kval = stack(nstack-1) npath = npath + 1 if ( npath > maxpath ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a)' ) ' NPATH exceeds internal limit MAXPATH.' stop end if pathlist(npath) = kval used(kval) = npath jval = ( kval - 1 ) / m + 1 ival = kval - ( jval - 1 ) * m ncan = ncan - 1 nstack = nstack-1 stack(nstack) = ncan ! ! If the candidate is not the goal, go to 10... ! if ( ival /= istop .or. jval /= jstop ) then go to 10 end if ! ! ...else we're done. ! do ipath = 1, npath-1 kval = pathlist(ipath) jval = ( kval - 1 ) / m + 1 ival = kval - ( jval - 1 ) * m kval2 = pathlist(ipath+1) if ( kval2 == kval - 1 ) then flat(ival,jval) = PATH else if ( kval2 == kval + m ) then bar(ival,jval+1) = PATH else if ( kval2 == kval - m ) then bar(ival,jval) = PATH else if ( kval2 == kval + 1 ) then flat(ival+1,jval) = PATH end if end do return end if 100 continue write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PATH - Fatal error!' write ( *, '(a)' ) ' The size of the internal stack was exceeded!' stop end subroutine maze_print ( bar, flat, m, n, istart, jstart, istop, jstop, title ) ! !******************************************************************************* ! !! MAZE_PRINT prints out a maze and a path. ! ! ! Example: ! ! +--+--+ ! |*****|$$ ! +**+**+**+ ! |00|*****| ! + +--+--+ ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer BAR(M,N+1), records the vertical "bars" in the maze. ! ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! 2, means "path", that the way is open, and the path goes this way. ! ! Input, integer FLAT(M+1,N), records the horizontal "flats" in the maze. ! ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! 2, means "path", that the way is open, and the path goes this way. ! ! Input, integer M, N, the number of rows and columns of cells. Currently, ! the program cannot handle a maze with more than 26 columns. ! ! Input, integer ISTART, JSTART, are the I and J cell coordinates of the ! starting cell. The starting cell will be marked "00". If no ! starting cell is to be specified, set ISTART = JSTART = 0. ! ! Input, integer ISTOP, JSTOP, are the I and J cell coordinates of the ! goal cell. The goal cell will be marked "$$". If no goal cell ! is to be specified, set ISTOP = JSTOP = 0. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer, parameter :: NMAX = 26 integer, parameter :: INDEF = -1 integer, parameter :: WALL = 0 integer, parameter :: OPEN = 1 integer, parameter :: PATH = 2 ! integer m integer n ! integer bar(m,n+1) integer flat(m+1,n) integer i integer ilo integer istart integer istop integer j integer jstart integer jstop integer nsafe character ( len = 3*(NMAX+1) ) string character ( len = * ) title ! if ( n > NMAX ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_PRINT - Warning!' write ( *, '(a,i6)' ) ' N may not be more than ', NMAX write ( *, '(a)' ) ' Only a portion of the maze will be shown.' end if if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' nsafe = min ( n, NMAX ) do i = 1, m string = ' ' ilo = 1 do j = 1, nsafe if ( flat(i,j) == WALL ) then string(ilo:ilo+3) = '+--+' else if ( flat(i,j) == OPEN ) then string(ilo:ilo+3) = '+ +' else if ( flat(i,j) == PATH ) then string(ilo:ilo+3) = '+**+' else if ( flat(i,j) == INDEF ) then end if ilo = ilo + 3 end do write ( *, '(a)' ) string(1:ilo) string = ' ' ilo = 1 do j = 1, nsafe+1 if ( bar(i,j) == WALL ) then string(ilo:ilo) = '|' else if ( bar(i,j) == OPEN ) then string(ilo:ilo) = ' ' else if ( bar(i,j) == PATH ) then string(ilo:ilo) = '*' else if ( bar(i,j) == INDEF ) then end if ! ! Now fill in the interior of the cell. ! if ( i == istart .and. j == jstart ) then string(ilo+1:ilo+2) = '00' else if ( i== istop .and. j == jstop ) then string(ilo+1:ilo+2) = '$$' else if ( bar(i,j) == PATH ) then string(ilo+1:ilo+2) = '**' else if ( j <= n ) then if ( flat(i,j) == PATH .or. bar(i,j+1) == PATH .or. & flat(i+1,j) == PATH ) then string(ilo+1:ilo+2) = '**' end if end if ilo = ilo + 3 end do ilo = ilo - 3 write ( *, '(a)' ) string(1:ilo) end do string = ' ' i = m+1 ilo = 1 do j = 1, nsafe if ( flat(i,j) == WALL ) then string(ilo:ilo+3) = '+--+' else if ( flat(i,j) == OPEN ) then string(ilo:ilo+3) = '+ +' else if ( flat(i,j) == PATH ) then string(ilo:ilo+3) = '+**+' else if ( flat(i,j) == INDEF ) then end if ilo = ilo + 3 end do write ( *, '(a)' ) string(1:ilo) return end subroutine maze_random ( bar, dad, flat, m, n ) ! !******************************************************************************* ! !! MAZE_RANDOM generates a random maze in a rectangular region. ! ! ! Discussion: ! ! The rectangular region is assumed to be made of a grid of M rows ! and N columns of square cells. The maze is to be begun in ! one cell, and ended in another. The boundary of the region ! is walled off, except possibly for entrances to the beginning ! cell, and an exit from the ending cell. ! ! Modified: ! ! 22 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BAR(M,N+1), records the vertical "bars" in the maze. ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! ! Output, integer DAD(M,N), a rooted tree representation of ! the maze. The root of the tree has DAD(I,J) = 0. All other cells ! that are connectable to the root should have DAD(I,J) = K, where ! K is the cell index K = ( J - 1 ) * M + I, with I and J the row ! and column indices of the cell. If the cell is not connectable ! to the root, then DAD(I,J) is -1. ! ! Output, integer FLAT(M+1,N), records the horizontal "flats" in the maze. ! -1, means "indefinite", that there is no cell of the maze on either ! side of this position; ! 0, means "wall", that there is a cell on at least one side, and ! a wall here; ! 1, means "open", that there are cells on both sides (or possibly ! an opening to the exterior) and the way is open. ! ! Input, integer M, N, the number of rows and columns of cells. ! implicit none ! integer, parameter :: maxstack = 500 integer, parameter :: NORTH = 1 integer, parameter :: EAST = 2 integer, parameter :: WEST = 3 integer, parameter :: SOUTH = 4 integer, parameter :: INDEF = -1 integer, parameter :: WALL = 0 integer, parameter :: OPEN = 1 ! integer m integer n ! integer bar(m,n+1) integer dad(m,n) integer dir integer flat(m+1,n) integer i integer ihi integer ival integer j integer jval integer nabe integer nbase integer stack(maxstack) ! if ( m < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' M must be at least 1.' stop end if if ( n < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' N must be at least 1.' stop end if if ( m == 1 .and. n == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' At least one of M and N must be more than 1.' stop end if ! ! Initialize arrays to INDEF. ! bar(1:m,1:n+1) = INDEF flat(1:m+1,1:n) = INDEF ! ! Set the boundaries to walls. ! flat(1,1:n) = WALL flat(m+1,1:n) = WALL bar(1:m,1) = WALL bar(1:m,n+1) = WALL ! ! Initialize the tree pointers. ! dad(1:m,1:n) = -1 ! ! Pick a random starting point. ! call i_random ( 1, m, ival ) call i_random ( 1, n, jval ) dad(ival,jval) = 0 ! ! Count the number of neighbors of the starting cell, ! choose randomly from the neigbors, and add it. ! 10 continue nabe = 0 do i = 1, m do j = 1, n if ( dad(i,j) /= -1 ) then if ( flat(i,j) /= WALL ) then if ( dad(i-1,j) == -1 ) then if ( nabe+3 > maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' Ran out of stack space.' return end if stack(nabe+1) = i stack(nabe+2) = j stack(nabe+3) = NORTH nabe = nabe + 3 end if end if if ( bar(i,j+1) /= WALL ) then if ( dad(i,j+1) == -1 ) then if ( nabe+3 > maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' Ran out of stack space.' return end if stack(nabe+1) = i stack(nabe+2) = j stack(nabe+3) = EAST nabe = nabe + 3 end if end if if ( bar(i,j) /= WALL ) then if ( dad(i,j-1) == -1 ) then if ( nabe+3 > maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' Ran out of stack space.' return end if stack(nabe+1) = i stack(nabe+2) = j stack(nabe+3) = WEST nabe = nabe + 3 end if end if if ( flat(i+1,j) /= WALL ) then if ( dad(i+1,j) == -1 ) then if ( nabe+3 > maxstack ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MAZE_RANDOM - Fatal error!' write ( *, '(a)' ) ' Ran out of stack space!' return end if stack(nabe+1) = i stack(nabe+2) = j stack(nabe+3) = SOUTH nabe = nabe + 3 end if end if end if end do end do ! ! If there are accessible neighbors, randomly choose one. ! if ( nabe > 0 ) then ihi = nabe / 3 call i_random ( 1, ihi, ival ) nbase = 3*ival - 3 i = stack(nbase+1) j = stack(nbase+2) dir = stack(nbase+3) if ( dir == NORTH ) then flat(i,j) = OPEN dad(i-1,j) = ( j - 1 ) * m + i else if ( dir == EAST ) then bar(i,j+1) = OPEN dad(i,j+1) = ( j - 1 ) * m + i else if ( dir == WEST ) then bar(i,j) = OPEN dad(i,j-1) = ( j - 1 ) * m + i else if ( dir == SOUTH ) then flat(i+1,j) = OPEN dad(i+1,j) = ( j - 1 ) * m + i end if go to 10 end if ! ! Set all remaining INDEF's to WALLS. ! do i = 1, m do j = 1, n+1 if ( bar(i,j) == INDEF ) then bar(i,j) = WALL end if end do end do do i = 1, m+1 do j = 1, n if ( flat(i,j) == INDEF ) then flat(i,j) = WALL end if end do end do return end subroutine network_flow_max ( nnode, nedge, iendpt, icpflo, isorce, isink, & icut, node_flow ) ! !******************************************************************************* ! !! NETWORK_FLOW_MAX finds the maximal flow and a minimal cut in a network. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 23 July 2000 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input/output, integer IENDPT(2,NEDGE), the edges of the network, ! defined as pairs of nodes. Each edge should be listed TWICE, ! the second time in reverse order. On output, the edges have ! been reordered, and so the columns of IENDPT have been rearranged. ! ! Input/output, integer ICPFLO(2,NEDGE). Capacities and flows. ! On input, ICPFLO(1,I) is the capacity of edge I. On output, ! ICPFLO(2,I) is the flow on edge I and ICPFLO(1,I) has ! been rearranged to match the reordering of IENDPT. ! ! Input, integer ISORCE, the designated source node. ! ! Input, integer ISINK, the designated sink node. ! ! Output, integer ICUT(NNODE). ICUT(I) = 1 if node I is in the ! minimal cut set, otherwise 0. ! ! Output, integer NODE_FLOW(NNODE). NODE_FLOW(I) is the value of the flow ! through node I. ! implicit none ! integer nedge integer nnode ! integer i integer iarray(nnode) integer icpflo(2,nedge) integer icut(nnode) integer idel integer ien1 integer ien2 integer iendpt(2,nedge) integer indx integer ip integer iparm integer iq integer ir integer iread integer irite integer is integer isink integer isorce integer isort integer it integer iwork(nnode,2) integer j integer kz integer lst integer m integer node_flow(nnode) ! iarray(1:nnode) = 0 idel = 0 do i = 1, nedge icpflo(2,i) = 0 ip = iendpt(1,i) if ( ip == isorce ) then idel = idel + icpflo(1,i) end if iarray(ip) = iarray(ip) + 1 end do node_flow(isorce) = idel is = 1 do i = 1, nnode it = iarray(i) iarray(i) = is iwork(i,1) = is is = is + it end do isort = 0 ien1 = 0 ien2 = 0 10 continue indx = 0 50 continue call sort_heap_external ( nedge, indx, ien1, ien2, is ) if ( indx < 0 ) then is = iendpt(1,ien1) - iendpt(1,ien2) if ( is == 0 ) then is = iendpt(2,ien1) - iendpt(2,ien2) end if else if ( indx > 0 ) then do ir = 1, 2 call i_swap ( iendpt(ir,ien1), iendpt(ir,ien2) ) call i_swap ( icpflo(ir,ien1), icpflo(ir,ien2) ) end do else if ( isort > 0 ) then return end if do i = 1, nedge iq = iendpt(2,i) iendpt(1,i) = iwork(iq,1) iwork(iq,1) = iwork(iq,1) + 1 end do go to 100 end if go to 50 80 continue iendpt(1,iendpt(1,ien1)) = ien2 iendpt(1,iendpt(1,ien2)) = ien1 do ir = 1, 2 call i_swap ( iendpt(ir,ien1), iendpt(ir,ien2) ) call i_swap ( icpflo(ir,ien1), icpflo(ir,ien2) ) end do if ( indx < 0 ) then go to 270 end if if ( indx == 0 ) then go to 170 end if go to 50 100 continue indx = 0 do i = 1, nnode if ( i /= isorce ) then node_flow(i) = 0 end if iwork(i,2) = nedge + 1 if ( i < nnode ) then iwork(i,2) = iarray(i+1) end if icut(i) = 0 end do iread = 0 irite = 1 iwork(1,1) = isorce icut(isorce) = - 1 120 continue iread = iread + 1 if ( iread <= irite ) then ip = iwork(iread,1) lst = iwork(ip,2) - 1 i = iarray(ip) - 1 130 continue i = i + 1 if ( i > lst ) then go to 120 end if iq = iendpt(2,i) idel = icpflo(1,i) - icpflo(2,i) if ( icut(iq) /= 0 .or. idel == 0 ) then go to 130 end if if ( iq /= isink ) then irite = irite + 1 iwork(irite,1) = iq end if icut(iq) = - 1 go to 130 end if if ( icut(isink) == 0 ) then icut(1:nnode) = - icut(1:nnode) do i = 1, nedge ip = iendpt(2,iendpt(1,i)) if ( icpflo(2,i) < 0 ) then node_flow(ip) = node_flow(ip) - icpflo(2,i) end if iendpt(1,i) = ip end do node_flow(isorce) = node_flow(isink) isort = 1 go to 10 end if icut(isink) = 1 160 continue iread = iread - 1 if ( iread == 0 ) then go to 180 end if ip = iwork(iread,1) ien1 = iarray(ip) - 1 ien2 = iwork(ip,2) - 1 170 continue if ( ien1 /= ien2 ) then iq = iendpt(2,ien2) if ( icut(iq) <= 0 .or. icpflo(1,ien2) == icpflo(2,ien2) ) then ien2 = ien2 - 1 go to 170 end if iendpt(2,ien2) = - iq icpflo(1,ien2) = icpflo(1,ien2) - icpflo(2,ien2) icpflo(2,ien2) = 0 ien1 = ien1 + 1 if ( ien1 < ien2 ) then go to 80 end if end if if ( ien1 >= iarray(ip) ) then icut(ip) = ien1 end if go to 160 180 continue kz = 0 do ir = 1, irite if ( icut(iwork(ir,1)) > 0 ) then kz = kz + 1 iwork(kz,1) = iwork(ir,1) end if end do indx = - 1 m = 1 200 continue ip = iwork(m,1) if ( node_flow(ip) > 0 ) then go to 250 end if 210 continue m = m + 1 if ( m <= kz ) then go to 200 end if iparm = 0 220 continue m = m - 1 if ( m == 1 ) then do i = 1, nedge iq = - iendpt(2,i) if ( iq >= 0 ) then iendpt(2,i) = iq j = iendpt(1,i) icpflo(1,i) = icpflo(1,i) - icpflo(2,j) idel = icpflo(2,i) - icpflo(2,j) icpflo(2,i) = idel icpflo(2,j) = - idel end if end do go to 100 end if ip = iwork(m,1) if ( node_flow(ip) < 0 ) then go to 220 end if if ( node_flow(ip) == 0 ) then lst = nedge + 1 if ( ip < nnode ) then lst = iarray(ip+1) end if i = iwork(ip,2) iwork(ip,2) = lst 240 continue if ( i == lst ) then go to 220 end if j = iendpt(1,i) idel = icpflo(2,j) icpflo(2,j) = 0 icpflo(1,j) = icpflo(1,j) - idel icpflo(2,i) = icpflo(2,i) - idel i = i + 1 go to 240 end if if ( iarray(ip) > icut(ip) ) then go to 300 end if 250 continue i = icut(ip) + 1 260 continue i = i - 1 if ( i < iarray(ip) ) then go to 290 end if iq = - iendpt(2,i) if ( node_flow(iq) < 0 ) then go to 260 end if idel = icpflo(1,i) - icpflo(2,i) if ( node_flow(ip) < idel ) then idel = node_flow(ip) end if icpflo(2,i) = icpflo(2,i) + idel node_flow(ip) = node_flow(ip) - idel node_flow(iq) = node_flow(iq) + idel iparm = 1 ien1 = iendpt(1,i) ien2 = iwork(iq,2) - 1 if ( ien1 < ien2 ) then go to 80 end if if ( ien1 /= ien2 ) then go to 280 end if 270 continue iwork(iq,2) = ien2 280 continue if ( node_flow(ip) > 0 ) then go to 260 end if if ( icpflo(1,i) == icpflo(2,i) ) then i = i - 1 end if 290 continue icut(ip) = i if ( iparm /= 0 ) then go to 210 end if 300 continue i = iwork(ip,2) 310 continue j = iendpt(1,i) idel = icpflo(2,j) if ( node_flow(ip) < idel ) then idel = node_flow(ip) end if icpflo(2,j) = icpflo(2,j) - idel node_flow(ip) = node_flow(ip) - idel iq = iendpt(2,i) node_flow(iq) = node_flow(iq) + idel i = i + 1 if ( node_flow(ip) > 0 ) then go to 310 end if node_flow(ip) = - 1 go to 220 end subroutine node_order_print ( nnode, order ) ! !******************************************************************************* ! !! NODE_ORDER_PRINT prints out a node ordering. ! ! ! Modified: ! ! 29 May 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer ORDER(NNODE), the node ordering. ORDER(1) is the label ! of the node which is to be taken as the first node, and so on. ! implicit none ! integer nnode ! integer i integer ihi integer ilo integer inc integer order(nnode) ! inc = 15 do ilo = 1, nnode, inc ihi = min ( ilo + inc - 1, nnode ) write ( *, '(a)' ) ' ' write ( *, '(a6,4x,15i4)' ) 'Order:', ( i, i = ilo, ihi ) write ( *, '(a6,4x,15i4)' ) 'Label:', order(ilo:ihi) end do return end subroutine node_relax ( cor3, cor3_new, cor3_nabe, face, face_order, max_cor3, & max_face, max_order, num_cor3, num_face ) ! !******************************************************************************* ! !! NODE_RELAX smooths a shape by an averaging operation on the node positions. ! ! ! Modified: ! ! 30 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real COR3(3,MAXCOR3), the coordinates of the nodes. ! ! Output, real COR3_NEW(3,MAXCOR3), the new, averaged coordinates of ! the nodes. ! ! Workspace, integer COR3_NABE(MAXCOR3). On output, COR3_NABE(I) ! will contain the number of node neighbors of node I. ! ! Input, integer FACE(MAX_ORDER,MAX_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. ! ! Input, integer FACE_ORDER(MAX_FACE), is the number of nodes ! making up each face. ! ! Input, integer MAX_FACE, the maximum number of faces. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer NUM_FACE, the number of faces. ! implicit none ! integer max_cor3 integer max_face integer max_order ! real cor3(3,max_cor3) real cor3_new(3,max_cor3) integer cor3_nabe(max_cor3) integer face(max_order,max_face) integer face_order(max_face) integer i integer icor3 integer iface integer inode integer ivert integer jnode integer num_cor3 integer num_face ! ! COR3_NEW will contain the new averaged coordinates. ! cor3_nabe(1:num_cor3) = 0 cor3_new(1:3,1:num_cor3) = 0.0E+00 ! ! Consider each edge. Essentially, the edge (I,J) is a signal to ! add the old coordinates of I to the new J coordinates, and vice versa. ! ! Because we are using a face representation, many, perhaps all the ! edges, will show up repeatedly, probably twice. To keep the algorithm ! simple, for now we will simply use an edge every time it shows up ! in a face, which means that edges that occur in multiple faces ! will be weighted more. ! do iface = 1, num_face inode = face(face_order(iface),iface) do ivert = 1, face_order(iface) jnode = inode inode = face(ivert,iface) cor3_nabe(inode) = cor3_nabe(inode) + 1 cor3_nabe(jnode) = cor3_nabe(jnode) + 1 cor3_new(1:3,jnode) = cor3_new(1:3,jnode) + cor3(1:3,inode) cor3_new(1:3,inode) = cor3_new(1:3,inode) + cor3(1:3,jnode) end do end do ! ! Copy the new into the old. ! do icor3 = 1, num_cor3 if ( cor3_nabe(icor3) /= 0 ) then cor3_new(1:3,icor3) = cor3_new(1:3,icor3) / real ( cor3_nabe(icor3) ) end if end do return end subroutine nodes_to_ps ( plotxmin2, plotymin2, alpha, iunit, nnode, x, y, & xmin, ymin ) ! !******************************************************************************* ! !! NODES_TO_PS writes subplot nodes to a PostScript file. ! ! ! Discussion: ! ! A small filled circle is placed at each node. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PLOTXMIN2, PLOTYMIN2, the Postscript point corresponding ! to the physical point XMIN, YMIN. ! ! Input, real ALPHA, the physical-to-Postscript scale factor. ! ! Input, integer IUNIT, the output FORTRAN unit. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real X(NNODE), Y(NNODE), the X and Y components of points. ! ! Input, real XMIN, YMIN, the coordinates of the physical origin. ! implicit none ! integer nnode ! real alpha integer i integer iunit integer plotxmin2 integer plotymin2 integer px1 integer py1 integer, parameter :: rad = 10 real x(nnode) real xmin real y(nnode) real ymin ! ! Draw points. ! do i = 1, nnode px1 = plotxmin2 + nint ( alpha * ( x(i) - xmin ) ) py1 = plotymin2 + nint ( alpha * ( y(i) - ymin ) ) write ( iunit, '(3i4,a)' ) px1, py1, rad, ' 0 360 arc closepath fill' end do return end subroutine object_build ( face, face_object, face_order, face_rank, face_tier, & max_order, num_face, num_object ) ! !******************************************************************************* ! !! OBJECT_BUILD builds edge-connected "objects" out of polygonal faces. ! ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer FACE(MAX_ORDER,NUM_FACE), describes the faces. ! FACE(I,J) is the index of the I-th node in face J. It is best ! if the nodes of all faces are listed in counterclockwise order. ! ! Output, integer FACE_OBJECT(NUM_FACE), describes the objects. ! FACE_OBJECT(I) is the index of the edge-connected "object" to ! which face I belongs. ! ! Input, integer FACE_ORDER(NUM_FACE), is the number of nodes ! making up each face. ! ! Output, integer FACE_RANK(NUM_FACE), is an ordered list of faces. ! FACE_RANK(1) is the index of the face in the first tier of the ! first object, followed by second tier faces, and so on until ! object one is complete. Object two follows, and so on. ! ! Output, integer FACE_TIER(NUM_FACE). FACE_TIER(I) is the "tier" ! of face I in its object. The seed of the object has tier 1, ! the neighbors of the seed have tier 2, and so on. ! ! Input, integer MAX_ORDER, is the maximum number of nodes that can ! make up a face, required to dimension FACE. ! ! Input, integer NUM_FACE, the number of faces. ! ! Output, integer NUM_OBJECT, the number of objects. ! implicit none ! integer max_order integer num_face ! integer face(max_order,num_face) integer face_object(num_face) integer face_order(num_face) integer face_rank(num_face) integer face_tier(num_face) integer i integer iface integer ihi integer ihi_next integer ilo integer ilo_next integer irank integer jface integer num_object integer seed integer tier integer touch ! ! Initialization. ! num_object = 0 if ( num_face <= 0 ) then return end if face_object(1:num_face) = 0 face_rank(1:num_face) = 0 face_tier(1:num_face) = 0 irank = 0 seed = 1 ! ! Begin the next object, seeded with face SEED. ! 10 continue tier = 1 num_object = num_object + 1 irank = irank + 1 face_rank(irank) = seed face_tier(seed) = tier face_object(seed) = num_object ilo = irank ihi = irank ! ! Begin the next tier of faces, which are neighbors of faces we ! found in the previous tier. ! 20 continue tier = tier + 1 ilo_next = ihi + 1 ihi_next = ihi do jface = 1, num_face if ( face_tier(jface) == 0 ) then do i = ilo, ihi iface = face_rank(i) call face_touch ( face, face_order, max_order, num_face, iface, & jface, touch ) if ( touch /= 0 ) then ihi_next = ihi_next + 1 irank = irank + 1 face_rank(irank) = jface face_tier(jface) = tier face_object(jface) = num_object exit end if end do end if end do if ( ihi_next >= ilo_next ) then ilo = ilo_next ihi = ihi_next go to 20 end if ! ! No neighbors were found, so this object is complete. ! Search for an unused face, which will be the seed of the next object. ! do iface = 1, num_face if ( face_tier(iface) == 0 ) then seed = iface go to 10 end if end do return end subroutine perm_cycle ( isig, n, isgn, ncycle, iopt ) ! !******************************************************************************* ! !! PERM_CYCLE analyzes a permutation. ! ! ! Discussion: ! ! The routine will count cycles, find the sign of a permutation, ! and tag a permutation. ! ! Example: ! ! Input: ! ! N = 9 ! IOPT = 1 ! ISIG = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Output: ! ! NCYCLE = 3 ! ISGN = +1 ! ISIG = -2, 3, 9, -6, -7, 8, 5, 4, 1 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 23 July 2000 ! ! Parameters: ! ! Input/output, integer ISIG(N). On input, ISIG describes a ! permutation, in the sense that entry I is to be moved to ISIG(I). ! If IOPT = 0, then ISIG will not be changed by this routine. ! If IOPT = 1, then on output, ISIG will be "tagged". That is, ! one element of every cycle in ISIG will be negated. In this way, ! a user can traverse a cycle by starting at any entry I1 of ISIG ! which is negative, moving to I2 = ABS(ISIG(I1)), then to ! ISIG(I2), and so on, until returning to I1. ! ! Input, integer N, the number of objects being permuted. ! ! Output, integer ISGN, the "sign" of the permutation, which is ! +1 if the permutation is even, -1 if odd. Every permutation ! may be produced by a certain number of pairwise switches. ! If the number of switches is even, the permutation itself is ! called even. ! ! Output, integer NCYCLE, the number of cycles in the permutation. ! ! Input, integer IOPT, requests tagging. ! 0, the permutation will not be tagged. ! 1, the permutation will be tagged. ! implicit none ! integer n ! integer i integer i1 integer i2 integer iopt integer is integer isgn integer isig(n) integer ncycle ! is = 1 ncycle = n do i = 1, n i1 = isig(i) do while ( i1 > i ) ncycle = ncycle - 1 i2 = isig(i1) isig(i1) = - i2 i1 = i2 end do if ( iopt /= 0 ) then is = - isign ( 1, isig(i) ) end if isig(i) = isign ( isig(i), is ) end do isgn = 1 - 2 * mod ( n-ncycle, 2 ) return end subroutine perm_free ( ipart, npart, ifree, nfree ) ! !******************************************************************************* ! !! PERM_FREE reports the number of unused items in a partial permutation. ! ! ! Discussion: ! ! It is assumed that the N objects being permuted are the integers ! from 1 to N, and that IPART contains a "partial" permutation, that ! is, the NPART entries of IPART represent the beginning of a ! permutation of all N items. ! ! The routine returns in IFREE the items that have not been used yet. ! ! Modified: ! ! 02 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IPART(NPART), the partial permutation, which should ! contain, at most once, some of the integers between 1 and ! NPART+NFREE. ! ! Input, integer NPART, the number of entries in IPART. NPART may be 0. ! ! Output, integer IFREE(NFREE), the integers between 1 and NPART+NFREE ! that were not used in IPART. ! ! Input, integer NFREE, the number of integers that have not been ! used in IPART. This is simply N - NPART. NFREE may be zero. ! implicit none ! integer nfree integer npart ! integer i integer ifree(nfree) integer ipart(npart) integer j integer k integer n ! n = npart + nfree if ( npart < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_FREE - Fatal error!' write ( *, '(a)' ) ' NPART < 0.' stop else if ( npart == 0 ) then call ivec_identity ( n, ifree ) else if ( nfree < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_FREE - Fatal error!' write ( *, '(a)' ) ' NFREE < 0.' stop else if ( nfree == 0 ) then return else k = 0 do i = 1, n do j = 1, npart if ( ipart(j) == i ) then go to 10 end if end do k = k + 1 if ( k > nfree ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_FREE - Fatal error!' write ( *, '(a)' ) ' The partial permutation is illegal.' write ( *, '(a)' ) ' It should contain, at most once, some of' write ( *, '(a,i6)' ) ' the integers between 1 and ', n stop end if ifree(k) = i 10 continue end do end if return end subroutine perm_inc ( iperm, ipos, n ) ! !******************************************************************************* ! !! PERM_INC "increments" a permutation to get the "next" one. ! ! ! Discussion: ! ! The routine is given IPERM, a permutation of the numbers from 1 to N, ! and a position IPOS between 1 and N. ! ! It returns the next permutation in the dictionary order which ! comes after all permutations beginning IPERM(1) through IPERM(IPOS). ! ! Examples: ! ! PERM IPOS ! ! Input 123456789 7 ! Output 123456798 7 ! ! Input 123456789 9 ! Output 213456789 0 ! ! Input 134826795 3 ! Output 134925678 3 ! ! Input 134826795 0 ! Output 123456789 0 ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer IPERM(N). ! On input, the current permutation. ! On output, the "incremented" permutation. ! ! Input/output, integer IPOS. ! On input, IPOS is the location of the end of the string of ! "digits" in IPERM that form the test string. That is, the ! new permutation to be computed must be the very next one, ! in dictionary order, which succeeds all strings whose first ! IPOS digits agree with the input value of IPERM. ! ! On output, IPOS is the position of the last digit of the output ! value of IPERM which agrees with the input value of IPERM. ! ! Input, integer N, is the number of entries in IPERM. ! implicit none ! integer n ! integer i integer ipcopy integer iperm(n) integer ipos integer j integer k integer new ! if ( ipos == 0 ) then ipos = n call ivec_identity ( n, iperm ) return end if ipcopy = ipos 10 continue ! ! To get the next permutation, we need to increment the IPOS+1 "digit". ! ! We do this by finding, if possible, a digit in positions IPOS+2 ! through N that is just larger than the current value IPOS+1 digit. ! If we find such a digit, it becomes the IPOS+1 digit, and the ! remaining values are sorted into increasing order. ! new = 0 do j = ipcopy+2, n if ( new == 0 ) then if ( iperm(j) > iperm(ipcopy+1) ) then new = j end if else if ( iperm(j) > iperm(ipcopy+1) .and. iperm(j) < iperm(new) ) then new = j end if end if end do ! ! There is a next candidate that agrees with IPERM through entry I. ! Swap entries IPOS+1 and NEW, and sort the entries (IPOS+2,...,N). ! ! The output value of IPOS equals the input value. ! if ( new /= 0 ) then call i_swap ( iperm(new), iperm(ipcopy+1) ) do j = ipcopy+2, n do k = j+1, n if ( iperm(j) > iperm(k) ) then call i_swap ( iperm(j), iperm(k) ) end if end do end do return end if ! ! There is no next candidate that agrees with IPERM through entry ! IPOS. Can we decrease IPOS and try for a next candidate that way? ! if ( ipcopy > 0 ) then ipcopy = ipcopy - 1 go to 10 end if ! ! IPOS is now zero. There is no successor to the current permutation, ! so we start again at the first permutation. ! ipos = 0 call ivec_identity ( n, iperm ) return end subroutine perm_inv ( n, isig ) ! !******************************************************************************* ! !! PERM_INV inverts a permutation. ! ! ! Modified: ! ! 23 July 2000 ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer ISIG(N). ! ! On input, ISIG describes a permutation. ! ! ISIG is used to represent a permutation by the convention that ! the permutation maps the letter I to ISIG(I). Thus, if ISIG ! contains the values (4, 1, 3, 2), then the permutation ! represented permutes 1 to 4, 2 to 1, 3 to 3, and 4 to 2. ! ! On output, ISIG describes the inverse permutation ! implicit none ! integer n ! integer i integer i0 integer i1 integer i2 integer is integer isig(n) ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INV - Fatal error!' write ( *, '(a,i6)' ) ' Input value of N = ', n stop end if is = 1 do i = 1, n i1 = isig(i) do while ( i1 > i ) i2 = isig(i1) isig(i1) = - i2 i1 = i2 end do is = - isign ( 1, isig(i) ) isig(i) = isign ( isig(i), is ) end do do i = 1, n i1 = - isig(i) if ( i1 >= 0 ) then i0 = i do i2 = isig(i1) isig(i1) = i0 if ( i2 < 0 ) then exit end if i0 = i1 i1 = i2 end do end if end do return end subroutine perm_next ( n, iarray, more, even ) ! !******************************************************************************* ! !! PERM_NEXT computes all of the permutations on N objects, one at a time. ! ! ! Discussion: ! ! If the routine is called with MORE = .TRUE., any permutation in ! IARRAY, and EVEN = .TRUE., then the successor of the input ! permutation will be produced, unless IARRAY is the last permutation ! on N letters, in which case IARRAY(1) will be set to 0 on return. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer IARRAY(N). ! ! If MORE is .TRUE., then IARRAY is assumed to contain the ! "previous" permutation, and on IARRAY(I) is the value ! of the I-th object under the next permutation. ! ! Otherwise, IARRAY(I) will be set to the "first" permutation. ! ! Input/output, logical MORE. ! ! Set MORE to FALSE before first calling this routine. ! ! MORE will be reset to .TRUE. and a permutation will be returned. ! ! Each new call produces a new permutation until ! MORE is returned .FALSE. ! ! Output, logical EVEN. ! ! EVEN is .TRUE. if the output permutation is even, that is, ! involves an even number of transpositions. ! ! EVEN is .FALSE. otherwise. ! implicit none ! integer n ! integer i integer i1 integer ia integer iarray(n) integer id integer is integer j integer l integer m logical more logical even ! if ( .not. more ) then call ivec_identity ( n, iarray ) more = .true. even = .true. if ( n == 1 ) then more = .false. return end if if ( iarray(n) /= 1 .or. iarray(1) /= 2 + mod ( n, 2 ) ) then return end if do i = 1, n-3 if ( iarray(i+1) /= iarray(i)+1 ) then return end if end do more = .false. else if ( n == 1 ) then iarray(1) = 0 more = .false. return end if if ( even ) then ia = iarray(1) iarray(1) = iarray(2) iarray(2) = ia even = .false. if ( iarray(n) /= 1 .or. iarray(1) /= 2 + mod ( n, 2 ) ) then return end if do i = 1, n-3 if ( iarray(i+1) /= iarray(i)+1 ) then return end if end do more = .false. return else is = 0 do i1 = 2, n ia = iarray(i1) i = i1-1 id = 0 do j = 1, i if ( iarray(j) > ia ) then id = id + 1 end if end do is = id + is if ( id /= i * mod ( is, 2 ) ) then go to 10 end if end do iarray(1) = 0 more = .false. return end if 10 continue m = mod ( is+1, 2 ) * (n+1) do j = 1, i if ( isign(1,iarray(j)-ia) /= isign(1,iarray(j)-m) ) then m = iarray(j) l = j end if end do iarray(l) = ia iarray(i1) = m even = .true. end if return end subroutine perm_random ( n, iarray ) ! !******************************************************************************* ! !! PERM_RANDOM selects a random permutation of N objects. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 02 March 1999 ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Output, integer IARRAY(N), the random permutation. ! implicit none ! integer n ! integer i integer iarray(n) integer j ! call ivec_identity ( n, iarray ) do i = 1, n call i_random ( i, n, j ) call i_swap ( iarray(j), iarray(i) ) end do return end subroutine poly ( n, iarray, ix0, iopt, ival ) ! !******************************************************************************* ! !! POLY performs operations on polynomials in power or factorial form. ! ! ! Definition: ! ! The power sum form of a polynomial is ! ! P(X) = A1+A2*X+A3*X**2+...+(AN+1)*X**N ! ! The Taylor expansion at C has the form ! ! P(X) = A1+A2*(X-C)+A3*(X-C)**2+...+(AN+1)*(X-C)**N ! ! The factorial form of a polynomial is ! ! P(X) = A1+A2*X+A3*(X)*(X-1)+A4*(X)*(X-1)*(X-2)+... ! +(AN+1)*(X)*(X-1)*...*(X-N+1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of coefficients in the polynomial ! (in other words, the polynomial degree + 1) ! ! Input, integer IOPT, a flag describing which algorithm is to ! be carried out: ! ! -3: Reverse Stirling. Input the coefficients of ! the polynomial in factorial form, output them in ! power sum form. ! ! -2: Stirling. Input the coefficients in power sum ! form, output them in factorial form. ! ! -1: Evaluate a polynomial which has been input ! in factorial form. ! ! 0: Evaluate a polynomial input in power sum form. ! ! 1 or more: Given the coefficients of a polynomial in ! power sum form, compute the first IOPT coefficients of ! the polynomial in Taylor expansion form. ! ! Input, integer IX0, for IOPT = -1, 0, or positive, the value X of the ! argument at which the polynomial is to be evaluated, or the ! Taylor expansion is to be carried out. ! ! Output, integer IVAL, for IOPT = -1 or 0, the value of the ! polynomial at the point IX0. ! ! Input, integer IARRAY(N). Contains the coefficients of the ! polynomial. Depending on the option chosen, these coefficients may ! be overwritten by those of a different form of the polynomial. ! implicit none ! integer n ! integer i integer iarray(n) integer ieps integer iopt integer ival integer iw integer ix0 integer iz integer m integer n1 ! n1 = min ( n, iopt ) n1 = max ( 1, n1 ) if ( iopt < -1 ) then n1 = n end if ieps = mod ( max ( -iopt, 0 ), 2 ) iw = -n * ieps if ( iopt > -2 ) then iw = iw + ix0 end if do m = 1, n1 ival = 0 iz = iw do i = m, n iz = iz + ieps ival = iarray(n+m-i) + iz * ival if ( iopt /= 0 .and. iopt /= -1 ) then iarray(n+m-i) = ival end if end do if ( iopt < 0 ) then iw = iw + 1 end if end do return end subroutine poly_to_tri ( face, ierror, max_face, max_vert, num_face, num_vert ) ! !******************************************************************************* ! !! POLY_TO_TRI converts a collection of polygons into a collection of triangles. ! ! ! Modified: ! ! 22 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer FACE(MAX_VERT,MAX_FACE), describes the faces. ! FACE(I,J) is the I-th node associated with the J-th face. ! This array is updated on return. ! ! Output, integer IERROR, error flag. ! 0, no error. ! 1, the algorithm failed because MAX_FACE was too small. ! 2, the algorithm failed because there were faces of order < 3. ! 3, the algorithm failed because there were faces of order > MAX_VERT. ! ! Input, integer MAX_FACE, the maximum number of faces allowed. ! ! Input, integer MAX_VERT, the maximum number of nodes allowed per face. ! ! Input/output, integer NUM_FACE, the number of faces. This value is updated ! on return. ! ! Input/output, integer NUM_VERT(MAX_FACE), the number of nodes ! associated with each face. On successful return, every entry of ! this array will be 3. ! implicit none ! integer max_face integer max_vert ! integer face(max_vert,max_face) integer ierror integer iface integer iface_old integer ivert integer k integer num_face integer num_face2 integer num_vert(max_face) ! ierror = 0 num_face2 = 0 do iface = 1, num_face if ( num_vert(iface) < 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POLY_TO_TRI - Fatal error!' write ( *, '(a,i6)' ) ' Illegal face ', iface write ( *, '(a,i6)' ) ' Number of nodes is ', num_vert(iface) ierror = 2 return else if ( num_vert(iface) > max_vert ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POLY_TO_TRI - Fatal error!' write ( *, '(a,i6)' ) ' Illegal face ', iface write ( *, '(a,i6)' ) ' Number of nodes is ', num_vert(iface) write ( *, '(a,i6)' ) ' MAX_VERT is ', max_vert ierror = 3 return end if do ivert = 3, num_vert(iface) num_face2 = num_face2 + 1 end do end do if ( num_face2 > max_face ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POLY_TO_TRI - Fatal error!' write ( *, '(a)' ) ' MAX_FACE is too small to replace all faces' write ( *, '(a)' ) ' by triangles.' write ( *, '(a,i6)' ) ' MAX_FACE = ', max_face write ( *, '(a,i6)' ) ' NUM_FACE2 = ', num_face2 ierror = 1 return end if iface_old = num_face k = num_vert(iface_old) do iface = num_face2, 1, -1 if ( k < 3 ) then iface_old = iface_old - 1 k = num_vert(iface_old) end if num_vert(iface) = 3 face(1,iface) = face(1,iface_old) do ivert = 2, 3 face(ivert,iface) = face(k+ivert-3,iface_old) end do k = k - 1 end do num_face = num_face2 return end subroutine pruefer_to_tree_arc ( nnode, iarray, inode, jnode ) ! !******************************************************************************* ! !! PRUEFER_TO_TREE_ARC is given a Pruefer code, and computes the tree. ! ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 26 October 1999 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer IARRAY(NNODE-2), the Pruefer code of the tree. ! ! Output, integer INODE(NNODE-1), JNODE(NNODE-1), the edge array of the ! tree. The I-th edge joins nodes INODE(I) and JNODE(I). ! implicit none ! integer nnode ! integer i integer iarray(nnode-2) integer ii integer inode(nnode-1) integer iwork(nnode) integer j integer jnode(nnode-1) ! ! Initialize IWORK(I) to count the number of neighbors of node I. ! The Pruefer code uses each node one less time than its total ! number of neighbors. ! iwork(1:nnode) = 1 do i = 1, nnode-2 iwork(iarray(i)) = iwork(iarray(i)) + 1 end do ! ! Now process each entry in the Pruefer code. ! do i = 1, nnode-2 ii = 0 do j = 1, nnode if ( iwork(j) == 1 ) then ii = j end if end do inode(i) = ii jnode(i) = iarray(i) iwork(ii) = 0 iwork(iarray(i)) = iwork(iarray(i)) - 1 end do inode(nnode-1) = iarray(nnode-2) if ( iarray(nnode-2) /= 1 ) then jnode(nnode-1) = 1 else jnode(nnode-1) = 2 end if return end subroutine pruefer_to_tree_2 ( nnode, iarray, itree ) ! !******************************************************************************* ! !! PRUEFER_TO_TREE_2 produces the edge list of a tree from its Pruefer code. ! ! ! Modified: ! ! 15 April 1999 ! ! Discussion: ! ! One can thus exhibit all trees on N nodes, produce ! one at random, find the M-th one on the list, etc, by ! manipulating the Pruefer codes. ! ! For every labeled tree on N nodes, there is a unique N-2 tuple ! of integers A1 through AN-2, with each A between 1 and N. There ! are N**(N-2) such sequences, and each one is associated with exactly ! one tree. ! ! Warning: ! ! This routine apparently assumes that the Pruefer code is ! generated by taking the LOWEST labeled terminal node each time. ! This is not consistent with PRUEFER_TO_TREE and TREE_TO_PRUEFER. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Parameters: ! ! Input, integer NNODE, number of nodes in desired tree. ! ! Output, integer IARRAY(NNODE). IARRAY(I), I = 1, NNODE-2 is the Pruefer ! code for the tree. ! ! Output, integer ITREE(NNODE); the I-th edge of the tree joins nodes ! I and ITREE(I). ! implicit none ! integer nnode ! integer i integer ir integer itree(nnode) integer iarray(nnode) integer j integer k integer kp integer l ! itree(1:nnode) = 0 do i = nnode-2, 1, -1 l = iarray(i) if ( itree(l) == 0 ) then iarray(i) = - l itree(l) = - 1 end if end do iarray(nnode-1) = nnode ! ! Find next index K so that ITREE(K) is 0. ! k = 1 j = 0 10 continue do while ( itree(k) /= 0 ) k = k + 1 end do kp = k 20 continue j = j + 1 ir = abs ( iarray(j) ) itree(kp) = ir if ( j /= nnode-1 ) then if ( iarray(j) > 0 ) then go to 10 end if if ( ir > k ) then itree(ir) = 0 go to 10 end if kp = ir go to 20 end if ! ! Restore the signs of IARRAY. ! iarray(1:nnode-2) = abs ( iarray(1:nnode-2) ) return end function pythag ( a, b ) ! !******************************************************************************* ! !! PYTHAG computes SQRT ( A**2 + B**2 ) carefully. ! ! ! Discussion: ! ! The formula ! ! PYTHAG = sqrt ( A**2 + B**2 ) ! ! is reasonably accurate, but the formula can actually fail if ! for example, A**2 is larger than the machine overflow. The ! formula can lose most of its accuracy if the sum of the squares ! is very large or very small. ! ! Reference: ! ! J H Wilkinson and C Reinsch, ! Handbook for Automatic Computation, ! Volume II, Linear Algebra, Part 2, ! Springer Verlag, 1971. ! ! B Smith, J Boyle, J Dongarra, B Garbow, Y Ikebe, V Klema, C Moler, ! Matrix Eigensystem Routines, EISPACK Guide, ! Lecture Notes in Computer Science, Volume 6, ! Springer Verlag, 1976. ! ! Modified: ! ! 02 March 2000 ! ! Parameters: ! ! Input, real A, B, the two legs of a right triangle. ! ! Output, real PYTHAG, the length of the hypotenuse. ! implicit none ! real a real b real p real pythag real r real s real t real u ! p = max ( abs ( a ), abs ( b ) ) if ( p /= 0.0E+00 ) then r = ( min ( abs ( a ), abs ( b ) ) / p )**2 10 continue t = 4.0E+00 + r if ( t /= 4.0E+00 ) then s = r / t u = 1.0E+00 + 2.0E+00 * s p = u * p r = ( s / u )**2 * r go to 10 end if end if pythag = p return end subroutine r_random ( rlo, rhi, r ) ! !******************************************************************************* ! !! R_RANDOM returns a random real in a given range. ! ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RLO, RHI, the minimum and maximum values. ! ! Output, real R, the randomly chosen value. ! implicit none ! logical, save :: seed = .false. real r real rhi real rlo real t ! if ( .not. seed ) then call random_seed seed = .true. end if ! ! Pick a random number in (0,1). ! call random_number ( harvest = t ) ! ! Set R. ! r = ( 1.0E+00 - t ) * rlo + t * rhi return end subroutine r_swap ( x, y ) ! !******************************************************************************* ! !! R_SWAP swaps two real values. ! ! ! Modified: ! ! 01 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none ! real x real y real z ! z = x x = y y = z return end subroutine rcol_find ( lda, m, n, a, x, icol ) ! !******************************************************************************* ! !! RCOL_FIND seeks a table column equal to a real vector. ! ! ! Example: ! ! Input: ! ! M = 3, ! N = 4, ! ! A = ( ! 1. 2. 3. 4. ! 5. 6. 7. 8. ! 9. 10. 11. 12. ) ! ! x = ( 3., ! 7., ! 11. ) ! ! Output: ! ! ICOL = 3 ! ! Modified: ! ! 01 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array, ! which must be at least M. ! ! Input, integer M, N, the number of rows and columns. ! ! Input, real A(LDA,N), a table of numbers, regarded as ! N columns of vectors of length M. ! ! Input, real X(M), a vector to be matched with a column of A. ! ! Output, integer ICOL, the index of the first column of A ! which exactly matches every entry of X, or 0 if no match ! could be found. ! implicit none ! integer lda integer m integer n ! real a(lda,n) integer i integer icol integer j real x(m) ! icol = 0 do j = 1, n icol = j do i = 1, m if ( x(i) /= a(i,j) ) then icol = 0 exit end if end do if ( icol /= 0 ) then return end if end do return end subroutine rmat_print ( a, ihi, ilo, jhi, jlo, lda, ncol, nrow ) ! !******************************************************************************* ! !! RMAT_PRINT prints out a portion of a dense matrix. ! ! ! Modified: ! ! 01 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real A(LDA,NCOL), an NROW by NCOL matrix to be printed. ! ! Input, integer IHI, ILO, the first and last rows to print. ! ! Input, integer JHI, JLO, the first and last columns to print. ! ! Input, integer LDA, the leading dimension of A. ! ! Input, integer NCOL, NROW, the number of rows and columns ! in the matrix A. ! implicit none ! integer, parameter :: incx = 5 ! integer lda integer ncol ! real a(lda,ncol) character ctemp(incx)*14 integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo integer nrow ! write ( *, '(a)' ) ' ' do j2lo = jlo, jhi, incx j2hi = j2lo + incx - 1 j2hi = min ( j2hi, ncol ) j2hi = min ( j2hi, jhi ) inc = j2hi + 1 - j2lo write ( *, '(a)' ) ' ' do j = j2lo, j2hi j2 = j + 1 - j2lo write ( ctemp(j2), '(i7,7x)' ) j end do write ( *, '(''Columns '',5a14)' ) ( ctemp(j2), j2 = 1, inc ) write ( *, '(a)' ) ' Row' write ( *, '(a)' ) ' ' i2lo = max ( ilo, 1 ) i2hi = min ( ihi, nrow ) do i = i2lo, i2hi do j2 = 1, inc j = j2lo - 1 + j2 if ( a(i,j) == 0.0E+00 ) then ctemp(j2) = ' 0.0' else write ( ctemp(j2), '(g14.6)' ) a(i,j) end if end do write ( *, '(i5,1x,5a14)' ) i, ctemp(1:inc) end do end do write ( *, '(a)' ) ' ' return end subroutine rvec_print ( n, a, title ) ! !******************************************************************************* ! !! RVEC_PRINT prints a real vector. ! ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, real A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! real a(n) integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,g14.6)' ) i, a(i) end do return end subroutine rvec_random ( n, a, alo, ahi ) ! !******************************************************************************* ! !! RVEC_RANDOM returns a random real vector in a given range. ! ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Output, real A(N), the vector of randomly chosen values. ! ! Input, real ALO, AHI, the range allowed for the entries. ! implicit none ! integer n ! real a(n) real ahi real alo integer i ! do i = 1, n call r_random ( alo, ahi, a(i) ) end do return end subroutine rvec2_print ( n, a1, a2, title ) ! !******************************************************************************* ! !! RVEC2_PRINT prints a pair of real vectors. ! ! ! Modified: ! ! 14 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, real A1(N), A2(N), the vectors to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! real a1(n) real a2(n) integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,2g14.6)' ) i, a1(i), a2(i) end do return end function rvec3_compare ( x1, y1, z1, x2, y2, z2 ) ! !******************************************************************************* ! !! RVEC3_COMPARE compares two R3 vectors. ! ! ! Modified: ! ! 10 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X1, Y1, Z1, the first vector. ! ! Input, real X2, Y2, Z2, the second vector. ! ! Output, character RVEC3_COMPARE: '<', '>' or '=' if the first vector ! is less, greater or equal to the second. ! implicit none ! character c character rvec3_compare real x1 real x2 real y1 real y2 real z1 real z2 ! if ( x1 < x2 ) then c = '<' else if ( x1 > x2 ) then c = '>' else if ( y1 < y2 ) then c = '<' else if ( y1 > y2 ) then c = '>' else if ( z1 < z2 ) then c = '<' else if ( z1 > z2 ) then c = '>' else c = '=' end if rvec3_compare = c return end subroutine rvec3_index_insert_unique ( maxn, n, x, y, z, indx, & xval, yval, zval, ival, ierror ) ! !******************************************************************************* ! !! RVEC3_INDEX_INSERT_UNIQUE inserts a unique R3 value in an indexed sorted list. ! ! ! Modified: ! ! 11 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXN, the maximum size of the list. ! ! Input/output, integer N, the size of the list. ! ! Input/output, real X(N), Y(N), Z(N), the list of R3 vectors. ! ! Input, integer INDX(N), the sort index of the list. ! ! Input, real XVAL, YVAL, ZVAL, the value to be inserted if it is ! not already in the list. ! ! Output, integer IVAL, the index in INDX corresponding to the ! value XVAL, YVAL, ZVAL. ! ! Output, integer IERROR, 0 for no error, 1 if an error occurred. ! implicit none ! integer maxn ! integer equal integer ierror integer indx(maxn) integer ival integer less integer more integer n real x(maxn) real xval real y(maxn) real yval real z(maxn) real zval ! ierror = 0 if ( n <= 0 ) then if ( maxn <= 0 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RVEC3_INDEX_INSERT_UNIQUE - Fatal error!' write ( *, '(a)' ) ' Not enough space to store new data.' return end if n = 1 x(1) = xval y(1) = yval z(1) = zval indx(1) = 1 ival = 1 return end if ! ! Does ( XVAL, YVAL, ZVAL ) already occur in ( X, Y, Z)? ! call rvec3_index_search ( maxn, n, x, y, z, indx, xval, yval, zval, & less, equal, more ) if ( equal == 0 ) then if ( n >= maxn ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RVEC3_INDEX_INSERT_UNIQUE - Fatal error!' write ( *, '(a)' ) ' Not enough space to store new data.' return end if x(n+1) = xval y(n+1) = yval z(n+1) = zval ival = more indx(n+1:more+1:-1) = indx(n:more:-1) indx(more) = n + 1 n = n + 1 else ival = equal end if return end subroutine rvec3_index_search ( maxn, n, x, y, z, indx, xval, yval, & zval, less, equal, more ) ! !******************************************************************************* ! !! RVEC3_INDEX_SEARCH searches for an R3 value in an indexed sorted list. ! ! ! Modified: ! ! 11 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MAXN, the maximum size of the list. ! ! Input, integer N, the size of the current list. ! ! Input, real X(N), Y(N), Z(N), the list. ! ! Input, integer INDX(N), the sort index of the list. ! ! Input, real XVAL, YVAL, ZVAL, the value to be sought. ! ! Output, integer LESS, EQUAL, MORE, the indexes in INDX of the ! entries of X that are just less than, equal to, and just greater ! than XVAL. If XVAL does not occur in X, then EQUAL is zero. ! If XVAL is the minimum entry of X, then LESS is 0. If XVAL ! is the greatest entry of X, then MORE is N+1. ! implicit none ! integer maxn ! character c integer equal integer hi integer indx(maxn) integer less integer lo integer mid integer more integer n character rvec3_compare real x(maxn) real xhi real xlo real xmid real xval real y(maxn) real yhi real ylo real ymid real yval real z(maxn) real zhi real zlo real zmid real zval ! if ( n <= 0 ) then less = 0 equal = 0 more = 0 return end if lo = 1 hi = n xlo = x(indx(lo)) ylo = y(indx(lo)) zlo = z(indx(lo)) xhi = x(indx(hi)) yhi = y(indx(hi)) zhi = z(indx(hi)) c = rvec3_compare ( xval, yval, zval, xlo, ylo, zlo ) if ( c == '<' ) then less = 0 equal = 0 more = 1 return else if ( c == '=' ) then less = 0 equal = 1 more = 2 return end if c = rvec3_compare ( xval, yval, zval, xhi, yhi, zhi ) if ( c == '>' ) then less = n equal = 0 more = n + 1 return else if ( c == '=' ) then less = n - 1 equal = n more = n + 1 return end if do if ( lo + 1 == hi ) then less = lo equal = 0 more = hi return end if mid = ( lo + hi ) / 2 xmid = x(indx(mid)) ymid = y(indx(mid)) zmid = z(indx(mid)) c = rvec3_compare ( xval, yval, zval, xmid, ymid, zmid ) if ( c == '=' ) then equal = mid less = equal - 1 more = equal + 1 return else if ( c == '<' ) then hi = mid else if ( c == '>' ) then lo = mid end if end do return end subroutine s_blanks_delete ( s ) ! !******************************************************************************* ! !! S_BLANKS_DELETE replaces consecutive blanks by one blank. ! ! ! Discussion: ! ! The remaining characters are left justified and right padded with blanks. ! TAB characters are converted to spaces. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i integer j character newchr character oldchr character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! j = 0 newchr = ' ' do i = 1, len ( s ) oldchr = newchr newchr = s(i:i) if ( newchr == TAB ) then newchr = ' ' end if s(i:i) = ' ' if ( oldchr /= ' ' .or. newchr /= ' ' ) then j = j + 1 s(j:j) = newchr end if end do return end subroutine s_cat ( s1, s2, s3 ) ! !******************************************************************************* ! !! S_CAT concatenates two strings to make a third string. ! ! ! Modified: ! ! 11 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, the "prefix" string. ! ! Input, character ( len = * ) S2, the "postfix" string. ! ! Output, character ( len = * ) S3, the string made by ! concatenating S1 and S2, ignoring any trailing blanks. ! implicit none ! character ( len = * ) s1 character ( len = * ) s2 character ( len = * ) s3 ! s3 = trim ( s1 ) // trim ( s2 ) return end function s_eqi ( strng1, strng2 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRNG1, STRNG2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none ! integer i integer len1 integer len2 integer lenc logical s_eqi character s1 character s2 character ( len = * ) strng1 character ( len = * ) strng2 ! len1 = len ( strng1 ) len2 = len ( strng2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc s1 = strng1(i:i) s2 = strng2(i:i) call ch_cap ( s1 ) call ch_cap ( s2 ) if ( s1 /= s2 ) then return end if end do do i = lenc + 1, len1 if ( strng1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( strng2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end subroutine s_to_i ( string, ival, ierror, last ) ! !******************************************************************************* ! !! S_TO_I reads an integer value from a string. ! ! ! Modified: ! ! 28 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) STRING, a string to be examined. ! ! Output, integer IVAL, the integer value read from the string. ! If STRING is blank, then IVAL will be returned 0. ! ! Output, integer IERROR, an error flag. ! 0, no error. ! 1, an error occurred. ! ! Output, integer LAST, the last character in STRING that was ! part of the representation of IVAL. ! implicit none ! character c integer i integer ierror integer isgn integer istate integer ival integer last integer lens character ( len = * ) string ! ierror = 0 istate = 0 isgn = 1 ival = 0 lens = len ( string ) i = 0 do i = i + 1 c = string(i:i) if ( istate == 0 ) then if ( c == ' ' ) then else if ( c == '-' ) then istate = 1 isgn = -1 else if ( c == '+' ) then istate = 1 isgn = + 1 else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if else if ( istate == 1 ) then if ( c == ' ' ) then else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then istate = 2 ival = ichar ( c ) - ichar ( '0' ) else ierror = 1 return end if else if ( istate == 2 ) then if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then ival = 10 * ival + ichar ( c ) - ichar ( '0' ) else istate = 3 end if end if ! ! Continue or exit? ! if ( istate == 3 ) then ival = isgn * ival last = i - 1 return else if ( i >= lens ) then if ( istate == 2 ) then ival = isgn * ival last = lens else ierror = 1 last = 0 end if return end if end do return end subroutine s_to_r ( s, r, ierror, lchar ) ! !******************************************************************************* ! !! S_TO_R reads a real number from a string. ! ! ! Discussion: ! ! This routine will read as many characters as possible until it reaches ! the end of the string, or encounters a character which cannot be ! part of the real number. ! ! Legal input is: ! ! 1 blanks, ! 2 '+' or '-' sign, ! 2.5 spaces ! 3 integer part, ! 4 decimal point, ! 5 fraction part, ! 6 'E' or 'e' or 'D' or 'd', exponent marker, ! 7 exponent sign, ! 8 exponent integer part, ! 9 exponent decimal point, ! 10 exponent fraction part, ! 11 blanks, ! 12 final comma or semicolon. ! ! with most quantities optional. ! ! Examples: ! ! S R ! ! '1' 1.0 ! ' 1 ' 1.0 ! '1A' 1.0 ! '12,34,56' 12.0 ! ' 34 7' 34.0 ! '-1E2ABCD' -100.0 ! '-1X2ABCD' -1.0 ! ' 2E-1' 0.2 ! '23.45' 23.45 ! '-4.2E+2' -420.0 ! '17d2' 1700.0 ! '-14e-2' -0.14 ! 'e2' 100.0 ! '-12.73e-9.23' -12.73 * 10.0**(-9.23) ! ! Modified: ! ! 12 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S, the string containing the ! data to be read. Reading will begin at position 1 and ! terminate at the end of the string, or when no more ! characters can be read to form a legal real. Blanks, ! commas, or other nonnumeric data will, in particular, ! cause the conversion to halt. ! ! Output, real R, the real value that was read from the string. ! ! Output, integer IERROR, error flag. ! ! 0, no errors occurred. ! ! 1, 2, 6 or 7, the input number was garbled. The ! value of IERROR is the last type of input successfully ! read. For instance, 1 means initial blanks, 2 means ! a plus or minus sign, and so on. ! ! Output, integer LCHAR, the number of characters read from ! the string to form the number, including any terminating ! characters such as a trailing comma or blanks. ! implicit none ! logical ch_eqi character c integer ierror integer ihave integer isgn integer iterm integer jbot integer jsgn integer jtop integer lchar integer nchar integer ndig real r real rbot real rexp real rtop character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! nchar = len_trim ( s ) ierror = 0 r = 0.0E+00 lchar = - 1 isgn = 1 rtop = 0.0E+00 rbot = 1.0E+00 jsgn = 1 jtop = 0 jbot = 1 ihave = 1 iterm = 0 do lchar = lchar + 1 c = s(lchar+1:lchar+1) ! ! Blank or TAB character. ! if ( c == ' ' .or. c == TAB ) then if ( ihave == 2 ) then else if ( ihave == 6 .or. ihave == 7 ) then iterm = 1 else if ( ihave > 1 ) then ihave = 11 end if ! ! Comma. ! else if ( c == ',' .or. c == ';' ) then if ( ihave /= 1 ) then iterm = 1 ihave = 12 lchar = lchar + 1 end if ! ! Minus sign. ! else if ( c == '-' ) then if ( ihave == 1 ) then ihave = 2 isgn = - 1 else if ( ihave == 6 ) then ihave = 7 jsgn = - 1 else iterm = 1 end if ! ! Plus sign. ! else if ( c == '+' ) then if ( ihave == 1 ) then ihave = 2 else if ( ihave == 6 ) then ihave = 7 else iterm = 1 end if ! ! Decimal point. ! else if ( c == '.' ) then if ( ihave < 4 ) then ihave = 4 else if ( ihave >= 6 .and. ihave <= 8 ) then ihave = 9 else iterm = 1 end if ! ! Exponent marker. ! else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then if ( ihave < 6 ) then ihave = 6 else iterm = 1 end if ! ! Digit. ! else if ( ihave < 11 .and. lge ( c, '0' ) .and. lle ( c, '9' ) ) then if ( ihave <= 2 ) then ihave = 3 else if ( ihave == 4 ) then ihave = 5 else if ( ihave == 6 .or. ihave == 7 ) then ihave = 8 else if ( ihave == 9 ) then ihave = 10 end if call ch_to_digit ( c, ndig ) if ( ihave == 3 ) then rtop = 10.0E+00 * rtop + real ( ndig ) else if ( ihave == 5 ) then rtop = 10.0E+00 * rtop + real ( ndig ) rbot = 10.0E+00 * rbot else if ( ihave == 8 ) then jtop = 10 * jtop + ndig else if ( ihave == 10 ) then jtop = 10 * jtop + ndig jbot = 10 * jbot end if ! ! Anything else is regarded as a terminator. ! else iterm = 1 end if ! ! If we haven't seen a terminator, and we haven't examined the ! entire string, go get the next character. ! if ( iterm == 1 .or. lchar+1 >= nchar ) then exit end if end do ! ! If we haven't seen a terminator, and we have examined the ! entire string, then we're done, and LCHAR is equal to NCHAR. ! if ( iterm /= 1 .and. lchar+1 == nchar ) then lchar = nchar end if ! ! Number seems to have terminated. Have we got a legal number? ! Not if we terminated in states 1, 2, 6 or 7! ! if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then ierror = ihave return end if ! ! Number seems OK. Form it. ! if ( jtop == 0 ) then rexp = 1.0E+00 else if ( jbot == 1 ) then rexp = 10.0E+00**( jsgn * jtop ) else rexp = jsgn * jtop rexp = rexp / jbot rexp = 10.0E+00**rexp end if end if r = isgn * rexp * rtop / rbot return end subroutine sge_check ( lda, m, n, ierror ) ! !******************************************************************************* ! !! SGE_CHECK checks the dimensions of a general matrix. ! ! ! Modified: ! ! 11 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array. ! LDA must be at least M. ! ! Input, integer M, the number of rows of the matrix. ! M must be positive. ! ! Input, integer N, the number of columns of the matrix. ! N must be positive. ! ! Output, integer IERROR, reports whether any errors were detected. ! IERROR is set to 0 before the checks are made, and then: ! IERROR = IERROR + 1 if LDA is illegal; ! IERROR = IERROR + 2 if M is illegal; ! IERROR = IERROR + 4 if N is illegal. ! implicit none ! integer ierror integer lda integer m integer n ! ierror = 0 if ( lda < m ) then ierror = ierror + 1 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'SGE_CHECK - Illegal LDA = ', lda end if if ( m < 1 ) then ierror = ierror + 2 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'SGE_CHECK - Illegal M = ', m end if if ( n < 1 ) then ierror = ierror + 4 write ( *, '(a)' ) ' ' write ( *, '(a,i6)' ) 'SGE_CHECK - Illegal N = ', n end if return end subroutine sge_det ( lda, n, a, ipivot, det ) ! !******************************************************************************* ! !! SGE_DET computes the determinant of a matrix factored by SGE_FA or SGE_TRF. ! ! ! Modified: ! ! 19 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array. ! LDA must be at least N. ! ! Input, integer N, the order of the matrix. ! N must be positive. ! ! Input, real A(LDA,N), the LU factors computed by SGE_FA or SGE_TRF. ! ! Input, integer IPIVOT(N), as computed by SGE_FA or SGE_TRF. ! ! Output, real DET, the determinant of the matrix. ! implicit none ! integer lda integer n ! real a(lda,n) real det integer i integer ierror integer ipivot(n) ! ! Check the dimensions. ! call sge_check ( lda, n, n, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SGE_DET - Fatal error!' write ( *, '(a)' ) ' Illegal dimensions.' return end if det = 1.0E+00 do i = 1, n det = det * a(i,i) end do do i = 1, n if ( ipivot(i) /= i ) then det = - det end if end do return end subroutine sge_fa ( lda, n, a, ipivot, info ) ! !******************************************************************************* ! !! SGE_FA factors a general matrix. ! ! ! Note: ! ! SGE_FA is a simplified version of the LINPACK routine SGEFA. ! ! Modified: ! ! 26 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer LDA, the leading dimension of the array. ! LDA must be at least N. ! ! Input, integer N, the order of the matrix. ! N must be positive. ! ! Input/output, real A(LDA,N), the matrix to be factored. ! On output, A contains an upper triangular matrix and the multipliers ! which were used to obtain it. The factorization can be written ! A = L * U, where L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! Output, integer IPIVOT(N), a vector of pivot indices. ! ! Output, integer INFO, singularity flag. ! 0, no singularity detected. ! nonzero, the factorization failed on the INFO-th step. ! implicit none ! integer lda integer n ! real a(lda,n) integer i integer ierror integer info integer ipivot(n) integer j integer k integer l real t ! ! Check the dimensions. ! call sge_check ( lda, n, n, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SGE_FA - Fatal error!' write ( *, '(a)' ) ' Illegal dimensions.' return end if info = 0 do k = 1, n-1 ! ! Find L, the index of the pivot row. ! l = k do i = k+1, n if ( abs ( a(i,k) ) > abs ( a(l,k) ) ) then l = i end if end do ipivot(k) = l ! ! If the pivot index is zero, the algorithm has failed. ! if ( a(l,k) == 0.0E+00 ) then info = k write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SGE_FA - Fatal error!' write ( *, '(a,i6)' ) ' Zero pivot on step ', info return end if ! ! Interchange rows L and K if necessary. ! if ( l /= k ) then call r_swap ( a(l,k), a(k,k) ) end if ! ! Normalize the values that lie below the pivot entry A(K,K). ! a(k+1:n,k) = -a(k+1:n,k) / a(k,k) ! ! Row elimination with column indexing. ! do j = k+1, n if ( l /= k ) then call r_swap ( a(l,j), a(k,j) ) end if a(k+1:n,j) = a(k+1:n,j) + a(k+1:n,k) * a(k,j) end do end do ipivot(n) = n if ( a(n,n) == 0.0E+00 ) then info = n write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SGE_FA - Fatal error!' write ( *, '(a,i6)' ) ' Zero pivot on step ', info end if return end subroutine shape_2d_edges_to_ps ( plotxmin2, plotymin2, alpha, iunit, & max_order, nface, nnode, face, face_order, x, y, xmin, ymin ) ! !******************************************************************************* ! !! SHAPE_2D_EDGES_TO_PS writes 2D shape edges to a PostScript file. ! ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PLOTXMIN2, PLOTYMIN2, the Postscript origin. ! ! Input, real ALPHA, the physical-to-Postscript scale factor. ! ! Input, integer IUNIT, the output FORTRAN unit. ! ! Input, integer MAX_ORDER, the maximum number of nodes per face. ! ! Input, integer NFACE, the number of faces. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer FACE(MAX_ORDER,NFACE), the nodes making faces. ! ! Input, integer FACE_ORDER(NFACE), the number of nodes per face. ! ! Input, real X(NNODE), Y(NNODE), the X and Y components of points. ! ! Input, real XMIN, YMIN, the physical origin. ! implicit none ! integer max_order integer nface integer nnode ! real alpha integer face(max_order,nface) integer face_order(nface) integer iface integer iunit integer j integer node integer plotxmin2 integer plotymin2 integer px integer py real x(nnode) real xmin real y(nnode) real ymin ! ! Draw faces and fill them. ! do iface = 1, nface write ( iunit, '(a)' ) 'newpath' node = face(face_order(iface),iface) px = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) write ( iunit, '(2i4,a,2i4,a)' ) px, py, ' moveto ' do j = 1, face_order(iface) node = face(j,iface) px = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) write ( iunit, '(2i4,a,2i4,a)' ) px, py, ' lineto ' end do write ( iunit, '(a)' ) 'stroke' ! write ( iunit, '(a)' ) 'fill' end do return end subroutine shape_2d_faces_to_ps ( plotxmin2, plotymin2, alpha, iunit, & max_order, nface, nnode, face, face_order, x, y, xmin, ymin ) ! !******************************************************************************* ! !! SHAPE_2D_FACES_TO_PS writes 2D shape faces to a PostScript file. ! ! ! Modified: ! ! 10 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PLOTXMIN2, PLOTYMIN2, the Postscript origin. ! ! Input, real ALPHA, the physical-to-Postscript scale factor. ! ! Input, integer IUNIT, the output FORTRAN unit. ! ! Input, integer MAX_ORDER, the maximum number of nodes per face. ! ! Input, integer NFACE, the number of faces. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer FACE(MAX_ORDER,NFACE), the nodes making faces. ! ! Input, integer FACE_ORDER(NFACE), the number of nodes per face. ! ! Input, real X(NNODE), Y(NNODE), the X and Y components of points. ! ! Input, real XMIN, YMIN, the physical origin. ! implicit none ! integer max_order integer nface integer nnode ! real alpha real blue integer face(max_order,nface) real green integer i integer iface integer iunit integer j integer node integer face_order(nface) integer plotxmin2 integer plotymin2 integer px integer py real red real x(nnode) real xmin real y(nnode) real ymin ! ! Draw the faces. ! do iface = 1, nface do i = 1, 2 if ( i == 1 ) then red = 0.9E+00 green = 0.9E+00 blue = 1.0E+00 else red = 0.0E+00 green = 0.0E+00 blue = 0.0E+00 end if write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' write ( iunit, '(a)' ) 'newpath' node = face(face_order(iface),iface) px = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) write ( iunit, '(2i4,a,2i4,a)' ) px, py, ' moveto ' do j = 1, face_order(iface) node = face(j,iface) px = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) write ( iunit, '(2i4,a,2i4,a)' ) px, py, ' lineto ' end do if ( i == 1 ) then write ( iunit, '(a)' ) 'fill' else write ( iunit, '(a)' ) 'stroke' end if end do end do return end subroutine shape_2d_nodes_to_ps ( plotxmin2, plotymin2, alpha, iunit, & nnode, x, y, xmin, ymin ) ! !******************************************************************************* ! !! SHAPE_2D_NODES_TO_PS writes 2D shape nodes to a PostScript file. ! ! ! Modified: ! ! 11 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer PLOTXMIN2, PLOTYMIN2, the Postscript origin. ! ! Input, real ALPHA, the physical-to-Postscript scale factor. ! ! Input, integer IUNIT, the output FORTRAN unit. ! ! Input, integer NNODE, the number of nodes. ! ! Input, real X(NNODE), Y(NNODE), the X and Y components of points. ! ! Input, real XMIN, YMIN, the physical origin. ! implicit none ! integer max_order integer nface integer nnode ! real alpha integer i integer iunit integer plotxmin2 integer plotymin2 integer px integer py real x(nnode) real xmin real y(nnode) real ymin ! ! Draw the nodes. ! do i = 1, nnode px = plotxmin2 + nint ( alpha * ( x(i) - xmin ) ) py = plotymin2 + nint ( alpha * ( y(i) - ymin ) ) write ( iunit, '(a,2i4,a)' ) 'newpath ', px, py, & ' 5 0 360 arc closepath stroke' end do return end subroutine shape_3d_edges_to_ps ( file_name, max_order, nface, nnode, & face, face_order, x, y, z ) ! !******************************************************************************* ! !! SHAPE_3D_EDGES_TO_PS writes 3D shape edges to a PostScript file. ! ! ! Discussion: ! ! Four views are created in one picture: XY, YZ, ZX, and XYZ. ! ! Modified: ! ! 09 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) FILE_NAME, the name of the output file. ! ! Input, integer MAX_ORDER, the maximum number of nodes per face. ! ! Input, integer NFACE, the number of faces. ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer FACE(MAX_ORDER,NFACE), the nodes making faces. ! ! Input, integer FACE_ORDER(NFACE), the number of nodes per face. ! ! Input, real X(NNODE), Y(NNODE), Z(NNODE), the X, Y and Z ! components of points. ! implicit none ! integer max_order integer nface integer nnode ! real alpha real blue character ( len = 8 ) date integer face(max_order,nface) integer face_order(nface) character ( len = * ) file_name real green integer i integer ios integer iunit integer, parameter :: margin = 36 integer pagexmax integer pagexmin integer pageymax integer pageymin integer plotxmax integer plotxmin integer plotxmin2 integer plotymax integer plotymin integer plotymin2 integer px1 integer px2 integer px3 integer px4 integer px5 integer py1 integer py2 integer py3 integer py4 integer py5 real red real x(nnode) real xmax real xmin real xx(nnode) real y(nnode) real ymax real ymin real yy(nnode) real z(nnode) ! ! Open the file. ! call get_unit ( iunit ) open ( unit = iunit, file = file_name, status = 'replace', iostat = ios ) if ( ios /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'SHAPE_3D_EDGES_TO_PS - Fatal error!' write ( *, '(a)' ) ' Could not open the output file.' return end if ! ! Write the prolog. ! pagexmax = 612 pagexmin = 0 pageymax = 792 pageymin = 0 px1 = 0 px2 = margin px3 = pagexmax / 2 px4 = pagexmax - margin px5 = pagexmax py1 = 0 py2 = margin py3 = pageymax / 2 py4 = pageymax - margin py5 = pageymax write ( iunit, '(a)' ) '%!PS-Adobe-3.0' write ( iunit, '(a)' ) '%%Document-Fonts: Times-Roman' write ( iunit, '(a,a)' ) '%%Title: ' , trim ( file_name ) write ( iunit, '(a)' ) '%%Creator: GRAFPACK(shape_3d_edges_to_ps)' call date_and_time ( date ) write ( iunit, '(a)' ) '%%CreationDate: ' // trim ( date ) write ( iunit, '(a)' ) '%%BoundingBox 0 0 612 794' write ( iunit, '(a)' ) '%%LanguageLevel: 2' write ( iunit, '(a)' ) '%%EndComments' write ( iunit, '(a)' ) '%%BeginProlog' write ( iunit, '(a)' ) '%%EndProlog' ! ! Draw gray lines to separate the boxes. ! red = 0.5 green = 0.5 blue = 0.5 write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' write ( iunit, '(2i4,a)' ) px2, py2, ' moveto ' write ( iunit, '(2i4,a)' ) px4, py2, ' lineto ' write ( iunit, '(2i4,a)' ) px2, py3, ' moveto ' write ( iunit, '(2i4,a)' ) px4, py3, ' lineto ' write ( iunit, '(2i4,a)' ) px2, py4, ' moveto ' write ( iunit, '(2i4,a)' ) px4, py4, ' lineto ' write ( iunit, '(2i4,a)' ) px2, py2, ' moveto ' write ( iunit, '(2i4,a)' ) px2, py4, ' lineto ' write ( iunit, '(2i4,a)' ) px3, py2, ' moveto ' write ( iunit, '(2i4,a)' ) px3, py4, ' lineto ' write ( iunit, '(2i4,a)' ) px4, py2, ' moveto ' write ( iunit, '(2i4,a)' ) px4, py4, ' lineto ' write ( iunit, '(a)' ) 'stroke' ! ! Determine ALPHA, the single scale factor to be used for both ! directions, and all four plots! ! xx(1:nnode) = x(1:nnode) yy(1:nnode) = y(1:nnode) xmin = minval ( xx(1:nnode) ) xmax = maxval ( xx(1:nnode) ) ymin = minval ( yy(1:nnode) ) ymax = maxval ( yy(1:nnode) ) alpha = min ( ( px3 - px2 ) / ( xmax - xmin ), & ( py4 - py3 ) / ( ymax - ymin ) ) xx(1:nnode) = y(1:nnode) yy(1:nnode) = z(1:nnode) xmin = minval ( xx(1:nnode) ) xmax = maxval ( xx(1:nnode) ) ymin = minval ( yy(1:nnode) ) ymax = maxval ( yy(1:nnode) ) alpha = min ( alpha, & ( px4 - px3 ) / ( xmax - xmin ), & ( py4 - py3 ) / ( ymax - ymin ) ) xx(1:nnode) = z(1:nnode) yy(1:nnode) = x(1:nnode) xmin = minval ( xx(1:nnode) ) xmax = maxval ( xx(1:nnode) ) ymin = minval ( yy(1:nnode) ) ymax = maxval ( yy(1:nnode) ) alpha = min ( alpha, & ( px3 - px2 ) / ( xmax - xmin ), & ( py3 - py2 ) / ( ymax - ymin ) ) xx(1:nnode) = 0.80 * x(1:nnode) - 0.31 * y(1:nnode) + 0.50 * z(1:nnode) yy(1:nnode) = 0.50 * x(1:nnode) + 0.80 * y(1:nnode) - 0.31 * z(1:nnode) xmin = minval ( xx(1:nnode) ) xmax = maxval ( xx(1:nnode) ) ymin = minval ( yy(1:nnode) ) ymax = maxval ( yy(1:nnode) ) alpha = min ( alpha, & ( px4 - px3 ) / ( xmax - xmin ), & ( py3 - py2 ) / ( ymax - ymin ) ) ! ! Set the fill color. ! red = 0.9E+00 green = 0.9E+00 blue = 1.0E+00 write ( iunit, '(3f7.4,a)' ) red, green, blue, ' setrgbcolor' ! ! XY edges. ! plotxmin = px2 plotxmax = px3 plotymin = py3 plotymax = py4 xx(1:nnode) = x(1:nnode) yy(1:nnode) = y(1:nnode) xmin = minval ( xx(1:nnode) ) xmax = maxval ( xx(1:nnode) ) ymin = minval ( yy(1:nnode) ) ymax = maxval ( yy(1:nnode) ) plotxmin2 = 0.5 * ( plotxmin + plotxmax - alpha * ( xmax - xmin ) ) plotymin2 = 0.5 * ( plotymin + plotymax - alpha * ( ymax - ymin ) ) call shape_2d_edges_to_ps ( plotxmin2, plotymin2, alpha, iunit, & max_order, nface, nnode, face, face_order, xx, yy, xmin, ymin ) ! ! YZ edges. ! plotxmin = px3 plotxmax = px4 plotymin = py3 plotymax = py4 xx(1:nnode) = y(1:nnode) yy(1:nnode) = z(1:nnode) xmin = minval ( xx(1:nnode) ) xmax = maxval ( xx(1:nnode) ) ymin =