hdiff output

r32606/CMakeLists.txt 2017-05-24 17:30:36.530722791 +0100 r32605/CMakeLists.txt 2017-05-24 17:30:48.314876610 +0100
  1: cmake_minimum_required(VERSION 2.6)  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/libmbpol/CMakeLists.txt' in revision 32605
  2:  
  3: project(libmbpol) 
  4: # Francesco Paesani's MBPOL flexible water potential 
  5: set(PROJECT_VERSION "0.0") 
  6: set(PROJECT_CONTACT "cv320@cam.ac.uk") 
  7:  
  8: # optimisation of polynomials takes forever 
  9: # would be better as a CMAKE variable 
 10:  
 11: if(${COMPILER_SWITCH} STREQUAL "g++") 
 12:   set(CMAKE_CXX_FLAGS_RELEASE -O0 -fPIC) 
 13: else() 
 14:   set(CMAKE_CXX_FLAGS_RELEASE -O0) 
 15: endif() 
 16:  
 17: file(GLOB LIBMBPOL_SOURCES *.cpp *.h) 
 18: add_library(libmbpol ${LIBMBPOL_SOURCES}) 


r32606/CMakeLists.txt~ 2017-05-24 17:30:36.782726079 +0100 r32605/CMakeLists.txt~ 2017-05-24 17:30:48.570879952 +0100
  1: cmake_minimum_required(VERSION 2.8)  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/libmbpol/CMakeLists.txt~' in revision 32605
  2:  
  3: # Silence warnings about PROJECT_VERSION not being set 
  4: cmake_policy(SET CMP0048 OLD) 
  5:  
  6: project(libmbpol) 
  7: # Francesco Paesani's MBPOL flexible water potential 
  8: set(PROJECT_VERSION "0.0") 
  9: set(PROJECT_CONTACT "jdf43@cam.ac.uk") 
 10:  
 11: # optimisation of polynomials takes forever 
 12: # would be better as a CMAKE variable 
 13:  
 14: if(${COMPILER_SWITCH} STREQUAL "g++") 
 15:   set(CMAKE_CXX_FLAGS_RELEASE -O0 -fPIC) 
 16: else() 
 17:   set(CMAKE_CXX_FLAGS_RELEASE -O0) 
 18: endif() 
 19:  
 20: file(GLOB LIBMBPOL_SOURCES *.cpp *.h) 
 21: add_library(libmbpol ${LIBMBPOL_SOURCES}) 


r32606/constants.h 2017-05-24 17:30:39.146756938 +0100 r32605/constants.h 2017-05-24 17:30:49.078886583 +0100
  1: #ifndef CONSTANTS_H  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/libmbpol/constants.h' in revision 32605
  2: #define CONSTANTS_H 
  3:  
  4: #include <cmath> 
  5:  
  6: namespace constants { 
  7:  
  8: const double Eh_J = 4.35974434e-18; // CODATA 2010 
  9: const double Na = 6.02214129e+23; // CODATA 2010 
 10:  
 11: const double kcal_J = 4184.0; 
 12: const double Eh_kcalmol = Eh_J*Na/kcal_J; 
 13:  
 14: const double Bohr_A = 0.52917721092; // CODATA 2010 
 15:  
 16: const double c0 = 299792458.0; // m/s CODATA 2010 
 17: const double ea0 = 8.47835326e-30; // C*m CODATA 2010 
 18:  
 19: const double D_au = (1.0/c0)*1.0e-21/ea0; // e * Bohr 
 20: const double D = D_au*Bohr_A; // e * A 
 21:  
 22: const double h_Js = 6.62606957e-34; // J*s CODATA 2010 
 23: const double hbar_Js = 1.054571726e-34; // J*s CODATA 2010 
 24: const double Eh_cm1 = 1.0e-2*Eh_J/(c0*h_Js); // cm-1 
 25:  
 26: const double cm1_kcalmol = Eh_kcalmol/Eh_cm1; 
 27:  
 28: const double kB = 1.3806488e-23; // JK-1 CODATA 2010 
 29:  
 30: namespace details { 
 31:  
 32: const double e =  1.602176565e-19; // C CODATA 2010 
 33:  
 34: // interaction energy of 2 unit charges 1A apart 
 35: const double E_cc = 1.0e-7*(c0*e*c0*e)/1.0e-10; // in J 
 36:  
 37: } // namespace details 
 38:  
 39: const double CHARGECON = std::sqrt(details::E_cc*Na/kcal_J); 
 40:  
 41: // from NIST web site 
 42:  
 43: const double H_mass = 1.00782503207; 
 44: const double O_mass = 15.99491461956; 
 45:  
 46: } // namespace constants 
 47:  
 48: #endif // CONSTANTS_H 


r32606/gammq.cpp 2017-05-24 17:30:39.398760227 +0100 r32605/gammq.cpp 2017-05-24 17:30:49.322889768 +0100
  1: #include <cmath>  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/libmbpol/gammq.cpp' in revision 32605
  2: #include <cassert> 
  3:  
  4: #include <iostream> 
  5:  
  6: #include <limits> 
  7: #include <algorithm> // for max 
  8:  
  9: #include "gammq.h" 
 10:  
 11: //////////////////////////////////////////////////////////////////////////////// 
 12:  
 13: namespace { 
 14:  
 15: //////////////////////////////////////////////////////////////////////////////// 
 16:  
 17: const double EPS = std::numeric_limits<double>::epsilon(); 
 18: const double FPMIN = std::numeric_limits<double>::min()/EPS; 
 19:  
 20: const int ngau = 18; 
 21:  
 22: const double y[18] = {0.0021695375159141994, 
 23: 0.011413521097787704,0.027972308950302116,0.051727015600492421, 
 24: 0.082502225484340941, 0.12007019910960293,0.16415283300752470, 
 25: 0.21442376986779355, 0.27051082840644336, 0.33199876341447887, 
 26: 0.39843234186401943, 0.46931971407375483, 0.54413605556657973, 
 27: 0.62232745288031077, 0.70331500465597174, 0.78649910768313447, 
 28: 0.87126389619061517, 0.95698180152629142}; 
 29:  
 30: const double w[18] = {0.0055657196642445571, 
 31: 0.012915947284065419,0.020181515297735382,0.027298621498568734, 
 32: 0.034213810770299537,0.040875750923643261,0.047235083490265582, 
 33: 0.053244713977759692,0.058860144245324798,0.064039797355015485, 
 34: 0.068745323835736408,0.072941885005653087,0.076598410645870640, 
 35: 0.079687828912071670,0.082187266704339706,0.084078218979661945, 
 36: 0.085346685739338721,0.085983275670394821}; 
 37:  
 38: //////////////////////////////////////////////////////////////////////////////// 
 39:  
 40: double gammpapprox(const double& a, const double& x, int psig) 
 41: { 
 42:     const double gln = ttm::gammln(a); 
 43:  
 44:     const double a1 = a-1.0; 
 45:     const double lna1 = std::log(a1); 
 46:     const double sqrta1 = std::sqrt(a1); 
 47:  
 48:     double xu, t, sum, ans; 
 49:  
 50:     if (x > a1) 
 51:         xu = std::max(a1 + 11.5*sqrta1, x + 6.0*sqrta1); 
 52:     else 
 53:         xu = std::max(0.0, std::min(a1 - 7.5*sqrta1, x - 5.0*sqrta1)); 
 54:  
 55:     sum = 0.0; 
 56:     for (int j = 0; j < ngau; ++j) { 
 57:         t = x + (xu - x)*y[j]; 
 58:         sum += w[j]*std::exp(-(t - a1) + a1*(std::log(t) - lna1)); 
 59:     } 
 60:  
 61:     ans = sum*(xu - x)*std::exp(a1*(lna1 - 1.0) - gln); 
 62:  
 63:     return (psig ? (ans > 0.0 ? 1.0 - ans : -ans) 
 64:                  : (ans >= 0.0 ? ans : 1.0 + ans)); 
 65: } 
 66:  
 67: //////////////////////////////////////////////////////////////////////////////// 
 68:  
 69: double gser(const double& a, const double& x) 
 70: { 
 71:     const double gln = ttm::gammln(a); 
 72:  
 73:     double ap = a; 
 74:     double sum = 1.0/a; 
 75:     double del = sum; 
 76:  
 77:     for (;;) { 
 78:         ++ap; 
 79:         del *= x/ap; 
 80:         sum += del; 
 81:         if (std::fabs(del) < std::fabs(sum)*EPS) { 
 82:             return sum*std::exp(- x + a*std::log(x) - gln); 
 83:         } 
 84:     } 
 85: } 
 86:  
 87: //////////////////////////////////////////////////////////////////////////////// 
 88:  
 89: double gcf(const double& a, const double& x) 
 90: { 
 91:     const double gln = ttm::gammln(a); 
 92:  
 93:     double b = x + 1.0 - a; 
 94:     double c = 1.0/FPMIN; 
 95:     double d = 1.0/b; 
 96:     double h = d; 
 97:  
 98:     for (int i = 1;; ++i) { 
 99:         const double an = -i*(i - a); 
100:  
101:         b += 2.0; 
102:         d = an*d + b; 
103:         if (std::fabs(d) < FPMIN) 
104:             d = FPMIN; 
105:  
106:         c = b + an/c; 
107:  
108:         if (std::fabs(c) < FPMIN) 
109:             c = FPMIN; 
110:  
111:         d = 1.0/d; 
112:         const double del = d*c; 
113:         h *= del; 
114:  
115:         if (std::fabs(del - 1.0) <= EPS) 
116:             break; 
117:     } 
118:  
119:     return std::exp( - x + a*std::log(x) - gln)*h; 
120: } 
121:  
122: //////////////////////////////////////////////////////////////////////////////// 
123:  
124: } // namespace 
125:  
126: //////////////////////////////////////////////////////////////////////////////// 
127:  
128: namespace ttm { 
129:  
130: //////////////////////////////////////////////////////////////////////////////// 
131:  
132: double gammq(const double& a, const double& x) 
133: { 
134:     const int ASWITCH = 100; 
135:  
136:     if (!(x >= 0.0 && a > 0.0)) { 
137:         std::cerr << "gammq: x = " << x << ", a = " << a << std::endl; 
138:     } 
139:  
140:     assert(x >= 0.0 && a > 0.0); 
141:  
142:     if (x == 0.0) 
143:         return 1.0; 
144:     else if (int(a) >= ASWITCH) 
145:         return gammpapprox(a, x, 0); 
146:     else if (x < a + 1.0) 
147:         return 1.0 - gser(a,x); 
148:     else 
149:         return gcf(a,x); 
150: } 
151:  
152: //////////////////////////////////////////////////////////////////////////////// 
153:  
154: double gammln(const double& xx) 
155: { 
156:     static const double cof[14] = {57.1562356658629235,-59.5979603554754912, 
157:     14.1360979747417471,-0.491913816097620199,.339946499848118887e-4, 
158:       .465236289270485756e-4,-.983744753048795646e-4,.158088703224912494e-3, 
159:      -.210264441724104883e-3,.217439618115212643e-3,-.164318106536763890e-3, 
160:       .844182239838527433e-4,-.261908384015814087e-4,.368991826595316234e-5}; 
161:  
162:     assert(xx > 0.0); 
163:  
164:     double x = xx; 
165:     double y = xx; 
166:  
167:     double tmp = x + 5.24218750000000000; 
168:     tmp = (x + 0.5)*std::log(tmp) - tmp; 
169:  
170:     double ser = 0.999999999999997092; 
171:     for (int j = 0; j < 14; ++j) 
172:         ser += cof[j]/++y; 
173:  
174:     return tmp + std::log(2.5066282746310005*ser/x); 
175: } 
176:  
177: //////////////////////////////////////////////////////////////////////////////// 
178:  
179: } // namespace ttm 
180:  
181: //////////////////////////////////////////////////////////////////////////////// 


r32606/gammq.h 2017-05-24 17:30:39.654763575 +0100 r32605/gammq.h 2017-05-24 17:30:49.570893005 +0100
  1: #ifndef GAMMQ_H  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/libmbpol/gammq.h' in revision 32605
  2: #define GAMMQ_H 
  3:  
  4: namespace ttm { 
  5:  
  6: double gammq(const double&, const double&); 
  7: double gammln(const double&); 
  8:  
  9: } // namespace ttm 
 10:  
 11: #endif // GAMMQ_H 


r32606/grafpack.f90 2017-05-24 17:30:35.494709268 +0100 r32605/grafpack.f90 2017-05-24 17:30:47.266862937 +0100
  1: module graph_mod  1: svn: E195012: Unable to find repository location for 'svn+ssh://svn.ch.private.cam.ac.uk/groups/wales/trunk/OPTIM/source/grafpack.f90' in revision 32605
  2:  
  3: implicit none 
  4:  
  5: contains 
  6:  
  7: subroutine balanc ( nm, n, a, low, igh, scale ) 
  8:  
  9: !*****************************************************************************80 
 10: ! 
 11: !! BALANC balances a real matrix before eigenvalue calculations. 
 12: ! 
 13: !  Discussion: 
 14: ! 
 15: !    This subroutine balances a real matrix and isolates eigenvalues 
 16: !    whenever possible. 
 17: ! 
 18: !    Suppose that the principal submatrix in rows LOW through IGH 
 19: !    has been balanced, that P(J) denotes the index interchanged 
 20: !    with J during the permutation step, and that the elements 
 21: !    of the diagonal matrix used are denoted by D(I,J).  Then 
 22: ! 
 23: !      SCALE(J) = P(J),    J = 1,...,LOW-1, 
 24: !               = D(J,J),  J = LOW,...,IGH, 
 25: !               = P(J)     J = IGH+1,...,N. 
 26: ! 
 27: !    The order in which the interchanges are made is N to IGH+1, 
 28: !    then 1 to LOW-1. 
 29: ! 
 30: !    Note that 1 is returned for LOW if IGH is zero formally. 
 31: ! 
 32: !  Licensing: 
 33: ! 
 34: !    This code is distributed under the GNU LGPL license.  
 35: ! 
 36: !  Modified: 
 37: ! 
 38: !    16 December 2008 
 39: ! 
 40: !  Author: 
 41: ! 
 42: !    Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow,  
 43: !    Ikebe, Klema, Moler. 
 44: !    FORTRAN90 version by John Burkardt. 
 45: ! 
 46: !  Reference: 
 47: ! 
 48: !    James Wilkinson, Christian Reinsch, 
 49: !    Handbook for Automatic Computation, 
 50: !    Volume II, Linear Algebra, Part 2, 
 51: !    Springer Verlag, 1971. 
 52: ! 
 53: !    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,  
 54: !    Y Ikebe, V Klema, Cleve Moler, 
 55: !    Matrix Eigensystem Routines, EISPACK Guide, 
 56: !    Lecture Notes in Computer Science, Volume 6, 
 57: !    Springer Verlag, 1976. 
 58: ! 
 59: !  Parameters: 
 60: ! 
 61: !    Input, integer ( kind = 4 ) NM, the leading dimension of A, which must 
 62: !    be at least N. 
 63: ! 
 64: !    Input, integer ( kind = 4 ) N, the order of the matrix. 
 65: ! 
 66: !    Input/output, real ( kind = 8 ) A(NM,N), the N by N matrix.  On output, 
 67: !    the matrix has been balanced. 
 68: ! 
 69: !    Output, integer ( kind = 4 ) LOW, IGH, indicate that A(I,J) is equal to  
 70: !    zero if 
 71: !    (1) I is greater than J and 
 72: !    (2) J=1,...,LOW-1 or I=IGH+1,...,N. 
 73: ! 
 74: !    Output, real ( kind = 8 ) SCALE(N), contains information determining the 
 75: !    permutations and scaling factors used. 
 76: ! 
 77:   implicit none 
 78:  
 79:   integer ( kind = 4 ) nm 
 80:   integer ( kind = 4 ) n 
 81:  
 82:   real ( kind = 8 ) a(nm,n) 
 83:   real ( kind = 8 ) b2 
 84:   real ( kind = 8 ) c 
 85:   real ( kind = 8 ) f 
 86:   real ( kind = 8 ) g 
 87:   integer ( kind = 4 ) i 
 88:   integer ( kind = 4 ) iexc 
 89:   integer ( kind = 4 ) igh 
 90:   integer ( kind = 4 ) j 
 91:   integer ( kind = 4 ) k 
 92:   integer ( kind = 4 ) l 
 93:   integer ( kind = 4 ) low 
 94:   integer ( kind = 4 ) m 
 95:   logical noconv 
 96:   real ( kind = 8 ) r 
 97:   real ( kind = 8 ), parameter :: radix = 16.0D+00 
 98:   real ( kind = 8 ) s 
 99:   real ( kind = 8 ) scale(n) 
100:  
101:   iexc = 0 
102:   j = 0 
103:   m = 0 
104:  
105:   b2 = radix * radix 
106:   k = 1 
107:   l = n 
108:   go to 100 
109:  
110: 20 continue 
111:  
112:   scale(m) = j 
113:  
114:   if ( j /= m ) then 
115:  
116:     do i = 1, l 
117:       call r8_swap ( a(i,j), a(i,m) ) 
118:     end do 
119:  
120:     do i = k, n 
121:       call r8_swap ( a(j,i), a(m,i) ) 
122:     end do 
123:  
124:   end if 
125:  
126: 50 continue 
127:  
128:   if ( iexc == 2 ) then 
129:     go to 130 
130:   end if 
131: ! 
132: !  Search for rows isolating an eigenvalue and push them down. 
133: ! 
134: 80 continue 
135:  
136:   if ( l == 1 ) then 
137:     low = k 
138:     igh = l 
139:     return 
140:   end if 
141:  
142:   l = l - 1 
143:  
144: 100 continue 
145:  
146:   do j = l, 1, -1 
147:  
148:      do i = 1, l 
149:        if ( i /= j ) then 
150:          if ( a(j,i) /= 0.0D+00 ) then 
151:            go to 120 
152:          end if 
153:        end if 
154:      end do 
155:  
156:      m = l 
157:      iexc = 1 
158:      go to 20 
159:  
160: 120  continue 
161:  
162:   end do 
163:  
164:   go to 140 
165: ! 
166: !  Search for columns isolating an eigenvalue and push them left. 
167: ! 
168: 130 continue 
169:  
170:   k = k + 1 
171:  
172: 140 continue 
173:  
174:   do j = k, l 
175:  
176:     do i = k, l 
177:       if ( i /= j ) then 
178:         if ( a(i,j) /= 0.0D+00 ) then 
179:           go to 170 
180:         end if 
181:       end if 
182:     end do 
183:  
184:     m = k 
185:     iexc = 2 
186:     go to 20 
187:  
188: 170 continue 
189:  
190:   end do 
191: ! 
192: !  Balance the submatrix in rows K to L. 
193: ! 
194:   scale(k:l) = 1.0D+00 
195: ! 
196: !  Iterative loop for norm reduction. 
197: ! 
198:   noconv = .true. 
199:  
200:   do while ( noconv ) 
201:  
202:     noconv = .false. 
203:  
204:     do i = k, l 
205:  
206:       c = 0.0D+00 
207:       r = 0.0D+00 
208:  
209:       do j = k, l 
210:         if ( j /= i ) then 
211:           c = c + abs ( a(j,i) ) 
212:           r = r + abs ( a(i,j) ) 
213:         end if 
214:       end do 
215: ! 
216: !  Guard against zero C or R due to underflow. 
217: ! 
218:       if ( c /= 0.0D+00 .and. r /= 0.0D+00 ) then 
219:  
220:         g = r / radix 
221:         f = 1.0D+00 
222:         s = c + r 
223:  
224:         do while ( c < g ) 
225:           f = f * radix 
226:           c = c * b2 
227:         end do 
228:  
229:         g = r * radix 
230:  
231:         do while ( g <= c ) 
232:           f = f / radix 
233:           c = c / b2 
234:         end do 
235: ! 
236: !  Balance. 
237: ! 
238:         if ( ( c + r ) / f < 0.95D+00 * s ) then 
239:  
240:           g = 1.0D+00 / f 
241:           scale(i) = scale(i) * f 
242:           noconv = .true. 
243:  
244:           a(i,k:n) = a(i,k:n) * g 
245:           a(1:l,i) = a(1:l,i) * f 
246:  
247:         end if 
248:  
249:       end if 
250:  
251:     end do 
252:  
253:   end do 
254:  
255:   low = k 
256:   igh = l 
257:  
258:   return 
259: end subroutine 
260: subroutine ch_cap ( c ) 
261:  
262: !*****************************************************************************80 
263: ! 
264: !! CH_CAP capitalizes a single character. 
265: ! 
266: !  Licensing: 
267: ! 
268: !    This code is distributed under the GNU LGPL license.  
269: ! 
270: !  Modified: 
271: ! 
272: !    19 July 1998 
273: ! 
274: !  Author: 
275: ! 
276: !    John Burkardt 
277: ! 
278: !  Parameters: 
279: ! 
280: !    Input/output, character C, the character to capitalize. 
281: ! 
282:   implicit none 
283:  
284:   character c 
285:   integer ( kind = 4 ) itemp 
286:  
287:   itemp = ichar ( c ) 
288:  
289:   if ( 97 <= itemp .and. itemp <= 122 ) then 
290:     c = char ( itemp - 32 ) 
291:   end if 
292:  
293:   return 
294: end subroutine 
295: function ch_eqi ( c1, c2 ) 
296:  
297: !*****************************************************************************80 
298: ! 
299: !! CH_EQI is a case insensitive comparison of two characters for equality. 
300: ! 
301: !  Example: 
302: ! 
303: !    C_EQI ( 'A', 'a' ) is .TRUE. 
304: ! 
305: !  Licensing: 
306: ! 
307: !    This code is distributed under the GNU LGPL license.  
308: ! 
309: !  Modified: 
310: ! 
311: !    14 August 1999 
312: ! 
313: !  Author: 
314: ! 
315: !    John Burkardt 
316: ! 
317: !  Parameters: 
318: ! 
319: !    Input, character C1, C2, the characters to compare. 
320: ! 
321: !    Output, logical CH_EQI, the result of the comparison. 
322: ! 
323:   implicit none 
324:  
325:   logical ch_eqi 
326:   character c1 
327:   character c2 
328:   character cc1 
329:   character cc2 
330:  
331:   cc1 = c1 
332:   cc2 = c2 
333:  
334:   call ch_cap ( cc1 ) 
335:   call ch_cap ( cc2 ) 
336:  
337:   if ( cc1 == cc2 ) then 
338:     ch_eqi = .true. 
339:   else 
340:     ch_eqi = .false. 
341:   end if 
342:  
343:   return 
344: end function ch_eqi 
345: subroutine ch_to_digit ( c, digit ) 
346:  
347: !*****************************************************************************80 
348: ! 
349: !! CH_TO_DIGIT returns the integer value of a base 10 digit. 
350: ! 
351: !  Example: 
352: ! 
353: !     C   DIGIT 
354: !    ---  ----- 
355: !    '0'    0 
356: !    '1'    1 
357: !    ...  ... 
358: !    '9'    9 
359: !    ' '    0 
360: !    'X'   -1 
361: ! 
362: !  Licensing: 
363: ! 
364: !    This code is distributed under the GNU LGPL license.  
365: ! 
366: !  Modified: 
367: ! 
368: !    04 August 1999 
369: ! 
370: !  Author: 
371: ! 
372: !    John Burkardt 
373: ! 
374: !  Parameters: 
375: ! 
376: !    Input, character C, the decimal digit, '0' through '9' or blank 
377: !    are legal. 
378: ! 
379: !    Output, integer ( kind = 4 ) DIGIT, the corresponding integer value.   
380: !    If C was 'illegal', then DIGIT is -1. 
381: ! 
382:   implicit none 
383:  
384:   character c 
385:   integer ( kind = 4 ) digit 
386:  
387:   if ( lge ( c, '0' ) .and. lle ( c, '9' ) ) then 
388:  
389:     digit = ichar ( c ) - 48 
390:  
391:   else if ( c == ' ' ) then 
392:  
393:     digit = 0 
394:  
395:   else 
396:  
397:     digit = - 1 
398:  
399:   end if 
400:  
401:   return 
402: end subroutine 
403: subroutine catalan ( n, c ) 
404:  
405: !*****************************************************************************80 
406: ! 
407: !! CATALAN computes the Catalan numbers, from C(0) to C(N). 
408: ! 
409: !  First values: 
410: ! 
411: !     C(0)     1 
412: !     C(1)     1 
413: !     C(2)     2 
414: !     C(3)     5 
415: !     C(4)    14 
416: !     C(5)    42 
417: !     C(6)   132 
418: !     C(7)   429 
419: !     C(8)  1430 
420: !     C(9)  4862 
421: !    C(10) 16796 
422: ! 
423: !  Formula: 
424: ! 
425: !    C(N) = (2*N)! / ( (N+1) * (N!) * (N!) ) 
426: !         = 1 / (N+1) * COMB ( 2N, N ) 
427: !         = 1 / (2N+1) * COMB ( 2N+1, N+1). 
428: ! 
429: !  Recursion: 
430: ! 
431: !    C(N) = 2 * (2*N-1) * C(N-1) / (N+1) 
432: !    C(N) = SUM ( I = 1 to N-1 ) C(I) * C(N-I) 
433: ! 
434: !  Comments: 
435: ! 
436: !    The Catalan number C(N) counts: 
437: ! 
438: !    1) the number of binary trees on N vertices; 
439: !    2) the number of ordered trees on N+1 vertices; 
440: !    3) the number of full binary trees on 2N+1 vertices; 
441: !    4) the number of well formed sequences of 2N parentheses; 
442: !    5) number of ways 2N ballots can be counted, in order, 
443: !       with N positive and N negative, so that the running sum 
444: !       is never negative; 
445: !    6) the number of standard tableaus in a 2 by N rectangular Ferrers diagram; 
446: !    7) the number of monotone functions from [1..N} to [1..N} which 
447: !       satisfy f(i) <= i for all i, 
448: !    8) the number of ways to triangulate a polygon with N+2 vertices. 
449: ! 
450: !  Example: 
451: ! 
452: !    N = 3 
453: ! 
454: !    ()()() 
455: !    ()(()) 
456: !    (()()) 
457: !    (())() 
458: !    ((())) 
459: ! 
460: !  Licensing: 
461: ! 
462: !    This code is distributed under the GNU LGPL license.  
463: ! 
464: !  Modified: 
465: ! 
466: !    14 August 1998 
467: ! 
468: !  Author: 
469: ! 
470: !    John Burkardt 
471: ! 
472: !  Reference: 
473: ! 
474: !    Dennis Stanton, Dennis White, 
475: !    Constructive Combinatorics, 
476: !    Springer Verlag, New York, 1986. 
477: ! 
478: !  Parameters: 
479: ! 
480: !    Input, integer ( kind = 4 ) N, the number of Catalan numbers desired. 
481: ! 
482: !    Output, integer ( kind = 4 ) C(0:N), the Catalan numbers from C(0) to C(N). 
483: ! 
484:   implicit none 
485:  
486:   integer ( kind = 4 ) n 
487:  
488:   integer ( kind = 4 ) i 
489:   integer ( kind = 4 ) c(0:n) 
490:  
491:   c(0) = 1 
492: ! 
493: !  The extra parentheses ensure that the integer division is 
494: !  done AFTER the integer multiplication. 
495: ! 
496:   do i = 1, n 
497:     c(i) = ( c(i-1) * 2 * ( 2 * i - 1 ) ) / ( i + 1 ) 
498:   end do 
499:  
500:   return 
501: end subroutine 
502: subroutine color_digraph_adj_degree ( adj, nnode, indegree, outdegree ) 
503:  
504: !*****************************************************************************80 
505: ! 
506: !! COLOR_DIGRAPH_ADJ_DEGREE computes the indegree and outdegree of each node. 
507: ! 
508: !  Discussion: 
509: ! 
510: !    The indegree of a node is the number of directed edges that  
511: !    end at the node.   
512: ! 
513: !    The outdegree of a node is the number of directed edges that 
514: !    begin at the node. 
515: ! 
516: !    The sum of the indegrees and outdegrees of all the nodes is twice  
517: !    the number of edges. 
518: ! 
519: !    The generalized case, where ADJ(I,J) can be greater than 1, indicating 
520: !    the existence of 2 or more distinct edges from node I to node J, 
521: !    will be properly handled by this routine.   
522: ! 
523: !  Licensing: 
524: ! 
525: !    This code is distributed under the GNU LGPL license.  
526: ! 
527: !  Modified: 
528: ! 
529: !    10 November 1999 
530: ! 
531: !  Author: 
532: ! 
533: !    John Burkardt 
534: ! 
535: !  Parameters: 
536: ! 
537: !    Input, integer ( kind = 4 ) ADJ(NNODE,NNODE), the adjacency information  
538: !    for graph 1.  ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is  
539: !    positive if there is an edge from node I to node J.  
540: ! 
541: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
542: ! 
543: !    Output, integer ( kind = 4 ) INDEGREE(NNODE), OUTDEGREE(NNODE),  
544: !    the indegree and outdegree of the nodes. 
545: ! 
546:   implicit none 
547:  
548:   integer ( kind = 4 ) nnode 
549:  
550:   integer ( kind = 4 ) adj(nnode,nnode) 
551:   integer ( kind = 4 ) i 
552:   integer ( kind = 4 ) indegree(nnode) 
553:   integer ( kind = 4 ) j 
554:   integer ( kind = 4 ) outdegree(nnode) 
555:  
556:   indegree(1:nnode) = 0 
557:   outdegree(1:nnode) = 0 
558:  
559:   do i = 1, nnode 
560:     do j = 1, nnode 
561:       if ( i /= j ) then 
562:         outdegree(i) = outdegree(i) + adj(i,j) 
563:         indegree(j) = indegree(j) + adj(i,j) 
564:       end if 
565:     end do 
566:   end do 
567:  
568:   return 
569: end subroutine 
570: subroutine color_digraph_adj_degree_seq ( adj, lda, nnode, in_seq, out_seq ) 
571:  
572: !*****************************************************************************80 
573: ! 
574: !! COLOR_DIGRAPH_ADJ_DEGREE_SEQ computes the degree sequence of a color digraph. 
575: ! 
576: !  Discussion: 
577: ! 
578: !    The directed degree sequence of a graph is the sequence of indegrees 
579: !    and the sequence of outdegrees, arranged to correspond to nodes of 
580: !    successively decreasing total degree.  For nodes of equal degree, those 
581: !    of higher outdegree take precedence.  
582: ! 
583: !  Licensing: 
584: ! 
585: !    This code is distributed under the GNU LGPL license.  
586: ! 
587: !  Modified: 
588: ! 
589: !    04 November 1999 
590: ! 
591: !  Author: 
592: ! 
593: !    John Burkardt 
594: ! 
595: !  Parameters: 
596: ! 
597: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
598: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
599: !    if there is an edge from node I to node J. 
600: ! 
601: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
602: !    which must be at least NNODE. 
603: ! 
604: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
605: ! 
606: !    Output, integer ( kind = 4 ) IN_SEQ(NNODE), OUT_SEQ(NNODE), 
607: !    the degree sequence of the digraph. 
608: ! 
609:   implicit none 
610:  
611:   integer ( kind = 4 ) lda 
612:   integer ( kind = 4 ) nnode 
613:  
614:   integer ( kind = 4 ) adj(lda,nnode) 
615:   integer ( kind = 4 ) in_seq(nnode) 
616:   integer ( kind = 4 ) out_seq(nnode) 
617:  
618:   call color_digraph_adj_degree ( adj, nnode, in_seq, out_seq ) 
619:  
620:   call i4vec2_sort_d ( nnode, out_seq, in_seq ) 
621:  
622:   return 
623: end subroutine 
624: subroutine color_digraph_adj_edge_count ( adj, lda, nnode, nedge ) 
625:  
626: !*****************************************************************************80 
627: ! 
628: !! COLOR_DIGRAPH_ADJ_EDGE_COUNT counts the number of edges in a color digraph. 
629: ! 
630: !  Licensing: 
631: ! 
632: !    This code is distributed under the GNU LGPL license.  
633: ! 
634: !  Modified: 
635: ! 
636: !    26 October 1998 
637: ! 
638: !  Author: 
639: ! 
640: !    John Burkardt 
641: ! 
642: !  Parameters: 
643: ! 
644: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
645: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
646: !    if there is an edge from node I to node J. 
647: ! 
648: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
649: !    which must be at least NNODE. 
650: ! 
651: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
652: ! 
653: !    Output, integer ( kind = 4 ) NEDGE, the number of edges. 
654: ! 
655:   implicit none 
656:  
657:   integer ( kind = 4 ) lda 
658:   integer ( kind = 4 ) nnode 
659:  
660:   integer ( kind = 4 ) adj(lda,nnode) 
661:   integer ( kind = 4 ) i 
662:   integer ( kind = 4 ) j 
663:   integer ( kind = 4 ) nedge 
664:  
665:   nedge = 0 
666:  
667:   do i = 1, nnode 
668:     do j = 1, nnode 
669:  
670:       if ( i /= j ) then 
671:         nedge = nedge + adj(i,j) 
672:       end if 
673:  
674:     end do 
675:   end do 
676:  
677:   return 
678: end subroutine 
679: subroutine color_digraph_adj_example_cube ( adj, lda, nnode ) 
680:  
681: !*****************************************************************************80 
682: ! 
683: !! COLOR_DIGRAPH_ADJ_EXAMPLE_CUBE sets up the cube color digraph. 
684: ! 
685: !  Diagram: 
686: ! 
687: ! 
688: !    8B----<-----3B 
689: !    |\          /|\ 
690: !    | A        V | | 
691: !    |  \      /  | | 
692: !    |  4R-->-7R  | | 
693: !    |   |     |  | | 
694: !    A   A     V  V A 
695: !    |   |     |  | | 
696: !    |   5B-<-2G  | | 
697: !    |  /      \  | | 
698: !    | A        A | | 
699: !    |/          \|/ 
700: !    1G----->----6B 
701: ! 
702: !  Licensing: 
703: ! 
704: !    This code is distributed under the GNU LGPL license.  
705: ! 
706: !  Modified: 
707: ! 
708: !    22 October 1998 
709: ! 
710: !  Author: 
711: ! 
712: !    John Burkardt 
713: ! 
714: !  Parameters: 
715: ! 
716: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
717: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
718: !    if there is an edge from node I to node J. 
719: ! 
720: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
721: !    which must be at least NNODE. 
722: ! 
723: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
724: ! 
725:   implicit none 
726:  
727:   integer ( kind = 4 ), parameter :: BLUE = 1 
728:   integer ( kind = 4 ), parameter :: GREEN = 2 
729:   integer ( kind = 4 ), parameter :: RED = 3 
730:  
731:   integer ( kind = 4 ) lda 
732:  
733:   integer ( kind = 4 ) adj(lda,lda) 
734:   integer ( kind = 4 ) nnode 
735:  
736:   nnode = 8 
737:  
738:   if ( lda < nnode ) then 
739:     write ( *, '(a)' ) ' ' 
740:     write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_EXAMPLE_CUBE - Fatal error!' 
741:     write ( *, '(a)' ) '  LDA is too small.' 
742:     stop 
743:   end if 
744:  
745:   adj(1:nnode,1:nnode) = 0 
746:  
747:   adj(1,1) = GREEN 
748:   adj(1,5) = 1 
749:   adj(1,6) = 1 
750:   adj(1,8) = 1 
751:  
752:   adj(2,2) = GREEN 
753:   adj(2,5) = 1 
754:  
755:   adj(3,3) = BLUE 
756:   adj(3,6) = 1 
757:   adj(3,7) = 1 
758:   adj(3,8) = 1 
759:  
760:   adj(4,4) = RED 
761:   adj(4,7) = 1 
762:   adj(4,8) = 1 
763:  
764:   adj(5,5) = BLUE 
765:   adj(5,4) = 1 
766:  
767:   adj(6,6) = BLUE 
768:   adj(6,2) = 1 
769:   adj(6,3) = 1 
770:  
771:   adj(7,7) = RED 
772:   adj(7,2) = 1 
773:  
774:   adj(8,8) = BLUE 
775:  
776:   return 
777: end subroutine 
778: subroutine color_digraph_adj_example_octo ( lda, example, seed, nnode, adj ) 
779:  
780: !*****************************************************************************80 
781: ! 
782: !! COLOR_DIGRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example color digraph. 
783: ! 
784: !  Diagram: 
785: ! 
786: !      1---2 
787: !     /|   |\ 
788: !    8-+---+-3 
789: !    | |   | | 
790: !    7-+---+-4 
791: !     \|   |/ 
792: !      6---5 
793: ! 
794: !     Graph "A" 
795: ! 
796: !    There are 7 graphs to choose from.  They are all on 8 nodes.  The first 
797: !    5 have degree 3 at every node.  Graphs 6 and 7 have degree 5 at every 
798: !    node. 
799: ! 
800: !  Licensing: 
801: ! 
802: !    This code is distributed under the GNU LGPL license.  
803: ! 
804: !  Modified: 
805: ! 
806: !    28 March 2005 
807: ! 
808: !  Author: 
809: ! 
810: !    John Burkardt 
811: ! 
812: !  Parameters: 
813: ! 
814: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
815: !    which must be at least NNODE. 
816: ! 
817: !    Input, integer ( kind = 4 ) EXAMPLE, should be between 1 and 60, and  
818: !    indicates which example graph to pick. 
819: ! 
820: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
821: !    number generator. 
822: ! 
823: !    Output, integer ( kind = 4 ) NNODE, the number of nodes, which should be 8. 
824: ! 
825: !    Output, integer ( kind = 4 ) ADJ(LDA,LDA), the adjacency information. 
826: !    ADJ(I,I) is the color of node I. 
827: !    ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. 
828: ! 
829:   implicit none 
830:  
831:   integer ( kind = 4 ), parameter :: BLUE = 1 
832:   integer ( kind = 4 ), parameter :: GREEN = 2 
833:   integer ( kind = 4 ), parameter :: RED = 3 
834:   integer ( kind = 4 ), parameter :: YELLOW = 4 
835:  
836:   integer ( kind = 4 ) lda 
837:  
838:   integer ( kind = 4 ) adj(lda,lda) 
839:   integer ( kind = 4 ) example 
840:   integer ( kind = 4 ) i 
841: !  integer ( kind = 4 ) i4_uniform 
842:   integer ( kind = 4 ) j 
843:   integer ( kind = 4 ) msave 
844:   integer ( kind = 4 ) nnode 
845:   integer ( kind = 4 ) nsave 
846:   integer ( kind = 4 ) seed 
847:  
848:   if ( nnode <= 0 ) then 
849:     nsave = i4_uniform ( 1, 12, seed ) 
850:     msave = i4_uniform ( 1, 5, seed ) 
851:   else 
852:     example = mod ( example - 1, 60 ) + 1 
853:     msave = ( example - 1 ) / 12 + 1 
854:     nsave = mod ( example - 1, 12 ) + 1 
855:   end if 
856:  
857:   nnode = 8 
858:  
859:   if ( lda < nnode ) then 
860:     write ( *, '(a)' ) ' ' 
861:     write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' 
862:     write ( *, '(a)' ) '  LDA is too small.' 
863:     stop 
864:   end if 
865:  
866:   adj(1:nnode,1:nnode) = 0 
867:  
868:   do i = 1, nnode 
869:     j = i + 1 
870:     if ( nnode < j ) then 
871:       j = j - nnode 
872:     end if 
873:  
874:     adj(i,j) = 1 
875:  
876:   end do 
877: ! 
878: !  Underlying graph 1. 
879: ! 
880:   if ( nsave == 1 ) then 
881:  
882:       adj(1,6) = 1 
883:       adj(2,5) = 1 
884:       adj(3,8) = 1 
885:       adj(4,7) = 1 
886:  
887:   else if ( nsave == 2 ) then 
888:  
889:       adj(1,6) = 1 
890:       adj(5,2) = 1 
891:       adj(3,8) = 1 
892:       adj(7,4) = 1 
893: ! 
894: !  Underlying graph 2. 
895: !  Digraphs 3 and 4 have different indegree/outdegree sequences. 
896: ! 
897:   else if ( nsave == 3 ) then 
898:  
899:     adj(1,6) = 1 
900:     adj(6,1) = 1 
901:     adj(2,8) = 1 
902:     adj(8,2) = 1 
903:     adj(3,5) = 1 
904:     adj(5,3) = 1 
905:     adj(4,7) = 1 
906:     adj(7,4) = 1 
907:  
908:   else if ( nsave == 4 ) then 
909:  
910:     adj(1,6) = 1 
911:     adj(2,8) = 1 
912:     adj(3,5) = 1 
913:     adj(4,7) = 1 
914: ! 
915: !  Underlying graph 3 
916: !  Digraphs 5 and 6 have the same indegree/outdegree sequences. 
917: ! 
918:   else if ( nsave == 5 ) then 
919:  
920:     adj(1,5) = 1 
921:     adj(2,6) = 1 
922:     adj(3,7) = 1 
923:     adj(4,8) = 1 
924:  
925:   else if ( nsave == 6 ) then 
926:  
927:     adj(1:nnode,1:nnode) = 0 
928:  
929:     adj(1,8) = 1 
930:     adj(1,5) = 1 
931:     adj(2,1) = 1 
932:     adj(2,3) = 1 
933:     adj(3,4) = 1 
934:     adj(3,7) = 1 
935:     adj(4,5) = 1 
936:     adj(4,8) = 1 
937:     adj(5,6) = 1 
938:     adj(6,2) = 1 
939:     adj(7,6) = 1 
940:     adj(8,7) = 1 
941: ! 
942: !  Underlying graph 4 
943: ! 
944:   else if ( nsave == 7 ) then 
945:  
946:     adj(3,1) = 1 
947:     adj(4,2) = 1 
948:     adj(5,7) = 1 
949:     adj(6,8) = 1 
950:  
951:   else if ( nsave == 8 ) then 
952:  
953:     adj(3,1) = 1 
954:     adj(4,2) = 1 
955:     adj(5,7) = 1 
956:     adj(8,6) = 1 
957: ! 
958: !  Underlying graph 5 
959: ! 
960:   else if ( nsave == 9 ) then 
961:  
962:     adj(1,4) = 1 
963:     adj(2,6) = 1 
964:     adj(8,3) = 1 
965:  
966:     adj(5,7) = 1 
967:     adj(7,5) = 1 
968:  
969:   else if ( nsave == 10 ) then 
970:  
971:     adj(1,4) = 1 
972:     adj(2,6) = 1 
973:     adj(3,8) = 1 
974:  
975:     adj(5,7) = 1 
976:     adj(7,5) = 1 
977: ! 
978: !  Underlying graph 6 
979: ! 
980:   else if ( nsave == 11 ) then 
981:  
982:     adj(1,4) = 1 
983:     adj(1,5) = 1 
984:     adj(1,6) = 1 
985:  
986:     adj(2,5) = 1 
987:     adj(2,6) = 1 
988:     adj(2,7) = 1 
989:  
990:     adj(3,6) = 1 
991:     adj(3,7) = 1 
992:     adj(3,8) = 1 
993:  
994:     adj(4,7) = 1 
995:     adj(4,8) = 1 
996:  
997:     adj(5,8) = 1 
998: ! 
999: !  Underlying graph 7 
1000: ! 
1001:   else if ( nsave == 12 ) then 
1002:  
1003:     adj(1,3) = 1 
1004:     adj(1,5) = 1 
1005:     adj(1,7) = 1 
1006:  
1007:     adj(2,4) = 1 
1008:     adj(2,6) = 1 
1009:     adj(2,8) = 1 
1010:  
1011:     adj(3,5) = 1 
1012:     adj(3,7) = 1 
1013:  
1014:     adj(4,6) = 1 
1015:     adj(4,8) = 1 
1016:  
1017:     adj(5,7) = 1 
1018:  
1019:     adj(6,8) = 1 
1020:  
1021:   end if 
1022:  
1023:   if ( msave == 1 ) then 
1024:  
1025:     adj(1,1) = RED 
1026:     adj(2,2) = RED 
1027:     adj(3,3) = RED 
1028:     adj(4,4) = BLUE 
1029:     adj(5,5) = BLUE 
1030:     adj(6,6) = BLUE 
1031:     adj(7,7) = GREEN 
1032:     adj(8,8) = GREEN 
1033:  
1034:   else if ( msave == 2 ) then 
1035:  
1036:     adj(1,1) = RED 
1037:     adj(2,2) = RED 
1038:     adj(3,3) = RED 
1039:     adj(4,4) = BLUE 
1040:     adj(5,5) = BLUE 
1041:     adj(6,6) = BLUE 
1042:     adj(7,7) = GREEN 
1043:     adj(8,8) = YELLOW 
1044:  
1045:   else if ( msave == 3 ) then 
1046:  
1047:     adj(1,1) = RED 
1048:     adj(2,2) = RED 
1049:     adj(3,3) = RED 
1050:     adj(4,4) = BLUE 
1051:     adj(5,5) = BLUE 
1052:     adj(6,6) = BLUE 
1053:     adj(7,7) = YELLOW 
1054:     adj(8,8) = YELLOW 
1055:  
1056:   else if ( msave == 4 ) then 
1057:  
1058:     adj(1,1) = RED 
1059:     adj(2,2) = RED 
1060:     adj(3,3) = RED 
1061:     adj(4,4) = BLUE 
1062:     adj(5,5) = BLUE 
1063:     adj(6,6) = GREEN 
1064:     adj(7,7) = GREEN 
1065:     adj(8,8) = GREEN 
1066:  
1067:   else if ( msave == 5 ) then 
1068:  
1069:     adj(1,1) = RED 
1070:     adj(2,2) = BLUE 
1071:     adj(3,3) = RED 
1072:     adj(4,4) = GREEN 
1073:     adj(5,5) = BLUE 
1074:     adj(6,6) = RED 
1075:     adj(7,7) = BLUE 
1076:     adj(8,8) = GREEN 
1077:  
1078:   end if 
1079: ! 
1080: !  Now permute the graph. 
1081: ! 
1082:   call i4mat_perm_random ( lda, nnode, seed, adj ) 
1083:  
1084:   return 
1085: end subroutine 
1086: subroutine color_digraph_adj_print ( adj, lda, nnode, title ) 
1087:  
1088: !*****************************************************************************80 
1089: ! 
1090: !! COLOR_DIGRAPH_ADJ_PRINT prints out the adjacency matrix of a color digraph. 
1091: ! 
1092: !  Licensing: 
1093: ! 
1094: !    This code is distributed under the GNU LGPL license.  
1095: ! 
1096: !  Modified: 
1097: ! 
1098: !    04 July 2000 
1099: ! 
1100: !  Author: 
1101: ! 
1102: !    John Burkardt 
1103: ! 
1104: !  Parameters: 
1105: ! 
1106: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1107: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1108: !    if there is an edge from node I to node J. 
1109: ! 
1110: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ, which must  
1111: !    be at least NNODE. 
1112: ! 
1113: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1114: ! 
1115: !    Input, character ( len = * ) TITLE, a title. 
1116: ! 
1117:   implicit none 
1118:  
1119:   integer ( kind = 4 ) lda 
1120:   integer ( kind = 4 ) nnode 
1121:  
1122:   integer ( kind = 4 ) adj(lda,nnode) 
1123:   integer ( kind = 4 ) i 
1124:   integer ( kind = 4 ) j 
1125:   integer ( kind = 4 ) k 
1126:   character ( len = 80 ) string 
1127:   character ( len = * ) title 
1128:  
1129:   write ( *, '(a)' ) ' ' 
1130:   write ( *, '(a)' ) trim ( title ) 
1131:   write ( *, '(a)' ) ' ' 
1132:  
1133:   do i = 1, nnode 
1134:  
1135:     do j = 1, nnode 
1136:  
1137:       k = (j-1) * 3 + 1 
1138:       write ( string(k:k+2), '(i3)' ) adj(i,j) 
1139:  
1140:     end do 
1141:  
1142:     write ( *, '(i2,2x,a)' ) i, string(1:3*nnode) 
1143:  
1144:   end do 
1145:  
1146:   return 
1147: end subroutine 
1148: subroutine color_digraph_adj_random ( nnode, ncolor, nedge, seed, adj ) 
1149:  
1150: !*****************************************************************************80 
1151: ! 
1152: !! COLOR_DIGRAPH_ADJ_RANDOM generates a random color graph. 
1153: ! 
1154: !  Licensing: 
1155: ! 
1156: !    This code is distributed under the GNU LGPL license.  
1157: ! 
1158: !  Modified: 
1159: ! 
1160: !    26 March 2005 
1161: ! 
1162: !  Author: 
1163: ! 
1164: !    John Burkardt 
1165: ! 
1166: !  Parameters: 
1167: ! 
1168: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1169: ! 
1170: !    Input, integer ( kind = 4 ) NCOLOR, the number of colors available.   
1171: !    Each node is assumed to have an associated color, between 1 and NCOLOR, 
1172: !    which will be chosen at random. 
1173: ! 
1174: !    Input, integer ( kind = 4 ) NEDGE, the number of edges, which must be  
1175: !    between 0 and NNODE*(NNODE-1). 
1176: ! 
1177: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
1178: !    number generator. 
1179: ! 
1180: !    Output, integer ( kind = 4 ) ADJ(NNODE,NNODE), the adjacency information.   
1181: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1182: !    if there is an edge from node I to node J. 
1183: ! 
1184:   implicit none 
1185:  
1186:   integer ( kind = 4 ) ncolor 
1187:   integer ( kind = 4 ) nedge 
1188:   integer ( kind = 4 ) nnode 
1189:  
1190:   integer ( kind = 4 ) adj(nnode,nnode) 
1191:   integer ( kind = 4 ) color 
1192:   integer ( kind = 4 ) i 
1193: !  integer ( kind = 4 ) i4_uniform 
1194:   integer ( kind = 4 ) iwork(nedge) 
1195:   integer ( kind = 4 ) j 
1196:   integer ( kind = 4 ) k 
1197:   integer ( kind = 4 ) l 
1198:   integer ( kind = 4 ) maxedge 
1199:   integer ( kind = 4 ) perm(ncolor) 
1200:   integer ( kind = 4 ) seed 
1201:   integer ( kind = 4 ) subset(ncolor) 
1202:  
1203:   if ( nnode <= 0  ) then 
1204:     write ( *, '(a)' ) ' ' 
1205:     write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_RANDOM - Fatal error!' 
1206:     write ( *, '(a,i8)' ) '  NNODE = ', nnode 
1207:     write ( *, '(a)' ) '  but NNODE must be at least 1.' 
1208:     stop 
1209:   end if 
1210:  
1211:   maxedge = nnode * ( nnode - 1 ) 
1212:  
1213:   if ( nedge < 0 .or. maxedge < nedge ) then 
1214:     write ( *, '(a)' ) ' ' 
1215:     write ( *, '(a)' ) 'COLOR_DIGRAPH_ADJ_RANDOM - Fatal error!' 
1216:     write ( *, '(a,i8)' ) '  NEDGE = ', nedge 
1217:     write ( *, '(a)' ) '  but NEDGE must be at least 0, and ' 
1218:     write ( *, '(a,i8)' ) '  no more than ', maxedge 
1219:     stop 
1220:   end if 
1221: ! 
1222: !  Start with no edges, no colors. 
1223: ! 
1224:   adj(1:nnode,1:nnode) = 0 
1225: ! 
1226: !  Choose the colors. 
1227: ! 
1228:   call ksub_random ( nnode, ncolor, seed, subset ) 
1229:  
1230:   call perm_random ( ncolor, seed, perm ) 
1231:  
1232:   do color = 1, ncolor 
1233:     i = subset(perm(color)) 
1234:     adj(i,i) = color 
1235:   end do 
1236:  
1237:   do i = 1, nnode 
1238:     if ( adj(i,i) == 0 ) then 
1239:       color = i4_uniform ( 1, ncolor, seed ) 
1240:       adj(i,i) = color 
1241:     end if 
1242:   end do 
1243: ! 
1244: !  Pick a random NEDGE subset. 
1245: ! 
1246:   call ksub_random ( maxedge, nedge, seed, iwork ) 
1247: ! 
1248: !  Mark the potential edges that were chosen. 
1249: ! 
1250:   k = 0 
1251:   l = 1 
1252:  
1253:   do i = 1, nnode 
1254:     do j = 1, nnode 
1255:  
1256:       if ( i /= j ) then 
1257:  
1258:         k = k + 1 
1259:         if ( l <= nedge ) then 
1260:  
1261:           if ( k == iwork(l) ) then 
1262:             adj(i,j) = 1 
1263:             l = l + 1 
1264:           end if 
1265:  
1266:         end if 
1267:  
1268:       end if 
1269:  
1270:     end do 
1271:   end do 
1272:  
1273:   return 
1274: end subroutine 
1275: subroutine color_graph_adj_color_count ( adj, lda, nnode, mcolor, ncolor ) 
1276:  
1277: !*****************************************************************************80 
1278: ! 
1279: !! COLOR_GRAPH_ADJ_COLOR_COUNT counts the number of colors in a color graph. 
1280: ! 
1281: !  Licensing: 
1282: ! 
1283: !    This code is distributed under the GNU LGPL license.  
1284: ! 
1285: !  Modified: 
1286: ! 
1287: !    27 October 1998 
1288: ! 
1289: !  Author: 
1290: ! 
1291: !    John Burkardt 
1292: ! 
1293: !  Parameters: 
1294: ! 
1295: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1296: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1297: !    if there is an edge between node I and node J. 
1298: ! 
1299: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1300: !    which must be at least NNODE. 
1301: ! 
1302: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1303: ! 
1304: !    Output, integer ( kind = 4 ) MCOLOR, the maximum color index. 
1305: ! 
1306: !    Output, integer ( kind = 4 ) NCOLOR, the number of colors. 
1307: ! 
1308:   implicit none 
1309:  
1310:   integer ( kind = 4 ) lda 
1311:   integer ( kind = 4 ) nnode 
1312:  
1313:   integer ( kind = 4 ) adj(lda,nnode) 
1314:   integer ( kind = 4 ) colors(nnode) 
1315:   integer ( kind = 4 ) i 
1316:   integer ( kind = 4 ) mcolor 
1317:   integer ( kind = 4 ) ncolor 
1318:  
1319:   mcolor = 0 
1320:   do i = 1, nnode 
1321:     mcolor = max ( mcolor, adj(i,i) ) 
1322:   end do 
1323:  
1324:   do i = 1, nnode 
1325:     colors(i) = adj(i,i) 
1326:   end do 
1327:  
1328:   call i4vec_sort_heap_a ( nnode, colors ) 
1329:  
1330:   call i4vec_uniq ( nnode, colors, ncolor ) 
1331:  
1332:   return 
1333: end subroutine 
1334: subroutine color_graph_adj_color_sequence ( adj, lda, nnode, seq ) 
1335:  
1336: !*****************************************************************************80 
1337: ! 
1338: !! COLOR_GRAPH_ADJ_COLOR_SEQUENCE computes the color sequence of a color graph. 
1339: ! 
1340: !  Discussion: 
1341: ! 
1342: !    The color sequence of a color graph is constructed by computing the 
1343: !    color of each node, and then ordering these values in decreasing order. 
1344: ! 
1345: !    If two color graphs are isomorphic, they must have the same color sequence. 
1346: ! 
1347: !    If two color graphs have different color sequences, they cannot be 
1348: !    isomorphic. 
1349: ! 
1350: !  Licensing: 
1351: ! 
1352: !    This code is distributed under the GNU LGPL license.  
1353: ! 
1354: !  Modified: 
1355: ! 
1356: !    02 November 1999 
1357: ! 
1358: !  Author: 
1359: ! 
1360: !    John Burkardt 
1361: ! 
1362: !  Parameters: 
1363: ! 
1364: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1365: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1366: !    if there is an edge between node I and node J. 
1367: ! 
1368: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1369: !    which must be at least NNODE. 
1370: ! 
1371: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1372: ! 
1373: !    Output, integer ( kind = 4 ) SEQ(NNODE), the color sequence. 
1374: ! 
1375:   implicit none 
1376:  
1377:   integer ( kind = 4 ) lda 
1378:   integer ( kind = 4 ) nnode 
1379:  
1380:   integer ( kind = 4 ) adj(lda,nnode) 
1381:   integer ( kind = 4 ) i 
1382:   integer ( kind = 4 ) seq(nnode) 
1383:  
1384:   do i = 1, nnode 
1385:     seq(i) = adj(i,i) 
1386:   end do 
1387:  
1388:   call i4vec_sort_heap_d ( nnode, seq ) 
1389:  
1390:   return 
1391: end subroutine 
1392: subroutine color_graph_adj_connect_random ( lda, nnode, nedge, & 
1393:   ncolor, seed, adj ) 
1394:  
1395: !*****************************************************************************80 
1396: ! 
1397: !! COLOR_GRAPH_ADJ_CONNECT_RANDOM generates a random connected color graph. 
1398: ! 
1399: !  Licensing: 
1400: ! 
1401: !    This code is distributed under the GNU LGPL license.  
1402: ! 
1403: !  Modified: 
1404: ! 
1405: !    28 March 2005 
1406: ! 
1407: !  Author: 
1408: ! 
1409: !    John Burkardt 
1410: ! 
1411: !  Parameters: 
1412: ! 
1413: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
1414: !    be at least NNODE. 
1415: ! 
1416: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1417: ! 
1418: !    Input, integer ( kind = 4 ) NEDGE, the number of edges, which must be  
1419: !    between NNODE-1 and (NNODE*(NNODE-1))/2.   
1420: ! 
1421: !    Input, integer ( kind = 4 ) NCOLOR, the number of colors available to  
1422: !    choose for the nodes.  NCOLOR must be at least 1, and no more than NNODE. 
1423: ! 
1424: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
1425: !    number generator. 
1426: ! 
1427: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1428: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1429: !    if there is an edge between node I and node J. 
1430: ! 
1431:   implicit none 
1432:  
1433:   integer ( kind = 4 ) lda 
1434:   integer ( kind = 4 ) ncolor 
1435:   integer ( kind = 4 ) nnode 
1436:   integer ( kind = 4 ) nedge 
1437:  
1438:   integer ( kind = 4 ) adj(lda,nnode) 
1439:   integer ( kind = 4 ) code(nnode-2) 
1440:   integer ( kind = 4 ) color 
1441:   integer ( kind = 4 ) i 
1442: !  integer ( kind = 4 ) i4_uniform 
1443:   integer ( kind = 4 ) inode(nnode-1) 
1444:   integer ( kind = 4 ) iwork(nedge) 
1445:   integer ( kind = 4 ) j 
1446:   integer ( kind = 4 ) jnode(nnode-1) 
1447:   integer ( kind = 4 ) k 
1448:   integer ( kind = 4 ) l 
1449:   integer ( kind = 4 ) maxedge 
1450:   integer ( kind = 4 ) nchoice 
1451:   integer ( kind = 4 ) nchoose 
1452:   integer ( kind = 4 ) nnode2 
1453:   integer ( kind = 4 ) perm(ncolor) 
1454:   integer ( kind = 4 ) seed 
1455:   integer ( kind = 4 ) subset(ncolor) 
1456: ! 
1457: !  Check. 
1458: ! 
1459:   if ( nnode <= 0  ) then 
1460:     write ( *, '(a)' ) ' ' 
1461:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' 
1462:     write ( *, '(a,i8)' ) '  NNODE = ', nnode 
1463:     write ( *, '(a)' ) '  but NNODE must be at least 1.' 
1464:     stop 
1465:   end if 
1466:  
1467:   if ( lda < nnode ) then 
1468:     write ( *, '(a)' ) ' ' 
1469:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' 
1470:     write ( *, '(a,i8)' ) '  LDA = ', lda 
1471:     write ( *, '(a,i8)' ) '  but LDA must be at least NNODE = ', nnode 
1472:     stop 
1473:   end if 
1474:  
1475:   maxedge = ( nnode * ( nnode - 1 ) ) / 2 
1476:  
1477:   if ( nedge < nnode-1 .or. maxedge < nedge ) then 
1478:     write ( *, '(a)' ) ' ' 
1479:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' 
1480:     write ( *, '(a,i8)' ) '  NEDGE = ', nedge 
1481:     write ( *, '(a)' ) '  but NEDGE must be at least 0, and ' 
1482:     write ( *, '(a,i8)' ) '  no more than ', maxedge 
1483:     stop 
1484:   end if 
1485:  
1486:   if ( ncolor < 1 .or. nnode < ncolor ) then 
1487:     write ( *, '(a)' ) ' ' 
1488:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_CONNECT_RANDOM - Fatal error!' 
1489:     write ( *, '(a,i8)' ) '  NCOLOR = ', ncolor 
1490:     write ( *, '(a)' ) '  but NCOLOR must be at least 1, and ' 
1491:     write ( *, '(a,i8)' ) '  no more than ', nnode 
1492:     stop 
1493:   end if 
1494: ! 
1495: !  Initialize the adjacency matrix. 
1496: ! 
1497:   adj(1:nnode,1:nnode) = 0 
1498: ! 
1499: !  Choose the colors. 
1500: ! 
1501:   call ksub_random ( nnode, ncolor, seed, subset ) 
1502:  
1503:   call perm_random ( ncolor, seed, perm ) 
1504:  
1505:   do color = 1, ncolor 
1506:     i = subset(perm(color)) 
1507:     adj(i,i) = color 
1508:   end do 
1509:  
1510:   do i = 1, nnode 
1511:     if ( adj(i,i) == 0 ) then 
1512:       color = i4_uniform ( 1, ncolor, seed ) 
1513:       adj(i,i) = color 
1514:     end if 
1515:   end do 
1516: ! 
1517: !  Pick a random tree. 
1518: ! 
1519:   call tree_arc_random ( nnode, seed, code, inode, jnode ) 
1520: ! 
1521: !  Convert information to adjacency form. 
1522: ! 
1523:   call graph_arc_to_graph_adj ( nnode-1, inode, jnode, adj, lda, nnode2 ) 
1524: ! 
1525: !  Now we have NEDGE - ( NNODE - 1 ) more edges to add. 
1526: ! 
1527:   nchoice = ( nnode * ( nnode - 1 ) ) / 2 - ( nnode - 1 ) 
1528:   nchoose = nedge - ( nnode - 1 ) 
1529:  
1530:   call ksub_random ( nchoice, nchoose, seed, iwork ) 
1531:  
1532:   k = 0 
1533:   l = 1 
1534:   do i = 1, nnode 
1535:     do j = i + 1, nnode 
1536:       if ( adj(i,j) /= 0 ) then 
1537:         k = k + 1 
1538:  
1539:         if ( l <= nchoose ) then 
1540:           if ( iwork(l) == k ) then 
1541:             adj(i,j) = 1 
1542:             adj(j,i) = 1 
1543:             l = l + 1 
1544:           end if 
1545:         end if 
1546:  
1547:       end if 
1548:     end do 
1549:   end do 
1550:  
1551:   return 
1552: end subroutine 
1553: subroutine color_graph_adj_degree ( adj, lda, nnode, degree ) 
1554:  
1555: !*****************************************************************************80 
1556: ! 
1557: !! COLOR_GRAPH_ADJ_DEGREE computes the degree of each node. 
1558: ! 
1559: !  Discussion: 
1560: ! 
1561: !    The degree of a node is the number of edges that are incident on it. 
1562: !    The sum of the degrees of the nodes is twice the number of edges. 
1563: ! 
1564: !    The generalized case, where ADJ(I,J) can be greater than 1, indicating 
1565: !    the existence of 2 or more distinct edges between nodes I and J, 
1566: !    will be properly handled by this routine.   
1567: ! 
1568: !  Licensing: 
1569: ! 
1570: !    This code is distributed under the GNU LGPL license.  
1571: ! 
1572: !  Modified: 
1573: ! 
1574: !    10 November 1999 
1575: ! 
1576: !  Author: 
1577: ! 
1578: !    John Burkardt 
1579: ! 
1580: !  Parameters: 
1581: ! 
1582: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1583: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1584: !    if there is an edge between node I and node J. 
1585: ! 
1586: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1587: !    which must be at least NNODE. 
1588: ! 
1589: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1590: ! 
1591: !    Output, integer ( kind = 4 ) DEGREE(NNODE), the degree of the nodes. 
1592: ! 
1593:   implicit none 
1594:  
1595:   integer ( kind = 4 ) lda 
1596:   integer ( kind = 4 ) nnode 
1597:  
1598:   integer ( kind = 4 ) adj(lda,nnode) 
1599:   integer ( kind = 4 ) degree(nnode) 
1600:   integer ( kind = 4 ) i 
1601:   integer ( kind = 4 ) j 
1602:  
1603:   degree(1:nnode) = 0 
1604:  
1605:   do i = 1, nnode 
1606:     do j = 1, nnode 
1607:       if ( i /= j ) then 
1608:         if ( adj(i,j) /= 0 ) then 
1609:           degree(i) = degree(i) + adj(i,j) 
1610:         end if 
1611:       end if 
1612:     end do 
1613:   end do 
1614:  
1615:   return 
1616: end subroutine 
1617: subroutine color_graph_adj_degree_seq ( adj, lda, nnode, seq ) 
1618:  
1619: !*****************************************************************************80 
1620: ! 
1621: !! COLOR_GRAPH_ADJ_DEGREE_SEQ computes the degree sequence of a color graph. 
1622: ! 
1623: !  Discussion: 
1624: ! 
1625: !    The degree sequence of a graph is constructed by computing the 
1626: !    degree of each node, and then ordering these values in decreasing order. 
1627: ! 
1628: !    If two graphs are isomorphic, they must have the same degree sequence. 
1629: ! 
1630: !    If two graphs have different degree sequences, they cannot be isomorphic. 
1631: ! 
1632: !  Licensing: 
1633: ! 
1634: !    This code is distributed under the GNU LGPL license.  
1635: ! 
1636: !  Modified: 
1637: ! 
1638: !    10 November 1999 
1639: ! 
1640: !  Author: 
1641: ! 
1642: !    John Burkardt 
1643: ! 
1644: !  Parameters: 
1645: ! 
1646: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1647: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1648: !    if there is an edge between node I and node J. 
1649: ! 
1650: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1651: !    which must be at least NNODE. 
1652: ! 
1653: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1654: ! 
1655: !    Output, integer ( kind = 4 ) SEQ(NNODE), the degree sequence. 
1656: ! 
1657:   implicit none 
1658:  
1659:   integer ( kind = 4 ) lda 
1660:   integer ( kind = 4 ) nnode 
1661:  
1662:   integer ( kind = 4 ) adj(lda,nnode) 
1663:   integer ( kind = 4 ) seq(nnode) 
1664:  
1665:   call color_graph_adj_degree ( adj, lda, nnode, seq ) 
1666:  
1667:   call i4vec_sort_heap_d ( nnode, seq ) 
1668:  
1669:   return 
1670: end subroutine 
1671: subroutine color_graph_adj_edge_count ( adj, lda, nnode, nedge ) 
1672:  
1673: !*****************************************************************************80 
1674: ! 
1675: !! COLOR_GRAPH_ADJ_EDGE_COUNT counts the number of edges in a color graph. 
1676: ! 
1677: !  Licensing: 
1678: ! 
1679: !    This code is distributed under the GNU LGPL license.  
1680: ! 
1681: !  Modified: 
1682: ! 
1683: !    26 October 1999 
1684: ! 
1685: !  Author: 
1686: ! 
1687: !    John Burkardt 
1688: ! 
1689: !  Parameters: 
1690: ! 
1691: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1692: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1693: !    if there is an edge between node I and node J. 
1694: ! 
1695: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1696: !    which must be at least NNODE. 
1697: ! 
1698: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
1699: ! 
1700: !    Output, integer ( kind = 4 ) NEDGE, the number of edges. 
1701: ! 
1702:   implicit none 
1703:  
1704:   integer ( kind = 4 ) lda 
1705:   integer ( kind = 4 ) nnode 
1706:  
1707:   integer ( kind = 4 ) adj(lda,nnode) 
1708:   integer ( kind = 4 ) i 
1709:   integer ( kind = 4 ) j 
1710:   integer ( kind = 4 ) nedge 
1711:  
1712:   nedge = 0 
1713:  
1714:   do i = 1, nnode 
1715:     do j = 1, nnode 
1716:  
1717:       if ( i /= j ) then 
1718:         nedge = nedge + adj(i,j) 
1719:       end if 
1720:  
1721:     end do 
1722:   end do 
1723:  
1724:   nedge = nedge / 2 
1725:  
1726:   return 
1727: end subroutine 
1728: subroutine color_graph_adj_example_bush ( adj, lda, nnode ) 
1729:  
1730: !*****************************************************************************80 
1731: ! 
1732: !! COLOR_GRAPH_ADJ_EXAMPLE_BUSH sets up the bush color graph. 
1733: ! 
1734: !  Diagram: 
1735: ! 
1736: !        6G  3R 
1737: !        |   | 
1738: !    1B--4G--5W--2R 
1739: !        | 
1740: !        7W 
1741: ! 
1742: !  Licensing: 
1743: ! 
1744: !    This code is distributed under the GNU LGPL license.  
1745: ! 
1746: !  Modified: 
1747: ! 
1748: !    22 October 1998 
1749: ! 
1750: !  Author: 
1751: ! 
1752: !    John Burkardt 
1753: ! 
1754: !  Parameters: 
1755: ! 
1756: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1757: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1758: !    if there is an edge between node I and node J. 
1759: ! 
1760: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1761: !    which must be at least NNODE. 
1762: ! 
1763: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
1764: ! 
1765:   implicit none 
1766:  
1767:   integer ( kind = 4 ), parameter :: BLUE = 1 
1768:   integer ( kind = 4 ), parameter :: GREEN = 2 
1769:   integer ( kind = 4 ), parameter :: RED = 3 
1770:   integer ( kind = 4 ), parameter :: WHITE = 4 
1771:  
1772:   integer ( kind = 4 ) lda 
1773:  
1774:   integer ( kind = 4 ) adj(lda,lda) 
1775:   integer ( kind = 4 ) nnode 
1776:  
1777:   nnode = 7 
1778:  
1779:   if ( lda < nnode ) then 
1780:     write ( *, '(a)' ) ' ' 
1781:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_BUSH - Fatal error!' 
1782:     write ( *, '(a)' ) '  LDA is too small!' 
1783:     stop 
1784:   end if 
1785:  
1786:   adj(1:nnode,1:nnode) = 0 
1787:  
1788:   adj(1,1) = BLUE 
1789:   adj(1,4) = 1 
1790:  
1791:   adj(2,2) = RED 
1792:   adj(2,5) = 1 
1793:  
1794:   adj(3,3) = RED 
1795:   adj(3,5) = 1 
1796:  
1797:   adj(4,1) = 1 
1798:   adj(4,4) = GREEN 
1799:   adj(4,5) = 1 
1800:   adj(4,6) = 1 
1801:   adj(4,7) = 1 
1802:  
1803:   adj(5,2) = 1 
1804:   adj(5,3) = 1 
1805:   adj(5,4) = 1 
1806:   adj(5,5) = WHITE 
1807:  
1808:   adj(6,4) = 1 
1809:   adj(6,6) = GREEN 
1810:  
1811:   adj(7,4) = 1 
1812:   adj(7,7) = WHITE 
1813:  
1814:   return 
1815: end subroutine 
1816: subroutine color_graph_adj_example_cube ( adj, lda, nnode ) 
1817:  
1818: !*****************************************************************************80 
1819: ! 
1820: !! COLOR_GRAPH_ADJ_EXAMPLE_CUBE sets up the cube color graph. 
1821: ! 
1822: !  Diagram: 
1823: ! 
1824: !      4R----7R 
1825: !     /|    /| 
1826: !    8B----3B| 
1827: !    | |   | | 
1828: !    | 5B--|-2G 
1829: !    |/    |/ 
1830: !    1G----6B 
1831: ! 
1832: !  Licensing: 
1833: ! 
1834: !    This code is distributed under the GNU LGPL license.  
1835: ! 
1836: !  Modified: 
1837: ! 
1838: !    22 October 1998 
1839: ! 
1840: !  Author: 
1841: ! 
1842: !    John Burkardt 
1843: ! 
1844: !  Parameters: 
1845: ! 
1846: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
1847: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
1848: !    if there is an edge between node I and node J. 
1849: ! 
1850: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1851: !    which must be at least NNODE. 
1852: ! 
1853: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
1854: ! 
1855:   implicit none 
1856:  
1857:   integer ( kind = 4 ), parameter :: BLUE = 1 
1858:   integer ( kind = 4 ), parameter :: GREEN = 2 
1859:   integer ( kind = 4 ), parameter :: RED = 3 
1860:  
1861:   integer ( kind = 4 ) lda 
1862:  
1863:   integer ( kind = 4 ) adj(lda,lda) 
1864:   integer ( kind = 4 ) nnode 
1865:  
1866:   nnode = 8 
1867:  
1868:   if ( lda < nnode ) then 
1869:     write ( *, '(a)' ) ' ' 
1870:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_CUBE - Fatal error!' 
1871:     write ( *, '(a)' ) '  LDA is too small.' 
1872:     stop 
1873:   end if 
1874:  
1875:   adj(1:nnode,1:nnode) = 0 
1876:  
1877:   adj(1,1) = GREEN 
1878:   adj(1,5) = 1 
1879:   adj(1,6) = 1 
1880:   adj(1,8) = 1 
1881:  
1882:   adj(2,2) = GREEN 
1883:   adj(2,5) = 1 
1884:   adj(2,6) = 1 
1885:   adj(2,7) = 1 
1886:  
1887:   adj(3,3) = BLUE 
1888:   adj(3,6) = 1 
1889:   adj(3,7) = 1 
1890:   adj(3,8) = 1 
1891:  
1892:   adj(4,4) = RED 
1893:   adj(4,5) = 1 
1894:   adj(4,7) = 1 
1895:   adj(4,8) = 1 
1896:  
1897:   adj(5,5) = BLUE 
1898:   adj(5,1) = 1 
1899:   adj(5,2) = 1 
1900:   adj(5,4) = 1 
1901:  
1902:   adj(6,6) = BLUE 
1903:   adj(6,1) = 1 
1904:   adj(6,2) = 1 
1905:   adj(6,3) = 1 
1906:  
1907:   adj(7,7) = RED 
1908:   adj(7,2) = 1 
1909:   adj(7,3) = 1 
1910:   adj(7,4) = 1 
1911:  
1912:   adj(8,8) = BLUE 
1913:   adj(8,1) = 1 
1914:   adj(8,3) = 1 
1915:   adj(8,4) = 1 
1916:  
1917:   return 
1918: end subroutine 
1919: subroutine color_graph_adj_example_octo ( lda, example, seed, nnode, adj ) 
1920:  
1921: !*****************************************************************************80 
1922: ! 
1923: !! COLOR_GRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example color graph. 
1924: ! 
1925: !  Diagram: 
1926: ! 
1927: !      1---2 
1928: !     /|   |\ 
1929: !    8-+---+-3 
1930: !    | |   | | 
1931: !    7-+---+-4 
1932: !     \|   |/ 
1933: !      6---5 
1934: ! 
1935: !     Graph "A" 
1936: ! 
1937: !    There are 7 graphs to choose from.  They are all on 8 nodes.  The first 
1938: !    5 have degree 3 at every node.  Graphs 6 and 7 have degree 5 at every 
1939: !    node. 
1940: ! 
1941: !  Licensing: 
1942: ! 
1943: !    This code is distributed under the GNU LGPL license.  
1944: ! 
1945: !  Modified: 
1946: ! 
1947: !    05 November 1999 
1948: ! 
1949: !  Author: 
1950: ! 
1951: !    John Burkardt 
1952: ! 
1953: !  Parameters: 
1954: ! 
1955: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
1956: !    which must be at least NNODE. 
1957: ! 
1958: !    Input, integer ( kind = 4 ) EXAMPLE, should be between 1 and 35, and  
1959: !    indicates which example graph to pick. 
1960: ! 
1961: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
1962: !    number generator. 
1963: ! 
1964: !    Output, integer ( kind = 4 ) NNODE, the number of nodes, which should be 8. 
1965: ! 
1966: !    Output, integer ( kind = 4 ) ADJ(LDA,LDA), the adjacency information. 
1967: !    ADJ(I,I) is the color of node I. 
1968: !    ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. 
1969: ! 
1970:   implicit none 
1971:  
1972:   integer ( kind = 4 ), parameter :: BLUE = 1 
1973:   integer ( kind = 4 ), parameter :: GREEN = 2 
1974:   integer ( kind = 4 ), parameter :: RED = 3 
1975:   integer ( kind = 4 ), parameter :: YELLOW = 4 
1976:  
1977:   integer ( kind = 4 ) lda 
1978:  
1979:   integer ( kind = 4 ) adj(lda,lda) 
1980:   integer ( kind = 4 ) example 
1981:   integer ( kind = 4 ) i 
1982: !  integer ( kind = 4 ) i4_uniform 
1983:   integer ( kind = 4 ) j 
1984:   integer ( kind = 4 ) msave 
1985:   integer ( kind = 4 ) nnode 
1986:   integer ( kind = 4 ) nsave 
1987:   integer ( kind = 4 ) seed 
1988:  
1989:   if ( example <= 0 ) then 
1990:     nsave = i4_uniform ( 1, 7, seed ) 
1991:     msave = i4_uniform ( 1, 5, seed ) 
1992:   else 
1993:     example = mod ( example - 1, 35 ) + 1 
1994:     msave = ( ( example - 1 ) / 7 ) + 1 
1995:     nsave = mod ( example - 1, 7 ) + 1 
1996:   end if 
1997:  
1998:   nnode = 8 
1999:  
2000:   if ( lda < nnode ) then 
2001:     write ( *, '(a)' ) ' ' 
2002:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' 
2003:     write ( *, '(a)' ) '  LDA is too small.' 
2004:     stop 
2005:   end if 
2006:  
2007:   adj(1:nnode,1:nnode) = 0 
2008:  
2009:   do i = 1, nnode 
2010:     j = i + 1 
2011:     if ( nnode < j ) then 
2012:       j = j - nnode 
2013:     end if 
2014:  
2015:     adj(i,j) = 1 
2016:     adj(j,i) = 1 
2017:  
2018:   end do 
2019: ! 
2020: !  Underlying graph 1. 
2021: ! 
2022:   if ( nsave == 1 ) then 
2023:  
2024:     adj(1,6) = 1 
2025:     adj(6,1) = 1 
2026:     adj(2,5) = 1 
2027:     adj(5,2) = 1 
2028:     adj(3,8) = 1 
2029:     adj(8,3) = 1 
2030:     adj(4,7) = 1 
2031:     adj(7,4) = 1 
2032: ! 
2033: !  Underlying graph 2. 
2034: ! 
2035:   else if ( nsave == 2 ) then 
2036:  
2037:     adj(1,6) = 1 
2038:     adj(6,1) = 1 
2039:     adj(2,8) = 1 
2040:     adj(8,2) = 1 
2041:     adj(3,5) = 1 
2042:     adj(5,3) = 1 
2043:     adj(4,7) = 1 
2044:     adj(7,4) = 1 
2045: ! 
2046: !  Underlying graph 3. 
2047: ! 
2048:   else if ( nsave == 3 ) then 
2049:  
2050:     adj(1,5) = 1 
2051:     adj(5,1) = 1 
2052:     adj(2,6) = 1 
2053:     adj(6,2) = 1 
2054:     adj(3,7) = 1 
2055:     adj(7,3) = 1 
2056:     adj(4,8) = 1 
2057:     adj(8,4) = 1 
2058: ! 
2059: !  Underlying graph 4. 
2060: ! 
2061:   else if ( nsave == 4 ) then 
2062:  
2063:     adj(1,3) = 1 
2064:     adj(3,1) = 1 
2065:     adj(2,4) = 1 
2066:     adj(4,2) = 1 
2067:     adj(5,7) = 1 
2068:     adj(7,5) = 1 
2069:     adj(6,8) = 1 
2070:     adj(8,6) = 1 
2071: ! 
2072: !  Underlying graph 5. 
2073: ! 
2074:   else if ( nsave == 5 ) then 
2075:  
2076:     adj(1,4) = 1 
2077:     adj(4,1) = 1 
2078:     adj(2,6) = 1 
2079:     adj(6,2) = 1 
2080:     adj(3,8) = 1 
2081:     adj(8,3) = 1 
2082:     adj(5,7) = 1 
2083:     adj(7,5) = 1 
2084: ! 
2085: !  Underlying graph 6. 
2086: ! 
2087:   else if ( nsave == 6 ) then 
2088:  
2089:     adj(1,4) = 1 
2090:     adj(1,5) = 1 
2091:     adj(1,6) = 1 
2092:  
2093:     adj(2,5) = 1 
2094:     adj(2,6) = 1 
2095:     adj(2,7) = 1 
2096:  
2097:     adj(3,6) = 1 
2098:     adj(3,7) = 1 
2099:     adj(3,8) = 1 
2100:  
2101:     adj(4,7) = 1 
2102:     adj(4,8) = 1 
2103:     adj(4,1) = 1 
2104:  
2105:     adj(5,8) = 1 
2106:     adj(5,1) = 1 
2107:     adj(5,2) = 1 
2108:  
2109:     adj(6,1) = 1 
2110:     adj(6,2) = 1 
2111:     adj(6,3) = 1 
2112:  
2113:     adj(7,2) = 1 
2114:     adj(7,3) = 1 
2115:     adj(7,4) = 1 
2116:  
2117:     adj(8,3) = 1 
2118:     adj(8,4) = 1 
2119:     adj(8,5) = 1 
2120: ! 
2121: !  Underlying graph 7. 
2122: ! 
2123:   else if ( nsave == 7 ) then 
2124:  
2125:     adj(1,3) = 1 
2126:     adj(1,5) = 1 
2127:     adj(1,7) = 1 
2128:  
2129:     adj(2,4) = 1 
2130:     adj(2,6) = 1 
2131:     adj(2,8) = 1 
2132:  
2133:     adj(3,5) = 1 
2134:     adj(3,7) = 1 
2135:     adj(3,1) = 1 
2136:  
2137:     adj(4,6) = 1 
2138:     adj(4,8) = 1 
2139:     adj(4,2) = 1 
2140:  
2141:     adj(5,7) = 1 
2142:     adj(5,1) = 1 
2143:     adj(5,3) = 1 
2144:  
2145:     adj(6,8) = 1 
2146:     adj(6,2) = 1 
2147:     adj(6,4) = 1 
2148:  
2149:     adj(7,1) = 1 
2150:     adj(7,3) = 1 
2151:     adj(7,5) = 1 
2152:  
2153:     adj(8,2) = 1 
2154:     adj(8,4) = 1 
2155:     adj(8,6) = 1 
2156:  
2157:   end if 
2158:  
2159:   if ( msave == 1 ) then 
2160:  
2161:     adj(1,1) = RED 
2162:     adj(2,2) = RED 
2163:     adj(3,3) = RED 
2164:     adj(4,4) = BLUE 
2165:     adj(5,5) = BLUE 
2166:     adj(6,6) = BLUE 
2167:     adj(7,7) = GREEN 
2168:     adj(8,8) = GREEN 
2169:  
2170:   else if ( msave == 2 ) then 
2171:  
2172:     adj(1,1) = RED 
2173:     adj(2,2) = RED 
2174:     adj(3,3) = RED 
2175:     adj(4,4) = BLUE 
2176:     adj(5,5) = BLUE 
2177:     adj(6,6) = BLUE 
2178:     adj(7,7) = GREEN 
2179:     adj(8,8) = YELLOW 
2180:  
2181:   else if ( msave == 3 ) then 
2182:  
2183:     adj(1,1) = RED 
2184:     adj(2,2) = RED 
2185:     adj(3,3) = RED 
2186:     adj(4,4) = BLUE 
2187:     adj(5,5) = BLUE 
2188:     adj(6,6) = BLUE 
2189:     adj(7,7) = YELLOW 
2190:     adj(8,8) = YELLOW 
2191:  
2192:   else if ( msave == 4 ) then 
2193:  
2194:     adj(1,1) = RED 
2195:     adj(2,2) = RED 
2196:     adj(3,3) = RED 
2197:     adj(4,4) = BLUE 
2198:     adj(5,5) = BLUE 
2199:     adj(6,6) = GREEN 
2200:     adj(7,7) = GREEN 
2201:     adj(8,8) = GREEN 
2202:  
2203:   else if ( msave == 5 ) then 
2204:  
2205:     adj(1,1) = RED 
2206:     adj(2,2) = BLUE 
2207:     adj(3,3) = RED 
2208:     adj(4,4) = GREEN 
2209:     adj(5,5) = BLUE 
2210:     adj(6,6) = RED 
2211:     adj(7,7) = BLUE 
2212:     adj(8,8) = GREEN 
2213:  
2214:   end if 
2215: ! 
2216: !  Now permute the graph. 
2217: ! 
2218:   call i4mat_perm_random ( lda, nnode, seed, adj ) 
2219:  
2220:   return 
2221: end subroutine 
2222: subroutine color_graph_adj_example_twig ( adj, lda, nnode ) 
2223:  
2224: !*****************************************************************************80 
2225: ! 
2226: !! COLOR_GRAPH_ADJ_EXAMPLE_TWIG sets up the twig color graph. 
2227: ! 
2228: !  Diagram: 
2229: ! 
2230: !    1R---2R---3B 
2231: ! 
2232: !  Licensing: 
2233: ! 
2234: !    This code is distributed under the GNU LGPL license.  
2235: ! 
2236: !  Modified: 
2237: ! 
2238: !    22 October 1998 
2239: ! 
2240: !  Author: 
2241: ! 
2242: !    John Burkardt 
2243: ! 
2244: !  Parameters: 
2245: ! 
2246: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
2247: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
2248: !    if there is an edge between node I and node J. 
2249: ! 
2250: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
2251: !    which must be at least NNODE. 
2252: ! 
2253: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
2254: ! 
2255:   implicit none 
2256:  
2257:   integer ( kind = 4 ), parameter :: BLUE = 1 
2258:   integer ( kind = 4 ), parameter :: RED = 3 
2259:  
2260:   integer ( kind = 4 ) lda 
2261:  
2262:   integer ( kind = 4 ) adj(lda,lda) 
2263:   integer ( kind = 4 ) nnode 
2264:  
2265:   nnode = 3 
2266:  
2267:   if ( lda < nnode ) then 
2268:     write ( *, '(a)' ) ' ' 
2269:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_EXAMPLE_TWIG - Fatal error!' 
2270:     write ( *, '(a)' ) '  LDA is too small!' 
2271:     stop 
2272:   end if 
2273:  
2274:   adj(1:nnode,1:nnode) = 0 
2275:  
2276:   adj(1,1) = RED 
2277:   adj(1,2) = 1 
2278:  
2279:   adj(2,1) = 1 
2280:   adj(2,2) = RED 
2281:   adj(2,3) = 1 
2282:  
2283:   adj(3,2) = 1 
2284:   adj(3,3) = BLUE 
2285:  
2286:   return 
2287: end subroutine 
2288: subroutine color_graph_adj_print ( adj, lda, nnode, title ) 
2289:  
2290: !*****************************************************************************80 
2291: ! 
2292: !! COLOR_GRAPH_ADJ_PRINT prints out the adjacency matrix of a color graph. 
2293: ! 
2294: !  Licensing: 
2295: ! 
2296: !    This code is distributed under the GNU LGPL license.  
2297: ! 
2298: !  Modified: 
2299: ! 
2300: !    04 July 2000 
2301: ! 
2302: !  Author: 
2303: ! 
2304: !    John Burkardt 
2305: ! 
2306: !  Parameters: 
2307: ! 
2308: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
2309: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
2310: !    if there is an edge between node I and node J. 
2311: ! 
2312: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ, which must  
2313: !    be at least NNODE. 
2314: ! 
2315: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
2316: ! 
2317: !    Input, character ( len = * ) TITLE, a title. 
2318: ! 
2319:   implicit none 
2320:  
2321:   integer ( kind = 4 ) lda 
2322:   integer ( kind = 4 ) nnode 
2323:  
2324:   integer ( kind = 4 ) adj(lda,nnode) 
2325:   integer ( kind = 4 ) i 
2326:   integer ( kind = 4 ) j 
2327:   integer ( kind = 4 ) k 
2328:   character ( len = 80 ) string 
2329:   character ( len = * ) title 
2330:  
2331:   if ( len_trim ( title ) /= 0 ) then 
2332:     write ( *, '(a)' ) ' ' 
2333:     write ( *, '(a)' ) trim ( title ) 
2334:   end if 
2335:  
2336:   write ( *, '(a)' ) ' ' 
2337:  
2338:   do i = 1, nnode 
2339:  
2340:     do j = 1, nnode 
2341:  
2342:       k = (j-1) * 3 + 1 
2343:       write ( string(k:k+2), '(i3)' ) adj(i,j) 
2344:  
2345:     end do 
2346:  
2347:     write ( *, '(i2,2x,a)' ) i, string(1:3*nnode) 
2348:  
2349:   end do 
2350:  
2351:   return 
2352: end subroutine 
2353: subroutine color_graph_adj_random ( lda, nnode, ncolor, nedge, seed, adj ) 
2354:  
2355: !*****************************************************************************80 
2356: ! 
2357: !! COLOR_GRAPH_ADJ_RANDOM generates a random color graph. 
2358: ! 
2359: !  Licensing: 
2360: ! 
2361: !    This code is distributed under the GNU LGPL license.  
2362: ! 
2363: !  Modified: 
2364: ! 
2365: !    28 March 2005 
2366: ! 
2367: !  Author: 
2368: ! 
2369: !    John Burkardt 
2370: ! 
2371: !  Parameters: 
2372: ! 
2373: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
2374: !    be at least NNODE. 
2375: ! 
2376: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
2377: ! 
2378: !    Input, integer ( kind = 4 ) NCOLOR, the number of colors available to  
2379: !    choose for the nodes.  NCOLOR must be at least 1, and no more than NNODE. 
2380: ! 
2381: !    Input, integer ( kind = 4 ) NEDGE, the number of edges, which must be  
2382: !    between 0 and (NNODE*(NNODE-1))/2. 
2383: ! 
2384: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
2385: !    number generator. 
2386: ! 
2387: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
2388: !    ADJ(I,I) is the color of node I; otherwise, ADJ(I,J) is positive 
2389: !    if there is an edge between node I and node J. 
2390: ! 
2391:   implicit none 
2392:  
2393:   integer ( kind = 4 ) lda 
2394:   integer ( kind = 4 ) nnode 
2395:   integer ( kind = 4 ) nedge 
2396:  
2397:   integer ( kind = 4 ) adj(lda,nnode) 
2398:   integer ( kind = 4 ) color 
2399:   integer ( kind = 4 ) i 
2400: !  integer ( kind = 4 ) i4_uniform 
2401:   integer ( kind = 4 ) iwork(nedge) 
2402:   integer ( kind = 4 ) j 
2403:   integer ( kind = 4 ) k 
2404:   integer ( kind = 4 ) l 
2405:   integer ( kind = 4 ) maxedge 
2406:   integer ( kind = 4 ) ncolor 
2407:   integer ( kind = 4 ) perm(ncolor) 
2408:   integer ( kind = 4 ) seed 
2409:   integer ( kind = 4 ) subset(ncolor) 
2410:  
2411:   if ( nnode <= 0  ) then 
2412:     write ( *, '(a)' ) ' ' 
2413:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_RANDOM - Fatal error!' 
2414:     write ( *, '(a,i8)' ) '  NNODE = ', nnode 
2415:     write ( *, '(a)' ) '  but NNODE must be at least 1.' 
2416:     stop 
2417:   end if 
2418:  
2419:   maxedge = ( nnode * ( nnode - 1 ) ) / 2 
2420:  
2421:   if ( nedge < 0 .or. maxedge < nedge ) then 
2422:     write ( *, '(a)' ) ' ' 
2423:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_RANDOM - Fatal error!' 
2424:     write ( *, '(a,i8)' ) '  NEDGE = ', nedge 
2425:     write ( *, '(a)' ) '  but NEDGE must be at least 0, and ' 
2426:     write ( *, '(a,i8)' ) '  no more than ', maxedge 
2427:     stop 
2428:   end if 
2429:  
2430:   if ( ncolor < 1 .or. nnode < ncolor ) then 
2431:     write ( *, '(a)' ) ' ' 
2432:     write ( *, '(a)' ) 'COLOR_GRAPH_ADJ_RANDOM - Fatal error!' 
2433:     write ( *, '(a)' ) '  Illegal value of NCOLOR.' 
2434:     stop 
2435:   end if 
2436: ! 
2437: !  Start out with no edges and no colors. 
2438: ! 
2439:   adj(1:nnode,1:nnode) = 0 
2440: ! 
2441: !  Choose the colors. 
2442: ! 
2443:   call ksub_random ( nnode, ncolor, seed, subset ) 
2444:  
2445:   call perm_random ( ncolor, seed, perm ) 
2446:  
2447:   do color = 1, ncolor 
2448:     i = subset(perm(color)) 
2449:     adj(i,i) = color 
2450:   end do 
2451:  
2452:   do i = 1, nnode 
2453:     if ( adj(i,i) == 0 ) then 
2454:       color = i4_uniform ( 1, ncolor, seed ) 
2455:       adj(i,i) = color 
2456:     end if 
2457:   end do 
2458: ! 
2459: !  Pick a random NEDGE subset of (N*(N-1))/2. 
2460: ! 
2461:   call ksub_random ( maxedge, nedge, seed, iwork ) 
2462: ! 
2463: !  The (n*(n-1))/2 spots in the superdiagonal are numbered as follows: 
2464: ! 
2465: !  * 1  2   3  ...  n-1   n 
2466: !  * * n+1 n+2 ... 2n-2  2n-1 
2467: !  ... 
2468: !  * *  *   *  ...   *   (n*(n-1))/2 
2469: !  * *  *   *  ...   *    * 
2470: ! 
2471:   k = 0 
2472:   l = 1 
2473:   do i = 1, nnode-1 
2474:     do j = i+1, nnode 
2475:  
2476:       k = k + 1 
2477:       if ( l <= nedge ) then 
2478:  
2479:         if ( k == iwork(l) ) then 
2480:           adj(i,j) = 1 
2481:           adj(j,i) = 1 
2482:           l = l + 1 
2483:         end if 
2484:  
2485:       end if 
2486:  
2487:     end do 
2488:   end do 
2489:  
2490:   return 
2491: end subroutine 
2492: subroutine degree_seq_is_graphic ( nnode, seq, result ) 
2493:  
2494: !*****************************************************************************80 
2495: ! 
2496: !! DEGREE_SEQ_IS_GRAPHIC reports whether a degree sequence represents a graph. 
2497: ! 
2498: !  Discussion: 
2499: ! 
2500: !    The degree sequence of a graph is constructed by computing the 
2501: !    degree of each node, and then ordering these values in decreasing order. 
2502: ! 
2503: !    A sequence of NNODE nonnegative integers is said to be "graphic" if 
2504: !    there exists a graph whose degree sequence is the given sequence. 
2505: ! 
2506: !    The Havel Hakimi theorem states that  
2507: ! 
2508: !      s t1 t2 ... ts d1 d2 ... dn 
2509: ! 
2510: !    is graphic if and only if 
2511: ! 
2512: !        t1-1 t2-1 ... ts-1 d1 d2 ... dn 
2513: ! 
2514: !    is graphic (after any necessary resorting and dropping of zeroes). 
2515: !    Definitely, the one thing we cannot have is that any nonzero entry 
2516: !    is equal to or greater than the number of nonzero entries. 
2517: ! 
2518: !  Licensing: 
2519: ! 
2520: !    This code is distributed under the GNU LGPL license.  
2521: ! 
2522: !  Modified: 
2523: ! 
2524: !    01 November 1999 
2525: ! 
2526: !  Author: 
2527: ! 
2528: !    John Burkardt 
2529: ! 
2530: !  Parameters: 
2531: ! 
2532: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
2533: ! 
2534: !    Input, integer ( kind = 4 ) SEQ(NNODE), the degree sequence to be tested. 
2535: ! 
2536: !    Output, integer ( kind = 4 ) RESULT, the result. 
2537: !    0, SEQ is not graphic. 
2538: !    1, SEQ is graphic. 
2539: ! 
2540:   implicit none 
2541:  
2542:   integer ( kind = 4 ) nnode 
2543:  
2544:   integer ( kind = 4 ) dmax 
2545:   integer ( kind = 4 ) i 
2546: !  integer ( kind = 4 ) i4vec_nonzero 
2547:   integer ( kind = 4 ) nonzero 
2548:   integer ( kind = 4 ) order 
2549:   integer ( kind = 4 ) result 
2550:   integer ( kind = 4 ) seq(nnode) 
2551:  
2552:   result = 0 
2553:  
2554:   do i = 1, nnode 
2555:     if ( seq(i) < 0 ) then 
2556:       return 
2557:     end if 
2558:   end do 
2559: ! 
2560: !  Check that the sequence is decreasing. 
2561: ! 
2562:   call i4vec_order_type ( nnode, seq, order ) 
2563:  
2564:   if ( order == -1 .or. order == 1 .or. order == 2 ) then 
2565:     return 
2566:   end if 
2567: ! 
2568: !  Now apply the Havel Hakimi theorem. 
2569: ! 
2570:   do 
2571:  
2572:     nonzero = i4vec_nonzero ( nnode, seq ) 
2573:  
2574:     if ( nonzero == 0 ) then 
2575:       result = 1 
2576:       exit 
2577:     end if 
2578:  
2579:     call i4vec_sort_heap_d ( nnode, seq ) 
2580:  
2581:     dmax = seq(1) 
2582:  
2583:     if ( nonzero <= dmax ) then 
2584:       result = 0 
2585:       exit 
2586:     end if 
2587:  
2588:     seq(1) = 0 
2589:     do i = 2, dmax + 1 
2590:       seq(i) = seq(i) - 1 
2591:     end do 
2592:  
2593:   end do 
2594:          
2595:   return 
2596: end subroutine 
2597: subroutine degree_seq_to_graph_adj ( nnode, seq, lda, adj, ierror ) 
2598:  
2599: !*****************************************************************************80 
2600: ! 
2601: !! DEGREE_SEQ_TO_GRAPH_ADJ computes a graph with the given degree sequence. 
2602: ! 
2603: !  Licensing: 
2604: ! 
2605: !    This code is distributed under the GNU LGPL license.  
2606: ! 
2607: !  Modified: 
2608: ! 
2609: !    07 November 1999 
2610: ! 
2611: !  Author: 
2612: ! 
2613: !    John Burkardt 
2614: ! 
2615: !  Parameters: 
2616: ! 
2617: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
2618: ! 
2619: !    Input, integer ( kind = 4 ) SEQ(NNODE), the degree sequence. 
2620: ! 
2621: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ. 
2622: ! 
2623: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information.   
2624: !    ADJ(I,J) is nonzero if there is an edge from node I to node J. 
2625: ! 
2626: !    Output, integer ( kind = 4 ) IERROR, is nonzero if an error occurred. 
2627: ! 
2628:   implicit none 
2629:  
2630:   integer ( kind = 4 ) lda 
2631:   integer ( kind = 4 ) nnode 
2632:  
2633:   integer ( kind = 4 ) adj(lda,nnode) 
2634:   integer ( kind = 4 ) i 
2635:   integer ( kind = 4 ) ierror 
2636:   integer ( kind = 4 ) indx(nnode) 
2637:   integer ( kind = 4 ) nonzero 
2638:   integer ( kind = 4 ) s 
2639:   integer ( kind = 4 ) seq(nnode) 
2640:   integer ( kind = 4 ) seq2(nnode) 
2641:  
2642:   ierror = 0 
2643:  
2644:   adj(1:nnode,1:nnode) = 0 
2645:  
2646:   seq2(1:nnode) = seq(1:nnode) 
2647:  
2648:   do 
2649:  
2650:     call i4vec_sort_heap_index_d ( nnode, seq2, indx ) 
2651:  
2652:     nonzero = 0 
2653:     do i = 1, nnode 
2654:       if ( seq2(i) /= 0 ) then 
2655:         nonzero = nonzero + 1 
2656:       end if 
2657:     end do 
2658:  
2659:     if ( nonzero == 0 ) then 
2660:       exit 
2661:     end if 
2662:  
2663:     s = seq2(indx(1)) 
2664:  
2665:     if ( nonzero <= s ) then 
2666:       ierror = 1 
2667:       write ( *, '(a)' ) ' ' 
2668:       write ( *, '(a)' ) 'DEGREE_SEQ_TO_GRAPH_ADJ - Fatal error!' 
2669:       write ( *, '(a)' ) '  The degree sequence is not graphic!' 
2670:       return 
2671:     end if 
2672:  
2673:     seq2(indx(1)) = 0 
2674:  
2675:     do i = 2, s+1 
2676:       adj(indx(i),indx(1)) = 1 
2677:       adj(indx(1),indx(i)) = 1 
2678:       seq2(indx(i)) = seq2(indx(i)) - 1 
2679:     end do 
2680:  
2681:   end do 
2682:  
2683:   return 
2684: end subroutine 
2685: subroutine dge_check ( lda, m, n, ierror ) 
2686:  
2687: !*****************************************************************************80 
2688: ! 
2689: !! DGE_CHECK checks the dimensions of a general matrix. 
2690: ! 
2691: !  Licensing: 
2692: ! 
2693: !    This code is distributed under the GNU LGPL license.  
2694: ! 
2695: !  Modified: 
2696: ! 
2697: !    11 January 1999 
2698: ! 
2699: !  Author: 
2700: ! 
2701: !    John Burkardt 
2702: ! 
2703: !  Parameters: 
2704: ! 
2705: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the array. 
2706: !    LDA must be at least M. 
2707: ! 
2708: !    Input, integer ( kind = 4 ) M, the number of rows of the matrix. 
2709: !    M must be positive. 
2710: ! 
2711: !    Input, integer ( kind = 4 ) N, the number of columns of the matrix. 
2712: !    N must be positive. 
2713: ! 
2714: !    Output, integer ( kind = 4 ) IERROR, reports whether any errors  
2715: !    were detected. 
2716: !    IERROR is set to 0 before the checks are made, and then: 
2717: !    IERROR = IERROR + 1 if LDA is illegal; 
2718: !    IERROR = IERROR + 2 if M is illegal; 
2719: !    IERROR = IERROR + 4 if N is illegal. 
2720: ! 
2721:   implicit none 
2722:  
2723:   integer ( kind = 4 ) ierror 
2724:   integer ( kind = 4 ) lda 
2725:   integer ( kind = 4 ) m 
2726:   integer ( kind = 4 ) n 
2727:  
2728:   ierror = 0 
2729:  
2730:   if ( lda < m ) then 
2731:     ierror = ierror + 1 
2732:     write ( *, '(a)' ) ' ' 
2733:     write ( *, '(a,i8)' ) 'DGE_CHECK - Illegal LDA = ', lda 
2734:   end if 
2735:  
2736:   if ( m < 1 ) then 
2737:     ierror = ierror + 2 
2738:     write ( *, '(a)' ) ' ' 
2739:     write ( *, '(a,i8)' ) 'DGE_CHECK - Illegal M = ', m 
2740:   end if 
2741:  
2742:   if ( n < 1 ) then 
2743:     ierror = ierror + 4 
2744:     write ( *, '(a)' ) ' ' 
2745:     write ( *, '(a,i8)' ) 'DGE_CHECK - Illegal N = ', n 
2746:   end if 
2747:  
2748:   return 
2749: end subroutine 
2750: subroutine dge_det ( lda, n, a, ipivot, det ) 
2751:  
2752: !*****************************************************************************80 
2753: ! 
2754: !! DGE_DET computes the determinant of a matrix factored by DGE_FA or DGE_TRF. 
2755: ! 
2756: !  Licensing: 
2757: ! 
2758: !    This code is distributed under the GNU LGPL license.  
2759: ! 
2760: !  Modified: 
2761: ! 
2762: !    19 October 1998 
2763: ! 
2764: !  Author: 
2765: ! 
2766: !    John Burkardt 
2767: ! 
2768: !  Parameters: 
2769: ! 
2770: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the array. 
2771: !    LDA must be at least N. 
2772: ! 
2773: !    Input, integer ( kind = 4 ) N, the order of the matrix. 
2774: !    N must be positive. 
2775: ! 
2776: !    Input, real ( kind = 8 ) A(LDA,N), the LU factors computed  
2777: !    by DGE_FA or DGE_TRF. 
2778: ! 
2779: !    Input, integer ( kind = 4 ) IPIVOT(N), as computed by DGE_FA or DGE_TRF. 
2780: ! 
2781: !    Output, real ( kind = 8 ) DET, the determinant of the matrix. 
2782: ! 
2783:   implicit none 
2784:  
2785:   integer ( kind = 4 ) lda 
2786:   integer ( kind = 4 ) n 
2787:  
2788:   real ( kind = 8 ) a(lda,n) 
2789:   real ( kind = 8 ) det 
2790:   integer ( kind = 4 ) i 
2791:   integer ( kind = 4 ) ierror 
2792:   integer ( kind = 4 ) ipivot(n) 
2793: ! 
2794: !  Check the dimensions. 
2795: ! 
2796:   call dge_check ( lda, n, n, ierror ) 
2797:  
2798:   if ( ierror /= 0 ) then 
2799:     write ( *, '(a)' ) ' ' 
2800:     write ( *, '(a)' ) 'DGE_DET - Fatal error!' 
2801:     write ( *, '(a)' ) '  Illegal dimensions.' 
2802:     return 
2803:   end if 
2804:  
2805:   det = 1.0D+00 
2806:  
2807:   do i = 1, n 
2808:     det = det * a(i,i) 
2809:   end do 
2810:  
2811:   do i = 1, n 
2812:     if ( ipivot(i) /= i ) then 
2813:       det = - det 
2814:     end if 
2815:   end do 
2816:  
2817:   return 
2818: end subroutine 
2819: subroutine dge_fa ( lda, n, a, ipivot, info ) 
2820:  
2821: !*****************************************************************************80 
2822: ! 
2823: !! DGE_FA factors a general matrix. 
2824: ! 
2825: !  Discussion: 
2826: ! 
2827: !    DGE_FA is a simplified version of the LINPACK routine DGEFA. 
2828: ! 
2829: !  Licensing: 
2830: ! 
2831: !    This code is distributed under the GNU LGPL license.  
2832: ! 
2833: !  Modified: 
2834: ! 
2835: !    26 February 2001 
2836: ! 
2837: !  Author: 
2838: ! 
2839: !    John Burkardt 
2840: ! 
2841: !  Parameters: 
2842: ! 
2843: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the array. 
2844: !    LDA must be at least N. 
2845: ! 
2846: !    Input, integer ( kind = 4 ) N, the order of the matrix. 
2847: !    N must be positive. 
2848: ! 
2849: !    Input/output, real ( kind = 8 ) A(LDA,N), the matrix to be factored. 
2850: !    On output, A contains an upper triangular matrix and the multipliers 
2851: !    which were used to obtain it.  The factorization can be written 
2852: !    A = L * U, where L is a product of permutation and unit lower 
2853: !    triangular matrices and U is upper triangular. 
2854: ! 
2855: !    Output, integer ( kind = 4 ) IPIVOT(N), a vector of pivot indices. 
2856: ! 
2857: !    Output, integer ( kind = 4 ) INFO, singularity flag. 
2858: !    0, no singularity detected. 
2859: !    nonzero, the factorization failed on the INFO-th step. 
2860: ! 
2861:   implicit none 
2862:  
2863:   integer ( kind = 4 ) lda 
2864:   integer ( kind = 4 ) n 
2865:  
2866:   real ( kind = 8 ) a(lda,n) 
2867:   integer ( kind = 4 ) i 
2868:   integer ( kind = 4 ) ierror 
2869:   integer ( kind = 4 ) info 
2870:   integer ( kind = 4 ) ipivot(n) 
2871:   integer ( kind = 4 ) j 
2872:   integer ( kind = 4 ) k 
2873:   integer ( kind = 4 ) l 
2874: ! 
2875: !  Check the dimensions. 
2876: ! 
2877:   call dge_check ( lda, n, n, ierror ) 
2878:  
2879:   if ( ierror /= 0 ) then 
2880:     write ( *, '(a)' ) ' ' 
2881:     write ( *, '(a)' ) 'DGE_FA - Fatal error!' 
2882:     write ( *, '(a)' ) '  Illegal dimensions.' 
2883:     return 
2884:   end if 
2885:  
2886:   info = 0 
2887:  
2888:   do k = 1, n-1 
2889: ! 
2890: !  Find L, the index of the pivot row. 
2891: ! 
2892:     l = k 
2893:     do i = k+1, n 
2894:       if ( abs ( a(l,k) ) < abs ( a(i,k) ) ) then 
2895:         l = i 
2896:       end if 
2897:     end do 
2898:  
2899:     ipivot(k) = l 
2900: ! 
2901: !  If the pivot index is zero, the algorithm has failed. 
2902: ! 
2903:     if ( a(l,k) == 0.0D+00 ) then 
2904:       info = k 
2905:       write ( *, '(a)' ) ' ' 
2906:       write ( *, '(a)' ) 'DGE_FA - Fatal error!' 
2907:       write ( *, '(a,i8)' ) '  Zero pivot on step ', info 
2908:       return 
2909:     end if 
2910: ! 
2911: !  Interchange rows L and K if necessary. 
2912: ! 
2913:     if ( l /= k ) then 
2914:       call r8_swap ( a(l,k), a(k,k) ) 
2915:     end if 
2916: ! 
2917: !  Normalize the values that lie below the pivot entry A(K,K). 
2918: ! 
2919:     a(k+1:n,k) = -a(k+1:n,k) / a(k,k) 
2920: ! 
2921: !  Row elimination with column indexing. 
2922: ! 
2923:     do j = k+1, n 
2924:  
2925:       if ( l /= k ) then 
2926:         call r8_swap ( a(l,j), a(k,j) ) 
2927:       end if 
2928:  
2929:       a(k+1:n,j) = a(k+1:n,j) + a(k+1:n,k) * a(k,j) 
2930:  
2931:     end do 
2932:  
2933:   end do 
2934:  
2935:   ipivot(n) = n 
2936:  
2937:   if ( a(n,n) == 0.0D+00 ) then 
2938:     info = n 
2939:     write ( *, '(a)' ) ' ' 
2940:     write ( *, '(a)' ) 'DGE_FA - Fatal error!' 
2941:     write ( *, '(a,i8)' ) '  Zero pivot on step ', info 
2942:   end if 
2943:  
2944:   return 
2945: end subroutine 
2946: subroutine digraph_adj_closure ( adj, lda, nnode ) 
2947:  
2948: !*****************************************************************************80 
2949: ! 
2950: !! DIGRAPH_ADJ_CLOSURE generates the transitive closure of a digraph. 
2951: ! 
2952: !  Discussion: 
2953: ! 
2954: !    The method is due to S Warshall. 
2955: ! 
2956: !  Definition: 
2957: ! 
2958: !    The transitive closure of a graph is a function REACH(I,J) so that 
2959: ! 
2960: !      REACH(I,J) = 0 if node J cannot be reached from node I; 
2961: !                   1 if node J can be reached from node I. 
2962: ! 
2963: !    This is an extension of the idea of adjacency.  REACH(I,J)=1 if 
2964: !    node J is adjacent to node I, or if node J is adjacent to a node 
2965: !    that is adjacent to node I, etc. 
2966: ! 
2967: !  Licensing: 
2968: ! 
2969: !    This code is distributed under the GNU LGPL license.  
2970: ! 
2971: !  Modified: 
2972: ! 
2973: !    26 October 1999 
2974: ! 
2975: !  Author: 
2976: ! 
2977: !    John Burkardt 
2978: ! 
2979: !  Reference: 
2980: ! 
2981: !    Robert Sedgewick, 
2982: !    Algorithms, 
2983: !    Addison Wesley, 1983, page 425. 
2984: ! 
2985: !  Parameters: 
2986: ! 
2987: !    Input/output, integer ( kind = 4 ) ADJ(LDA,NNODE). 
2988: ! 
2989: !    On input, ADJ is the adjacency matrix.  ADJ(I,J) 
2990: !    is nonzero if there is an edge from node I to node J. 
2991: ! 
2992: !    On output, ADJ is the transitive closure matrix. 
2993: ! 
2994: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
2995: !    be at least NNODE. 
2996: ! 
2997: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
2998: ! 
2999:   implicit none 
3000:  
3001:   integer ( kind = 4 ) lda 
3002:   integer ( kind = 4 ) nnode 
3003:  
3004:   integer ( kind = 4 ) adj(lda,nnode) 
3005:   integer ( kind = 4 ) i 
3006:   integer ( kind = 4 ) j 
3007:   integer ( kind = 4 ) k 
3008: ! 
3009: !  You can "reach" a node from itself. 
3010: ! 
3011:   do i = 1, nnode 
3012:     adj(i,i) = 1 
3013:   end do 
3014:  
3015:   do i = 1, nnode 
3016:     do j = 1, nnode 
3017:       if ( adj(j,i) /= 0 ) then 
3018:         do k = 1, nnode 
3019:           if ( adj(i,k) /= 0 ) then 
3020:             adj(j,k) = 1 
3021:           end if 
3022:         end do 
3023:       end if 
3024:     end do 
3025:   end do 
3026:  
3027:   return 
3028: end subroutine 
3029: subroutine digraph_adj_components ( adj, lda, nnode, ncomp, comp, dad, order ) 
3030:  
3031: !*****************************************************************************80 
3032: ! 
3033: !! DIGRAPH_ADJ_COMPONENTS finds the strongly connected components of a digraph. 
3034: ! 
3035: !  Discussion: 
3036: ! 
3037: !    A digraph is a directed graph. 
3038: ! 
3039: !    A strongly connected component of a directed graph is the largest 
3040: !    set of nodes such that there is a directed path from any node to  
3041: !    any other node in the same component. 
3042: ! 
3043: !  Licensing: 
3044: ! 
3045: !    This code is distributed under the GNU LGPL license.  
3046: ! 
3047: !  Modified: 
3048: ! 
3049: !    15 April 1999 
3050: ! 
3051: !  Reference: 
3052: ! 
3053: !    K Thulasiraman, M Swamy, 
3054: !    Graph Theory and Algorithms, 
3055: !    John Wiley, New York, 1992. 
3056: ! 
3057: !  Parameters: 
3058: ! 
3059: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3060: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
3061: ! 
3062: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ. 
3063: ! 
3064: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3065: ! 
3066: !    Output, integer ( kind = 4 ) NCOMP, the number of strongly connected  
3067: !    components. 
3068: ! 
3069: !    Output, integer ( kind = 4 ) COMP(NNODE), lists the connected component  
3070: !    to which each node belongs. 
3071: ! 
3072: !    Output, integer ( kind = 4 ) DAD(NNODE), the father array for the depth  
3073: !    first search trees.  DAD(I) = 0 means that node I is the root of  
3074: !    one of the trees.  DAD(I) = J means that the search descended 
3075: !    from node J to node I. 
3076: ! 
3077: !    Output, integer ( kind = 4 ) ORDER(NNODE), the order in which the nodes  
3078: !    were traversed, from 1 to NNODE. 
3079: ! 
3080:   implicit none 
3081:  
3082:   integer ( kind = 4 ) lda 
3083:   integer ( kind = 4 ) nnode 
3084:  
3085:   integer ( kind = 4 ) adj(lda,nnode) 
3086:   integer ( kind = 4 ) comp(nnode) 
3087:   integer ( kind = 4 ) dad(nnode) 
3088:   integer ( kind = 4 ) iorder 
3089:   integer ( kind = 4 ) lowlink(nnode) 
3090:   integer ( kind = 4 ) mark(nnode) 
3091:   integer ( kind = 4 ) ncomp 
3092:   integer ( kind = 4 ) nstack 
3093:   integer ( kind = 4 ) order(nnode) 
3094:   integer ( kind = 4 ) point(nnode) 
3095:   integer ( kind = 4 ) stack(nnode) 
3096:   integer ( kind = 4 ) v 
3097:   integer ( kind = 4 ) w 
3098:   integer ( kind = 4 ) x 
3099: ! 
3100: !  Initialization. 
3101: ! 
3102:   comp(1:nnode) = 0 
3103:   dad(1:nnode) = 0 
3104:   order(1:nnode) = 0 
3105:   lowlink(1:nnode) = 0 
3106:   mark(1:nnode) = 0 
3107:   point(1:nnode) = 0 
3108:  
3109:   iorder = 0 
3110:   nstack = 0 
3111:   ncomp = 0 
3112: ! 
3113: !  Select any node V not stored in the stack, that is, with MARK(V) = 0. 
3114: ! 
3115:   do 
3116:  
3117:     v = 0 
3118:  
3119:     do 
3120:  
3121:       v = v + 1 
3122:  
3123:       if ( nnode < v ) then 
3124:         adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) 
3125:         return 
3126:       end if 
3127:  
3128:       if ( mark(v) /= 1 ) then 
3129:         exit 
3130:       end if 
3131:  
3132:     end do 
3133:  
3134:     iorder = iorder + 1 
3135:  
3136:     order(v) = iorder 
3137:     lowlink(v) = iorder 
3138:     mark(v) = 1 
3139:   
3140:     nstack = nstack + 1 
3141:     stack(nstack) = v 
3142:     point(v) = 1 
3143:  
3144: 30  continue 
3145: ! 
3146: !  Consider each node W. 
3147: ! 
3148:     do w = 1, nnode 
3149: ! 
3150: !  Is there an edge (V,W) and has it not been examined yet? 
3151: ! 
3152:       if ( 0 < adj(v,w) ) then 
3153:  
3154:         adj(v,w) = - adj(v,w) 
3155: ! 
3156: !  Is the node on the other end of the edge undiscovered yet? 
3157: ! 
3158:         if ( mark(w) == 0 ) then 
3159:  
3160:           iorder = iorder + 1 
3161:           order(w) = iorder 
3162:           lowlink(w) = iorder 
3163:           dad(w) = v 
3164:           mark(w) = 1 
3165:  
3166:           nstack = nstack + 1 
3167:           stack(nstack) = w 
3168:           point(w) = 1 
3169:  
3170:           v = w 
3171:  
3172:         else if ( mark(w) == 1 ) then 
3173:  
3174:           if ( order(w) < order(v) .and. point(w) == 1 ) then 
3175:             lowlink(v) = min ( lowlink(v), order(w) ) 
3176:           end if 
3177:  
3178:         end if 
3179:  
3180:         go to 30 
3181:  
3182:       end if 
3183:  
3184:     end do 
3185:  
3186:     if ( lowlink(v) == order(v) ) then 
3187:  
3188:       ncomp = ncomp + 1 
3189:  
3190:       do 
3191:  
3192:         if ( nstack <= 0 ) then 
3193:           write ( *, '(a)' ) ' ' 
3194:           write ( *, '(a)' ) 'DIGRAPH_ADJ_COMPONENTS - Fatal error!' 
3195:           write ( *, '(a)' ) '  Illegal stack reference.' 
3196:           stop 
3197:         end if 
3198:  
3199:         x = stack(nstack) 
3200:         nstack = nstack - 1 
3201:  
3202:         point(x) = 0 
3203:         comp(x) = ncomp 
3204:  
3205:         if ( x == v ) then 
3206:           exit 
3207:         end if 
3208:  
3209:       end do 
3210:  
3211:     end if 
3212:  
3213:     if ( dad(v) /= 0 ) then 
3214:       lowlink(dad(v)) = min ( lowlink(dad(v)), lowlink(v) ) 
3215:       v = dad(v) 
3216:       go to 30 
3217:     end if 
3218:  
3219:   end do 
3220:  
3221:   return 
3222: end subroutine 
3223: subroutine digraph_adj_cycle ( adj, lda, nnode, adj2, dad, order ) 
3224:  
3225: !*****************************************************************************80 
3226: ! 
3227: !! DIGRAPH_ADJ_CYCLE searches for cycles in a digraph. 
3228: ! 
3229: !  Licensing: 
3230: ! 
3231: !    This code is distributed under the GNU LGPL license.  
3232: ! 
3233: !  Modified: 
3234: ! 
3235: !    04 July 2000 
3236: ! 
3237: !  Parameters: 
3238: ! 
3239: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3240: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
3241: ! 
3242: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ and ADJ2. 
3243: ! 
3244: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3245: ! 
3246: !    Output, integer ( kind = 4 ) ADJ2(LDA,NNODE), will be one of the following 
3247: !    values depending on the role of the edge from node I to node J: 
3248: !       0, no edge, 
3249: !       1, neither in a search tree, nor needed to disconnect a cycle; 
3250: !      -1, completes a cycle, 
3251: !      -2, part of a search tree. 
3252: ! 
3253: !    Output, integer ( kind = 4 ) DAD(NNODE), the father array for the depth 
3254: !    first search trees.  DAD(I) = 0 means that node I is the root of  
3255: !    one of the trees.  DAD(I) = J means that the search descended 
3256: !    from node J to node I. 
3257: ! 
3258: !    Output, integer ( kind = 4 ) ORDER(NNODE), the order in which the nodes 
3259: !    were traversed, from 1 to NNODE. 
3260: ! 
3261:   implicit none 
3262:  
3263:   integer ( kind = 4 ) lda 
3264:   integer ( kind = 4 ) nnode 
3265:  
3266:   integer ( kind = 4 ) adj(lda,nnode) 
3267:   integer ( kind = 4 ) adj2(lda,nnode) 
3268:   integer ( kind = 4 ) dad(nnode) 
3269:   integer ( kind = 4 ) daddy 
3270:   integer ( kind = 4 ) i 
3271:   integer ( kind = 4 ) j 
3272:   integer ( kind = 4 ) jj 
3273:   integer ( kind = 4 ) maxstack 
3274:   integer ( kind = 4 ) nstack 
3275:   integer ( kind = 4 ) order(nnode) 
3276:   integer ( kind = 4 ) rank 
3277:   integer ( kind = 4 ) stack(2*(nnode-1)) 
3278: ! 
3279: !  Initialization. 
3280: ! 
3281:   adj2(1:nnode,1:nnode) = adj(1:nnode,1:nnode) 
3282:   dad(1:nnode) = 0 
3283:   maxstack = 2 * ( nnode - 1 ) 
3284:   order(1:nnode) = 0 
3285:  
3286:   rank = 0 
3287:  
3288:   do i = 1, nnode 
3289:  
3290:     if ( order(i) == 0 ) then 
3291:  
3292:       daddy = i 
3293:       nstack = 0 
3294: ! 
3295: !  Visit the unvisited node DAD. 
3296: ! 
3297: 10    continue 
3298:  
3299:       rank = rank + 1 
3300:       order(daddy) = rank 
3301:       j = 0 
3302: ! 
3303: !  Consider visiting node J from node DAD. 
3304: ! 
3305: 20    continue 
3306:  
3307:       j = j + 1 
3308: ! 
3309: !  If  
3310: !    J is a reasonable value,  
3311: !    J is adjacent to DAD, and  
3312: !    J is unvisited, 
3313: !  then  
3314: !    put DAD into the stack,  
3315: !    make J the new value of DAD, and 
3316: !    examine J's neighbors. 
3317: ! 
3318:       if ( j <= nnode ) then 
3319:  
3320:         if ( 0 < adj2(daddy,j) ) then 
3321:  
3322:           if ( order(j) == 0 ) then 
3323:  
3324:             adj2(daddy,j) = -2 
3325:  
3326:             if ( nstack+2 <= maxstack ) then 
3327:               dad(j) = daddy 
3328:               stack(nstack+1) = daddy 
3329:               stack(nstack+2) = j 
3330:               nstack = nstack + 2 
3331:               daddy = j 
3332:               go to 10 
3333:             else 
3334:               write ( *, '(a)' ) ' ' 
3335:               write ( *, '(a)' ) 'DIGRAPH_ADJ_CYCLE - Fatal error!' 
3336:               write ( *, '(a)' ) '  Out of stack space.' 
3337:               stop 
3338:             end if 
3339: ! 
3340: !  Adjacent node J has already been visited.  If J is actually 
3341: !  in the current stack, then we have a cycle. 
3342: ! 
3343:           else 
3344:  
3345:             if ( j == daddy ) then 
3346:  
3347:               adj2(daddy,j) = - 1 
3348:  
3349:             else 
3350:  
3351:               do jj = 1, nstack-1, 2 
3352:                 if ( stack(jj) == j ) then 
3353:                   adj2(daddy,j) = - 1 
3354:                 end if 
3355:               end do 
3356:  
3357:             end if 
3358:  
3359:             go to 20 
3360:  
3361:           end if 
3362: ! 
3363: !  If J is not suitable for a visit, get the next value of J. 
3364: ! 
3365:         else 
3366:  
3367:           go to 20 
3368:  
3369:         end if 
3370: ! 
3371: !  If no more neighbors to consider, back up one node. 
3372: ! 
3373:       else if ( 2 <= nstack ) then 
3374:  
3375:         daddy = stack(nstack-1) 
3376:         j = stack(nstack) 
3377:         nstack = nstack - 2 
3378:         go to 20 
3379: ! 
3380: !  If no more nodes to consider in this tree, bail out. 
3381: ! 
3382:       else 
3383:  
3384:         nstack = 0 
3385:  
3386:       end if 
3387:  
3388:     end if 
3389:  
3390:   end do 
3391:  
3392:   return 
3393: end subroutine 
3394: subroutine digraph_adj_degree ( adj, lda, nnode, indegree, outdegree ) 
3395:  
3396: !*****************************************************************************80 
3397: ! 
3398: !! DIGRAPH_ADJ_DEGREE computes the indegree and outdegree of each node. 
3399: ! 
3400: !  Discussion: 
3401: ! 
3402: !    The indegree of a node is the number of directed edges that  
3403: !    end at the node.   
3404: ! 
3405: !    The outdegree of a node is the number of directed edges that 
3406: !    begin at the node. 
3407: ! 
3408: !    The sum of the indegrees and outdegrees of all the nodes is twice  
3409: !    the number of edges. 
3410: ! 
3411: !    The generalized case, where ADJ(I,J) can be greater than 1, indicating 
3412: !    the existence of 2 or more distinct edges from node I to node J, 
3413: !    will be properly handled by this routine.   
3414: ! 
3415: !  Licensing: 
3416: ! 
3417: !    This code is distributed under the GNU LGPL license.  
3418: ! 
3419: !  Modified: 
3420: ! 
3421: !    01 October 1999 
3422: ! 
3423: !  Author: 
3424: ! 
3425: !    John Burkardt 
3426: ! 
3427: !  Parameters: 
3428: ! 
3429: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3430: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
3431: ! 
3432: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
3433: !    which must be at least NNODE. 
3434: ! 
3435: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3436: ! 
3437: !    Output, integer ( kind = 4 ) INDEGREE(NNODE), OUTDEGREE(NNODE),  
3438: !    the indegree and outdegree of the nodes. 
3439: ! 
3440:   implicit none 
3441:  
3442:   integer ( kind = 4 ) lda 
3443:   integer ( kind = 4 ) nnode 
3444:  
3445:   integer ( kind = 4 ) adj(lda,nnode) 
3446:   integer ( kind = 4 ) i 
3447:   integer ( kind = 4 ) indegree(nnode) 
3448:   integer ( kind = 4 ) j 
3449:   integer ( kind = 4 ) outdegree(nnode) 
3450:  
3451:   indegree(1:nnode) = 0 
3452:   outdegree(1:nnode) = 0 
3453:  
3454:   do i = 1, nnode 
3455:     do j = 1, nnode 
3456:       if ( adj(i,j) /= 0 ) then 
3457:         outdegree(i) = outdegree(i) + adj(i,j) 
3458:         indegree(j) = indegree(j) + adj(i,j) 
3459:       end if 
3460:     end do 
3461:   end do 
3462:  
3463:   return 
3464: end subroutine 
3465: subroutine digraph_adj_degree_max ( adj, lda, nnode, indegree_max, & 
3466:   outdegree_max, degree_max ) 
3467:  
3468: !*****************************************************************************80 
3469: ! 
3470: !! DIGRAPH_ADJ_DEGREE_MAX computes the maximum degrees of a digraph. 
3471: ! 
3472: !  Licensing: 
3473: ! 
3474: !    This code is distributed under the GNU LGPL license.  
3475: ! 
3476: !  Modified: 
3477: ! 
3478: !    22 October 1999 
3479: ! 
3480: !  Author: 
3481: ! 
3482: !    John Burkardt 
3483: ! 
3484: !  Parameters: 
3485: ! 
3486: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3487: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
3488: ! 
3489: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
3490: !    which must be at least NNODE. 
3491: ! 
3492: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3493: ! 
3494: !    Output, integer ( kind = 4 ) INDEGREE_MAX, OUTDEGREE_MAX, the maximum  
3495: !    indegree and outdegree, considered independently, which may occur at  
3496: !    different nodes. 
3497: ! 
3498: !    Output, integer ( kind = 4 ) DEGREE_MAX, the maximum value of the sum at  
3499: !    each node of the indegree and outdegree. 
3500: ! 
3501:   implicit none 
3502:  
3503:   integer ( kind = 4 ) lda 
3504:   integer ( kind = 4 ) nnode 
3505:  
3506:   integer ( kind = 4 ) adj(lda,nnode) 
3507:   integer ( kind = 4 ) degree 
3508:   integer ( kind = 4 ) degree_max 
3509:   integer ( kind = 4 ) i 
3510:   integer ( kind = 4 ) indegree 
3511:   integer ( kind = 4 ) indegree_max 
3512:   integer ( kind = 4 ) outdegree 
3513:   integer ( kind = 4 ) outdegree_max 
3514:  
3515:   degree_max = 0 
3516:   indegree_max = 0 
3517:   outdegree_max = 0 
3518:  
3519:   do i = 1, nnode 
3520:  
3521:     indegree = sum ( adj(1:nnode,i) ) 
3522:     outdegree = sum ( adj(i,1:nnode) ) 
3523:  
3524:     degree = indegree + outdegree 
3525:  
3526:     indegree_max = max ( indegree_max, indegree ) 
3527:     outdegree_max = max ( outdegree_max, outdegree ) 
3528:     degree_max = max ( degree_max, degree ) 
3529:       
3530:   end do 
3531:  
3532:   return 
3533: end subroutine 
3534: subroutine digraph_adj_degree_seq ( adj, lda, nnode, in_seq, out_seq ) 
3535:  
3536: !*****************************************************************************80 
3537: ! 
3538: !! DIGRAPH_ADJ_DEGREE_SEQ computes the directed degree sequence. 
3539: ! 
3540: !  Discussion: 
3541: ! 
3542: !    The directed degree sequence of a graph is the sequence of indegrees 
3543: !    and the sequence of outdegrees, arranged to correspond to nodes of 
3544: !    successively decreasing total degree.  For nodes of equal degree, those 
3545: !    of higher outdegree take precedence.  
3546: ! 
3547: !  Licensing: 
3548: ! 
3549: !    This code is distributed under the GNU LGPL license.  
3550: ! 
3551: !  Modified: 
3552: ! 
3553: !    22 October 1999 
3554: ! 
3555: !  Author: 
3556: ! 
3557: !    John Burkardt 
3558: ! 
3559: !  Parameters: 
3560: ! 
3561: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3562: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
3563: ! 
3564: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
3565: !    which must be at least NNODE. 
3566: ! 
3567: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3568: ! 
3569: !    Output, integer ( kind = 4 ) IN_SEQ(NNODE), OUT_SEQ(NNODE), 
3570: !    the degree sequence of the digraph. 
3571: ! 
3572:   implicit none 
3573:  
3574:   integer ( kind = 4 ) lda 
3575:   integer ( kind = 4 ) nnode 
3576:  
3577:   integer ( kind = 4 ) adj(lda,nnode) 
3578:   integer ( kind = 4 ) in_seq(nnode) 
3579:   integer ( kind = 4 ) out_seq(nnode) 
3580:  
3581:   call digraph_adj_degree ( adj, lda, nnode, in_seq, out_seq ) 
3582:  
3583:   call i4vec2_sort_d ( nnode, out_seq, in_seq ) 
3584:  
3585:   return 
3586: end subroutine 
3587: subroutine digraph_adj_edge_count ( adj, lda, nnode, nedge ) 
3588:  
3589: !*****************************************************************************80 
3590: ! 
3591: !! DIGRAPH_ADJ_EDGE_COUNT counts the number of edges in a digraph. 
3592: ! 
3593: !  Licensing: 
3594: ! 
3595: !    This code is distributed under the GNU LGPL license.  
3596: ! 
3597: !  Modified: 
3598: ! 
3599: !    26 October 1999 
3600: ! 
3601: !  Author: 
3602: ! 
3603: !    John Burkardt 
3604: ! 
3605: !  Parameters: 
3606: ! 
3607: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3608: !    ADJ(I,J) is 1 if there is an edge from node I to node J. 
3609: ! 
3610: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
3611: !    which must be at least NNODE. 
3612: ! 
3613: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3614: ! 
3615: !    Output, integer ( kind = 4 ) NEDGE, the number of edges in the digraph. 
3616: ! 
3617:   implicit none 
3618:  
3619:   integer ( kind = 4 ) lda 
3620:   integer ( kind = 4 ) nnode 
3621:  
3622:   integer ( kind = 4 ) adj(lda,nnode) 
3623:   integer ( kind = 4 ) nedge 
3624:  
3625:   nedge = sum ( adj(1:nnode,1:nnode) ) 
3626:  
3627:   return 
3628: end subroutine 
3629: subroutine digraph_adj_eigen ( adj, lda, nnode, neigen, eigenr, eigeni ) 
3630:  
3631: !*****************************************************************************80 
3632: ! 
3633: !! DIGRAPH_ADJ_EIGEN: eigenvalues of a digraph from its adjacency matrix. 
3634: ! 
3635: !  Licensing: 
3636: ! 
3637: !    This code is distributed under the GNU LGPL license.  
3638: ! 
3639: !  Modified: 
3640: ! 
3641: !    18 September 2000 
3642: ! 
3643: !  Author: 
3644: ! 
3645: !    John Burkardt 
3646: ! 
3647: !  Parameters: 
3648: ! 
3649: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3650: !    ADJ(I,J) is 1 if there is an edge from node I to node J. 
3651: ! 
3652: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
3653: !    which must be at least NNODE. 
3654: ! 
3655: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
3656: ! 
3657: !    Output, integer ( kind = 4 ) NEIGEN, the number of eigenvalues computed. 
3658: !    Normally, this would be equal to NNODE, unless the algorithm failed. 
3659: ! 
3660: !    Output, real ( kind = 8 ) EIGENR(NNODE), EIGENI(NNODE), contains the real 
3661: !    and imaginary parts of the computed eigenvalues. 
3662: ! 
3663:   implicit none 
3664:  
3665:   integer ( kind = 4 ) lda 
3666:   integer ( kind = 4 ) nnode 
3667:  
3668:   real ( kind = 8 ) a(nnode,nnode) 
3669:   integer ( kind = 4 ) adj(lda,nnode) 
3670:   real ( kind = 8 ) eigeni(nnode) 
3671:   real ( kind = 8 ) eigenr(nnode) 
3672:   integer ( kind = 4 ) i 
3673:   integer ( kind = 4 ) igh 
3674:   integer ( kind = 4 ) ind(nnode) 
3675:   integer ( kind = 4 ) info 
3676:   integer ( kind = 4 ) low 
3677:   integer ( kind = 4 ) neigen 
3678:   real ( kind = 8 ) scale(nnode) 
3679:  
3680:   a(1:nnode,1:nnode) = real ( adj(1:nnode,1:nnode), kind = 8 ) 
3681:  
3682:   call balanc ( nnode, nnode, a, low, igh, scale ) 
3683:  
3684:   call elmhes ( nnode, nnode, low, igh, a, ind ) 
3685:  
3686:   call hqr ( nnode, nnode, low, igh, a, eigenr, eigeni, info ) 
3687:  
3688:   if ( info == 0 ) then 
3689:     neigen = nnode 
3690:   else 
3691:     neigen = nnode - info 
3692:     do i = 1, neigen 
3693:       eigenr(i) = eigenr(i+info) 
3694:       eigeni(i) = eigeni(i+info) 
3695:     end do 
3696:   end if 
3697:  
3698:   return 
3699: end subroutine 
3700: subroutine digraph_adj_example_cycler ( adj, lda, nnode ) 
3701:  
3702: !*****************************************************************************80 
3703: ! 
3704: !! DIGRAPH_ADJ_EXAMPLE_CYCLER sets adjacency information for the cycler digraph. 
3705: ! 
3706: !  Diagram: 
3707: !   
3708: !           A 
3709: !           V 
3710: !    9--><--7---<--3--><---4 
3711: !    |            /|      / 
3712: !    V           A |     / 
3713: !    |          /  |    / 
3714: !    5----<----1   V   A 
3715: !    |        /    |  / 
3716: !    V       A     | / 
3717: !    |      /      |/ 
3718: !    2-->---8---<--6 
3719: !     \------>----/ 
3720: ! 
3721: !  Licensing: 
3722: ! 
3723: !    This code is distributed under the GNU LGPL license.  
3724: ! 
3725: !  Modified: 
3726: ! 
3727: !    22 October 1999 
3728: ! 
3729: !  Author: 
3730: ! 
3731: !    John Burkardt 
3732: ! 
3733: !  Parameters: 
3734: ! 
3735: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
3736: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
3737: ! 
3738: !    Input, integer ( kind = 4 ) LDA, the maximum value of NNODE, which  
3739: !    must be at least 9. 
3740: ! 
3741: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
3742: ! 
3743:   implicit none 
3744:  
3745:   integer ( kind = 4 ) lda 
3746:  
3747:   integer ( kind = 4 ) adj(lda,lda) 
3748:   integer ( kind = 4 ) nnode 
3749:  
3750:   nnode = 9 
3751:  
3752:   if ( lda < nnode ) then 
3753:     write ( *, '(a)' ) ' ' 
3754:     write ( *, '(a)' ) 'DIGRAPH_ADJ_EXAMPLE_CYCLER - Fatal error!' 
3755:     write ( *, '(a)' ) '  LDA is too small.' 
3756:     stop 
3757:   end if 
3758:  
3759:   adj(1:nnode,1:nnode) = 0 
3760:  
3761:   adj(1,3) = 1 
3762:   adj(1,5) = 1 
3763:  
3764:   adj(2,6) = 1 
3765:   adj(2,8) = 1 
3766:  
3767:   adj(3,4) = 1 
3768:   adj(3,6) = 1 
3769:   adj(3,7) = 1 
3770:  
3771:   adj(4,3) = 1 
3772:  
3773:   adj(5,2) = 1 
3774:  
3775:   adj(6,4) = 1 
3776:   adj(6,8) = 1 
3777:  
3778:   adj(7,7) = 1 
3779:   adj(7,9) = 1 
3780:  
3781:   adj(8,1) = 1 
3782:  
3783:   adj(9,5) = 1 
3784:   adj(9,7) = 1 
3785:  
3786:   return 
3787: end subroutine 
3788: subroutine digraph_adj_example_octo ( lda, example, seed, nnode, adj ) 
3789:  
3790: !*****************************************************************************80 
3791: ! 
3792: !! DIGRAPH_ADJ_EXAMPLE_OCTO sets up an 8 node example digraph. 
3793: ! 
3794: !  Diagram: 
3795: ! 
3796: !      1---2 
3797: !     /|   |\ 
3798: !    8-+---+-3 
3799: !    | |   | | 
3800: !    7-+---+-4 
3801: !     \|   |/ 
3802: !      6---5 
3803: ! 
3804: !     Graph "A" 
3805: ! 
3806: !    There are 12 digraphs to choose from, all on 8 nodes.  There are 7 
3807: !    underlying graphs.  The first 5 underlying graphs have degree 3 at  
3808: !    every node.  Graphs 6 and 7 have degree 5 at every node. 
3809: ! 
3810: !  Licensing: 
3811: ! 
3812: !    This code is distributed under the GNU LGPL license.  
3813: ! 
3814: !  Modified: 
3815: ! 
3816: !    05 November 1999 
3817: ! 
3818: !  Author: 
3819: ! 
3820: !    John Burkardt 
3821: ! 
3822: !  Parameters: 
3823: ! 
3824: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the ADJ array, 
3825: !    which must be at least NNODE. 
3826: ! 
3827: !    Input, integer ( kind = 4 ) EXAMPLE, should be between 1 and 12, and  
3828: !    indicates which example graph to pick. 
3829: ! 
3830: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
3831: !    number generator. 
3832: ! 
3833: !    Output, integer ( kind = 4 ) NNODE, the number of nodes, which should be 8. 
3834: ! 
3835: !    Output, integer ( kind = 4 ) ADJ(LDA,LDA), the adjacency information. 
3836: !    ADJ(I,J) is 1 if nodes I and J are adjacent and 0 otherwise. 
3837: ! 
3838:   implicit none 
3839:  
3840:   integer ( kind = 4 ) lda 
3841:  
3842:   integer ( kind = 4 ) adj(lda,lda) 
3843:   integer ( kind = 4 ) example 
3844:   integer ( kind = 4 ) i 
3845: !  integer ( kind = 4 ) i4_uniform 
3846:   integer ( kind = 4 ) j 
3847:   integer ( kind = 4 ) nnode 
3848:   integer ( kind = 4 ) nsave 
3849:   integer ( kind = 4 ) seed 
3850:  
3851:   if ( example <= 0 ) then 
3852:     nsave = i4_uniform ( 1, 12, seed ) 
3853:   else 
3854:     example = mod ( example - 1, 12 ) + 1 
3855:     nsave = example 
3856:   end if 
3857:  
3858:   nnode = 8 
3859:  
3860:   if ( lda < nnode ) then 
3861:     write ( *, '(a)' ) ' ' 
3862:     write ( *, '(a)' ) 'DIGRAPH_ADJ_EXAMPLE_OCTO - Fatal error!' 
3863:     write ( *, '(a)' ) '  LDA is too small.' 
3864:     stop 
3865:   end if 
3866:  
3867:   adj(1:nnode,1:nnode) = 0 
3868:  
3869:   do i = 1, nnode 
3870:     j = i + 1 
3871:     if ( nnode < j ) then 
3872:       j = j - nnode 
3873:     end if 
3874:  
3875:     adj(i,j) = 1 
3876:  
3877:   end do 
3878: ! 
3879: !  Underlying graph 1. 
3880: ! 
3881:   if ( nsave == 1 ) then 
3882:  
3883:       adj(1,6) = 1 
3884:       adj(2,5) = 1 
3885:       adj(3,8) = 1 
3886:       adj(4,7) = 1 
3887:  
3888:   else if ( nsave == 2 ) then 
3889:  
3890:       adj(1,6) = 1 
3891:       adj(5,2) = 1 
3892:       adj(3,8) = 1 
3893:       adj(7,4) = 1 
3894: ! 
3895: !  Underlying graph 2. 
3896: !  Digraphs 3 and 4 have different indegree/outdegree sequences. 
3897: ! 
3898:   else if ( nsave == 3 ) then 
3899:  
3900:     adj(1,6) = 1 
3901:     adj(6,1) = 1 
3902:     adj(2,8) = 1 
3903:     adj(8,2) = 1 
3904:     adj(3,5) = 1 
3905:     adj(5,3) = 1 
3906:     adj(4,7) = 1 
3907:     adj(7,4) = 1 
3908:  
3909:   else if ( nsave == 4 ) then 
3910:  
3911:     adj(1,6) = 1 
3912:     adj(2,8) = 1 
3913:     adj(3,5) = 1 
3914:     adj(4,7) = 1 
3915: ! 
3916: !  Underlying graph 3 
3917: !  Digraphs 5 and 6 have the same indegree/outdegree sequences. 
3918: ! 
3919:   else if ( nsave == 5 ) then 
3920:  
3921:     adj(1,5) = 1 
3922:     adj(2,6) = 1 
3923:     adj(3,7) = 1 
3924:     adj(4,8) = 1 
3925:  
3926:   else if ( nsave == 6 ) then 
3927:  
3928:     adj(1:nnode,1:nnode) = 0 
3929:  
3930:     adj(1,8) = 1 
3931:     adj(1,5) = 1 
3932:     adj(2,1) = 1 
3933:     adj(2,3) = 1 
3934:     adj(3,4) = 1 
3935:     adj(3,7) = 1 
3936:     adj(4,5) = 1 
3937:     adj(4,8) = 1 
3938:     adj(5,6) = 1 
3939:     adj(6,2) = 1 
3940:     adj(7,6) = 1 
3941:     adj(8,7) = 1 
3942: ! 
3943: !  Underlying graph 4 
3944: ! 
3945:   else if ( nsave == 7 ) then 
3946:  
3947:     adj(3,1) = 1 
3948:     adj(4,2) = 1 
3949:     adj(5,7) = 1 
3950:     adj(6,8) = 1 
3951:  
3952:   else if ( nsave == 8 ) then 
3953:  
3954:     adj(3,1) = 1 
3955:     adj(4,2) = 1 
3956:     adj(5,7) = 1 
3957:     adj(8,6) = 1 
3958: ! 
3959: !  Underlying graph 5 
3960: ! 
3961:   else if ( nsave == 9 ) then 
3962:  
3963:     adj(1,4) = 1 
3964:     adj(2,6) = 1 
3965:     adj(8,3) = 1 
3966:  
3967:     adj(5,7) = 1 
3968:     adj(7,5) = 1 
3969:  
3970:   else if ( nsave == 10 ) then 
3971:  
3972:     adj(1,4) = 1 
3973:     adj(2,6) = 1 
3974:     adj(3,8) = 1 
3975:  
3976:     adj(5,7) = 1 
3977:     adj(7,5) = 1 
3978: ! 
3979: !  Underlying graph 6 
3980: ! 
3981:   else if ( nsave == 11 ) then 
3982:  
3983:     adj(1,4) = 1 
3984:     adj(1,5) = 1 
3985:     adj(1,6) = 1 
3986:  
3987:     adj(2,5) = 1 
3988:     adj(2,6) = 1 
3989:     adj(2,7) = 1 
3990:  
3991:     adj(3,6) = 1 
3992:     adj(3,7) = 1 
3993:     adj(3,8) = 1 
3994:  
3995:     adj(4,7) = 1 
3996:     adj(4,8) = 1 
3997:  
3998:     adj(5,8) = 1 
3999: ! 
4000: !  Underlying graph 7 
4001: ! 
4002:   else if ( nsave == 12 ) then 
4003:  
4004:     adj(1,3) = 1 
4005:     adj(1,5) = 1 
4006:     adj(1,7) = 1 
4007:  
4008:     adj(2,4) = 1 
4009:     adj(2,6) = 1 
4010:     adj(2,8) = 1 
4011:  
4012:     adj(3,5) = 1 
4013:     adj(3,7) = 1 
4014:  
4015:     adj(4,6) = 1 
4016:     adj(4,8) = 1 
4017:  
4018:     adj(5,7) = 1 
4019:  
4020:     adj(6,8) = 1 
4021:  
4022:   end if 
4023: ! 
4024: !  Now permute the graph. 
4025: ! 
4026:   call i4mat_perm_random ( lda, nnode, seed, adj ) 
4027:  
4028:   return 
4029: end subroutine 
4030: subroutine digraph_adj_example_sixty ( adj, lda, nnode ) 
4031:  
4032: !*****************************************************************************80 
4033: ! 
4034: !! DIGRAPH_ADJ_EXAMPLE_SIXTY sets the adjacency matrix for the sixty digraph. 
4035: ! 
4036: !  Discussion: 
4037: ! 
4038: !    The nodes of the digraph are divisors of 60.  There is a link from I to 
4039: !    J if divisor I can be divided by divisor J. 
4040: ! 
4041: !  Licensing: 
4042: ! 
4043: !    This code is distributed under the GNU LGPL license.  
4044: ! 
4045: !  Modified: 
4046: ! 
4047: !    11 August 2000 
4048: ! 
4049: !  Author: 
4050: ! 
4051: !    John Burkardt 
4052: ! 
4053: !  Parameters: 
4054: ! 
4055: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
4056: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
4057: ! 
4058: !    Input, integer ( kind = 4 ) LDA, the maximum value of NNODE, which must  
4059: !    be at least 12. 
4060: ! 
4061: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
4062: ! 
4063:   implicit none 
4064:  
4065:   integer ( kind = 4 ) lda 
4066:  
4067:   integer ( kind = 4 ) adj(lda,lda) 
4068:   integer ( kind = 4 ) d(12) 
4069:   integer ( kind = 4 ) i 
4070:   integer ( kind = 4 ) j 
4071:   integer ( kind = 4 ) nnode 
4072:  
4073:   nnode = 12 
4074:  
4075:   if ( lda < nnode ) then 
4076:     write ( *, '(a)' ) ' ' 
4077:     write ( *, '(a)' ) 'DIGRAPH_ADJ_EXAMPLE_SIXTY - Fatal error!' 
4078:     write ( *, '(a)' ) '  LDA is too small.' 
4079:     stop 
4080:   end if 
4081:  
4082:   d(1:12) = (/ 60, 30, 20, 15, 12, 10, 6, 5, 4, 3, 2, 1 /) 
4083:  
4084:   do i = 1, nnode 
4085:     do j = 1, nnode 
4086:       if ( i == j ) then 
4087:         adj(i,j) = 0 
4088:       else if ( mod ( d(i), d(j) ) == 0 ) then 
4089:         adj(i,j) = 1 
4090:       else 
4091:         adj(i,j) = 0 
4092:       end if 
4093:     end do 
4094:   end do 
4095:  
4096:   return 
4097: end subroutine 
4098: subroutine digraph_adj_ham_cand ( adj, lda, nnode, circuit, k, nstack, & 
4099:   stack, maxstack, ncan ) 
4100:  
4101: !*****************************************************************************80 
4102: ! 
4103: !! DIGRAPH_ADJ_HAM_CAND: candidates for the next node in a Hamiltonian circuit. 
4104: ! 
4105: !  Discussion: 
4106: ! 
4107: !    This routine is used in conjunction with I4VEC_BACKTRACK.   
4108: ! 
4109: !    A Hamiltonian circuit of a digraph is a path that starts at a given node,  
4110: !    visits every node exactly once, and returns to the starting node. 
4111: ! 
4112: !  Licensing: 
4113: ! 
4114: !    This code is distributed under the GNU LGPL license.  
4115: ! 
4116: !  Modified: 
4117: ! 
4118: !    16 August 2000 
4119: ! 
4120: !  Author: 
4121: ! 
4122: !    John Burkardt 
4123: ! 
4124: !  Reference: 
4125: ! 
4126: !    Albert Nijenhuis, Herbert Wilf, 
4127: !    Combinatorial Algorithms, 
4128: !    Academic Press, 1978, second edition, 
4129: !    ISBN 0-12-519260-6. 
4130: ! 
4131: !  Parameters: 
4132: ! 
4133: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE).  ADJ(I,J) = 1 if there is 
4134: !    an edge from node I to node J, 0 otherwise. 
4135: ! 
4136: !    Input, integer ( kind = 4 ) LDA, the first dimension of ADJ. 
4137: !    LDA must be at least NNODE. 
4138: ! 
4139: !    Input, integer ( kind = 4 ) NNODE, the number of nodes in the digraph. 
4140: ! 
4141: !    Input, integer ( kind = 4 ) CIRCUIT(NNODE), contains in CIRCUIT(1:K-1)  
4142: !    the partial candidate circuit being constructed. 
4143: ! 
4144: !    Input, integer ( kind = 4 ) K, the index of the next node to be determined 
4145: !    for the circuit. 
4146: ! 
4147: !    Input/output, integer ( kind = 4 ) NSTACK, the current length of the stack. 
4148: ! 
4149: !    Input, integer ( kind = 4 ) STACK(MAXSTACK), candidates for positions  
4150: !    1...K-1. 
4151: ! 
4152: !    Input, integer ( kind = 4 ) MAXSTACK, the dimension of STACK. 
4153: ! 
4154: !    Input/output, integer ( kind = 4 ) NCAN(NNODE), the number of candidates  
4155: !    for each position.  On input, contains values for steps 1 to K-1.  On  
4156: !    output, the value for position K has been determined. 
4157: ! 
4158:   implicit none 
4159:  
4160:   integer ( kind = 4 ) lda 
4161:   integer ( kind = 4 ) nnode 
4162:   integer ( kind = 4 ) maxstack 
4163:  
4164:   integer ( kind = 4 ) adj(lda,nnode) 
4165:   integer ( kind = 4 ) circuit(nnode) 
4166:   integer ( kind = 4 ) i 
4167:   integer ( kind = 4 ) iwork(nnode) 
4168:   integer ( kind = 4 ) k 
4169:   integer ( kind = 4 ) ncan(nnode) 
4170:   integer ( kind = 4 ) nstack 
4171:   integer ( kind = 4 ) stack(maxstack) 
4172:  
4173:   ncan(k) = 0 
4174:  
4175:   if ( k == 1 ) then 
4176:     stack(1) = 1 
4177:     nstack = 1 
4178:     ncan(k) = 1 
4179:     return 
4180:   end if 
4181:  
4182:   iwork(1:nnode) = adj(circuit(k-1),1:nnode) 
4183:   
4184:   iwork(circuit(1:k-1)) = 0 
4185:    
4186:   if ( k /= nnode ) then 
4187:   
4188:     do i = 1, nnode 
4189:       if ( iwork(i) == 1 ) then 
4190:         if ( maxstack <= nstack ) then 
4191:           write ( *, '(a)' ) ' ' 
4192:           write ( *, '(a)' ) 'DIGRAPH_ADJ_HAM_CAND - Fatal error!' 
4193:           write ( *, '(a)' ) '  MAXSTACK is too small.' 
4194:           stop 
4195:         end if 
4196:         nstack = nstack + 1 
4197:         stack(nstack) = i 
4198:         ncan(k) = ncan(k) + 1 
4199:       end if 
4200:     end do 
4201:   
4202:     return 
4203:   
4204:   else if ( k == nnode ) then 
4205:   
4206:     do i = 1, nnode 
4207:   
4208:       if ( iwork(i) == 1 ) then 
4209:   
4210:         if ( adj(i,1) /= 0 ) then 
4211:           if ( maxstack <= nstack ) then 
4212:             write ( *, '(a)' ) ' ' 
4213:             write ( *, '(a)' ) 'DIGRAPH_ADJ_HAM_CAND - Fatal error!' 
4214:             write ( *, '(a)' ) '  MAXSTACK is too small.' 
4215:             stop 
4216:           end if 
4217:           nstack = nstack + 1 
4218:           stack(nstack) = i 
4219:           ncan(k) = ncan(k) + 1 
4220:         end if 
4221:  
4222:         return 
4223:   
4224:       end if 
4225:   
4226:     end do 
4227:  
4228:   end if 
4229:   
4230:   return 
4231: end subroutine 
4232: subroutine digraph_adj_ham_next ( adj, lda, nnode, circuit, stack, & 
4233:   maxstack, ncan, more ) 
4234:  
4235: !*****************************************************************************80 
4236: ! 
4237: !! DIGRAPH_ADJ_HAM_NEXT returns the next Hamilton circuit for a digraph. 
4238: ! 
4239: !  Discussion: 
4240: ! 
4241: !    The routine produces all the Hamilton circuits of a digraph, one at a time. 
4242: ! 
4243: !    A Hamiltonian circuit of a digraph is a path that starts at a given 
4244: !    node, visits every node exactly once, and returns to the starting node. 
4245: ! 
4246: !  Licensing: 
4247: ! 
4248: !    This code is distributed under the GNU LGPL license.  
4249: ! 
4250: !  Modified: 
4251: ! 
4252: !    16 August 2000 
4253: ! 
4254: !  Author: 
4255: ! 
4256: !    John Burkardt 
4257: ! 
4258: !  Reference: 
4259: ! 
4260: !    Albert Nijenhuis, Herbert Wilf, 
4261: !    Combinatorial Algorithms, 
4262: !    Academic Press, 1978, second edition, 
4263: !    ISBN 0-12-519260-6. 
4264: ! 
4265: !  Parameters: 
4266: ! 
4267: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency matrix of the  
4268: !    digraph.  ADJ(I,J) = 1 if there is an edge from node I to node J,  
4269: !    0 otherwise. 
4270: ! 
4271: !    Input, integer ( kind = 4 ) LDA, the first dimension of ADJ as 
4272: !    declared in the calling program.  LDA must be at least NNODE. 
4273: ! 
4274: !    Input, integer ( kind = 4 ) NNODE, the number of nodes in the digraph. 
4275: ! 
4276: !    Input/output, integer ( kind = 4 ) CIRCUIT(NNODE).  On the first call to  
4277: !    this routine, the contents of CIRCUIT are irrelevant.  On return, CIRCUIT  
4278: !    contains a list of the nodes that form a cirucit.  On each subsequent  
4279: !    call, the input value of CIRCUIT is used to construct the next solution, 
4280: !    so the user should not alter the contents of CIRCUIT during a computation. 
4281: ! 
4282: !    Workspace, integer STACK(MAXSTACK).  Candidates for the positions in 
4283: !    the circuit. 
4284: ! 
4285: !    Input, integer ( kind = 4 ) MAXSTACK, the dimension of STACK. 
4286: ! 
4287: !    Workspace, integer NCAN(NNODE), a count of the number of candidates for  
4288: !    each step. 
4289: ! 
4290: !    Input/output, logical MORE. 
4291: !    On first call, set MORE to .FALSE, and do not alter it after. 
4292: !    On return, MORE is TRUE if another circuit has been returned in 
4293: !    IARRAY, and FALSE if there are no more circuits. 
4294: ! 
4295:   implicit none 
4296:  
4297:   integer ( kind = 4 ) lda 
4298:   integer ( kind = 4 ) nnode 
4299:   integer ( kind = 4 ) maxstack 
4300:  
4301:   integer ( kind = 4 ) adj(lda,nnode) 
4302:   integer ( kind = 4 ) circuit(nnode) 
4303:   integer ( kind = 4 ), save :: indx = 0 
4304:   integer ( kind = 4 ), save :: k = 0 
4305:   logical more 
4306:   integer ( kind = 4 ) ncan(nnode) 
4307:   integer ( kind = 4 ), save :: nstack = 0 
4308:   integer ( kind = 4 ) stack(maxstack) 
4309:  
4310:   if ( .not. more ) then 
4311:     indx = 0 
4312:     k = 0 
4313:     more = .true. 
4314:     nstack = 0 
4315:   end if 
4316:   
4317:   do 
4318:   
4319:     call i4vec_backtrack ( nnode, circuit, indx, k, nstack, stack, maxstack, & 
4320:       ncan ) 
4321:   
4322:     if ( indx == 1 ) then 
4323:  
4324:       exit 
4325:  
4326:     else if ( indx == 2 ) then 
4327:  
4328:       call digraph_adj_ham_cand ( adj, lda, nnode, circuit, k, nstack, & 
4329:         stack, maxstack, ncan ) 
4330:  
4331:     else 
4332:  
4333:       more = .false. 
4334:       exit 
4335:  
4336:     end if 
4337:  
4338:   end do 
4339:   
4340:   return 
4341: end subroutine 
4342: subroutine digraph_adj_ham_next_brute ( adj, lda, nnode, circuit, iset ) 
4343:  
4344: !*****************************************************************************80 
4345: ! 
4346: !! DIGRAPH_ADJ_HAM_NEXT_BRUTE finds the next Hamiltonian circuit in a digraph. 
4347: ! 
4348: !  Discussion: 
4349: ! 
4350: !    This is a brute force algorithm, and not suitable for large problems. 
4351: !    It is really only useful as a demonstration, and as a check for 
4352: !    the backtracking algorithm. 
4353: ! 
4354: !  Licensing: 
4355: ! 
4356: !    This code is distributed under the GNU LGPL license.  
4357: ! 
4358: !  Modified: 
4359: ! 
4360: !    01 April 2001 
4361: ! 
4362: !  Author: 
4363: ! 
4364: !    John Burkardt 
4365: ! 
4366: !  Parameters: 
4367: ! 
4368: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
4369: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
4370: ! 
4371: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ, which must  
4372: !    be at least NNODE. 
4373: ! 
4374: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
4375: ! 
4376: !    Input/output, integer ( kind = 4 ) CIRCUIT(NNODE). 
4377: ! 
4378: !    On input, if ISET = 0, then CIRCUIT is not presumed to contain any  
4379: !    information.  If ISET is nonzero, then CIRCUIT contains the circuit  
4380: !    computed on the previous call. 
4381: ! 
4382: !    On output, CIRCUIT contains the circuit computed by this call. 
4383: ! 
4384: !    Input/output, integer ( kind = 4 ) ISET. 
4385: !    On input, 0 means this is the first call for this graph.   
4386: !    Any other value means this is a repeated call for more circuits. 
4387: ! 
4388: !    On output, a 0 value means that no more circuits could be computed. 
4389: !    Otherwise, ISET is incremented by one on each call. 
4390: ! 
4391:   implicit none 
4392:  
4393:   integer ( kind = 4 ) lda 
4394:   integer ( kind = 4 ) nnode 
4395:  
4396:   integer ( kind = 4 ) adj(lda,nnode) 
4397:   integer ( kind = 4 ) circuit(nnode) 
4398:   integer ( kind = 4 ) i 
4399:   integer ( kind = 4 ) ipos 
4400:   integer ( kind = 4 ) iset 
4401: ! 
4402: !  If ISET is 0, this is a starting call, and we set CIRCUIT 
4403: !  to the lexically first circuit to check. 
4404: ! 
4405: !  Otherwise, we set CIRCUIT to the next permutation. 
4406: ! 
4407:   if ( iset == 0 ) then 
4408:     ipos = 0 
4409:     circuit(1:nnode) = 0 
4410:   else 
4411:     ipos = nnode - 1 
4412:   end if 
4413:   
4414:   do 
4415:   
4416:     call perm_inc ( circuit, ipos, nnode ) 
4417:  
4418:     if ( ipos <= 0 .or. circuit(1) /= 1 ) then 
4419:       iset = 0 
4420:       circuit(1:nnode) = 0 
4421:       return 
4422:     end if 
4423: ! 
4424: !  Check whether the entries of CIRCUIT actually form a circuit. 
4425: !  If we find a break in the circuit, store that location in IPOS 
4426: !  and move on to try the next permutation. 
4427: ! 
4428:     ipos = 0 
4429:     do i = 1, nnode-1 
4430:       if ( adj(circuit(i),circuit(i+1)) == 0 ) then 
4431:         ipos = i 
4432:         exit 
4433:       end if 
4434:     end do 
4435:  
4436:     if ( ipos /= 0 ) then 
4437:       cycle 
4438:     end if 
4439: ! 
4440: !  If the circuit connects all the nodes, we only have to check whether 
4441: !  the last node connects back to the first one. 
4442: ! 
4443:     if ( adj(circuit(nnode),circuit(1)) /= 0 ) then 
4444:       exit 
4445:     end if 
4446:  
4447:     ipos = nnode - 1 
4448:  
4449:   end do 
4450:  
4451:   iset = iset + 1 
4452:  
4453:   return 
4454: end subroutine 
4455: subroutine digraph_adj_ham_path_next_brute ( adj, lda, nnode, path, iset ) 
4456:  
4457: !*****************************************************************************80 
4458: ! 
4459: !! DIGRAPH_ADJ_HAM_PATH_NEXT_BRUTE: next path in digraph that visits all nodes. 
4460: ! 
4461: !  Discussion: 
4462: ! 
4463: !    The path is not required to be a circuit.  That is, there is no requirement 
4464: !    that there be an edge from the last node visited back to the first one. 
4465: ! 
4466: !    This is a brute force algorithm, and not suitable for large problems. 
4467: ! 
4468: !  Licensing: 
4469: ! 
4470: !    This code is distributed under the GNU LGPL license.  
4471: ! 
4472: !  Modified: 
4473: ! 
4474: !    20 March 2001 
4475: ! 
4476: !  Author: 
4477: ! 
4478: !    John Burkardt 
4479: ! 
4480: !  Parameters: 
4481: ! 
4482: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
4483: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
4484: ! 
4485: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ, which must  
4486: !    be at least NNODE. 
4487: ! 
4488: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
4489: ! 
4490: !    Input/output, integer ( kind = 4 ) PATH(NNODE). 
4491: ! 
4492: !    On input, if ISET = 0, then PATH is not presumed to contain any 
4493: !    information.  If ISET is nonzero, then PATH contains the 
4494: !    path computed on the previous call. 
4495: ! 
4496: !    On output, PATH contains the path computed by this call. 
4497: ! 
4498: !    Input/output, integer ( kind = 4 ) ISET. 
4499: ! 
4500: !    On input, a 0 value means this is the first call for this 
4501: !    graph.  Any other value means this is a repeated call for more paths. 
4502: ! 
4503: !    On output, a 0 value means that no more paths could be computed. 
4504: !    Otherwise, ISET is incremented by one on each call. 
4505: ! 
4506:   implicit none 
4507:  
4508:   integer ( kind = 4 ) lda 
4509:   integer ( kind = 4 ) nnode 
4510:  
4511:   integer ( kind = 4 ) adj(lda,nnode) 
4512:   integer ( kind = 4 ) i 
4513:   integer ( kind = 4 ) ipos 
4514:   integer ( kind = 4 ) iset 
4515:   integer ( kind = 4 ) path(nnode) 
4516: ! 
4517: !  If ISET is 0, this is a starting call, and we set PATH 
4518: !  to the lexically first path to check. 
4519: ! 
4520: !  Otherwise, we set PATH to the next permutation. 
4521: ! 
4522:   if ( iset == 0 ) then 
4523:     ipos = 0 
4524:     path(1:nnode) = 0 
4525:   else 
4526:     ipos = nnode - 1 
4527:   end if 
4528:   
4529:   do 
4530:   
4531:     call perm_inc ( path, ipos, nnode ) 
4532:   
4533:     if ( ipos == 0 ) then 
4534:       iset = 0 
4535:       path(1:nnode) = 0 
4536:       return 
4537:     end if 
4538: ! 
4539: !  Check whether the entries of PATH actually form a path. 
4540: ! 
4541:     ipos = 0 
4542:     do i = 1, nnode-1 
4543:       if ( adj(path(i),path(i+1)) == 0 ) then 
4544:         ipos = i 
4545:         exit 
4546:       end if 
4547:     end do 
4548:  
4549:     if ( ipos == 0 ) then 
4550:       exit 
4551:     end if 
4552:  
4553:   end do  
4554:  
4555:   iset = iset + 1 
4556:   
4557:   return 
4558: end subroutine 
4559: subroutine digraph_adj_is_edge_connected ( adj, lda, nnode, result ) 
4560:  
4561: !*****************************************************************************80 
4562: ! 
4563: !! DIGRAPH_ADJ_IS_EDGE_CONNECTED determines if a digraph is edgewise connected. 
4564: ! 
4565: !  Discussion: 
4566: ! 
4567: !    A digraph is edgewise connected if from any edge it is possible to reach 
4568: !    any other edge.  An edgewise connected digraph may include isolated nodes. 
4569: ! 
4570: !  Licensing: 
4571: ! 
4572: !    This code is distributed under the GNU LGPL license.  
4573: ! 
4574: !  Modified: 
4575: ! 
4576: !    01 April 2001 
4577: ! 
4578: !  Author: 
4579: ! 
4580: !    John Burkardt 
4581: ! 
4582: !  Parameters: 
4583: ! 
4584: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
4585: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
4586: ! 
4587: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
4588: !    be at least NNODE. 
4589: ! 
4590: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
4591: ! 
4592: !    Output, integer ( kind = 4 ) RESULT. 
4593: !    0, the digraph is not edgewise connected. 
4594: !    1, the digraph is edgewise connected. 
4595: ! 
4596:   implicit none 
4597:  
4598:   integer ( kind = 4 ) lda 
4599:   integer ( kind = 4 ) nnode 
4600:  
4601:   integer ( kind = 4 ) adj(lda,nnode) 
4602:   integer ( kind = 4 ) found(nnode) 
4603:   integer ( kind = 4 ) i 
4604:   integer ( kind = 4 ) ihi 
4605:   integer ( kind = 4 ) ii 
4606:   integer ( kind = 4 ) ilo 
4607:   integer ( kind = 4 ) j 
4608:   integer ( kind = 4 ) jhi 
4609:   integer ( kind = 4 ) jlo 
4610:   integer ( kind = 4 ) list(nnode) 
4611:   integer ( kind = 4 ) result 
4612: ! 
4613: !  FOUND(I) is 1 if edge I has been reached. 
4614: !  LIST(I) contains a list of the nodes as they are reached. 
4615: ! 
4616:   list(1:nnode) = 0 
4617:   found(1:nnode) = 0 
4618: ! 
4619: !  Find an edge. 
4620: ! 
4621:   ilo = 1 
4622:   ihi = 0 
4623:  
4624:   do i = 1, nnode 
4625:     do j = 1, nnode 
4626:  
4627:       if ( 0 < adj(i,j) ) then 
4628:  
4629:         adj(i,j) = - adj(i,j) 
4630:         ihi = ihi + 1 
4631:         list(ihi) = i 
4632:         found(i) = 1 
4633:  
4634:         if ( i /= j ) then 
4635:           ihi = ihi + 1 
4636:           list(ihi) = j 
4637:           found(j) = 1 
4638:         end if 
4639:  
4640:         exit 
4641:  
4642:       end if 
4643:  
4644:     end do 
4645:  
4646:     if ( 0 < ihi ) then 
4647:       exit 
4648:     end if 
4649:  
4650:   end do 
4651: ! 
4652: !  A digraph with NO edges is edgewise connected! 
4653: ! 
4654:   if ( ihi == 0 ) then 
4655:     result = 1 
4656:     return 
4657:   end if 
4658: ! 
4659: !  From the batch of edge nodes found last time, LIST(ILO:IHI), 
4660: !  look for unfound neighbors, and store their indices in LIST(JLO:JHI). 
4661: ! 
4662:   do 
4663:  
4664:     jlo = ihi + 1 
4665:     jhi = ihi 
4666:  
4667:     do ii = ilo, ihi 
4668:  
4669:       i = list(ii) 
4670:  
4671:       do j = 1, nnode 
4672:  
4673:         if ( 0 < adj(i,j) ) then 
4674:  
4675:           adj(i,j) = - adj(i,j) 
4676:  
4677:           if ( found(j) == 0 ) then 
4678:             jhi = jhi + 1 
4679:             list(jhi) = j 
4680:             found(j) = 1 
4681:           end if 
4682:  
4683:         end if 
4684:  
4685:       end do 
4686:  
4687:     end do 
4688:  
4689:     if ( jhi < jlo ) then 
4690:       exit 
4691:     end if 
4692:  
4693:     ilo = jlo 
4694:     ihi = jhi 
4695:  
4696:   end do 
4697: ! 
4698: !  If any edges were unvisited, then the digraph is not edgewise connected. 
4699: ! 
4700:   result = 1 
4701:  
4702:   do i = 1, nnode 
4703:     do j = 1, nnode 
4704:       if ( 0 < adj(i,j) ) then 
4705:         result = 0 
4706:       end if 
4707:     end do 
4708:   end do 
4709: ! 
4710: !  Restore the positive sign of ADJ. 
4711: ! 
4712:   adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) 
4713:  
4714:   return 
4715: end subroutine 
4716: subroutine digraph_adj_is_eulerian ( adj, lda, nnode, result ) 
4717:  
4718: !*****************************************************************************80 
4719: ! 
4720: !! DIGRAPH_ADJ_IS_EULERIAN determines if a digraph is Eulerian. 
4721: ! 
4722: !  Discussion: 
4723: ! 
4724: !    A digraph is path-Eulerian if there exists a path through the digraph 
4725: !    which uses every edge once. 
4726: ! 
4727: !    A digraph is circuit-Eulerian if there exists a path through the digraph 
4728: !    which uses every edge once, and which starts and ends on the same node. 
4729: ! 
4730: !    Note that it is NOT necessary for the path or circuit to pass through 
4731: !    every node; simply that all the edges can be used exactly once to 
4732: !    make a connected path.  This means an Eulerian digraph can have isolated 
4733: !    nodes, for instance. 
4734: ! 
4735: !    A digraph is path-Eulerian if and only if it is edge-connected, and  
4736: !    for all but two nodes, the indegree and outdegree are equal, and 
4737: !    for those two nodes, the indegree and outdegree, if different, differ 
4738: !    by 1. 
4739: ! 
4740: !    A digraph is circuit-Eulerian if and only if it is edge connected and 
4741: !    for every node the indegree equals the outdegree. 
4742: ! 
4743: !  Licensing: 
4744: ! 
4745: !    This code is distributed under the GNU LGPL license.  
4746: ! 
4747: !  Modified: 
4748: ! 
4749: !    28 October 1999 
4750: ! 
4751: !  Author: 
4752: ! 
4753: !    John Burkardt 
4754: ! 
4755: !  Parameters: 
4756: ! 
4757: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
4758: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
4759: ! 
4760: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
4761: !    be at least NNODE. 
4762: ! 
4763: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
4764: ! 
4765: !    Output, integer ( kind = 4 ) RESULT. 
4766: !    0, the digraph is not Eulerian. 
4767: !    1, the digraph is path-Eulerian. 
4768: !    2, the digraph is circuit-Eulerian. 
4769: ! 
4770:   implicit none 
4771:  
4772:   integer ( kind = 4 ) lda 
4773:   integer ( kind = 4 ) nnode 
4774:  
4775:   integer ( kind = 4 ) adj(lda,nnode) 
4776:   integer ( kind = 4 ) i 
4777:   integer ( kind = 4 ) indegree(nnode) 
4778:   integer ( kind = 4 ) ndiff 
4779:   integer ( kind = 4 ) outdegree(nnode) 
4780:   integer ( kind = 4 ) result 
4781: ! 
4782: !  First check that the digraph is edgewise connected. 
4783: ! 
4784:   call digraph_adj_is_edge_connected ( adj, lda, nnode, result ) 
4785:  
4786:   if ( result == 0 ) then 
4787:     return 
4788:   end if 
4789: ! 
4790: !  Now look at node degree. 
4791: ! 
4792:   call digraph_adj_degree ( adj, lda, nnode, indegree, outdegree ) 
4793:  
4794:   ndiff = 0 
4795:  
4796:   do i = 1, nnode 
4797:  
4798:     if ( indegree(i) /= outdegree(i) ) then 
4799:  
4800:       ndiff = ndiff + 1 
4801:  
4802:       if ( 2 < ndiff ) then 
4803:         result = 0 
4804:         return 
4805:       end if 
4806:  
4807:       if ( 1 < abs ( indegree(i) - outdegree(i) ) ) then 
4808:         result = 0 
4809:         return 
4810:       end if 
4811:  
4812:     end if 
4813:  
4814:   end do 
4815:  
4816:   if ( ndiff == 0 ) then 
4817:     result = 2 
4818:   else 
4819:     result = 1 
4820:   end if 
4821:  
4822:   return 
4823: end subroutine 
4824: subroutine digraph_adj_is_strong_connected ( adj, lda, nnode, result ) 
4825:  
4826: !*****************************************************************************80 
4827: ! 
4828: !! DIGRAPH_ADJ_IS_STRONG_CONNECTED: is a digraph strongly connected? 
4829: ! 
4830: !  Licensing: 
4831: ! 
4832: !    This code is distributed under the GNU LGPL license.  
4833: ! 
4834: !  Modified: 
4835: ! 
4836: !    23 November 1999 
4837: ! 
4838: !  Parameters: 
4839: ! 
4840: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
4841: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
4842: ! 
4843: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ. 
4844: ! 
4845: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
4846: ! 
4847: !    Output, integer ( kind = 4 ) RESULT, 
4848: !    0, the digraph is not strongly connected; 
4849: !    1, the digraph is strongly connected. 
4850: ! 
4851:   implicit none 
4852:  
4853:   integer ( kind = 4 ) lda 
4854:   integer ( kind = 4 ) nnode 
4855:  
4856:   integer ( kind = 4 ) adj(lda,nnode) 
4857:   integer ( kind = 4 ) dad(nnode) 
4858:   integer ( kind = 4 ) iorder 
4859:   integer ( kind = 4 ) lowlink(nnode) 
4860:   integer ( kind = 4 ) mark(nnode) 
4861:   integer ( kind = 4 ) ncomp 
4862:   integer ( kind = 4 ) nstack 
4863:   integer ( kind = 4 ) order(nnode) 
4864:   integer ( kind = 4 ) point(nnode) 
4865:   integer ( kind = 4 ) result 
4866:   integer ( kind = 4 ) stack(nnode) 
4867:   integer ( kind = 4 ) v 
4868:   integer ( kind = 4 ) w 
4869:   integer ( kind = 4 ) x 
4870: ! 
4871: !  Initialization. 
4872: ! 
4873:   dad(1:nnode) = 0 
4874:   order(1:nnode) = 0 
4875:   lowlink(1:nnode) = 0 
4876:   mark(1:nnode) = 0 
4877:   point(1:nnode) = 0 
4878:  
4879:   iorder = 0 
4880:   nstack = 0 
4881:   ncomp = 0 
4882: ! 
4883: !  Select any node V not stored in the stack, that is, with MARK(V) = 0. 
4884: ! 
4885:   do 
4886:  
4887:     v = 0 
4888:  
4889:     do 
4890:  
4891:       v = v + 1 
4892:  
4893:       if ( nnode < v ) then 
4894:  
4895:         adj(1:nnode,1:nnode) = abs ( adj(1:nnode,1:nnode) ) 
4896:  
4897:         if ( 1 < ncomp ) then 
4898:           result = 0 
4899:         else 
4900:           result = 1 
4901:         end if 
4902:  
4903:         return 
4904:       end if 
4905:  
4906:       if ( mark(v) /= 1 ) then 
4907:         exit 
4908:       end if 
4909:  
4910:     end do 
4911:  
4912:     iorder = iorder + 1 
4913:  
4914:     order(v) = iorder 
4915:     lowlink(v) = iorder 
4916:     mark(v) = 1 
4917:  
4918:     nstack = nstack + 1 
4919:     stack(nstack) = v 
4920:     point(v) = 1 
4921:  
4922: 30  continue 
4923: ! 
4924: !  Consider each node W. 
4925: ! 
4926:     do w = 1, nnode 
4927: ! 
4928: !  Is there an edge (V,W) and has it not been examined yet? 
4929: ! 
4930:       if ( 0 < adj(v,w) ) then 
4931:  
4932:         adj(v,w) = - adj(v,w) 
4933: ! 
4934: !  Is the node on the other end of the edge undiscovered yet? 
4935: ! 
4936:         if ( mark(w) == 0 ) then 
4937:  
4938:           iorder = iorder + 1 
4939:           order(w) = iorder 
4940:           lowlink(w) = iorder 
4941:           dad(w) = v 
4942:           mark(w) = 1 
4943:  
4944:           nstack = nstack + 1 
4945:           stack(nstack) = w 
4946:           point(w) = 1 
4947:  
4948:           v = w 
4949:  
4950:         else if ( mark(w) == 1 ) then 
4951:  
4952:           if ( order(w) < order(v) .and. point(w) == 1 ) then 
4953:             lowlink(v) = min ( lowlink(v), order(w) ) 
4954:           end if 
4955:  
4956:         end if 
4957:  
4958:         go to 30 
4959:  
4960:       end if 
4961:  
4962:     end do 
4963:  
4964:     if ( lowlink(v) == order(v) ) then 
4965:  
4966:       ncomp = ncomp + 1 
4967:  
4968:       do 
4969:  
4970:         if ( nstack <= 0 ) then 
4971:           write ( *, '(a)' ) ' ' 
4972:           write ( *, '(a)' ) 'DIGRAPH_ADJ_IS_STRONG_CONNECTED - Fatal error!' 
4973:           write ( *, '(a)' ) '  Illegal stack reference.' 
4974:           stop 
4975:         end if 
4976:  
4977:         x = stack(nstack) 
4978:         nstack = nstack - 1 
4979:  
4980:         point(x) = 0 
4981:  
4982:         if ( x == v ) then 
4983:           exit 
4984:         end if 
4985:  
4986:       end do 
4987:  
4988:     end if 
4989:  
4990:     if ( dad(v) /= 0 ) then 
4991:       lowlink(dad(v)) = min ( lowlink(dad(v)), lowlink(v) ) 
4992:       v = dad(v) 
4993:       go to 30 
4994:     end if 
4995:  
4996:   end do 
4997:  
4998:   return 
4999: end subroutine 
5000: subroutine digraph_adj_is_tournament ( adj, lda, nnode, result ) 
5001:  
5002: !*****************************************************************************80 
5003: ! 
5004: !! DIGRAPH_ADJ_IS_TOURNAMENT determines if a digraph is a tournament. 
5005: ! 
5006: !  Discussion: 
5007: ! 
5008: !    A digraph is a tournament if every pair of distinct nodes is connected by 
5009: !    exactly one directed edge. 
5010: ! 
5011: !  Licensing: 
5012: ! 
5013: !    This code is distributed under the GNU LGPL license.  
5014: ! 
5015: !  Modified: 
5016: ! 
5017: !    07 September 2000 
5018: ! 
5019: !  Author: 
5020: ! 
5021: !    John Burkardt 
5022: ! 
5023: !  Parameters: 
5024: ! 
5025: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
5026: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
5027: ! 
5028: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
5029: !    be at least NNODE. 
5030: ! 
5031: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5032: ! 
5033: !    Output, integer ( kind = 4 ) RESULT. 
5034: !    0, the digraph is not a tournament. 
5035: !    1, the digraph is a tournament. 
5036: ! 
5037:   implicit none 
5038:  
5039:   integer ( kind = 4 ) lda 
5040:   integer ( kind = 4 ) nnode 
5041:  
5042:   integer ( kind = 4 ) adj(lda,nnode) 
5043:   integer ( kind = 4 ) i 
5044:   integer ( kind = 4 ) j 
5045:   integer ( kind = 4 ) result 
5046:  
5047:   result = 0 
5048: ! 
5049: !  No self links. 
5050: ! 
5051:   do i = 1, nnode 
5052:     if ( adj(i,i) /= 0 ) then 
5053:       return 
5054:     end if 
5055:   end do 
5056: ! 
5057: !  Distinct I and J must have exactly one connection. 
5058: ! 
5059:   do i = 1, nnode 
5060:     do j = i+1, nnode 
5061:       if ( .not. ( adj(i,j) == 0 .and. adj(j,i) == 1 ) .and. & 
5062:            .not. ( adj(i,j) == 1 .and. adj(j,i) == 0 ) ) then 
5063:         return 
5064:       end if 
5065:     end do 
5066:   end do 
5067:  
5068:   result = 1 
5069:   
5070:   return 
5071: end subroutine 
5072: subroutine digraph_adj_is_transitive ( adj, lda, nnode, result ) 
5073:  
5074: !*****************************************************************************80 
5075: ! 
5076: !! DIGRAPH_ADJ_IS_TRANSITIVE determines if a digraph is transitive. 
5077: ! 
5078: !  Discussion: 
5079: ! 
5080: !    A digraph is transitive if whenever there's a long way between two 
5081: !    nodes, there's an immediate way.  Formally: 
5082: ! 
5083: !      ADJ(I,J) and ADJ(J,K) nonzero imply ADJ(I,K) nonzero. 
5084: ! 
5085: !  Licensing: 
5086: ! 
5087: !    This code is distributed under the GNU LGPL license.  
5088: ! 
5089: !  Modified: 
5090: ! 
5091: !    01 November 1999 
5092: ! 
5093: !  Author: 
5094: ! 
5095: !    John Burkardt 
5096: ! 
5097: !  Parameters: 
5098: ! 
5099: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
5100: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
5101: ! 
5102: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
5103: !    be at least NNODE. 
5104: ! 
5105: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5106: ! 
5107: !    Output, integer ( kind = 4 ) RESULT. 
5108: !    0, the digraph is not transitive. 
5109: !    1, the digraph is transitive. 
5110: ! 
5111:   implicit none 
5112:  
5113:   integer ( kind = 4 ) lda 
5114:   integer ( kind = 4 ) nnode 
5115:  
5116:   integer ( kind = 4 ) adj(lda,nnode) 
5117:   integer ( kind = 4 ) i 
5118:   integer ( kind = 4 ) j 
5119:   integer ( kind = 4 ) k 
5120:   integer ( kind = 4 ) result 
5121:  
5122:   result = 0 
5123:  
5124:   do i = 1, nnode 
5125:     do j = 1, nnode 
5126:       if ( adj(i,j) /= 0 ) then 
5127:         do k = 1, nnode 
5128:           if ( adj(j,k) /= 0 ) then 
5129:             if ( adj(i,k) == 0 ) then 
5130:               return 
5131:             end if 
5132:           end if 
5133:         end do 
5134:       end if 
5135:     end do 
5136:   end do 
5137:  
5138:   result = 1 
5139:  
5140:   return 
5141: end subroutine 
5142: subroutine digraph_adj_is_weak_connected ( adj, lda, nnode, result ) 
5143:  
5144: !*****************************************************************************80 
5145: ! 
5146: !! DIGRAPH_ADJ_IS_WEAK_CONNECTED determines if a digraph is weakly connected. 
5147: ! 
5148: !  Discussion: 
5149: ! 
5150: !    A digraph is weakly connected if the underlying graph is node connected. 
5151: !    In other words, if a graph is constructed from the digraph by replacing 
5152: !    every directed edge by an undirected edge, and the it is possible to 
5153: !    travel from any node to any other node, then the digraph is weakly 
5154: !    connected. 
5155: ! 
5156: !  Licensing: 
5157: ! 
5158: !    This code is distributed under the GNU LGPL license.  
5159: ! 
5160: !  Modified: 
5161: ! 
5162: !    04 November 1999 
5163: ! 
5164: !  Author: 
5165: ! 
5166: !    John Burkardt 
5167: ! 
5168: !  Parameters: 
5169: ! 
5170: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency matrix for  
5171: !    the digraph.  ADJ(I,J) is nonzero if there is an edge from node I  
5172: !    to node J. 
5173: ! 
5174: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which  
5175: !    must be at least NNODE. 
5176: ! 
5177: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5178: ! 
5179: !    Output, integer ( kind = 4 ) RESULT. 
5180: !    0, the digraph is not weakly connected. 
5181: !    1, the digraph is weakly connected. 
5182: ! 
5183:   implicit none 
5184:  
5185:   integer ( kind = 4 ) lda 
5186:   integer ( kind = 4 ) nnode 
5187:  
5188:   integer ( kind = 4 ) adj(lda,nnode) 
5189:   integer ( kind = 4 ) result 
5190:  
5191:   call graph_adj_is_node_connected ( adj, lda, nnode, result ) 
5192:  
5193:   return 
5194: end subroutine 
5195: subroutine digraph_adj_print ( adj, lda, nnode, title ) 
5196:  
5197: !*****************************************************************************80 
5198: ! 
5199: !! DIGRAPH_ADJ_PRINT prints out an adjacency matrix for a digraph. 
5200: ! 
5201: !  Discussion: 
5202: ! 
5203: !    This routine actually allows the entries of ADJ to have ANY value. 
5204: !    Values between 0 and 9 will be printed as is.  Other values will 
5205: !    be printed as '*'. 
5206: ! 
5207: !  Licensing: 
5208: ! 
5209: !    This code is distributed under the GNU LGPL license.  
5210: ! 
5211: !  Modified: 
5212: ! 
5213: !    04 July 2000 
5214: ! 
5215: !  Author: 
5216: ! 
5217: !    John Burkardt 
5218: ! 
5219: !  Parameters: 
5220: ! 
5221: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency matrix of a  
5222: !    digraph.  ADJ(I,J) is 1 if there is a direct connection FROM node I TO  
5223: !    node J, and is 0 otherwise. 
5224: ! 
5225: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ, which  
5226: !    must be at least NNODE. 
5227: ! 
5228: !    Input, integer ( kind = 4 ) NNODE, the number of nodes.   
5229: ! 
5230: !    Input, character ( len = * ) TITLE, a title. 
5231: ! 
5232:   implicit none 
5233:  
5234:   integer ( kind = 4 ) lda 
5235:   integer ( kind = 4 ) nnode 
5236:  
5237:   integer ( kind = 4 ) adj(lda,nnode) 
5238:   integer ( kind = 4 ) i 
5239:   integer ( kind = 4 ) j 
5240:   integer ( kind = 4 ) jhi 
5241:   character ( len = 80 ) string 
5242:   character ( len = * ) title 
5243:  
5244:   if ( len_trim ( title ) /= 0 ) then 
5245:     write ( *, '(a)' ) ' ' 
5246:     write ( *, '(a)' ) trim ( title ) 
5247:   end if 
5248:  
5249:   write ( *, '(a)' ) ' ' 
5250:  
5251:   do i = 1, nnode 
5252:  
5253:     jhi = min ( nnode, 80 ) 
5254:  
5255:     do j = 1, jhi 
5256:  
5257:       if ( 0 <= adj(i,j) .and. adj(i,j) <= 9 ) then 
5258:         string(j:j) = char ( 48 + adj(i,j) ) 
5259:       else 
5260:         string(j:j) = '*' 
5261:       end if 
5262:  
5263:     end do 
5264:  
5265:     write ( *, '(i2,2x,a)' ) i, string(1:jhi) 
5266:  
5267:   end do 
5268:  
5269:   return 
5270: end subroutine 
5271: subroutine digraph_adj_random ( lda, nnode, nedge, seed, adj ) 
5272:  
5273: !*****************************************************************************80 
5274: ! 
5275: !! DIGRAPH_ADJ_RANDOM generates a random digraph. 
5276: ! 
5277: !  Discussion: 
5278: ! 
5279: !    A digraph is a directed graph. 
5280: ! 
5281: !    The user specifies the number of nodes and edges in the digraph. 
5282: ! 
5283: !  Licensing: 
5284: ! 
5285: !    This code is distributed under the GNU LGPL license.  
5286: ! 
5287: !  Modified: 
5288: ! 
5289: !    28 March 2005 
5290: ! 
5291: !  Author: 
5292: ! 
5293: !    John Burkardt 
5294: ! 
5295: !  Parameters: 
5296: ! 
5297: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must  
5298: !    be at least NNODE. 
5299: ! 
5300: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5301: ! 
5302: !    Input, integer ( kind = 4 ) NEDGE, the number of edges, which must be  
5303: !    between 0 and NNODE*(NNODE-1). 
5304: ! 
5305: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random  
5306: !    number generator. 
5307: ! 
5308: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
5309: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
5310: ! 
5311:   implicit none 
5312:  
5313:   integer ( kind = 4 ) lda 
5314:   integer ( kind = 4 ) nnode 
5315:   integer ( kind = 4 ) nedge 
5316:  
5317:   integer ( kind = 4 ) adj(lda,nnode) 
5318:   integer ( kind = 4 ) i 
5319:   integer ( kind = 4 ) iwork(nedge) 
5320:   integer ( kind = 4 ) j 
5321:   integer ( kind = 4 ) k 
5322:   integer ( kind = 4 ) l 
5323:   integer ( kind = 4 ) maxedge 
5324:   integer ( kind = 4 ) seed 
5325:  
5326:   if ( nnode <= 0  ) then 
5327:     write ( *, '(a)' ) ' ' 
5328:     write ( *, '(a)' ) 'DIGRAPH_ADJ_RANDOM - Fatal error!' 
5329:     write ( *, '(a,i8)' ) '  NNODE = ', nnode 
5330:     write ( *, '(a)' ) '  but NNODE must be at least 1.' 
5331:     stop 
5332:   end if 
5333:  
5334:   maxedge = nnode * ( nnode - 1 ) 
5335:  
5336:   if ( nedge < 0 .or. maxedge < nedge ) then 
5337:     write ( *, '(a)' ) ' ' 
5338:     write ( *, '(a)' ) 'DIGRAPH_RANDOM - Fatal error!' 
5339:     write ( *, '(a,i8)' ) '  NEDGE = ', nedge 
5340:     write ( *, '(a)' ) '  but NEDGE must be at least 0, and ' 
5341:     write ( *, '(a,i8)' ) '  no more than ', maxedge 
5342:     stop 
5343:   end if 
5344:  
5345:   adj(1:nnode,1:nnode) = 0 
5346: ! 
5347: !  Pick a random NEDGE subset of NNODE*(NNODE-1). 
5348: ! 
5349:   call ksub_random ( maxedge, nedge, seed, iwork ) 
5350: ! 
5351: !  The usable spots in the matrix are numbered as follows: 
5352: ! 
5353: !   *    1    2   3  ...      n-2        n-1 
5354: !   n    *   n+1 n+2 ...     2n-1      2(n-1) 
5355: !  2n-1  2n   *  ... ... ........  .......... 
5356: !  .... ...  ... ... ...     *     (n-1)(n-1) 
5357: !  .... ...  ... ... ...   n(n-1)       * 
5358: ! 
5359:   k = 0 
5360:   l = 1 
5361:   do i = 1, nnode 
5362:     do j = 1, nnode 
5363:  
5364:       if ( i /= j ) then 
5365:  
5366:         k = k + 1 
5367:         if ( l <= nedge ) then 
5368:  
5369:           if ( k == iwork(l) ) then 
5370:             adj(i,j) = 1 
5371:             l = l + 1 
5372:           end if 
5373:  
5374:         end if 
5375:  
5376:       end if 
5377:  
5378:     end do 
5379:   end do 
5380:  
5381:   return 
5382: end subroutine 
5383: subroutine digraph_adj_reduce ( adj, nnode ) 
5384:  
5385: !*****************************************************************************80 
5386: ! 
5387: !! DIGRAPH_ADJ_REDUCE generates a transitive reduction of a digraph. 
5388: ! 
5389: !  Discussion: 
5390: ! 
5391: !    This routine is given an adjacency matrix B, which might be a 
5392: !    transitive closure of a graph G. 
5393: ! 
5394: !    The transitive closure graph is generated from a graph G by the  
5395: !    following procedure: 
5396: ! 
5397: !      B(I,J) = 0 if node J cannot be reached from node I in graph G; 
5398: !               1 if node J can be reached from node I in graph G. 
5399: ! 
5400: !    The purpose of this routine is to try to find the original, sparser 
5401: !    graph G which generated the given transitive closure graph.  Such a 
5402: !    graph G is known as a transitive reduction..  In general, 
5403: !    there is no unique solution.  In particular, any graph is a transitive 
5404: !    reduction of itself.   
5405: ! 
5406: !    Hence, the real task is to drop as many redundant edges as possible 
5407: !    from the given graph, arriving at a graph from which no more edges  
5408: !    may be removed. 
5409: ! 
5410: !  Method: 
5411: ! 
5412: !    One way of explaining the algorithm is based on the adjacency matrix: 
5413: ! 
5414: !    * Zero out the diagonals of the adjacency matrix. 
5415: ! 
5416: !    * Consider row 1.  Any other row that can "reach" row 1 doesn't 
5417: !      need a 1 if row 1 has it.  So "subtract" all the 1's in row 1 
5418: !      from such rows.  We are done with row 1 and column 1. 
5419: ! 
5420: !    * Repeat for the other rows. 
5421: ! 
5422: !  Licensing: 
5423: ! 
5424: !    This code is distributed under the GNU LGPL license.  
5425: ! 
5426: !  Modified: 
5427: ! 
5428: !    15 April 1999 
5429: ! 
5430: !  Author: 
5431: ! 
5432: !    John Burkardt 
5433: ! 
5434: !  Parameters: 
5435: ! 
5436: !    Input/output, integer ( kind = 4 ) ADJ(NNODE,NNODE). 
5437: !    On input, the adjacency matrix of the transitive closure graph H. 
5438: !    On output, the adjacency matrix of a transitive reduction graph G  
5439: !    of the graph H. 
5440: ! 
5441: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5442: ! 
5443:   implicit none 
5444:  
5445:   integer ( kind = 4 ) nnode 
5446:  
5447:   integer ( kind = 4 ) adj(nnode,nnode) 
5448:   integer ( kind = 4 ) i 
5449:   integer ( kind = 4 ) j 
5450:   integer ( kind = 4 ) k 
5451: ! 
5452: !  First discard those useless self-edges. 
5453: ! 
5454:   do i = 1, nnode 
5455:     adj(i,i) = 0 
5456:   end do 
5457: ! 
5458: !  If you can get from J to I and I to K, you don't need a direct 
5459: !  edge from J to K. 
5460: ! 
5461:   do i = 1, nnode 
5462:     do j = 1, nnode 
5463:       if ( adj(j,i) /= 0 ) then 
5464:         do k = 1, nnode 
5465:           if ( adj(i,k) /= 0 ) then 
5466:             adj(j,k) = 0 
5467:           end if 
5468:         end do 
5469:       end if 
5470:     end do 
5471:   end do 
5472:  
5473:   return 
5474: end subroutine 
5475: subroutine digraph_adj_to_digraph_arc ( adj, lda, nnode, maxedge, nedge, & 
5476:   inode, jnode ) 
5477:  
5478: !*****************************************************************************80 
5479: ! 
5480: !! DIGRAPH_ADJ_TO_DIGRAPH_ARC converts digraph from adjacency to arc list form. 
5481: ! 
5482: !  Licensing: 
5483: ! 
5484: !    This code is distributed under the GNU LGPL license.  
5485: ! 
5486: !  Modified: 
5487: ! 
5488: !    26 October 1999 
5489: ! 
5490: !  Author: 
5491: ! 
5492: !    John Burkardt 
5493: ! 
5494: !  Parameters: 
5495: ! 
5496: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
5497: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
5498: ! 
5499: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must 
5500: !    be at least NNODE. 
5501: ! 
5502: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5503: ! 
5504: !    Input, integer ( kind = 4 ) MAXEDGE, the maximum number of edges. 
5505: ! 
5506: !    Output, integer ( kind = 4 ) NEDGE, the number of edges. 
5507: ! 
5508: !    Output, integer ( kind = 4 ) INODE(MAXEDGE), JNODE(MAXEDGE), the arc list  
5509: !    of the digraph. 
5510: ! 
5511:   implicit none 
5512:  
5513:   integer ( kind = 4 ) lda 
5514:   integer ( kind = 4 ) maxedge 
5515:   integer ( kind = 4 ) nnode 
5516:  
5517:   integer ( kind = 4 ) adj(lda,nnode) 
5518:   integer ( kind = 4 ) i 
5519:   integer ( kind = 4 ) inode(maxedge) 
5520:   integer ( kind = 4 ) j 
5521:   integer ( kind = 4 ) jnode(maxedge) 
5522:   integer ( kind = 4 ) nedge 
5523:  
5524:   nedge = 0 
5525:  
5526:   inode(1:maxedge) = 0 
5527:   jnode(1:maxedge) = 0 
5528:  
5529:   do j = 1, nnode 
5530:     do i = 1, nnode 
5531:       if ( adj(i,j) /= 0 ) then 
5532:         nedge = nedge + 1 
5533:         if ( nedge <= maxedge ) then 
5534:           inode(nedge) = i 
5535:           jnode(nedge) = j 
5536:         else 
5537:           write ( *, '(a)' ) ' ' 
5538:           write ( *, '(a)' ) 'DIGRAPH_ADJ_TO_DIGRAPH_ARC - Fatal error!' 
5539:           write ( *, '(a)' ) '  MAXEDGE exceeded.' 
5540:           stop 
5541:         end if 
5542:       end if 
5543:     end do 
5544:   end do 
5545:  
5546:   return 
5547: end subroutine 
5548: subroutine digraph_adj_to_digraph_inc ( adj, lda, nnode, maxarc, narc, inc ) 
5549:  
5550: !*****************************************************************************80 
5551: ! 
5552: !! DIGRAPH_ADJ_TO_DIGRAPH_INC converts adjacency digraph to incidence digraph. 
5553: ! 
5554: !  Discussion: 
5555: ! 
5556: !    INC(node,arc) = 0 if NODE is not the beginning or end of ARC, or 
5557: !                       if ARC is a loop; 
5558: !                     1 if NODE is the beginning of ARC; 
5559: !                    -1 if NODE is the end of ARC. 
5560: !  Licensing: 
5561: ! 
5562: !    This code is distributed under the GNU LGPL license.  
5563: ! 
5564: !  Modified: 
5565: ! 
5566: !    05 July 2000 
5567: ! 
5568: !  Author: 
5569: ! 
5570: !    John Burkardt 
5571: ! 
5572: !  Parameters: 
5573: ! 
5574: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency matrix for the  
5575: !    graph.  ADJ(I,J) is nonzero if there is an edge from node I to node J. 
5576: ! 
5577: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must 
5578: !    be at least NNODE. 
5579: ! 
5580: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5581: ! 
5582: !    Input, integer ( kind = 4 ) MAXARC, the maximum number of arcs. 
5583: ! 
5584: !    Output, integer ( kind = 4 ) NARC, the number of arcs. 
5585: ! 
5586: !    Output, integer ( kind = 4 ) INC(LDA,MAXARC), the incidence matrix. 
5587: ! 
5588:   implicit none 
5589:  
5590:   integer ( kind = 4 ) lda 
5591:   integer ( kind = 4 ) maxarc 
5592:   integer ( kind = 4 ) nnode 
5593:  
5594:   integer ( kind = 4 ) adj(lda,nnode) 
5595:   integer ( kind = 4 ) i 
5596:   integer ( kind = 4 ) inc(lda,maxarc) 
5597:   integer ( kind = 4 ) j 
5598:   integer ( kind = 4 ) narc 
5599:  
5600:   narc = 0 
5601:  
5602:   do j = 1, nnode 
5603:     do i = 1, nnode 
5604:  
5605:       if ( i == j ) then 
5606:  
5607:       else if ( adj(i,j) /= 0 ) then 
5608:         narc = narc + 1 
5609:         if ( narc <= maxarc ) then 
5610:           inc(i,narc) = 1 
5611:           inc(j,narc) = -1 
5612:         else 
5613:           write ( *, '(a)' ) ' ' 
5614:           write ( *, '(a)' ) 'DIGRAPH_ADJ_TO_DIGRAPH_INC - Fatal error!' 
5615:           write ( *, '(a)' ) '  MAXARC exceeded.' 
5616:           stop 
5617:         end if 
5618:       end if 
5619:     end do 
5620:   end do 
5621:  
5622:   return 
5623: end subroutine 
5624: subroutine digraph_adj_top_sort ( adj, lda, nnode, dad, visit, node_list ) 
5625:  
5626: !*****************************************************************************80 
5627: ! 
5628: !! DIGRAPH_ADJ_TOP_SORT: reverse topological sort of a directed acyclic graph. 
5629: ! 
5630: !  Discussion: 
5631: ! 
5632: !    The routine performs a depth first search of the DAG and returns: 
5633: ! 
5634: !    * a list of the order in which the nodes were visited; 
5635: !    * a list of the parents of each node in the search trees; 
5636: !    * a list of the nodes, in a reverse topological order. 
5637: ! 
5638: !    In a reverse topological sorting of the nodes of a directed 
5639: !    acyclic graph, nodes are listed "lowest" first.  That is, 
5640: !    if node A precedes node B in the list, then there may or may 
5641: !    not be an edge or indirect path from B to A, but there 
5642: !    is neither an edge or indirect path from A to B. 
5643: ! 
5644: !  Licensing: 
5645: ! 
5646: !    This code is distributed under the GNU LGPL license.  
5647: ! 
5648: !  Modified: 
5649: ! 
5650: !    15 April 1999 
5651: ! 
5652: !  Author: 
5653: ! 
5654: !    John Burkardt 
5655: ! 
5656: !  Reference: 
5657: ! 
5658: !    Robert Sedgewick, 
5659: !    Algorithms, 
5660: !    Addison Wesley, 1983, page 426. 
5661: ! 
5662: !  Parameters: 
5663: ! 
5664: !    Input, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
5665: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
5666: ! 
5667: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ, which must 
5668: !    be at least NNODE. 
5669: ! 
5670: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5671: ! 
5672: !    Output, integer ( kind = 4 ) DAD(NNODE), the father array for the depth 
5673: !    first search trees.  DAD(I) = 0 means that node I is the root of  
5674: !    one of the trees.  DAD(I) = J means that the search descended 
5675: !    from node J to node I. 
5676: ! 
5677: !    Output, integer ( kind = 4 ) VISIT(NNODE), the order in which the nodes 
5678: !    were visited, from 1 to NNODE. 
5679: ! 
5680: !    Output, integer ( kind = 4 ) NODE_LIST(NNODE), a list of the nodes, in 
5681: !    reverse topological order. 
5682: ! 
5683:   implicit none 
5684:  
5685:   integer ( kind = 4 ) lda 
5686:   integer ( kind = 4 ) nnode 
5687:  
5688:   integer ( kind = 4 ) adj(lda,nnode) 
5689:   integer ( kind = 4 ) dad(nnode) 
5690:   integer ( kind = 4 ) daddy 
5691:   integer ( kind = 4 ) i 
5692:   integer ( kind = 4 ) j 
5693:   integer ( kind = 4 ) maxstack 
5694:   integer ( kind = 4 ) nsort 
5695:   integer ( kind = 4 ) nstack 
5696:   integer ( kind = 4 ) node_list(nnode) 
5697:   integer ( kind = 4 ) rank 
5698:   integer ( kind = 4 ) stack(2*(nnode-1)) 
5699:   integer ( kind = 4 ) visit(nnode) 
5700:  
5701:   dad(1:nnode) = 0 
5702:   maxstack = 2 * ( nnode - 1 ) 
5703:   visit(1:nnode) = 0 
5704:   node_list(1:nnode) = 0 
5705:  
5706:   rank = 0 
5707:   nsort = 0 
5708:  
5709:   do i = 1, nnode 
5710: ! 
5711: !  Find the next unused node and begin a new search tree. 
5712: ! 
5713:     if ( visit(i) == 0 ) then 
5714:  
5715:       daddy = i 
5716:       dad(daddy) = 0 
5717:       nstack = 0 
5718: ! 
5719: !  Visit node DAD. 
5720: ! 
5721: 10    continue 
5722:  
5723:       rank = rank + 1 
5724:       visit(daddy) = rank 
5725:       j = 0 
5726: ! 
5727: !  Consider visiting node J from node DAD. 
5728: ! 
5729: 20    continue 
5730:  
5731:       j = j + 1 
5732: ! 
5733: !  If J is a reasonable value, adjacent to DAD, and unvisited, 
5734: !  then put DAD into the stack, make J the new value of DAD, 
5735: !  and go to 10. 
5736: ! 
5737:       if ( j <= nnode ) then 
5738:  
5739:         if ( adj(daddy,j) /= 0 .and. visit(j) == 0 ) then 
5740:  
5741:           if ( nstack+2 <= maxstack ) then 
5742:             dad(j) = daddy 
5743:             stack(nstack+1) = daddy 
5744:             stack(nstack+2) = j 
5745:             nstack = nstack + 2 
5746:             daddy = j 
5747:             go to 10 
5748:           else 
5749:             write ( *, '(a)' ) ' ' 
5750:             write ( *, '(a)' ) 'DIGRAPH_ADJ_TOP_SORT - Fatal error!' 
5751:             write ( *, '(a)' ) '  Out of stack space.' 
5752:             stop 
5753:           end if 
5754: ! 
5755: !  If J is not suitable for a visit, get the next value of J. 
5756: ! 
5757:         else 
5758:  
5759:           go to 20 
5760:  
5761:         end if 
5762: ! 
5763: !  If no more neighbors to consider, back up one node. 
5764: ! 
5765:       else if ( 2 <= nstack ) then 
5766:  
5767:         nsort = nsort + 1 
5768:         node_list(nsort) = daddy 
5769:  
5770:         daddy = stack(nstack-1) 
5771:         j = stack(nstack) 
5772:         nstack = nstack - 2 
5773:         go to 20 
5774: ! 
5775: !  If no more nodes to consider in this tree, bail out. 
5776: ! 
5777:       else 
5778:  
5779:         nsort = nsort + 1 
5780:         node_list(nsort) = daddy 
5781:  
5782:         nstack = 0 
5783:  
5784:       end if 
5785:  
5786:     end if 
5787:  
5788:   end do 
5789:  
5790:   return 
5791: end subroutine 
5792: subroutine digraph_adj_tournament_random ( lda, nnode, seed, adj ) 
5793:  
5794: !*****************************************************************************80 
5795: ! 
5796: !! DIGRAPH_ADJ_TOURNAMENT_RANDOM generates a random tournament digraph. 
5797: ! 
5798: !  Discussion: 
5799: ! 
5800: !    Definition: A tournament is a directed graph in which every pair  
5801: !    of nodes are joined by exactly one directed edge. 
5802: ! 
5803: !    The user specifies the number of nodes in the digraph.  The number of 
5804: !    edges will be (NNODE*(NNODE-1))/2. 
5805: ! 
5806: !  Licensing: 
5807: ! 
5808: !    This code is distributed under the GNU LGPL license.  
5809: ! 
5810: !  Modified: 
5811: ! 
5812: !    28 March 2005 
5813: ! 
5814: !  Author: 
5815: ! 
5816: !    John Burkardt 
5817: ! 
5818: !  Parameters: 
5819: ! 
5820: !    Input, integer ( kind = 4 ) LDA, the leading dimension of LDA, which must 
5821: !    be at least NNODE. 
5822: ! 
5823: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5824: ! 
5825: !    Input/output, integer ( kind = 4 ) SEED, a seed for the random number 
5826: !    generator. 
5827: ! 
5828: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
5829: !    ADJ(I,J) is 1 if there is a direct link from node I to node J. 
5830: ! 
5831:   implicit none 
5832:  
5833:   integer ( kind = 4 ) lda 
5834:   integer ( kind = 4 ) nnode 
5835:  
5836:   integer ( kind = 4 ) adj(lda,nnode) 
5837:   integer ( kind = 4 ) i 
5838: !  integer ( kind = 4 ) i4_uniform 
5839:   integer ( kind = 4 ) j 
5840:   integer ( kind = 4 ) k 
5841:   integer ( kind = 4 ) seed 
5842:  
5843:   if ( nnode <= 0  ) then 
5844:     write ( *, '(a)' ) ' ' 
5845:     write ( *, '(a)' ) 'DIGRAPH_ADJ_TOURNAMENT_RANDOM - Fatal error!' 
5846:     write ( *, '(a,i8)' ) '  NNODE = ', nnode 
5847:     write ( *, '(a)' ) '  but NNODE must be at least 1.' 
5848:     stop 
5849:   end if 
5850:  
5851:   adj(1:nnode,1:nnode) = 0 
5852:  
5853:   do i = 1, nnode 
5854:     do j = i+1, nnode 
5855:  
5856:       k = i4_uniform ( 1, 2, seed ) 
5857:  
5858:       if ( k == 1 ) then 
5859:         adj(i,j) = 1 
5860:       else 
5861:         adj(j,i) = 1 
5862:       end if 
5863:  
5864:     end do 
5865:   end do 
5866:  
5867:   return 
5868: end subroutine 
5869: subroutine digraph_arc_degree ( nnode, nedge, inode, jnode, indegree, & 
5870:   outdegree ) 
5871:  
5872: !*****************************************************************************80 
5873: ! 
5874: !! DIGRAPH_ARC_DEGREE determines the degree of the nodes of a digraph. 
5875: ! 
5876: !  Discussion: 
5877: ! 
5878: !    Definition: The degree of a node is the number of edges that  
5879: !    include the node. 
5880: ! 
5881: !  Licensing: 
5882: ! 
5883: !    This code is distributed under the GNU LGPL license.  
5884: ! 
5885: !  Modified: 
5886: ! 
5887: !    04 July 2000 
5888: ! 
5889: !  Author: 
5890: ! 
5891: !    John Burkardt 
5892: ! 
5893: !  Parameters: 
5894: ! 
5895: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
5896: ! 
5897: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
5898: ! 
5899: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the pairs of nodes 
5900: !    that form the edges. 
5901: ! 
5902: !    Output, integer ( kind = 4 ) INDEGREE(NNODE), OUTDEGREE(NNODE), the 
5903: !    indegree and outdegree of each node, that is, the number of edges that end  
5904: !    with the node, and the number of edges that begin with it. 
5905: ! 
5906:   implicit none 
5907:  
5908:   integer ( kind = 4 ) nedge 
5909:   integer ( kind = 4 ) nnode 
5910:  
5911:   integer ( kind = 4 ) i 
5912:   integer ( kind = 4 ) indegree(nnode) 
5913:   integer ( kind = 4 ) inode(nedge) 
5914:   integer ( kind = 4 ) jnode(nedge) 
5915:   integer ( kind = 4 ) n 
5916:   integer ( kind = 4 ) outdegree(nnode) 
5917:  
5918:   indegree(1:nnode) = 0 
5919:   outdegree(1:nnode) = 0 
5920:  
5921:   do i = 1, nedge 
5922:  
5923:     n = inode(i) 
5924:     if ( 1 <= n .and. n <= nnode ) then 
5925:       outdegree(n) = outdegree(n) + 1 
5926:     else 
5927:       write ( *, '(a)' ) ' ' 
5928:       write ( *, '(a)' ) 'DIGRAPH_ARC_DEGREE - Fatal error!' 
5929:       write ( *, '(a,i8)' ) '  Out-of-range node value = ', n 
5930:       stop 
5931:     end if 
5932:  
5933:     n = jnode(i) 
5934:     if ( 1 <= n .and. n <= nnode ) then 
5935:       indegree(n) = indegree(n) + 1 
5936:     else 
5937:       write ( *, '(a)' ) ' ' 
5938:       write ( *, '(a)' ) 'DIGRAPH_ARC_DEGREE - Fatal error!' 
5939:       write ( *, '(a,i8)' ) '  Out-of-range node value = ', n 
5940:       stop 
5941:     end if 
5942:  
5943:   end do 
5944:  
5945:   return 
5946: end subroutine 
5947: subroutine digraph_arc_edge_sort ( nedge, inode, jnode ) 
5948:  
5949: !*****************************************************************************80 
5950: ! 
5951: !! DIGRAPH_ARC_EDGE_SORT sorts the edge array of a graph. 
5952: ! 
5953: !  Discussion: 
5954: ! 
5955: !    The edges are sorted in dictionary order. 
5956: ! 
5957: !  Example: 
5958: ! 
5959: !    Input: 
5960: ! 
5961: !      INODE  JNODE 
5962: ! 
5963: !        3      2 
5964: !        2      4 
5965: !        4      3 
5966: !        2      1 
5967: !        1      4 
5968: ! 
5969: !    Output: 
5970: ! 
5971: !      INODE  JNODE 
5972: ! 
5973: !        1      4 
5974: !        2      1 
5975: !        2      4 
5976: !        3      2 
5977: !        4      3 
5978: ! 
5979: !  Licensing: 
5980: ! 
5981: !    This code is distributed under the GNU LGPL license.  
5982: ! 
5983: !  Modified: 
5984: ! 
5985: !    24 July 2000 
5986: ! 
5987: !  Author: 
5988: ! 
5989: !    John Burkardt 
5990: ! 
5991: !  Parameters: 
5992: ! 
5993: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
5994: ! 
5995: !    Input/output, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the edge 
5996: !    array.  The I-th edge goes from node INODE(I) to node JNODE(I). 
5997: !    On output, the INODE and JNODE arrays have been sorted as described. 
5998: ! 
5999:   implicit none 
6000:  
6001:   integer ( kind = 4 ) nedge 
6002:  
6003:   integer ( kind = 4 ) iedge 
6004:   integer ( kind = 4 ) indx 
6005:   integer ( kind = 4 ) inode(nedge) 
6006:   integer ( kind = 4 ) isgn 
6007:   integer ( kind = 4 ) jedge 
6008:   integer ( kind = 4 ) jnode(nedge) 
6009:  
6010:   if ( nedge <= 1 ) then 
6011:     return 
6012:   end if 
6013: ! 
6014: !  Sort the edges using an external heap sort. 
6015: ! 
6016:   iedge = 0 
6017:   jedge = 0 
6018:   indx = 0 
6019:   isgn = 0 
6020:  
6021:   do 
6022:  
6023:     call sort_heap_external ( nedge, indx, iedge, jedge, isgn ) 
6024: ! 
6025: !  Interchange edges IEDGE and JEDGE. 
6026: ! 
6027:     if ( 0 < indx ) then 
6028:  
6029:       call i4_swap ( inode(iedge), inode(jedge) ) 
6030:       call i4_swap ( jnode(iedge), jnode(jedge) ) 
6031: ! 
6032: !  Compare edges IEDGE and JEDGE. 
6033: ! 
6034:     else if ( indx < 0 ) then 
6035:  
6036:       if ( ( inode(iedge) < inode(jedge) ) .or. & 
6037:         ( inode(iedge) == inode(jedge) .and. & 
6038:           jnode(iedge) < jnode(jedge) ) ) then 
6039:         isgn = -1 
6040:       else 
6041:         isgn = +1 
6042:       end if 
6043:  
6044:     else if ( indx == 0 ) then 
6045:  
6046:       exit 
6047:  
6048:     end if 
6049:  
6050:   end do 
6051:   
6052:   return 
6053: end subroutine 
6054: subroutine digraph_arc_euler_circ_cand ( nedge, inode, jnode, circuit, k, & 
6055:   nstack, stack, maxstack, ncan, iwork, lwork ) 
6056:  
6057: !*****************************************************************************80 
6058: ! 
6059: !! DIGRAPH_ARC_EULER_CIRC_CAND: candidates for K-th edge of an Euler circuit. 
6060: ! 
6061: !  Discussion: 
6062: ! 
6063: !    This routine is used in conjunction with I4VEC_BACKTRACK, which directs 
6064: !    the search for a complete Euler circuit. 
6065: ! 
6066: !  Licensing: 
6067: ! 
6068: !    This code is distributed under the GNU LGPL license.  
6069: ! 
6070: !  Modified: 
6071: ! 
6072: !    17 August 2000 
6073: ! 
6074: !  Author: 
6075: ! 
6076: !    Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. 
6077: !    FORTRAN90 version by John Burkardt. 
6078: ! 
6079: !  Reference: 
6080: ! 
6081: !    Albert Nijenhuis, Herbert Wilf, 
6082: !    Combinatorial Algorithms, 
6083: !    Academic Press, 1978, second edition, 
6084: !    ISBN 0-12-519260-6. 
6085: ! 
6086: !  Parameters: 
6087: ! 
6088: !    Input, integer ( kind = 4 ) NEDGE, the number of edges in the digraph. 
6089: ! 
6090: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the edge array of  
6091: !    the digraph.  The I-th edge extends from node INODE(I) to JNODE(I). 
6092: ! 
6093: !    Input, integer ( kind = 4 ) CIRCUIT(NEDGE), CIRCUIT(I) is the I-th edge  
6094: !    in the circuit.  A full circuit will have NEDGE edges, but on input we  
6095: !    only have K-1. 
6096: ! 
6097: !    Input, integer ( kind = 4 ) K, the index of the next edge to be determined 
6098: !    in circuit. 
6099: ! 
6100: !    Input/output, integer ( kind = 4 ) NSTACK, the current length of the stack. 
6101: ! 
6102: !    Input, integer ( kind = 4 ) STACK(MAXSTACK), as yet unused candidates for  
6103: !    positions 1 to K-1. 
6104: ! 
6105: !    Input, integer ( kind = 4 ) MAXSTACK, the dimension of STACK. 
6106: ! 
6107: !    Workspace, integer IWORK(NEDGE). 
6108: ! 
6109: !    Workspace, logical LWORK(NEDGE). 
6110: ! 
6111:   implicit none 
6112:  
6113:   integer ( kind = 4 ) nedge 
6114:   integer ( kind = 4 ) maxstack 
6115:  
6116:   integer ( kind = 4 ) circuit(nedge) 
6117:   integer ( kind = 4 ) i 
6118:   integer ( kind = 4 ) inode(nedge) 
6119:   integer ( kind = 4 ) it 
6120:   integer ( kind = 4 ) iwork(nedge) 
6121:   integer ( kind = 4 ) jnode(nedge) 
6122:   integer ( kind = 4 ) k 
6123:   logical lwork(nedge) 
6124:   integer ( kind = 4 ) ncan(nedge) 
6125:   integer ( kind = 4 ) nstack 
6126:   integer ( kind = 4 ) stack(maxstack) 
6127:  
6128:   ncan(k) = 0 
6129:  
6130:   if ( k == 1 ) then 
6131:     iwork(1) = jnode(1) 
6132:     stack(1) = 1 
6133:     nstack = 1 
6134:     ncan(k) = 1 
6135:     return 
6136:   end if 
6137:   
6138:   if ( 2 < k ) then 
6139:     iwork(k-1) = inode(circuit(k-1)) + jnode(circuit(k-1)) - iwork(k-2) 
6140:   end if 
6141:   
6142:   it = iwork(k-1) 
6143:   
6144:   do i = 1, nedge 
6145:     lwork(i) = it == inode(i) 
6146:   end do 
6147:   
6148:   lwork(circuit(1:k-1)) = .false. 
6149:    
6150:   do i = 1, nedge 
6151:     if ( lwork(i) ) then 
6152:       if ( maxstack <= nstack ) then 
6153:         write ( *, '(a)' ) ' ' 
6154:         write ( *, '(a)' ) 'DIGRAPH_ARC_EULER_CIRC_CAND - Fatal error!' 
6155:         write ( *, '(a)' ) '  Stack size exceeded.' 
6156:         stop 
6157:       end if 
6158:       nstack = nstack + 1 
6159:       stack(nstack) = i 
6160:       ncan(k) = ncan(k) + 1 
6161:     end if 
6162:   end do 
6163:   
6164:   return 
6165: end subroutine 
6166: subroutine digraph_arc_euler_circ_next ( nedge, inode, jnode, circuit, stack, & 
6167:   maxstack, ncan, more ) 
6168:  
6169: !*****************************************************************************80 
6170: ! 
6171: !! DIGRAPH_ARC_EULER_CIRC_NEXT returns the next Euler circuit for a digraph. 
6172: ! 
6173: !  Discussion: 
6174: ! 
6175: !    The routine produces all the Euler circuits of a digraph, one at a time. 
6176: ! 
6177: !    Definition: An Euler circuit of a digraph is a path starting at some node,  
6178: !    using all the edges of the digraph exactly once, and returning 
6179: !    to the starting node. 
6180: ! 
6181: !  Licensing: 
6182: ! 
6183: !    This code is distributed under the GNU LGPL license.  
6184: ! 
6185: !  Modified: 
6186: ! 
6187: !    17 August 2000 
6188: ! 
6189: !  Author: 
6190: ! 
6191: !    Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. 
6192: !    FORTRAN90 version by John Burkardt. 
6193: ! 
6194: !  Reference: 
6195: ! 
6196: !    Albert Nijenhuis, Herbert Wilf, 
6197: !    Combinatorial Algorithms, 
6198: !    Academic Press, 1978, second edition, 
6199: !    ISBN 0-12-519260-6. 
6200: ! 
6201: !  Parameters: 
6202: ! 
6203: !    Input, integer ( kind = 4 ) NEDGE, the number of edges in the digraph. 
6204: ! 
6205: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the edge array  
6206: !    of the digraph.  The I-th edge extends from node INODE(I) to JNODE(I). 
6207: ! 
6208: !    Output, integer ( kind = 4 ) CIRCUIT(NEDGE).  If MORE = TRUE on output,  
6209: !    then IARRAY contains the edges, in order, that constitute this circuit. 
6210: ! 
6211: !    Workspace, integer STACK(MAXSTACK).   
6212: ! 
6213: !    Input, integer ( kind = 4 ) MAXSTACK, the dimension of STACK. 
6214: ! 
6215: !    Input/output, logical MORE. 
6216: !    On first call, set MORE to .FALSE, and do not alter it after. 
6217: !    On return, MORE is TRUE if another circuit has been returned in 
6218: !    IARRAY, and FALSE if there are no more circuits. 
6219: ! 
6220:   implicit none 
6221:  
6222:   integer ( kind = 4 ) nedge 
6223:   integer ( kind = 4 ) maxstack 
6224:  
6225:   integer ( kind = 4 ) circuit(nedge) 
6226:   integer ( kind = 4 ) inode(nedge) 
6227:   integer ( kind = 4 ), save :: indx = 0 
6228:   integer ( kind = 4 ) iwork(nedge) 
6229:   integer ( kind = 4 ) jnode(nedge) 
6230:   integer ( kind = 4 ), save :: k = 0 
6231:   logical lwork(nedge) 
6232:   logical more 
6233:   integer ( kind = 4 ) ncan(nedge) 
6234:   integer ( kind = 4 ), save :: nstack = 0 
6235:   integer ( kind = 4 ) stack(maxstack) 
6236:  
6237:   if ( .not. more ) then 
6238:     indx = 0 
6239:     k = 0 
6240:     more = .true. 
6241:     nstack = 0 
6242:   end if 
6243:   
6244:   do 
6245:   
6246:     call i4vec_backtrack ( nedge, circuit, indx, k, nstack, stack, maxstack, & 
6247:       ncan ) 
6248:   
6249:     if ( indx == 1 ) then 
6250:  
6251:       exit 
6252:  
6253:     else if ( indx == 2 ) then 
6254:  
6255:       call digraph_arc_euler_circ_cand ( nedge, inode, jnode, circuit, k, & 
6256:         nstack, stack, maxstack, ncan, iwork, lwork ) 
6257:  
6258:     else 
6259:  
6260:       more = .false. 
6261:       exit 
6262:  
6263:     end if 
6264:  
6265:   end do 
6266:   
6267:   return 
6268: end subroutine 
6269: subroutine digraph_arc_example_cycler ( maxedge, nedge, inode, jnode ) 
6270:  
6271: !*****************************************************************************80 
6272: ! 
6273: !! DIGRAPH_ARC_EXAMPLE_CYCLER sets arc list information for the cycler digraph. 
6274: ! 
6275: !  Diagram: 
6276: !   
6277: !           A 
6278: !           | 
6279: !           V 
6280: !    9--><--7---<--3--><---4 
6281: !    |            /|      / 
6282: !    V           A |     / 
6283: !    |          /  |    / 
6284: !    5----<----1   V   A 
6285: !    |        /    |  / 
6286: !    V       A     | / 
6287: !    |      /      |/ 
6288: !    2-->---8---<--6 
6289: !     \------>----/ 
6290: ! 
6291: !  Licensing: 
6292: ! 
6293: !    This code is distributed under the GNU LGPL license.  
6294: ! 
6295: !  Modified: 
6296: ! 
6297: !    26 October 1999 
6298: ! 
6299: !  Author: 
6300: ! 
6301: !    John Burkardt 
6302: ! 
6303: !  Parameters: 
6304: ! 
6305: !    Input, integer ( kind = 4 ) MAXEDGE, the maximum number of edges. 
6306: ! 
6307: !    Output, integer ( kind = 4 ) NEDGE, the number of edges. 
6308: ! 
6309: !    Output, integer ( kind = 4 ) INODE(MAXEDGE), JNODE(MAXEDGE), the arc list 
6310: !    for the digraph. 
6311: ! 
6312:   implicit none 
6313:  
6314:   integer ( kind = 4 ) maxedge 
6315:  
6316:   integer ( kind = 4 ) inode(maxedge) 
6317:   integer ( kind = 4 ) jnode(maxedge) 
6318:   integer ( kind = 4 ) nedge 
6319:  
6320:   nedge = 16 
6321:  
6322:   if ( maxedge < nedge ) then 
6323:     write ( *, '(a)' ) ' ' 
6324:     write ( *, '(a)' ) 'DIGRAPH_ARC_EXAMPLE_CYCLER - Fatal error!' 
6325:     write ( *, '(a)' ) '  MAXEDGE is too small.' 
6326:     stop 
6327:   end if 
6328:  
6329:   inode(1) = 1 
6330:   jnode(1) = 3 
6331:  
6332:   inode(2) = 1 
6333:   jnode(2) = 5 
6334:  
6335:   inode(3) = 2 
6336:   jnode(3) = 6 
6337:  
6338:   inode(4) = 2 
6339:   jnode(4) = 8 
6340:  
6341:   inode(5) = 3 
6342:   jnode(5) = 4 
6343:  
6344:   inode(6) = 3 
6345:   jnode(6) = 6 
6346:  
6347:   inode(7) = 3 
6348:   jnode(7) = 7 
6349:  
6350:   inode(8) = 4 
6351:   jnode(8) = 3 
6352:  
6353:   inode(9) = 5 
6354:   jnode(9) = 2 
6355:  
6356:   inode(10) = 6 
6357:   jnode(10) = 4 
6358:  
6359:   inode(11) = 6 
6360:   jnode(11) = 8 
6361:  
6362:   inode(12) = 7 
6363:   jnode(12) = 7 
6364:  
6365:   inode(13) = 7 
6366:   jnode(13) = 9 
6367:  
6368:   inode(14) = 8 
6369:   jnode(14) = 1 
6370:  
6371:   inode(15) = 9 
6372:   jnode(15) = 5 
6373:  
6374:   inode(16) = 9 
6375:   jnode(16) = 7 
6376:  
6377:   return 
6378: end subroutine 
6379: subroutine digraph_arc_is_eulerian ( nnode, nedge, inode, jnode, indegree, & 
6380:   outdegree, result ) 
6381:  
6382: !*****************************************************************************80 
6383: ! 
6384: !! DIGRAPH_ARC_IS_EULERIAN determines if a digraph is Eulerian. 
6385: ! 
6386: !  Discussion: 
6387: ! 
6388: !    A digraph is Eulerian if there exists a circuit through the graph 
6389: !    which uses every edge once. 
6390: ! 
6391: !  Licensing: 
6392: ! 
6393: !    This code is distributed under the GNU LGPL license.  
6394: ! 
6395: !  Modified: 
6396: ! 
6397: !    04 July 2000 
6398: ! 
6399: !  Author: 
6400: ! 
6401: !    John Burkardt 
6402: ! 
6403: !  Parameters: 
6404: ! 
6405: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
6406: ! 
6407: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
6408: ! 
6409: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the pairs of nodes 
6410: !    that form the edges. 
6411: ! 
6412: !    Output, integer ( kind = 4 ) INDEGREE(NNODE), OUTDEGREE(NODE), the 
6413: !    indegree and outdegree of each node, that is, the number of edges that  
6414: !    end with the node, and that begin the node. 
6415: ! 
6416: !    Output, integer ( kind = 4 ) RESULT. 
6417: !    0, the digraph is not Eulerian. 
6418: !    1, the digraph is Eulerian, but the starting and ending nodes differ. 
6419: !    2, the digraph is Eulerian, and there is a closed Euler circuit. 
6420: ! 
6421:   implicit none 
6422:  
6423:   integer ( kind = 4 ) nedge 
6424:   integer ( kind = 4 ) nnode 
6425:  
6426:   integer ( kind = 4 ) i 
6427:   integer ( kind = 4 ) indegree(nnode) 
6428:   integer ( kind = 4 ) inode(nedge) 
6429:   integer ( kind = 4 ) jnode(nedge) 
6430:   integer ( kind = 4 ) n_minus 
6431:   integer ( kind = 4 ) n_plus 
6432:   integer ( kind = 4 ) outdegree(nnode) 
6433:   integer ( kind = 4 ) result 
6434:  
6435:   call digraph_arc_degree ( nnode, nedge, inode, jnode, indegree, outdegree ) 
6436:  
6437:   n_plus = 0 
6438:   n_minus = 0 
6439:  
6440:   do i = 1, nnode 
6441:  
6442:     if ( indegree(i) == outdegree(i) ) then 
6443:  
6444:     else if ( n_plus == 0 .and. indegree(i) == outdegree(i) + 1 ) then 
6445:       n_plus = 1 
6446:     else if ( n_minus == 0 .and. indegree(i) == outdegree(i) - 1 ) then 
6447:       n_minus = 1 
6448:     else 
6449:       result = 0 
6450:       return 
6451:     end if 
6452:  
6453:   end do 
6454:  
6455:   if ( n_plus == 0 .and. n_minus == 0 ) then 
6456:     result = 2 
6457:   else if ( n_plus == 1 .and. n_minus == 1 ) then 
6458:     result = 1 
6459:   else 
6460:     write ( *, '(a)' ) ' ' 
6461:     write ( *, '(a)' ) 'DIGRAPH_ARC_IS_EULERIAN - Fatal error!' 
6462:     write ( *, '(a)' ) '  The algorithm failed.' 
6463:     stop 
6464:   end if 
6465:  
6466:   return 
6467: end subroutine 
6468: subroutine digraph_arc_print ( nedge, inode, jnode, title ) 
6469:  
6470: !*****************************************************************************80 
6471: ! 
6472: !! DIGRAPH_ARC_PRINT prints out a digraph from an edge list. 
6473: ! 
6474: !  Licensing: 
6475: ! 
6476: !    This code is distributed under the GNU LGPL license.  
6477: ! 
6478: !  Modified: 
6479: ! 
6480: !    04 July 2000 
6481: ! 
6482: !  Author: 
6483: ! 
6484: !    John Burkardt 
6485: ! 
6486: !  Parameters: 
6487: ! 
6488: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
6489: ! 
6490: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the beginning and 
6491: !    end nodes of the edges. 
6492: ! 
6493: !    Input, character ( len = * ) TITLE, a title. 
6494: ! 
6495:   implicit none 
6496:  
6497:   integer ( kind = 4 ) nedge 
6498:  
6499:   integer ( kind = 4 ) i 
6500:   integer ( kind = 4 ) inode(nedge) 
6501:   integer ( kind = 4 ) jnode(nedge) 
6502:   character ( len = * ) title 
6503:  
6504:   if ( len_trim ( title ) /= 0 ) then 
6505:     write ( *, '(a)' ) ' ' 
6506:     write ( *, '(a)' ) trim ( title ) 
6507:   end if 
6508:  
6509:   write ( *, '(a)' ) ' ' 
6510:  
6511:   do i = 1, nedge 
6512:     write ( *, '(i8,4x,2i8)' ) i, inode(i), jnode(i) 
6513:   end do 
6514:  
6515:   return 
6516: end subroutine 
6517: subroutine digraph_arc_to_digraph_adj ( nedge, inode, jnode, adj, lda, nnode ) 
6518:  
6519: !*****************************************************************************80 
6520: ! 
6521: !! DIGRAPH_ARC_TO_DIGRAPH_ADJ converts arc list digraph to an adjacency digraph. 
6522: ! 
6523: !  Licensing: 
6524: ! 
6525: !    This code is distributed under the GNU LGPL license.  
6526: ! 
6527: !  Modified: 
6528: ! 
6529: !    26 October 1999 
6530: ! 
6531: !  Author: 
6532: ! 
6533: !    John Burkardt 
6534: ! 
6535: !  Parameters: 
6536: ! 
6537: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
6538: ! 
6539: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the edge array. 
6540: !    The I-th edge connects nodes INODE(I) and JNODE(I). 
6541: ! 
6542: !    Output, integer ( kind = 4 ) ADJ(LDA,NNODE), the adjacency information. 
6543: ! 
6544: !    Input, integer ( kind = 4 ) LDA, the leading dimension of ADJ. 
6545: ! 
6546: !    Output, integer ( kind = 4 ) NNODE, the number of nodes. 
6547: ! 
6548:   implicit none 
6549:  
6550:   integer ( kind = 4 ) lda 
6551:   integer ( kind = 4 ) nedge 
6552:  
6553:   integer ( kind = 4 ) adj(lda,*) 
6554:   integer ( kind = 4 ) i 
6555:   integer ( kind = 4 ) inode(nedge) 
6556:   integer ( kind = 4 ) j 
6557:   integer ( kind = 4 ) jnode(nedge) 
6558:   integer ( kind = 4 ) k 
6559:   integer ( kind = 4 ) mnode 
6560:   integer ( kind = 4 ) nnode 
6561: ! 
6562: !  Determine the number of nodes. 
6563: ! 
6564:   call graph_arc_node_count ( nedge, inode, jnode, mnode, nnode ) 
6565:  
6566:   if ( lda < nnode ) then 
6567:     write ( *, '(a)' ) ' ' 
6568:     write ( *, '(a)' ) 'DIGRAPH_ARC_TO_DIGRAPH_ADJ - Fatal error!' 
6569:     write ( *, '(a)' ) '  Number of nodes exceeds LDA.' 
6570:     stop 
6571:   end if 
6572:  
6573:   adj(1:nnode,1:nnode) = 0 
6574:  
6575:   do k = 1, nedge 
6576:     i = inode(k) 
6577:     j = jnode(k) 
6578:     adj(i,j) = 1 
6579:   end do 
6580:  
6581:   return 
6582: end subroutine 
6583: subroutine digraph_arc_to_digraph_star ( nnode, nedge, inode, jnode, arcfir, & 
6584:   fwdarc ) 
6585:  
6586: !*****************************************************************************80 
6587: ! 
6588: !! DIGRAPH_ARC_TO_DIGRAPH_STAR sets forward star representation of a digraph. 
6589: ! 
6590: !  Licensing: 
6591: ! 
6592: !    This code is distributed under the GNU LGPL license.  
6593: ! 
6594: !  Modified: 
6595: ! 
6596: !    04 September 1999 
6597: ! 
6598: !  Author: 
6599: ! 
6600: !    John Burkardt 
6601: ! 
6602: !  Parameters: 
6603: ! 
6604: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
6605: ! 
6606: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
6607: ! 
6608: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE); the I-th edge 
6609: !    extends from node INODE(I) to JNODE(I). 
6610: ! 
6611: !    Output, integer ( kind = 4 ) ARCFIR(NNODE+1); ARCFIR(I) is the number of 
6612: !    the first edge starting at node I in the forward star representation. 
6613: ! 
6614: !    Output, integer ( kind = 4 ) FWDARC(NEDGE); FWDARC(I) is the ending node of 
6615: !    the I-th edge in the forward star representation. 
6616: ! 
6617:   implicit none 
6618:  
6619:   integer ( kind = 4 ) nedge 
6620:   integer ( kind = 4 ) nnode 
6621:  
6622:   integer ( kind = 4 ) arcfir(nnode+1) 
6623:   integer ( kind = 4 ) fwdarc(nedge) 
6624:   integer ( kind = 4 ) i 
6625:   integer ( kind = 4 ) inode(nedge) 
6626:   integer ( kind = 4 ) j 
6627:   integer ( kind = 4 ) jnode(nedge) 
6628:   integer ( kind = 4 ) k 
6629: ! 
6630: !  Set up the forward star representation. 
6631: ! 
6632:   k = 0 
6633:  
6634:   do i = 1, nnode 
6635:  
6636:     arcfir(i) = k + 1 
6637:  
6638:     do j = 1, nedge 
6639:  
6640:       if ( inode(j) == i ) then 
6641:         k = k + 1 
6642:         fwdarc(k) = jnode(j) 
6643:       end if 
6644:  
6645:     end do 
6646:  
6647:   end do 
6648:  
6649:   arcfir(nnode+1) = k + 1 
6650:  
6651:   return 
6652: end subroutine 
6653: subroutine digraph_arc_weight_print ( nedge, inode, jnode, wnode, title ) 
6654:  
6655: !*****************************************************************************80 
6656: ! 
6657: !! DIGRAPH_ARC_WEIGHT_PRINT prints out a weighted digraph from an edge list. 
6658: ! 
6659: !  Licensing: 
6660: ! 
6661: !    This code is distributed under the GNU LGPL license.  
6662: ! 
6663: !  Modified: 
6664: ! 
6665: !    23 July 2000 
6666: ! 
6667: !  Author: 
6668: ! 
6669: !    John Burkardt 
6670: ! 
6671: !  Parameters: 
6672: ! 
6673: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
6674: ! 
6675: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the beginning and 
6676: !    end nodes of the edges. 
6677: ! 
6678: !    Input, real ( kind = 8 ) WNODE(NEDGE), the weights of the edges. 
6679: ! 
6680: !    Input, character ( len = * ) TITLE, a title. 
6681: ! 
6682:   implicit none 
6683:  
6684:   integer ( kind = 4 ) nedge 
6685:  
6686:   integer ( kind = 4 ) i 
6687:   integer ( kind = 4 ) inode(nedge) 
6688:   integer ( kind = 4 ) jnode(nedge) 
6689:   character ( len = * ) title 
6690:   real ( kind = 8 ) wnode(nedge) 
6691:  
6692:   if ( len_trim ( title ) /= 0 ) then 
6693:     write ( *, '(a)' ) ' ' 
6694:     write ( *, '(a)' ) trim ( title ) 
6695:   end if 
6696:  
6697:   write ( *, '(a)' ) ' ' 
6698:  
6699:   do i = 1, nedge 
6700:     write ( *, '(i8,4x,2i8,g14.6)' ) i, inode(i), jnode(i), wnode(i) 
6701:   end do 
6702:  
6703:   return 
6704: end subroutine 
6705: subroutine digraph_dist_print ( dist, lda, nnode, title ) 
6706:  
6707: !*****************************************************************************80 
6708: ! 
6709: !! DIGRAPH_DIST_PRINT prints the distance matrix defining a digraph. 
6710: ! 
6711: !  Licensing: 
6712: ! 
6713: !    This code is distributed under the GNU LGPL license.  
6714: ! 
6715: !  Modified: 
6716: ! 
6717: !    22 July 2000 
6718: ! 
6719: !  Author: 
6720: ! 
6721: !    John Burkardt 
6722: ! 
6723: !  Parameters: 
6724: ! 
6725: !    Input, real ( kind = 8 ) DIST(LDA,NNODE), the distance matrix.   
6726: !    DIST(I,J) is the distance from node I to node J. 
6727: ! 
6728: !    Input, integer ( kind = 4 ) LDA, the leading dimension of DIST, which must 
6729: !    be at least NNODE. 
6730: ! 
6731: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
6732: ! 
6733: !    Input, character ( len = * ) TITLE, a title. 
6734: ! 
6735:   implicit none 
6736:  
6737:   integer ( kind = 4 ) lda 
6738:   integer ( kind = 4 ) nnode 
6739:  
6740:   real ( kind = 8 ) dist(lda,nnode) 
6741:   integer ( kind = 4 ) ihi 
6742:   integer ( kind = 4 ) ilo 
6743:   integer ( kind = 4 ) jhi 
6744:   integer ( kind = 4 ) jlo 
6745:   integer ( kind = 4 ) ncol 
6746:   integer ( kind = 4 ) nrow 
6747:   character ( len = * ) title 
6748:  
6749:   if ( len_trim ( title ) /= 0 ) then 
6750:     write ( *, '(a)' ) ' ' 
6751:     write ( *, '(a)' ) trim ( title ) 
6752:   end if 
6753:  
6754:   write ( *, '(a)' ) ' ' 
6755:  
6756:   ilo = 1 
6757:   ihi = nnode 
6758:   jlo = 1 
6759:   jhi = nnode 
6760:   ncol = nnode 
6761:   nrow = nnode 
6762:  
6763:   call r8mat_print ( dist, ihi, ilo, jhi, jlo, lda, ncol, nrow ) 
6764:  
6765:   return 
6766: end subroutine 
6767: subroutine digraph_inc_print ( lda, nnode, narc, inc, title ) 
6768:  
6769: !*****************************************************************************80 
6770: ! 
6771: !! DIGRAPH_INC_PRINT prints the incidence matrix of a digraph. 
6772: ! 
6773: !  Licensing: 
6774: ! 
6775: !    This code is distributed under the GNU LGPL license.  
6776: ! 
6777: !  Modified: 
6778: ! 
6779: !    05 July 2000 
6780: ! 
6781: !  Author: 
6782: ! 
6783: !    John Burkardt 
6784: ! 
6785: !  Parameters: 
6786: ! 
6787: !    Input, integer ( kind = 4 ) LDA, the leading dimension of the array. 
6788: ! 
6789: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
6790: ! 
6791: !    Input, integer ( kind = 4 ) NARC, the number of arcs. 
6792: ! 
6793: !    Input, integer ( kind = 4 ) INC(LDA,NARC), the NNODE by NARC incidence 
6794: !    matrix. 
6795: ! 
6796: !    Input, character ( len = * ) TITLE, a title. 
6797: ! 
6798:   implicit none 
6799:  
6800:   integer ( kind = 4 ) lda 
6801:   integer ( kind = 4 ) narc 
6802:  
6803:   integer ( kind = 4 ) i 
6804:   integer ( kind = 4 ) inc(lda,narc) 
6805:   integer ( kind = 4 ) nnode 
6806:   character ( len = * ) title 
6807:  
6808:   if ( len_trim ( title ) /= 0 ) then 
6809:     write ( *, '(a)' ) ' ' 
6810:     write ( *, '(a)' ) trim ( title ) 
6811:   end if 
6812:  
6813:   write ( *, '(a)' ) ' ' 
6814:  
6815:   do i = 1, nnode 
6816:     write ( *, '(20i3)' ) inc(i,1:narc) 
6817:   end do 
6818:  
6819:   return 
6820: end subroutine 
6821: subroutine edge_add_nodes ( edge, max_edge, num_edge, iface, n1, n2, ierror ) 
6822:  
6823: !*****************************************************************************80 
6824: ! 
6825: !! EDGE_ADD_NODES adds the edge defined by two nodes to the edge list. 
6826: ! 
6827: !  Licensing: 
6828: ! 
6829: !    This code is distributed under the GNU LGPL license.  
6830: ! 
6831: !  Modified: 
6832: ! 
6833: !    12 October 1998 
6834: ! 
6835: !  Author: 
6836: ! 
6837: !    John Burkardt 
6838: ! 
6839: !  Parameters: 
6840: ! 
6841: !    Input, integer ( kind = 4 ) EDGE(4,MAX_EDGE), edge information. 
6842: !    EDGE(1,I) is the starting node of edge I; 
6843: !    EDGE(2,I) is the ending node of edge I; 
6844: !    EDGE(3,I) is the positive face; 
6845: !    EDGE(4,I) is the negative face, if any. 
6846: ! 
6847: !    Input, integer ( kind = 4 ) MAX_EDGE, the maximum number of edges. 
6848: ! 
6849: !    Input/output, integer ( kind = 4 ) NUM_EDGE, the number of edges. 
6850: ! 
6851: !    Input, integer ( kind = 4 ) IFACE, the face to which the nodes belong. 
6852: ! 
6853: !    Input, integer ( kind = 4 ) N1, N2, two nodes which form an edge. 
6854: ! 
6855: !    Output, integer ( kind = 4 ) IERROR, error flag, 0 = no error,  
6856: !    nonzero = error. 
6857: ! 
6858:   implicit none 
6859:  
6860:   integer ( kind = 4 ) max_edge 
6861:  
6862:   integer ( kind = 4 ) edge(4,max_edge) 
6863:   integer ( kind = 4 ) ierror 
6864:   integer ( kind = 4 ) iface 
6865:   integer ( kind = 4 ) n1 
6866:   integer ( kind = 4 ) n2 
6867:   integer ( kind = 4 ) num_edge 
6868:  
6869:   if ( num_edge < max_edge ) then 
6870:     num_edge = num_edge + 1 
6871:     edge(1,num_edge) = n1 
6872:     edge(2,num_edge) = n2 
6873:     edge(3,num_edge) = iface 
6874:     edge(4,num_edge) = 0 
6875:     ierror = 0 
6876:   else 
6877:     write ( *, '(a)' ) ' ' 
6878:     write ( *, '(a)' ) 'EDGE_ADD_NODES - Fatal error!' 
6879:     write ( *, '(a,i8)' ) '  Exceeding MAX_EDGE = ', max_edge 
6880:     ierror = 1 
6881:   end if 
6882:  
6883:   return 
6884: end subroutine 
6885: subroutine edge_bound ( edge, max_edge, num_edge ) 
6886:  
6887: !*****************************************************************************80 
6888: ! 
6889: !! EDGE_BOUND reports the edges which are part of the boundary. 
6890: ! 
6891: !  Licensing: 
6892: ! 
6893: !    This code is distributed under the GNU LGPL license.  
6894: ! 
6895: !  Modified: 
6896: ! 
6897: !    12 October 1998 
6898: ! 
6899: !  Author: 
6900: ! 
6901: !    John Burkardt 
6902: ! 
6903: !  Parameters: 
6904: ! 
6905: !    Input, integer ( kind = 4 ) EDGE(4,MAX_EDGE), edge information. 
6906: !    EDGE(1,I) is the starting node of edge I; 
6907: !    EDGE(2,I) is the ending node of edge I; 
6908: !    EDGE(3,I) is the positive face; 
6909: !    EDGE(4,I) is the negative face, if any. 
6910: ! 
6911: !    Input, integer ( kind = 4 ) MAX_EDGE, the maximum number of edges. 
6912: ! 
6913: !    Input, integer ( kind = 4 ) NUM_EDGE, the number of edges. 
6914: ! 
6915:   implicit none 
6916:  
6917:   integer ( kind = 4 ) max_edge 
6918:  
6919:   integer ( kind = 4 ) edge(4,max_edge) 
6920:   integer ( kind = 4 ) iedge 
6921:   integer ( kind = 4 ) num_bound 
6922:   integer ( kind = 4 ) num_edge 
6923:  
6924:   num_bound = 0 
6925:  
6926:   do iedge = 1, num_edge 
6927:     if ( ( edge(3,iedge) /= 0 .and. edge(4,iedge) == 0 ) .or. & 
6928:          ( edge(3,iedge) == 0 .and. edge(4,iedge) /= 0 ) ) then 
6929:       num_bound = num_bound + 1 
6930:     end if 
6931:   end do 
6932:  
6933:   write ( *, '(a)' ) ' ' 
6934:   write ( *, '(a)' ) 'EDGE_BOUND' 
6935:   write ( *, '(a,i8)' ) '  Number of boundary edges = ', num_bound 
6936:  
6937:   return 
6938: end subroutine 
6939: subroutine edge_match_face ( edge, max_edge, num_edge, facelist, n, index ) 
6940:  
6941: !*****************************************************************************80 
6942: ! 
6943: !! EDGE_MATCH_FACE seeks an edge common to a face and the edge list. 
6944: ! 
6945: !  Discussion: 
6946: ! 
6947: !    If a common edge is found, then the information in the face node 
6948: !    list is adjusted so that the first two entries correspond to the 
6949: !    matching edge in EDGE, but in reverse order. 
6950: ! 
6951: !  Licensing: 
6952: ! 
6953: !    This code is distributed under the GNU LGPL license.  
6954: ! 
6955: !  Modified: 
6956: ! 
6957: !    12 October 1998 
6958: ! 
6959: !  Author: 
6960: ! 
6961: !    John Burkardt 
6962: ! 
6963: !  Parameters: 
6964: ! 
6965: !    Input, integer ( kind = 4 ) EDGE(4,MAX_EDGE), edge information. 
6966: !    EDGE(1,I) is the starting node of edge I; 
6967: !    EDGE(2,I) is the ending node of edge I; 
6968: !    EDGE(3,I) is the positive face; 
6969: !    EDGE(4,I) is the negative face, if any. 
6970: ! 
6971: !    Input, integer ( kind = 4 ) MAX_EDGE, the maximum number of edges. 
6972: ! 
6973: !    Input, integer ( kind = 4 ) NUM_EDGE, the number of edges. 
6974: ! 
6975: !    Input/output, integer ( kind = 4 ) FACELIST(N), the list of nodes making a 
6976: !    face. 
6977: ! 
6978: !    Input, integer ( kind = 4 ) N, the number of nodes in the face. 
6979: ! 
6980: !    Output, integer ( kind = 4 ) INDEX, the results of the search. 
6981: !    0, there is no edge common to the face and the EDGE array. 
6982: !    nonzero, edge INDEX is common to the face and the EDGE array. 
6983: ! 
6984:   implicit none 
6985:  
6986:   integer ( kind = 4 ) n 
6987:   integer ( kind = 4 ) max_edge 
6988:  
6989:   integer ( kind = 4 ) edge(4,max_edge) 
6990:   integer ( kind = 4 ) facelist(n) 
6991:   integer ( kind = 4 ) iedge 
6992:   integer ( kind = 4 ) index 
6993:   integer ( kind = 4 ) j 
6994:   integer ( kind = 4 ) jp1 
6995:   integer ( kind = 4 ) n1 
6996:   integer ( kind = 4 ) n2 
6997:   integer ( kind = 4 ) num_edge 
6998:  
6999:   index = 0 
7000:  
7001:   if ( n <= 0 ) then 
7002:     return 
7003:   end if 
7004:  
7005:   if ( num_edge <= 0 ) then 
7006:     return 
7007:   end if 
7008:  
7009:   do j = 1, n 
7010:  
7011:     if ( j == n ) then 
7012:       jp1 = 1 
7013:     else 
7014:       jp1 = j + 1 
7015:     end if 
7016:  
7017:     n1 = facelist(j) 
7018:     n2 = facelist(jp1) 
7019:  
7020:     do iedge = 1, num_edge 
7021:  
7022:       if ( edge(1,iedge) == n2 .and. edge(2,iedge) == n1 ) then 
7023:  
7024:         call i4vec_rotate ( n, 1 - j, facelist ) 
7025:  
7026:         index = iedge 
7027:         return 
7028:  
7029:       else if ( edge(1,iedge) == n1 .and. edge(2,iedge) == n2 ) then 
7030:  
7031:         call i4vec_rotate ( n, n - jp1, facelist ) 
7032:  
7033:         call i4vec_reverse ( n, facelist ) 
7034:  
7035:         index = iedge 
7036:         return 
7037:  
7038:       end if 
7039:  
7040:     end do 
7041:     
7042:   end do 
7043:  
7044:   return 
7045: end subroutine 
7046: subroutine edge_match_nodes ( edge, max_edge, num_edge, n1, n2, iedge ) 
7047:  
7048: !*****************************************************************************80 
7049: ! 
7050: !! EDGE_MATCH_NODES seeks an edge of the form (N1,N2) or (N2,N1) in EDGE. 
7051: ! 
7052: !  Licensing: 
7053: ! 
7054: !    This code is distributed under the GNU LGPL license.  
7055: ! 
7056: !  Modified: 
7057: ! 
7058: !    12 October 1998 
7059: ! 
7060: !  Author: 
7061: ! 
7062: !    John Burkardt 
7063: ! 
7064: !  Parameters: 
7065: ! 
7066: !    Input, integer ( kind = 4 ) EDGE(4,MAX_EDGE), edge information. 
7067: !    EDGE(1,I) is the starting node of edge I; 
7068: !    EDGE(2,I) is the ending node of edge I; 
7069: !    EDGE(3,I) is the positive face; 
7070: !    EDGE(4,I) is the negative face, if any. 
7071: ! 
7072: !    Input, integer ( kind = 4 ) MAX_EDGE, the maximum number of edges. 
7073: ! 
7074: !    Input, integer ( kind = 4 ) NUM_EDGE, the number of edges. 
7075: ! 
7076: !    Input, integer ( kind = 4 ) N1, N2, two nodes that form an edge. 
7077: ! 
7078: !    Output, integer ( kind = 4 ) IEDGE, the results of the search. 
7079: !    0, no matching edge was found. 
7080: !    nonzero, edge IEDGE of the EDGE array matches (N1,N2) or (N2,N1). 
7081: ! 
7082:   implicit none 
7083:  
7084:   integer ( kind = 4 ) max_edge 
7085:  
7086:   integer ( kind = 4 ) edge(4,max_edge) 
7087:   integer ( kind = 4 ) i 
7088:   integer ( kind = 4 ) iedge 
7089:   integer ( kind = 4 ) n1 
7090:   integer ( kind = 4 ) n2 
7091:   integer ( kind = 4 ) num_edge 
7092:  
7093:   iedge = 0 
7094:   do i = 1, num_edge 
7095:  
7096:     if ( ( n1 == edge(1,i) .and. n2 == edge(2,i) ) .or. & 
7097:          ( n2 == edge(1,i) .and. n1 == edge(2,i) ) ) then 
7098:       iedge = i 
7099:       return 
7100:     end if 
7101:  
7102:   end do 
7103:  
7104:   return 
7105: end subroutine 
7106: subroutine edges_to_ps ( plotxmin2, plotymin2, alpha, iunit, inode, jnode, & 
7107:   nedge, nnode, x, y, xmin, ymin ) 
7108:  
7109: !*****************************************************************************80 
7110: ! 
7111: !! EDGES_TO_PS writes subplot edges to a PostScript file. 
7112: ! 
7113: !  Licensing: 
7114: ! 
7115: !    This code is distributed under the GNU LGPL license.  
7116: ! 
7117: !  Modified: 
7118: ! 
7119: !    09 October 2000 
7120: ! 
7121: !  Author: 
7122: ! 
7123: !    John Burkardt 
7124: ! 
7125: !  Parameters: 
7126: ! 
7127: !    Input, integer ( kind = 4 ) PLOTXMIN2, PLOTYMIN2, the Postscript origin. 
7128: ! 
7129: !    Input, real ( kind = 8 ) ALPHA, the physical-to-Postscript scale factor. 
7130: ! 
7131: !    Input, integer ( kind = 4 ) IUNIT, the output FORTRAN unit. 
7132: ! 
7133: !    Input, integer ( kind = 4 ) INODE(NEDGE), JNODE(NEDGE), the edge array. 
7134: !    The I-th edge connects nodes INODE(I) and JNODE(I). 
7135: ! 
7136: !    Input, integer ( kind = 4 ) NEDGE, the number of edges. 
7137: ! 
7138: !    Input, integer ( kind = 4 ) NNODE, the number of nodes. 
7139: ! 
7140: !    Input, real ( kind = 8 ) X(NNODE), Y(NNODE), the X and Y components 
7141: !    of points. 
7142: ! 
7143: !    Input, real ( kind = 8 ) XMIN, YMIN, the physical origin. 
7144: ! 
7145:   implicit none 
7146:  
7147:   integer ( kind = 4 ) nedge 
7148:   integer ( kind = 4 ) nnode 
7149:  
7150:   real ( kind = 8 ) alpha 
7151:   integer ( kind = 4 ) i 
7152:   integer ( kind = 4 ) inode(nedge) 
7153:   integer ( kind = 4 ) iunit 
7154:   integer ( kind = 4 ) jnode(nedge) 
7155:   integer ( kind = 4 ) node 
7156:   integer ( kind = 4 ) plotxmin2 
7157:   integer ( kind = 4 ) plotymin2 
7158:   integer ( kind = 4 ) px1 
7159:   integer ( kind = 4 ) px2 
7160:   integer ( kind = 4 ) py1 
7161:   integer ( kind = 4 ) py2 
7162:   real ( kind = 8 ) x(nnode) 
7163:   real ( kind = 8 ) xmin 
7164:   real ( kind = 8 ) y(nnode) 
7165:   real ( kind = 8 ) ymin 
7166: ! 
7167: !  Draw lines. 
7168: ! 
7169:   do i = 1, nedge 
7170:  
7171:     node = inode(i) 
7172:     px1 = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) 
7173:     py1 = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) 
7174:  
7175:     node = jnode(i) 
7176:     px2 = plotxmin2 + nint ( alpha * ( x(node) - xmin ) ) 
7177:     py2 = plotymin2 + nint ( alpha * ( y(node) - ymin ) ) 
7178:  
7179:     write ( iunit, '(2i4,a,2i4,a)' ) px1, py1, ' moveto ', px2, py2, & 
7180:       ' lineto stroke' 
7181:  
7182:   end do 
7183:  
7184:   return 
7185: end subroutine 
7186: subroutine elmhes ( nm, n, low, igh, a, ind ) 
7187:  
7188: !*****************************************************************************80 
7189: ! 
7190: !! ELMHES transforms a real general matrix to upper Hessenberg form. 
7191: ! 
7192: !  Discussion: 
7193: ! 
7194: !    Given a real general matrix, this subroutine reduces a submatrix 
7195: !    situated in rows and columns LOW through IGH to upper Hessenberg 
7196: !    form by stabilized elementary similarity transformations. 
7197: ! 
7198: !  Reference: 
7199: ! 
7200: !    Martin, James Wilkinson, 
7201: !    ELMHES, 
7202: !    Numerische Mathematik, 
7203: !    Volume 12, pages 349-368, 1968. 
7204: ! 
7205: !    James Wilkinson, Christian Reinsch, 
7206: !    Handbook for Automatic Computation, 
7207: !    Volume II, Linear Algebra, Part 2, 
7208: !    Springer Verlag, 1971. 
7209: ! 
7210: !    Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,  
7211: !    Y Ikebe, V Klema, Cleve Moler, 
7212: !    Matrix Eigensystem Routines, EISPACK Guide, 
7213: !    Lecture Notes in Computer Science, Volume 6, 
7214: !    Springer Verlag, 1976. 
7215: ! 
7216: !  Parameters: 
7217: ! 
7218: !    Input, integer ( kind = 4 ) NM, the leading dimension of the array A. 
7219: !    NM must be at least N. 
7220: ! 
7221: !    Input, integer ( kind = 4 ) N, the order of the matrix. 
7222: ! 
7223: !    Input, integer ( kind = 4 ) LOW, IGH, are determined by the balancing 
7224: !    routine BALANC.  If BALANC has not been used, set LOW = 1, IGH = N. 
7225: ! 
7226: !    Input/output, real ( kind = 8 ) A(NM,N).  On input, the matrix to be 
7227: !    reduced.  On output, the Hessenberg matrix.  The multipliers 
7228: !    which were used in the reduction are stored in the 
7229: !    remaining triangle under the Hessenberg matrix. 
7230: ! 
7231: !    Output, integer ( kind = 4 ) IND(N), contains information on the rows and 
7232: !    columns interchanged in the reduction.  Only elements LOW through IGH are 
7233: !    used. 
7234: ! 
7235:   implicit none 
7236:  
7237:   integer ( kind = 4 ) igh 
7238:   integer ( kind = 4 ) n 
7239:   integer ( kind = 4 ) nm 
7240:  
7241:   real ( kind = 8 ) a(nm,n) 
7242:   integer ( kind = 4 ) i 
7243:   integer ( kind = 4 ) ind(igh) 
7244:   integer ( kind = 4 ) j 
7245:   integer ( kind = 4 ) la 
7246:   integer ( kind = 4 ) low 
7247:   integer ( kind = 4 ) m 
7248:   integer ( kind = 4 ) mm1 
7249:   real ( kind = 8 ) x 
7250:   real ( kind = 8 ) y 
7251:  
7252:   la = igh - 1 
7253:  
7254:   do m = low + 1, la 
7255:  
7256:     mm1 = m - 1 
7257:     x = 0.0D+00 
7258:     i = m 
7259:  
7260:     do j = m, igh 
7261:       if ( abs ( x ) < abs ( a(j,mm1) ) ) then 
7262:         x = a(j,mm1) 
7263:         i = j 
7264:       end if 
7265:     end do 
7266:  
7267:     ind(m) = i 
7268: ! 
7269: !  Interchange rows and columns of the matrix. 
7270: ! 
7271:     if ( i /= m ) then 
7272:  
7273:       do j = mm1, n 
7274:         call r8_swap ( a(i,j), a(m,j) ) 
7275:       end do 
7276:  
7277:       do j = 1, igh 
7278:         call r8_swap ( a(j,i), a(j,m) ) 
7279:       end do 
7280:  
7281:     end if 
7282:  
7283:     if ( x /= 0.0D+00 ) then 
7284:  
7285:       do i = m+1, igh 
7286:  
7287:         y = a(i,mm1) 
7288:  
7289:         if ( y /= 0.0D+00 ) then 
7290:  
7291:           y = y / x 
7292:           a(i,mm1) = y 
7293:  
7294:           do j = m, n 
7295:             a(i,j) = a(i,j) - y * a(m,j) 
7296:           end do 
7297:  
7298:           do j = 1, igh 
7299:             a(j,m) = a(j,m) + y * a(j,i) 
7300:           end do 
7301:  
7302:         end if 
7303:  
7304:       end do 
7305:  
7306:     end if 
7307:  
7308:   end do 
7309:  
7310:   return 
7311: end subroutine 
7312: subroutine face_check ( edge, face, face_object, face_order, face_rank, & 
7313:   face_tier, max_edge, max_order, num_edge, num_face, num_object ) 
7314:  
7315: !*****************************************************************************80 
7316: ! 
7317: !! FACE_CHECK checks and analyzes a set of faces. 
7318: ! 
7319: !  Licensing: 
7320: ! 
7321: !    This code is distributed under the GNU LGPL license.  
7322: ! 
7323: !  Modified: 
7324: ! 
7325: !    12 October 1998 
7326: ! 
7327: !  Author: 
7328: ! 
7329: !    John Burkardt 
7330: ! 
7331: !  Parameters: 
7332: ! 
7333: !    Output, integer ( kind = 4 ) EDGE(4,MAX_EDGE), edge information. 
7334: !    EDGE(1,I) is the starting node of edge I; 
7335: !    EDGE(2,I) is the ending node of edge I; 
7336: !    EDGE(3,I) is the positive face; 
7337: !    EDGE(4,I) is the negative face, or 0 if the edge is used once. 
7338: ! 
7339: !    Input, integer ( kind = 4 ) FACE(MAX_ORDER,NUM_FACE), describes the faces. 
7340: !    FACE(I,J) is the index of the I-th node in face J.  It is best 
7341: !    if the nodes of all faces are listed in counterclockwise order. 
7342: ! 
7343: !    Output, integer ( kind = 4 ) FACE_OBJECT(NUM_FACE), describes the objects. 
7344: !    FACE_OBJECT(I) is the index of the edge-connected "object" to  
7345: !    which face I belongs. 
7346: ! 
7347: !    Input, integer ( kind = 4 ) FACE_ORDER(NUM_FACE), is the number of nodes 
7348: !    making up each face. 
7349: ! 
7350: !    Output, integer ( kind = 4 ) FACE_RANK(NUM_FACE), is an ordered list of 
7351: !    faces.  FACE_RANK(1) is the index of the face in the first tier of the  
7352: !    first object, followed by second tier faces, and so on until 
7353: !    object one is complete.  Object two follows, and so on. 
7354: ! 
7355: !    Output, integer ( kind = 4 ) FACE_TIER(NUM_FACE).  FACE_TIER(I) is the 
7356: !    "tier" of face I in its object.  The seed of the object has tier 1, 
7357: !    the neighbors of the seed have tier 2, and so on. 
7358: ! 
7359: !    Input, integer ( kind = 4 ) MAX_EDGE, the maximum number of edges. 
7360: ! 
7361: !    Input, integer ( kind = 4 ) MAX_ORDER, is the maximum number of nodes that 
7362: !    can make up a face, required to dimension FACE. 
7363: ! 
7364: !    Output, integer ( kind = 4 ) NUM_EDGE, the number of edges. 
7365: ! 
7366: !    Input, integer ( kind = 4 ) NUM_FACE, the number of faces. 
7367: ! 
7368: !    Output, integer ( kind = 4 ) NUM_OBJECT, the number of objects. 
7369: ! 
7370:   implicit none 
7371:  
7372:   integer ( kind = 4 ) max_edge 
7373:   integer ( kind = 4 ) max_order 
7374:   integer ( kind = 4 ) num_face 
7375:  
7376:   integer ( kind = 4 ) edge(4,max_edge) 
7377:   integer ( kind = 4 ) face(max_order,num_face) 
7378:   integer ( kind = 4 ) face_object(num_face) 
7379:   integer ( kind = 4 ) face_order(num_face) 
7380:   integer ( kind = 4 ) face_rank(num_face) 
7381:   integer ( kind = 4 ) face_tier(num_face) 
7382:   integer ( kind = 4 ) i 
7383:   integer ( kind = 4 ) ierror 
7384:   integer ( kind = 4 ) j 
7385:   integer ( kind = 4 ) num_edge 
7386:   integer ( kind = 4 ) num_fix 
7387:   integer ( kind = 4 ) num_object 
7388: ! 
7389: !  Organize the faces into layered objects. 
7390: ! 
7391:   write ( *, '(a)' ) ' ' 
7392:   write ( *, '(a)' ) 'Determine edge-connected objects.' 
7393:  
7394:   call object_build ( face, face_object, face_order, face_rank, face_tier, & 
7395:     max_order, num_face, num_object ) 
7396:  
7397:   write ( *, '(a)' ) ' ' 
7398:   write ( *, '(a,i8)' ) 'Number of objects = ', num_object 
7399:   write ( *, '(a)' ) ' ' 
7400:   write ( *, '(a)' ) 'Face, Object, Tier' 
7401:   write ( *, '(a)' ) ' ' 
7402:  
7403:   do i = 1, num_face 
7404:     write ( *, '(3i8)' ) i, face_object(i), face_tier(i) 
7405:   end do 
7406:  
7407:   write ( *, '(a)' ) ' ' 
7408:   write ( *, '(a)' ) 'Preferred order:' 
7409:   write ( *, '(a)' ) '  Order, Face' 
7410:   write ( *, '(a)' ) ' ' 
7411:   do i = 1, num_face 
7412:     write ( *, '(2i8)' ) i, face_rank(i) 
7413:   end do 
7414: ! 
7415: !  Reorder the faces by object and tier. 
7416: ! 
7417:   write ( *, '(a)' ) ' ' 
7418:   write ( *, '(a)' ) 'Reorder the faces.' 
7419:  
7420:   call face_sort ( face, face_object, face_order, face_tier, max_order, & 
7421:     num_face ) 
7422:  
7423:   write ( *, '(a)' ) ' ' 
7424:   write ( *, '(a)' ) 'Face, Label, Object, Tier' 
7425:   write ( *, '(a)' ) ' ' 
7426:  
7427:   do i = 1, num_face 
7428:     write ( *, '(4i8)' ) i, face_rank(i), face_object(i), face_tier(i) 
7429:   end do 
7430: ! 
7431: !  Construct the edge list. 
7432: ! 
7433:   write ( *, '(a)' ) ' ' 
7434:   write ( *, '(a)' ) 'Construct the edge list.' 
7435:   write ( *, '(a)' ) '(While doing so, check for edges used more' 
7436:   write ( *, '(a)' ) 'than twice.)' 
7437:  
7438:   call face_to_edge ( edge, face, face_order, ierror, max_edge, max_order, & 
7439:     num_edge, num_face ) 
7440:  
7441:   if ( ierror /= 0 ) then 
7442:     write ( *, '(a)' ) ' ' 
7443:     write ( *, '(a)' ) 'FACE_CHECK - Fatal error!' 
7444:     write ( *, '(a)' ) '  FACE_TO_EDGE failed.' 
7445:     return 
7446:   end if 
7447:  
7448:   write ( *, '(a)' ) ' ' 
7449:   write ( *, '(a)' ) 'Edge, Node1, Node2, Face1, Face2, Tier, Object' 
7450:   write ( *, '(a)' ) ' ' 
7451:   write ( *, '(a)' ) ' I, node1(i), node2(i), face1(i), face2(i)' 
7452:   write ( *, '(a)' ) ' ' 
7453:  
7454:   do i = 1, num_edge 
7455:     write ( *, '(10i3)' ) i, ( edge(j,i), j = 1, 4 ) 
7456:   end do 
7457:  
7458:   write ( *, '(a)' ) ' ' 
7459:   write ( *, '(a)' ) 'Face, Order, Nodes' 
7460:   write ( *, '(a)' ) ' ' 
7461:   do i = 1, num_face 
7462:     write ( *, '(10i3)' ) i, face_order(i), ( face(j,i), j = 1, face_order(i) ) 
7463:   end do 
7464: ! 
7465: !  Now force faces to have a consistent orientation. 
7466: ! 
7467:   write ( *, '(a)' ) ' ' 
7468:   write ( *, '(a)' ) 'Force faces to consistent orientation.' 
7469:    
7470:   call face_flip ( edge, face, face_order, max_edge, max_order, num_edge, & 
7471:     num_face, num_fix ) 
7472:  
7473:   write ( *, '(a)' ) ' ' 
7474:   write ( *, '(a)' ) 'Face, Order, Nodes' 
7475:   write ( *, '(a)' ) ' ' 
7476:   do i = 1, num_face 
7477:     write ( *, '(10i3)' ) i, face_order(i), ( face(j,i), j = 1, face_order(i) ) 
7478:   end do 
7479:  
7480:   write ( *, '(a)' ) ' ' 
7481:   write ( *, '(a)' ) 'List boundary edges.' 
7482:  
7483:   call edge_bound ( edge, max_edge, num_edge ) 
7484:  
7485:   return 
7486: end subroutine 
7487: subroutine face_example_box ( face, face_order, max_face, max_order, num_face ) 
7488:  
7489: !*****************************************************************************80 
7490: ! 
7491: !! FACE_EXAMPLE_BOX returns the faces of a simple box. 
7492: ! 
7493: !  Diagram: 
7494: ! 
7495: !    1---------------------------4 
7496: !    |\                         /| 
7497: !    | \                       / | 
7498: !    |  \         1           /  | 
7499: !    |   \                   /   | 
7500: !    |    2-----------------3    | 
7501: !    |    |                 |    | 
7502: !    |    |                 |    | 
7503: !    |  3 |       4         | 5  | 
7504: !    |    |                 |    | 
7505: !    |    |                 |    | 
7506: !    |    6-----------------7    | 
7507: !    |   /                   \   | 
7508: !    |  /                     \  | 
7509: !    | /          2            \ | 
7510: !    |/                         \| 
7511: !    5---------------------------8 
7512: ! 
7513: !  Discussion: 
7514: ! 
7515: !    This routine is used to supply some very simple data for the  
7516: !    face checking routines. 
7517: ! 
7518: !    This is "almost" a cube, except that one face is missing. 
7519: ! 
7520: !  Licensing: 
7521: ! 
7522: !    This code is distributed under the GNU LGPL license.  
7523: ! 
7524: !  Modified: 
7525: ! 
7526: !    06 October 1998 
7527: ! 
7528: !  Author: 
7529: ! 
7530: !    John Burkardt 
7531: ! 
7532: !  Parameters: 
7533: ! 
7534: !    Output, integer ( kind = 4 ) FACE(MAX_ORDER,NUM_FACE), describes the faces. 
7535: !    FACE(I,J) is the index of the I-th node in face J.  It is best 
7536: !    if the nodes of all faces are listed in counterclockwise order. 
7537: ! 
7538: !    Output, integer ( kind = 4 ) FACE_ORDER(NUM_FACE), is the number of nodes 
7539: !    making up each face. 
7540: ! 
7541: !    Input, integer ( kind = 4 ) MAX_FACE, the maximum number of faces allowed. 
7542: ! 
7543: !    Input, integer ( kind = 4 ) MAX_ORDER, is the maximum number of nodes that 
7544: !    can make up a face, required to dimension FACE. 
7545: ! 
7546: !    Output, integer ( kind = 4 ) NUM_FACE, the number of faces. 
7547: ! 
7548:   implicit none 
7549:  
7550:   integer ( kind = 4 ) max_order 
7551:   integer ( kind = 4 ) max_face 
7552:  
7553:   integer ( kind = 4 ) face(max_order,max_face) 
7554:   integer ( kind = 4 ) face_order(max_face) 
7555:   integer ( kind = 4 ) num_face 
7556:  
7557:   num_face = 5 
7558:  
7559:   if ( max_face < num_face ) then 
7560:     write ( *, '(a)' ) ' ' 
7561:     write ( *, '(a)' ) 'FACE_EXAMPLE_OPEN_BOX - Fatal error!' 
7562:     write ( *, '(a,i8)' ) '  Increase MAX_FACE to ', num_face 
7563:     stop 
7564:   end if 
7565:  
7566:   face(1,1) = 1 
7567:   face(2,1) = 2 
7568:   face(3,1) = 3 
7569:   face(4,1) = 4 
7570:  
7571:   face(1,2) = 5 
7572:   face(2,2) = 6 
7573:   face(3,2) = 7 
7574:   face(4,2) = 8 
7575:  
7576:   face(1,3) = 1 
7577:   face(2,3) = 2 
7578:   face(3,3) = 6 
7579:   face(4,3) = 5 
7580:  
7581:   face(1,4) = 6 
7582:   face(2,4) = 7 
7583:   face(3,4) = 3 
7584:   face(4,4) = 2 
7585:  
7586:   face(1,5) = 3 
7587:   face(2,5) = 4 
7588:   face(3,5) = 8 
7589:   face(4,5) = 7 
7590:  
7591:   face_order(1:num_face) = 4 
7592:  
7593:   return 
7594: end subroutine 
7595: subroutine face_example_pieces ( face, face_order, max_face, max_order, & 
7596:   num_face ) 
7597:  
7598: !*****************************************************************************80 
7599: ! 
7600: !! FACE_EXAMPLE_PIECES returns the faces of a set of three objects. 
7601: ! 
7602: !  Diagram: 
7603: ! 
7604: !    1---------------------------4 
7605: !    |\                         /| 
7606: !    | \                       / |       9--------10 
7607: !    |  \        7            /  |       |         | 
7608: !    |   \                   /   |       |   1     | 
7609: !    |    2-----------------3    |       |         | 
7610: !    |    |                 |    |       |         | 
7611: !    |    |                 |    |       11-------12 
7612: !    |  3 |       4         | 5  |        \       / 
7613: !    |    |                 |    |         \  6  / 
7614: !    |    |                 |    |          \   / 
7615: !    |    6-----------------7    |           \ / 
7616: !    |   /                   \   |           13 
7617: !    |  /                     \  |           / \ 
7618: !    | /          8            \ |          /   \ 
7619: !    |/                         \|         /  2  \ 
7620: !    5---------------------------8        /       \ 
7621: !                                        14-------15 
7622: ! 
7623: !  Discussion: 
7624: ! 
7625: !    THREE_PIECE is used to supply some very simple data for the  
7626: !    face checking routines. 
7627: ! 
7628: !  Licensing: 
7629: ! 
7630: !    This code is distributed under the GNU LGPL license.  
7631: ! 
7632: !  Modified: 
7633: ! 
7634: !    06 October 1998 
7635: ! 
7636: !  Author: 
7637: ! 
7638: !    John Burkardt 
7639: ! 
7640: !  Parameters: 
7641: ! 
7642: !    Output, integer ( kind = 4 ) FACE(MAX_ORDER,MAX_FACE), describes the faces. 
7643: !    FACE(I,J) is the index of the I-th node in face J.  It is best 
7644: !    if the nodes of all faces are listed in counterclockwise order. 
7645: ! 
7646: !    Output, integer ( kind = 4 ) FACE_ORDER(MAX_FACE), is the number of nodes 
7647: !    making up each face. 
7648: ! 
7649: !    Input, integer ( kind = 4 ) MAX_FACE, the maximum number of faces allowed. 
7650: ! 
7651: !    Input, integer ( kind = 4 ) MAX_ORDER, is the maximum number of nodes that 
7652: !    can make up a face, required to dimension FACE. 
7653: ! 
7654: !    Output, integer ( kind = 4 ) NUM_FACE, the number of faces. 
7655: ! 
7656:   implicit none 
7657:  
7658:   integer ( kind = 4 ) max_order 
7659:   integer ( kind = 4 ) max_face 
7660:  
7661:   integer ( kind = 4 ) face(max_order,max_face) 
7662:   integer ( kind = 4 ) face_order(max_face) 
7663:   integer ( kind = 4 ) num_face 
7664:  
7665:   num_face = 8 
7666:  
7667:   if ( max_face < num_face ) then 
7668:     write ( *, '(a)' ) ' ' 
7669:     write ( *, '(a)' ) 'FACE_EXAMPLE_PIECES - Fatal error!' 
7670:     write ( *, '(a)' ) '  MAX_FACE < NUM_FACE!' 
7671:     write ( *, '(a,i8)' ) '  NUM_FACE = ', num_face 
7672:     write ( *, '(a,i8)' ) '  MAX_FACE = ', max_face 
7673:     stop 
7674:   end if 
7675:  
7676:   face(1,1) = 9 
7677:   face(2,1) = 10 
7678:   face(3,1) = 12 
7679:   face(4,1) = 11 
7680:  
7681:   face(1,2) = 14 
7682:   face(2,2) = 13 
7683:   face(3,2) = 15 
7684:  
7685:   face(1,3) = 1 
7686:   face(2,3) = 2 
7687:   face(3,3) = 6 
7688:   face(4,3) = 5 
7689:  
7690:   face(1,4) = 6 
7691:   face(2,4) = 7 
7692:   face(3,4) = 3 
7693:   face(4,4) = 2 
7694:  
7695:   face(1,5) = 3 
7696:   face(2,5) = 4 
7697:   face(3,5) = 8 
7698:   face(4,5) = 7 
7699:  
7700:   face(1,6) = 13 
7701:   face(2,6) = 12 
7702:   face(3,6) = 11 
7703:  
7704:   face(1,7) = 1 
7705:   face(2,7) = 2 
7706:   face(3,7) = 3 
7707:   face(4,7) = 4 
7708:  
7709:   face(1,8) = 5 
7710:   face(2,8) = 6 
7711:   face(3,8) = 7 
7712:   face(4,8) = 8 
7713:  
7714:   face_order(1) = 4 
7715:   face_order(2) = 3 
7716:   face_order(3) = 4 
7717:   face_order(4) = 4 
7718:   face_order(5) = 4 
7719:   face_order(6) = 3 
7720:   face_order(7) = 4 
7721:   face_order(8) = 4 
7722:  
7723:   return 
7724: end subroutine 
7725: subroutine face_flip ( edge, face, face_order, max_edge, max_order, & 
7726:   num_edge, num_face, num_fix ) 
7727:  
7728: !*****************************************************************************80 
7729: ! 
7730: !! FACE_FLIP flips faces to achieve a consistent orientation. 
7731: ! 
7732: !  Licensing: 
7733: ! 
7734: !    This code is distributed under the GNU LGPL license.  
7735: ! 
7736: !  Modified: 
7737: ! 
7738: !    12 October 1998 
7739: ! 
7740: !  Author: 
7741: ! 
7742: !    John Burkardt 
7743: ! 
7744: !  Parameters: 
7745: ! 
7746: !    Input, integer ( kind = 4 ) EDGE(4,MAX_EDGE), edge information. 
7747: !    EDGE(1,I) is the starting node of edge I; 
7748: !    EDGE(2,I) is the ending node of edge I; 
7749: !    EDGE(3,I) is the positive face; 
7750: !    EDGE(4,I) is the negative face, if any. 
7751: ! 
7752: !    Input, integer ( kind = 4 ) FACE(MAX_ORDE