subroutine asm_enum ( n, asm_num ) ! !******************************************************************************* ! !! ASM_ENUM returns the number of alternating sign matrices of a given order. ! ! ! Discussion: ! ! N ASM_NUM ! ! 0 1 ! 1 1 ! 2 2 ! 3 7 ! 4 42 ! 5 429 ! 6 7436 ! 7 218348 ! ! A direct formula is ! ! ASM_NUM ( N ) = product ( 0 <= I <= N-1 ) ( 3 * I + 1 )! / ( N + I )! ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the matrices. ! ! Output, integer ASM_NUM, the number of alternating sign matrices of ! order N. ! implicit none ! integer n ! integer a(n+1) integer asm_num integer b(n+1) integer c(n+1) integer i integer nn ! asm_num = 0 nn = n + 1 if ( n+1 <= 0 ) then return end if ! ! Row 1 ! a(1) = 1 if ( n+1 == 1 ) then asm_num = a(1) return end if ! ! Row 2 ! a(1) = 1 if ( n+1 == 2 ) then asm_num = a(1) return end if b(1) = 2 c(1) = 2 a(2) = 1 ! ! Row 3 and on. ! do nn = 3, n b(nn-1) = nn do i = nn-2, 2, -1 b(i) = b(i) + b(i-1) end do b(1) = 2 c(nn-1) = 2 do i = nn-2, 2, -1 c(i) = c(i) + c(i-1) end do c(1) = nn a(1) = sum ( a(1:nn-1) ) do i = 2, nn a(i) = a(i-1) * c(i-1) / b(i-1) end do end do asm_num = sum ( a(1:n) ) return end subroutine asm_triangle ( n, a ) ! !******************************************************************************* ! !! ASM_TRIANGLE returns a row of the alternating sign matrix triangle. ! ! ! Discussion: ! ! The first seven rows of the triangle are as follows: ! ! 1 2 3 4 5 6 7 ! ! 1 1 ! 2 1 1 ! 3 2 3 2 ! 4 7 14 14 7 ! 5 42 105 135 105 42 ! 6 429 1287 2002 2002 1287 429 ! 7 7436 26026 47320 56784 47320 26026 7436 ! ! For a given N, the value of A(J) represents entry A(I,J) of ! the triangular matrix, and gives the number of alternating sign matrices ! of order N in which the (unique) 1 in row 1 occurs in column J. ! ! Thus, of alternating sign matrices of order 3, there are ! 2 with a leading 1 in column 1: ! ! 1 0 0 1 0 0 ! 0 1 0 0 0 1 ! 0 0 1 0 1 0 ! ! 3 with a leading 1 in column 2, and ! ! 0 1 0 0 1 0 0 1 0 ! 1 0 0 0 0 1 1-1 1 ! 0 0 1 1 0 0 0 1 0 ! ! 2 with a leading 1 in column 3: ! ! 0 0 1 0 0 1 ! 1 0 0 0 1 0 ! 0 1 0 1 0 0 ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the desired row. ! ! Output, integer A(N), the entries of the row. ! implicit none ! integer n ! integer a(n) integer b(n) integer c(n) integer i integer nn ! if ( n <= 0 ) then return end if ! ! Row 1 ! a(1) = 1 if ( n == 1 ) then return end if ! ! Row 2 ! nn = 2 b(1) = 2 c(1) = nn a(1) = sum ( a(1:nn-1) ) do i = 2, nn a(i) = a(i-1) * c(i-1) / b(i-1) end do if ( n == 2 ) then return end if ! ! Row 3 and on. ! do nn = 3, n b(nn-1) = nn do i = nn-2, 2, -1 b(i) = b(i) + b(i-1) end do b(1) = 2 c(nn-1) = 2 do i = nn-2, 2, -1 c(i) = c(i) + c(i-1) end do c(1) = nn a(1) = sum ( a(1:nn-1) ) do i = 2, nn a(i) = a(i-1) * c(i-1) / b(i-1) end do end do return end subroutine bell ( b, n ) ! !******************************************************************************* ! !! BELL returns the Bell numbers from 0 to N. ! ! ! Discussion: ! ! The Bell number B(N) is the number of restricted growth functions ! on N. ! ! Note that the Stirling numbers of the second kind, S^m_n, count the ! number of partitions of N objects into M classes, and so it is ! true that ! ! B(N) = S^1_N + S^2_N + ... + S^N_N. ! ! Definition: ! ! The Bell number B(N) is defined as the number of partitions (of ! any size) of a set of N distinguishable objects. ! ! A partition of a set is a division of the objects of the set into ! subsets. ! ! Examples: ! ! There are 15 partitions of a set of 4 objects: ! ! (1234), (123)(4), (124)(3), (12)(34), (12)(3)(4), ! (134)(2), (13)(24), (13)(2)(4), (14)(23), (1)(234), ! (1)(23)(4), (14)(2)(3), (1)(24)(3), (1)(2)(34), (1)(2)(3)(4) ! ! and so B(4) = 15. ! ! First values: ! ! N B(N) ! 0 1 ! 1 1 ! 2 2 ! 3 5 ! 4 15 ! 5 52 ! 6 203 ! 7 877 ! 8 4140 ! 9 21147 ! 10 115975 ! ! Recursion: ! ! B(I) = sum ( 1 <= J <= I ) Binomial ( I-1, J-1 ) * B(I-J) ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer B(0:N), the Bell numbers from 0 to N. ! ! Input, integer N, the number of Bell numbers desired. ! implicit none ! integer n ! integer b(0:n) integer combo integer i integer j ! b(0) = 1 do i = 1, n b(i) = 0 do j = 1, i call combin2 ( i-1, j-1, combo ) b(i) = b(i) + combo * b(i-j) end do end do return end subroutine catalan ( n, c ) ! !******************************************************************************* ! !! CATALAN computes the Catalan numbers, from C(0) to C(N). ! ! ! First values: ! ! C(0) 1 ! C(1) 1 ! C(2) 2 ! C(3) 5 ! C(4) 14 ! C(5) 42 ! C(6) 132 ! C(7) 429 ! C(8) 1430 ! C(9) 4862 ! C(10) 16796 ! ! Formula: ! ! C(N) = (2*N)! / ( (N+1) * (N!) * (N!) ) ! = 1 / (N+1) * COMB ( 2N, N ) ! = 1 / (2N+1) * COMB ( 2N+1, N+1). ! ! Recursion: ! ! C(N) = 2 * (2*N-1) * C(N-1) / (N+1) ! C(N) = sum ( 1 <= I <= N-1 ) C(I) * C(N-I) ! ! Comments: ! ! The Catalan number C(N) counts: ! ! 1) the number of binary trees on N vertices; ! 2) the number of ordered trees on N+1 vertices; ! 3) the number of full binary trees on 2N+1 vertices; ! 4) the number of well formed sequences of 2N parentheses; ! 5) number of ways 2N ballots can be counted, in order, ! with N positive and N negative, so that the running sum ! is never negative; ! 6) the number of standard tableaus in a 2 by N rectangular Ferrers diagram; ! 7) the number of monotone functions from [1..N} to [1..N} which ! satisfy f(i) <= i for all i; ! 8) the number of ways to triangulate a polygon with N+2 vertices. ! ! Example: ! ! N = 3 ! ! ()()() ! ()(()) ! (()()) ! (())() ! ((())) ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 14 August 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of Catalan numbers desired. ! ! Output, integer C(0:N), the Catalan numbers from C(0) to C(N). ! implicit none ! integer n ! integer c(0:n) integer i ! c(0) = 1 ! ! The extra parentheses ensure that the integer division is ! done AFTER the integer multiplication. ! do i = 1, n c(i) = ( c(i-1) * 2 * ( 2 * i - 1 ) ) / ( i + 1 ) end do return end subroutine cfrac_to_rat ( a, n, p, q ) ! !******************************************************************************* ! !! CFRAC_TO_RAT converts a monic continued fraction to an ordinary fraction. ! ! ! Discussion: ! ! The routine is given the monic or "simple" continued fraction with ! integer coefficients: ! ! A(1) + 1 / ( A(2) + 1 / ( A(3) ... + 1 / A(N) ) ) ! ! and returns the N successive approximants P(I)/Q(I) ! to the value of the rational number represented by the continued ! fraction, with the value exactly equal to the final ratio P(N)/Q(N). ! ! Reference: ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Modified: ! ! 01 October 2000 ! ! Parameters: ! ! Input, integer A(N), the continued fraction coefficients. ! ! Input, integer N, the number of continued fraction coefficients. ! ! Output, integer P(N), Q(N), the N successive approximations ! to the value of the continued fraction. ! implicit none ! integer n ! integer a(n) integer i integer p(n) integer q(n) ! do i = 1, n if ( i == 1 ) then p(i) = a(i) * 1 + 0 q(i) = a(i) * 0 + 1 else if ( i == 2 ) then p(i) = a(i) * p(i-1) + 1 q(i) = a(i) * q(i-1) + 0 else p(i) = a(i) * p(i-1) + p(i-2) q(i) = a(i) * q(i-1) + q(i-2) end if end do return end subroutine cfrac_to_rfrac ( g, h, m, p, q ) ! !******************************************************************************* ! !! CFRAC_TO_RFRAC converts a polynomial fraction from continued to rational form. ! ! ! Discussion: ! ! The routine accepts a continued polynomial fraction: ! ! G(1) / ( H(1) + ! G(2) * X / ( H(2) + ! G(3) * X / ( H(3) + ... ! G(M) * X / ( H(M) )...) ) ) ! ! and returns the equivalent rational polynomial fraction: ! ! P(1) + P(2) * X + ... + P(L1) * X**(L1) ! ------------------------------------------------------- ! Q(1) + Q(2) * X + ... + Q(L2) * X**(L2-1) ! ! where ! ! L1 = (M+1)/2 ! L2 = (M+2)/2. ! ! Reference: ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Modified: ! ! 17 April 2000 ! ! Parameters: ! ! Input, real G(M), H(M), the continued polynomial fraction coefficients. ! ! Input, integer M, the number of continued fraction polynomial coefficients. ! ! Output, real P((M+1)/2), Q((M+2)/2), the rational polynomial fraction ! coefficients. ! implicit none ! integer m ! real a(m,(m+2)/2) real g(m) real h(m) integer i integer j real p((m+1)/2) real q((m+2)/2) ! if ( m == 1 ) then p(1) = g(1) q(1) = h(1) return end if do i = 1, m do j = 1, (m+2)/2 a(i,j) = 0.0E+00 end do end do ! ! Solve for P's ! a(1,1) = g(1) a(2,1) = g(1) * h(2) do i = 3, m a(i,1) = h(i) * a(i-1,1) do j = 2, (i+1)/2 a(i,j) = h(i) * a(i-1,j) + g(i) * a(i-2,j-1) end do end do do i = 1, (m+1)/2 p(i) = a(m,i) end do a(1,1) = h(1) a(2,1) = h(1) * h(2) a(2,2) = g(2) do i = 3, m a(i,1) = h(i) * a(i-1,1) do j = 2, (i+2) / 2 a(i,j) = h(i) * a(i-1,j) + g(i) * a(i-2,j-1) end do end do do i = 1, (m+2)/2 q(i) = a(m,i) end do return end subroutine ch_cap ( c ) ! !******************************************************************************* ! !! CH_CAP capitalizes a single character. ! ! ! Modified: ! ! 19 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character C, the character to capitalize. ! implicit none ! character c integer itemp ! itemp = ichar ( c ) if ( 97 <= itemp .and. itemp <= 122 ) then c = char ( itemp - 32 ) end if return end subroutine chinese_check ( n, m, ierror ) ! !******************************************************************************* ! !! CHINESE_CHECK checks the Chinese remainder moduluses. ! ! ! Discussion: ! ! For a Chinese remainder representation, the moduluses M(I) must ! be positive and pairwise prime. Also, in case this is not obvious, ! no more than one of the moduluses may be 1. ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of moduluses. ! ! Input, integer M(N), the moduluses. These should be positive ! and pairwise prime. ! ! Output, integer IERROR, an error flag. ! 0, no error was detected. ! nonzero, an error was detected. ! implicit none ! integer n ! integer i integer ierror logical ivec_pairwise_prime integer j integer m(n) ! ierror = 0 ! ! Do not allow nonpositive entries. ! if ( any ( m(1:n) <= 0 ) ) then ierror = 1 return end if ! ! Allow one entry to be 1, but not two entries. ! do i = 1, n do j = i+1, n if ( m(i) == 1 .and. m(j) == 1 ) then ierror = 2 return end if end do end do ! ! Now check pairwise primeness. ! if ( .not. ivec_pairwise_prime ( n, m ) ) then ierror = 3 return end if return end subroutine chinese_to_i ( n, m, r, j ) ! !******************************************************************************* ! !! CHINESE_TO_I converts a set of Chinese remainders to an equivalent integer. ! ! ! Discussion: ! ! Given a set of N pairwise prime, positive moduluses M(I), and ! a corresponding set of remainders M(I), this routine finds an ! integer J such that, for all I, ! ! J = R(I) mod M(I) ! ! Modified: ! ! 10 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of moduluses. ! ! Input, integer M(N), the moduluses. These should be positive ! and pairwise prime. ! ! Input, integer R(N), the Chinese remainder representation of the integer. ! ! Output, integer J, the corresponding integer. ! implicit none ! integer n ! integer a integer b(n) integer big_m integer c integer i integer ierror integer j integer m(n) integer r(n) ! call chinese_check ( n, m, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHINESE_TO_I - Fatal error!' write ( *, '(a)' ) ' The moduluses are not legal.' stop end if ! ! Set BIG_M. ! big_m = product ( m ) ! ! Solve BIG_M / M(I) * B(I) = 1, mod M(I) ! do i = 1, n a = big_m / m(i) c = 1 call congruence ( a, m(i), c, ierror, b(i) ) end do ! ! Set J = sum ( 1 <= I <= N ) ( R(I) * B(I) * BIG_M / M(I) ) mod M ! j = 0 do i = 1, n j = mod ( j + r(i) * b(i) * ( big_m / m(i) ), big_m ) end do return end subroutine comb ( m, n, l, iarray ) ! !******************************************************************************* ! !! COMB returns the L-th combination of N things out of M. ! ! ! Discussion: ! ! The combinations are ordered lexically. ! ! Lexical order can be illustrated for the general case of N and M as ! follows: ! ! 1: 1, 2, 3, ..., N-2, N-1, N ! 2: 1, 2, 3, ..., N-2, N-1, N+1 ! 3: 1, 2, 3, ..., N-2, N-1, N+2 ! ... ! M-N+1: 1, 2, 3, ..., N-2, N-1, M ! M-N+2: 1, 2, 3, ..., N-2, N, N+1 ! M-N+3: 1, 2, 3, ..., N-2, N, N+2 ! ... ! LAST-2: M-N, M-N+1, M-N+3, ..., M-2, M-1, M ! LAST-1: M-N, M-N+2, M-N+3, ..., M-2, M-1, M ! LAST: M-N+1, M-N+2, M-N+3, ..., M-2, M-1, M ! ! There are a total of M!/(N!*(M-N)!) combinations of M ! things taken N at a time. ! ! Reference: ! ! B P Buckles and M Lybanon, ! Algorithm 515, ! Generation of a Vector from the Lexicographical Index, ! ACM Transactions on Mathematical Software, ! Volume 3, Number 2, pages 180-182, June 1977. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer M, the size of the set. ! ! Input, integer N, the number of things in the combination. ! N must be greater than 0, and no greater than M. ! ! Input, integer L, the lexicographical index of combination ! sought. L must be at least 1, and no greater than M!/(N!*(M-N)!). ! ! Output, integer IARRAY(N), array containing the combination set. ! implicit none ! integer n ! integer i integer iarray(n) integer j integer k integer l integer m ! ! Initialize lower bound index at zero. ! k = 0 ! ! Loop to select elements in ascending order. ! do i = 1, n - 1 ! ! Set lower bound element number for next element value. ! iarray(i) = 0 if ( i /= 1 ) then iarray(i) = iarray(i-1) end if ! ! Check each element value. ! do iarray(i) = iarray(i) + 1 call combin2 ( m-iarray(i), n-i, j ) k = k + j if ( k >= l ) then exit end if end do k = k - j end do iarray(n) = iarray(n-1) + l - k return end subroutine comb_next ( done, n, k, iarray ) ! !******************************************************************************* ! !! COMB_NEXT computes combinations of K things out of N. ! ! ! Discussion: ! ! The combinations are computed one at a time, in lexicographical order. ! ! Reference: ! ! Charles Mifsud, ! Combination in Lexicographic Order, ! ACM algorithm 154, ! March 1963. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input/output, logical DONE, indicator. ! On input, if this is the first call, the user should set ! DONE to FALSE. On each subsequent call, the value of ! DONE should be left at its output value from the previous ! call. ! ! On output, if DONE is TRUE, then a new combination was ! computed and returned. If DONE is FALSE, then the list ! of combinations was finished on the previous call. ! ! Input, integer N, the total number of things. ! ! Input, integer K, the number of things in each combination. ! ! Output, integer IARRAY(K), contains the list of elements in ! the current combination. ! implicit none ! integer k ! logical done integer i integer iarray(k) integer j integer n ! if ( done ) then call ivec_identity ( k, iarray ) if ( k > 1 ) then done = .false. else done = .true. end if else if ( iarray(k) < n ) then iarray(k) = iarray(k) + 1 return end if do i = k, 2, -1 if ( iarray(i-1) < n-k+i-1 ) then iarray(i-1) = iarray(i-1) + 1 do j = i, k iarray(j) = iarray(i-1) + j - ( i-1 ) end do return end if end do done = .true. end if return end subroutine comb_row ( ido, n, irow ) ! !******************************************************************************* ! !! COMB_ROW computes a row of the combinatorial coefficients. ! ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IDO, startup information. ! ! 0, build up the table from scratch. ! 1, N = 0, or IROW contains the previous row of combinatorial coefficients. ! ! Input, integer N, the desired row. N must be 0 or greater. ! ! Output, integer IROW(N+1), the combinatorial coefficients. ! implicit none ! integer n ! integer i integer ido integer irow(n+1) integer k ! if ( n < 0 ) then return end if if ( ido == 1 ) then do i = n, 2, -1 irow(i) = irow(i) + irow(i-1) end do irow(n+1) = 1 else irow(1) = 1 irow(2:n+1) = 0 do k = 1, n do i = k+1, 2, -1 irow(i) = irow(i) + irow(i-1) end do end do end if return end subroutine combin ( n, k, cnk ) ! !******************************************************************************* ! !! COMBIN computes the combinatorial coefficient C(N,K). ! ! ! Method: ! ! Real arithmetic is used, and C(N,K) is computed directly, via ! Gamma functions, rather than recursively. ! ! Definition: ! ! C(N,K) is the number of distinct combinations of K objects ! chosen from a set of N distinct objects. A combination is ! like a set, in that order does not matter. ! ! Examples: ! ! The number of combinations of 2 things chosen from 5 is 10. ! ! C(5,2) = ( 5 * 4 * 3 * 2 * 1 ) / ( ( 3 * 2 * 1 ) * ( 2 * 1 ) ) = 10. ! ! The actual combinations may be represented as: ! ! (1,2), (1,3), (1,4), (1,5), (2,3), ! (2,4), (2,5), (3,4), (3,5), (4,5). ! ! Formula: ! ! C(N,K) = N! / ( (N-K)! * K! ) ! ! Modified: ! ! 16 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the value of N. ! ! Input, integer K, the value of K. ! ! Output, real CNK, the value of C(N,K) ! implicit none ! real arg real cnk real fack real facn real facnmk real gamma_log integer k integer n ! if ( n < 0 ) then cnk = 0.0E+00 else if ( k == 0 ) then cnk = 1.0E+00 else if ( k == 1 ) then cnk = real ( n ) else if ( k > 1 .and. k < n-1 ) then arg = real ( n + 1 ) facn = gamma_log ( arg ) arg = real ( k + 1 ) fack = gamma_log ( arg ) arg = real ( n - k + 1 ) facnmk = gamma_log ( arg ) cnk = anint ( exp ( facn - fack - facnmk ) ) else if ( k == n-1 ) then cnk = real ( n ) else if ( k == n ) then cnk = 1.0E+00 else cnk = 0.0E+00 end if return end subroutine combin2 ( n, k, icnk ) ! !******************************************************************************* ! !! COMBIN2 computes the binomial coefficient C(N,K). ! ! ! Discussion: ! ! The value is calculated in such a way as to avoid overflow and ! roundoff. The calculation is done in integer arithmetic. ! ! Formula: ! ! ICNK = C(N,K) = N! / ( K! * (N-K)! ) ! ! Reference: ! ! M L Wolfson and H V Wright, ! Combinatorial of M Things Taken N at a Time, ! ACM algorithm 160, ! Communications of the ACM, ! April, 1963. ! ! Modified: ! ! 17 January 1999 ! ! Parameters: ! ! Input, integer N, K, are the values of N and K. ! ! Output, integer ICNK, the number of combinations of N ! things taken K at a time. ! implicit none ! integer i integer icnk integer k integer mn integer mx integer n ! mn = min ( k, n-k ) if ( mn < 0 ) then icnk = 0 else if ( mn == 0 ) then icnk = 1 else mx = max ( k, n-k ) icnk = mx + 1 do i = 2, mn icnk = ( icnk * ( mx + i ) ) / i end do end if return end subroutine comp_next ( n, k, iarray, more ) ! !******************************************************************************* ! !! COMP_NEXT computes the compositions of the integer N into K parts. ! ! ! Discussion: ! ! The routine computes one composition on each call until there are no more. ! For instance, one composition of 6 into 3 parts is ! 3+2+1, another would be 6+0+0. ! ! Example: ! ! The 28 compositions of 6 into three parts are: ! ! 6 0 0, 5 1 0, 5 0 1, 4 2 0, 4 1 1, 4 0 2, ! 3 3 0, 3 2 1, 3 1 2, 3 0 3, 2 4 0, 2 3 1, ! 2 2 2, 2 1 3, 2 0 4, 1 5 0, 1 4 1, 1 3 2, ! 1 2 3, 1 1 4, 1 0 5, 0 6 0, 0 5 1, 0 4 2, ! 0 3 3, 0 2 4, 0 1 5, 0 0 6. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the integer whose compositions are desired. ! ! Input, integer K, the number of parts in the composition. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th part of ! the composition. ! ! Input/output, logical MORE. ! Set MORE = .FALSE. on first call. It will be reset to .TRUE. on return ! with a new composition. Each new call returns another composition until ! MORE is set to .FALSE. when the last composition has been computed ! and returned. ! implicit none ! integer k ! integer i integer iarray(k) integer, save :: ih = 0 integer, save :: it = 0 logical more integer n ! if ( .not. more ) then it = n ih = 0 iarray(1) = n iarray(2:k) = 0 else if ( it > 1 ) then ih = 0 end if ih = ih + 1 it = iarray(ih) iarray(ih) = 0 iarray(1) = it - 1 iarray(ih+1) = iarray(ih+1) + 1 end if more = iarray(k) /= n return end subroutine comp_random ( n, k, iarray ) ! !******************************************************************************* ! !! COMP_RANDOM selects a random composition of the integer N into K parts. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the integer to be decomposed. ! ! Input, integer K, the number of parts in the composition. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th part of the ! composition. ! implicit none ! integer k ! integer i integer iarray(k) integer l integer m integer n ! call ksub_random ( n+k-1, k-1, iarray ) iarray(k) = n + k l = 0 do i = 1, k m = iarray(i) iarray(i) = iarray(i) - l - 1 l = m end do return end subroutine congruence ( a, b, c, ierror, x ) ! !******************************************************************************* ! !! CONGRUENCE solves a congruence of the form A * X = C mod ( B ). ! ! ! Discussion: ! ! A, B and C are given integers. The equation is solvable if and only ! if the greatest common divisor of A and B also divides C. ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998, page 446. ! ! Modified: ! ! 09 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, C, the coefficients of the Diophantine equation. ! ! Output, integer IERROR, error flag. ! 0, no error, X was computed. ! 1, A = B = 0, C is nonzero. ! 2, A = 0, B and C nonzero, but C is not a multiple of B. ! 3, A nonzero, B zero, C nonzero, but C is not a multiple of A. ! 4, A, B, C nonzero, but GCD of A and B does not divide C. ! 5, algorithm ran out of internal space. ! ! Output, integer X, the solution of the Diophantine equation. ! X will be between 0 and B-1. ! implicit none ! integer, parameter :: nmax = 100 ! integer a integer a_copy integer a_mag integer a_sign integer b integer b_copy integer b_mag integer b_sign integer c integer c_copy integer g integer i_gcd integer ierror integer k integer n real norm_new real norm_old integer q(nmax) logical swap integer temp integer x integer xnew integer y integer ynew ! ! Defaults for output parameters. ! ierror = 0 x = 0 y = 0 ! ! Special cases. ! if ( a == 0 .and. b == 0 .and. c == 0 ) then x = 0 return else if ( a == 0 .and. b == 0 .and. c /= 0 ) then ierror = 1 x = 0 return else if ( a == 0 .and. b /= 0 .and. c == 0 ) then x = 0 return else if ( a == 0 .and. b /= 0 .and. c /= 0 ) then x = 0 if ( mod ( c, b ) /= 0 ) then ierror = 2 end if return else if ( a /= 0 .and. b == 0 .and. c == 0 ) then x = 0 return else if ( a /= 0 .and. b == 0 .and. c /= 0 ) then x = c / a if ( mod ( c, a ) /= 0 ) then ierror = 3 end if return else if ( a /= 0 .and. b /= 0 .and. c == 0 ) then g = i_gcd ( a, b ) x = b / g return end if ! ! Now handle the "general" case: A, B and C are nonzero. ! ! Step 1: Compute the GCD of A and B, which must also divide C. ! g = i_gcd ( a, b ) if ( mod ( c, g ) /= 0 ) then ierror = 4 return end if a_copy = a / g b_copy = b / g c_copy = c / g ! ! Step 2: Split A and B into sign and magnitude. ! a_mag = abs ( a_copy ) a_sign = sign ( 1, a_copy ) b_mag = abs ( b_copy ) b_sign = sign ( 1, b_copy ) ! ! Another special case, A_MAG = 1 or B_MAG = 1. ! if ( a_mag == 1 ) then x = a_sign * c_copy return else if ( b_mag == 1 ) then x = 0 return end if ! ! Step 3: Produce the Euclidean remainder sequence. ! if ( a_mag >= b_mag ) then swap = .false. q(1) = a_mag q(2) = b_mag else swap = .true. q(1) = b_mag q(2) = a_mag end if n = 3 do q(n) = mod ( q(n-2), q(n-1) ) if ( q(n) == 1 ) then exit end if n = n + 1 if ( n > nmax ) then ierror = 5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CONGRUENCE - Fatal error!' write ( *, '(a)' ) ' Exceeded number of iterations.' stop end if end do ! ! Step 4: Now go backwards to solve X * A_MAG + Y * B_MAG = 1. ! y = 0 do k = n, 2, -1 x = y y = ( 1 - x * q(k-1) ) / q(k) end do ! ! Step 5: Undo the swapping. ! if ( swap ) then call i_swap ( x, y ) end if ! ! Step 6: Now apply signs to X and Y so that X * A + Y * B = 1. ! x = x * a_sign ! ! Step 7: Multiply by C, so that X * A + Y * B = C. ! x = x * c_copy ! ! Step 8: Now force 0 <= X < B. ! x = mod ( x, b ) return end subroutine count_pose ( blocks, goal ) ! !******************************************************************************* ! !! COUNT_POSE poses a problem for the game "The Count is Good" ! ! ! Discussion: ! ! The French television show "The Count is Good" has a game that goes ! as follows: ! ! A number is chosen at random between 100 and 999. This is the GOAL. ! ! Six numbers are randomly chosen from the set 1, 2, 3, 4, 5, 6, 7, 8, ! 9, 10, 25, 50, 75, 100. These numbers are the BLOCKS. ! ! The player must construct a formula, using some or all of the blocks, ! (but not more than once), and the operations of addition, subtraction, ! multiplication and division. Parentheses should be used to remove ! all ambiguity. However, it is forbidden to use subtraction in a ! way that produces a negative result, and all division must come out ! exactly, with no remainder. ! ! This routine poses a sample problem from the show. The point is, ! to determine how to write a program that can solve such a problem. ! ! Reference: ! ! Raymond Seroul, ! Programming for Mathematicians, ! Springer Verlag, 2000, page 355-357. ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer BLOCKS(6), the six numbers available for the formula. ! ! Output, integer GOAL, the goal number. ! implicit none ! integer blocks(6) integer goal integer ind(6) integer, dimension ( 14 ) :: stuff = & (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 25, 50, 75, 100 /) ! call i_random ( 100, 999, goal ) call ksub_random ( 14, 6, ind ) blocks(1:6) = stuff(ind(1:6)) return end function d_pi ( ) ! !******************************************************************************* ! !! D_PI returns the value of pi as a double precision quantity. ! ! ! Modified: ! ! 19 December 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, double precision D_PI, the value of pi. ! implicit none ! double precision d_pi ! d_pi = 3.14159265358979323846264338327950288419716939937510D+00 return end subroutine d_to_cfrac ( r, n, a, p, q ) ! !******************************************************************************* ! !! D_TO_CFRAC converts a double precision value to a continued fraction. ! ! ! Discussion: ! ! The routine is given a real number R. It computes a sequence of ! continued fraction approximations to R, returning the results as ! simple fractions of the form P(I) / Q(I). ! ! Example: ! ! X = 2 * PI ! N = 7 ! ! A = [ *, 6, 3, 1, 1, 7, 2, 146, 3 ] ! P = [ 1, 6, 19, 25, 44, 333, 710, 103993, 312689 ] ! Q = [ 0, 1, 3, 4, 7, 53, 113, 16551, 49766 ] ! ! (This ignores roundoff error, which will cause later terms to differ). ! ! Reference: ! ! Norman Richert, ! Strang's Strange Figures, ! American Mathematical Monthly, ! Volume 99, Number 2, February 1992, pages 101-107. ! ! Modified: ! ! 10 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision R, the real value. ! ! Input, integer N, the number of convergents to compute. ! ! Output, integer A(0:N), the partial quotients. ! ! Output, integer P(-1:N), Q(-1:N), the numerators and denominators ! of the continued fraction approximations. ! implicit none ! integer n ! integer a(0:n) integer i integer p(-1:n) integer q(-1:n) double precision r double precision r_copy double precision x(0:n) ! if ( r == 0.0D+00 ) then a(0:n) = 0 p(-1:n) = 0 q(-1:n) = 1 return end if r_copy = abs ( r ) p(-1) = 1 q(-1) = 0 p(0) = int ( r_copy ) q(0) = 1 x(0) = r_copy a(0) = int ( x(0) ) do i = 1, n x(i) = 1.0E+00 / ( x(i-1) - dble ( a(i-1) ) ) a(i) = int ( x(i) ) p(i) = a(i) * p(i-1) + p(i-2) q(i) = a(i) * q(i-1) + q(i-2) end do if ( r < 0.0D+00 ) then p(-1:n) = - p(-1:n) end if return end subroutine d_to_dec ( dval, itop, ibot ) ! !******************************************************************************* ! !! D_TO_DEC converts a double precision quantity to a decimal representation. ! ! ! Discussion: ! ! Given the double precision value DVAL, the routine computes integers ! ITOP and IBOT so that it is approximately true that: ! ! DVAL = ITOP * 10 ** IBOT ! ! In particular, only DEC_DIGIT digits of DVAL are used in constructing the ! representation. ! ! Modified: ! ! 25 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, double precision DVAL, the value whose decimal representation ! is desired. ! ! Output, integer ITOP, IBOT, the approximate decimal representation of DVAL. ! ITOP is an integer, strictly between -10**DEC_DIGIT and 10**DEC_DIGIT. ! IBOT is an integer exponent of 10. ! implicit none ! integer dec_digit double precision dtop double precision dval integer ibot integer itop real ten1 real ten2 ! ! Special cases. ! if ( dval == 0.0D+00 ) then itop = 0 ibot = 0 return end if ! ! Factor DVAL = DTOP * 10**IBOT ! dtop = dval ibot = 0 ! ! Get the number of decimal digits. ! dec_digit = 0 call i_data ( 'GET', 'DEC_DIGIT', dec_digit ) ! ! Now normalize so that 10**(DEC_DIGIT-1) <= ABS(DTOP) < 10**(DEC_DIGIT) ! ten1 = 10.0E+00**( dec_digit - 1 ) ten2 = 10.0E+00**dec_digit do while ( abs ( dtop ) < ten1 ) dtop = dtop * 10.0D+00 ibot = ibot - 1 end do do while ( abs ( dtop ) >= ten2 ) dtop = dtop / 10.0D+00 ibot = ibot + 1 end do ! ! ITOP is the integer part of DTOP, rounded. ! itop = nint ( dtop ) ! ! Now divide out any factors of ten from ITOP. ! if ( itop /= 0 ) then do while ( 10 * ( itop / 10 ) == itop ) itop = itop / 10 ibot = ibot + 1 end do end if return end subroutine debruijn ( m, n, string ) ! !******************************************************************************* ! !! DEBRUIJN constructs a de Bruijn sequence. ! ! ! Description: ! ! Suppose we have an alphabet of M letters, and we are interested in ! all possible strings of length N. If M = 2 and N = 3, then we are ! interested in the M**N strings: ! ! 000 ! 001 ! 010 ! 011 ! 100 ! 101 ! 110 ! 111 ! ! Now, instead of making a list like this, we prefer, if possible, to ! write a string of letters, such that every consecutive sequence of ! N letters is one of the strings, and every string occurs once, if ! we allow wraparound. ! ! For the above example, a suitable sequence would be the 8 characters: ! ! 00011101(00... ! ! where we have suggested the wraparound feature by repeating the first ! two characters at the end. ! ! Such a sequence is called a de Bruijn sequence. It can easily be ! constructed by considering a directed graph, whose nodes are all ! M**(N-1) strings of length N-1. A node I has a directed edge to ! node J (labeled with character K) if the string at node J can ! be constructed by beheading the string at node I and adding character K. ! ! In this setting, a de Bruijn sequence is simply an Eulerian circuit ! of the directed graph, with the edge labels being the entries of the ! sequence. In general, there are many distinct de Bruijn sequences ! for the same parameter M and N. This program will only find one ! of them. ! ! Modified: ! ! 06 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the number of letters in the alphabet. ! ! Input, integer N, the number of letters in a codeword. ! ! Output, integer STRING(M**N), a deBruijn string. ! implicit none ! integer m integer n ! integer i integer iedge integer inode(m**n) integer ivec(n-1) integer j integer jnode(m**n) integer jvec(n-1) integer k integer knode(m**n) integer nedge integer nnode logical success integer string(m**n) integer trail(m**n) ! ! Construct the adjacency information. ! nnode = m**(n-1) nedge = m**n iedge = 0 do i = 1, nnode call index_unrank0 ( n-1, m, i, ivec ) do k = 1, m jvec(1:n-2) = ivec(2:n-1) jvec(n-1) = k call index_rank0 ( n-1, m, jvec, j ) iedge = iedge + 1 inode(iedge) = i jnode(iedge) = j knode(iedge) = k end do end do ! ! Determine a circuit. ! call digraph_arc_euler ( nnode, nedge, inode, jnode, success, trail ) ! ! The string is constructed from the labels of the edges in the circuit. ! string(1:nedge) = knode(trail(1:nedge)) return end subroutine dec_add ( itop1, ibot1, itop2, ibot2, itop, ibot ) ! !******************************************************************************* ! !! DEC_ADD adds two decimal quantities. ! ! ! Discussion: ! ! The routine computes ! ! ITOP * 10**IBOT = ITOP1 * 10**IBOT1 + ITOP2 * 10**IBOT2 ! ! while trying to avoid integer overflow. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITOP1, IBOT1, the first number to be added. ! ! Input, integer ITOP2, IBOT2, the second number to be added. ! ! Output, integer ITOP, IBOT, the sum. ! implicit none ! integer ibot integer ibot1 integer ibot2 integer itop integer itop1 integer itop2 integer jtop1 integer jtop2 ! if ( itop1 == 0 ) then itop = itop2 ibot = ibot2 return else if ( itop2 == 0 ) then itop = itop1 ibot = ibot1 return else if ( ibot1 == ibot2 ) then itop = itop1 + itop2 ibot = ibot1 call dec_round ( itop, ibot ) return end if ! ! Line up the exponents. ! jtop1 = itop1 jtop2 = itop2 if ( ibot1 < ibot2 ) then jtop2 = jtop2 * 10**( ibot2 - ibot1 ) else jtop1 = jtop1 * 10**( ibot1 - ibot2 ) end if ! ! Add the coefficients. ! itop = jtop1 + jtop2 ibot = min ( ibot1, ibot2 ) ! ! Clean up the result. ! call dec_round ( itop, ibot ) return end subroutine dec_div ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) ! !******************************************************************************* ! !! DEC_DIV divides two decimal values. ! ! ! Discussion: ! ! A decimal quantity is stored as ! ! (ITOP,IBOT) ! ! representing the value ! ! ITOP * 10 ** IBOT. ! ! The routine computes ! ! ITOP * 10**IBOT = (ITOP1 * 10**IBOT1) / (ITOP2 * 10**IBOT2) ! ! = (ITOP1/ITOP2) * 10**(IBOT1-IBOT2) ! ! while avoiding integer overflow. ! ! Modified: ! ! 23 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITOP1, IBOT1, the numerator. ! ! Input, integer ITOP2, IBOT2, the denominator. ! ! Output, integer ITOP, IBOT, the result. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred. ! implicit none ! double precision dval integer ibot integer ibot1 integer ibot2 integer ibot3 integer ierror integer itop integer itop1 integer itop2 integer itop3 ! ! First special case, top fraction is 0. ! if ( itop1 == 0 ) then itop = 0 ibot = 0 return end if ! ! First error, bottom of fraction is 0. ! if ( itop2 == 0 ) then ierror = 1 itop = 0 ibot = 0 return end if ! ! Second special case, result is 1. ! if ( itop1 == itop2 .and. ibot1 == ibot2 ) then itop = 1 ibot = 0 return end if ! ! Third special case, result is power of 10. ! if ( itop1 == itop2 ) then itop = 1 ibot = ibot1 - ibot2 return end if ! ! Fourth special case: ITOP1/ITOP2 is exact. ! if ( ( itop1 / itop2 ) * itop2 == itop1 ) then itop = itop1 / itop2 ibot = ibot1 - ibot2 return end if ! ! General case. ! dval = dble ( itop1 ) / dble ( itop2 ) call d_to_dec ( dval, itop3, ibot3 ) itop = itop3 ibot = ibot3 + ibot1 - ibot2 return end subroutine dec_mul ( itop1, ibot1, itop2, ibot2, itop, ibot ) ! !******************************************************************************* ! !! DEC_MUL multiplies two decimals. ! ! ! Discussion: ! ! The routine computes ! ! ITOP * 10**IBOT = (ITOP1 * 10**IBOT1) * (ITOP2 * 10**IBOT2) ! = (ITOP1*ITOP2) * 10**(IBOT1+IBOT2) ! ! while avoiding integer overflow. ! ! Modified: ! ! 25 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITOP1, IBOT1, the first multiplier. ! ! Input, integer ITOP2, IBOT2, the second multiplier. ! ! Output, integer ITOP, IBOT, the product. ! implicit none ! double precision dval integer i_max integer ibot integer ibot1 integer ibot2 integer ibot3 integer itop integer itop1 integer itop2 integer itop3 real temp ! i_max = huge ( i_max ) ! ! The result is zero if either ITOP1 or ITOP2 is zero. ! if ( itop1 == 0 .or. itop2 == 0 ) then itop = 0 ibot = 0 return end if ! ! The result is simple if either ITOP1 or ITOP2 is one. ! if ( abs ( itop1 ) == 1 .or. abs ( itop2 ) == 1 ) then itop = itop1 * itop2 ibot = ibot1 + ibot2 return end if temp = log ( real ( abs ( itop1 ) ) ) + log ( real ( abs ( itop2 ) ) ) if ( temp < log ( real ( i_max ) ) ) then itop = itop1 * itop2 ibot = ibot1 + ibot2 else dval = dble ( itop1 ) * dble ( itop2 ) call d_to_dec ( dval, itop3, ibot3 ) itop = itop3 ibot = ibot3 + ( ibot1 + ibot2 ) end if call dec_round ( itop, ibot ) return end subroutine dec_round ( itop, ibot ) ! !******************************************************************************* ! !! DEC_ROUND rounds a decimal fraction to a given number of digits. ! ! ! Discussion: ! ! The routine takes an arbitrary decimal fraction represented by ! ! ITOP * 10**IBOT ! ! and makes sure that ITOP has no more than DEC_DIGIT digits. ! DEC_DIGIT can be set or reported by calling I_DATA. ! ! Modified: ! ! 25 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ITOP, IBOT, the coefficient and exponent ! of a decimal fraction. On return, ITOP has no more than ! DEC_DIGIT decimal digits. ! implicit none ! integer dec_digit integer ibot integer itop ! if ( itop == 0 ) then ibot = 0 return end if dec_digit = 0 call i_data ( 'GET', 'DEC_DIGIT', dec_digit ) do while ( abs ( itop ) >= 10**dec_digit ) itop = nint ( real ( itop ) / 10.0E+00 ) ibot = ibot + 1 end do ! ! Absorb trailing 0's into the exponent. ! do while ( ( itop / 10 ) * 10 == itop ) itop = itop / 10 ibot = ibot + 1 end do return end subroutine dec_to_r ( a, itop, ibot ) ! !***************************************************************************** ! !! DEC_TO_R converts a decimal ITOP * 10**IBOT to a real value. ! ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real A, the equivalent real value. ! ! Input, integer ITOP, IBOT, the coefficient and exponent ! of the decimal value. ! implicit none ! real a integer ibot integer itop ! a = itop * 10.0E+00**ibot return end subroutine dec_to_rat ( iatop, iabot ) ! !******************************************************************************* ! !! DEC_TO_RAT converts a decimal to a rational representation. ! ! ! Discussion: ! ! On input, a value is represented as IATOP * 10**IABOT. ! ! On output, approximately the same value is represented as IATOP / IABOT. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer IATOP, IABOT. ! On input, these quantities represent the value IATOP * 10 ** IABOT. ! On output, these quantities represent the value IATOP / IABOT. ! integer iabot integer iatop integer i_gcd integer itmp ! if ( iabot >= 0 ) then iatop = iatop * 10**iabot iabot = 1 else iabot = 10**( - iabot ) itmp = i_gcd ( iatop, iabot ) iatop = iatop / itmp iabot = iabot / itmp end if return end subroutine dec_to_s_left ( ival, jval, s ) ! !******************************************************************************* ! !! DEC_TO_S_LEFT returns a left-justified representation of IVAL * 10**JVAL. ! ! ! Examples: ! ! IVAL JVAL S ! ---- ---- ------ ! 0 0 0 ! 21 3 21000 ! -3 0 -3 ! 147 -2 14.7 ! 16 -5 0.00016 ! 34 30 Inf ! 123 -21 0.0000000000000000012 ! 34 -30 0.0 ! ! Modified: ! ! 13 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, JVAL, integers which represent the decimal. ! ! Output, character ( len = * ) S, the representation of the value. ! The string is 'Inf' or '0.0' if the value was too large ! or small to represent with a fixed point format. ! implicit none ! character ( len = 22 ) chrrep integer i integer iget1 integer iget2 integer iput1 integer iput2 integer ival integer jval integer maxdigit integer ndigit integer nleft character ( len = * ) s ! s = ' ' if ( ival == 0 ) then s = '0' return end if maxdigit = len ( s ) ! ! Store a representation of IVAL in CHRREP. ! write ( chrrep, '(i22)' ) ival call s_blank_delete ( chrrep ) ndigit = len_trim ( chrrep ) ! ! Overflow if JVAL is positive, and NDIGIT + JVAL > MAXDIGIT. ! if ( jval > 0 ) then if ( ndigit + jval > maxdigit ) then s = 'Inf' return end if end if ! ! Underflow if JVAL is negative, and 3 + NDIGIT - JVAL > MAXDIGIT. ! if ( jval < 0 ) then if ( ival > 0 ) then if ( 3 - ndigit - jval > maxdigit ) then s = '0.0' return end if else if ( 5 - ndigit - jval > maxdigit ) then s = '0.0' return end if end if end if ! ! If JVAL is nonnegative, insert trailing zeros. ! if ( jval >= 0 ) then s(1:ndigit) = chrrep(1:ndigit) do i = ndigit+1, ndigit+jval s(i:i) = '0' end do else if ( jval < 0 ) then iput2 = 0 iget2 = 0 ! ! Sign. ! if ( ival < 0 ) then iput1 = 1 iput2 = 1 iget2 = 1 s(iput1:iput2) = '-' ndigit = ndigit - 1 end if ! ! Digits of the integral part. ! if ( ndigit + jval > 0 ) then iput1 = iput2 + 1 iput2 = iput1 + ndigit + jval -1 iget1 = iget2 + 1 iget2 = iget1 + ndigit+jval - 1 s(iput1:iput2) = chrrep(iget1:iget2) else iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '0' end if ! ! Decimal point. ! iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '.' ! ! Leading zeroes. ! do i = 1, - jval - ndigit iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '0' end do nleft = min ( -jval, ndigit ) nleft = min ( nleft, maxdigit - iput2 ) iput1 = iput2 + 1 iput2 = iput1 + nleft - 1 iget1 = iget2 + 1 iget2 = iget1 + nleft - 1 s(iput1:iput2) = chrrep(iget1:iget2) end if return end subroutine decmat_det ( n, iatop, iabot, idtop, idbot, ierror ) ! !******************************************************************************* ! !! DECMAT_DET finds the determinant of an N by N matrix of decimal entries. ! ! ! Warning: ! ! The brute force method is used. The routine should only be used for ! small matrices, since this calculation requires the summation of N! ! products of N numbers. ! ! Modified: ! ! 17 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of rows and columns of A. ! ! Input, integer IATOP(N,N), IABOT(N,N), the decimal ! representation of the matrix. ! ! Output, integer IDTOP, IDBOT, the decimal determinant of the matrix. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred (probably overflow). ! implicit none ! integer n ! logical even integer i integer iabot(n,n) integer iatop(n,n) integer iarray(n) integer ibot integer ibot1 integer ibot2 integer idbot integer idtop integer ierror integer itop integer itop1 integer itop2 logical more ! ierror = 0 more = .false. idtop = 0 idbot = 1 ! ! Compute the next permutation. ! do call perm_next ( n, iarray, more, even ) ! ! The sign of this term depends on the sign of the permutation. ! if ( even ) then itop = 1 else itop = - 1 end if ! ! Choose one item from each row, as specified by the permutation, ! and multiply them ! ibot = 0 do i = 1, n itop1 = itop ibot1 = ibot itop2 = iatop(i,iarray(i)) ibot2 = iabot(i,iarray(i)) call dec_mul ( itop1, ibot1, itop2, ibot2, itop, ibot ) end do ! ! Add this term to the total. ! itop1 = itop ibot1 = ibot itop2 = idtop ibot2 = idbot call dec_add ( itop1, ibot1, itop2, ibot2, itop, ibot ) idtop = itop idbot = ibot if ( .not. more ) then exit end if end do return end subroutine decmat_print ( m, n, a, b, title ) ! !******************************************************************************* ! !! DECMAT_PRINT prints out decimal vectors and matrices. ! ! ! Modified: ! ! 12 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the matrix. ! ! Input, integer A(M,N), B(M,N), the decimal matrix. ! ! Input, character ( len = * ) TITLE, a label for the object being printed. ! implicit none ! integer m integer n ! integer a(m,n) integer b(m,n) character ( len = 22 ) chrtmp character ( len = 10 ) chrtmp1 character ( len = 10 ) chrtmp2 character ( len = 10 ) chrtmp3 character ( len = 40 ) format2 integer i integer ichi integer iclo integer imax integer imin integer izhi integer izlo integer j integer jmax integer jmin integer khi integer klo integer kmax integer lenc integer, parameter :: ncolum = 80 integer npline character ( len = 100 ) output character ( len = * ) title ! ! Figure out how wide we must make each column. ! imax = 0 jmax = 0 do i = 1, m do j = 1, n call dec_to_s_left ( a(i,j), b(i,j), chrtmp ) lenc = len_trim ( chrtmp ) jmax = max ( jmax, lenc ) end do end do kmax = 2 + imax + 1 + jmax npline = ncolum / kmax ! ! Set up the format for the heading. ! call i_to_s_left ( npline, chrtmp2 ) call i_to_s_left ( kmax, chrtmp3 ) format2 = '(' // chrtmp2 // 'i' // chrtmp3 // ')' call s_blank_delete ( format2 ) do jmin = 1, n, npline jmax = min ( jmin+npline-1, n ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' if ( jmin > 1 .or. jmax < n ) then write ( output, * ) 'Columns ', jmin, ' to ', jmax call s_blanks_delete ( output ) write ( *, '(a)' ) trim ( output ) write ( *, '(a)' ) ' ' end if do i = 1, m output = ' ' do j = jmin, jmax klo = 4 + (j-jmin) * kmax + 1 khi = 4 + (j-jmin) * kmax + kmax call dec_to_s_left ( a(i,j), b(i,j), chrtmp ) output(klo:khi) = adjustr ( chrtmp(1:kmax) ) end do write ( *, '(a)' ) trim ( output ) end do end do return end subroutine derange_back_candidate ( n, iarray, k, nstack, stack, ncan ) ! !******************************************************************************* ! !! DERANGE_BACK_CANDIDATE finds possible values for the K-th entry of a derangement. ! ! ! Modified: ! ! 10 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the derangement. ! ! Input, integer IARRAY(N). The first K-1 entries of IARRAY ! record the currently set values of the derangement. ! ! Input, integer K, the entry of the derangement for which candidates ! are to be found. ! ! Input/output, integer NSTACK, the length of the stack. ! ! Input/output, integer STACK((N*(N+1))/2). On output, we have added ! the candidates for entry K to the end of the stack. ! ! Input/output, integer NCAN(N), the number of candidates for each level. ! implicit none ! integer n ! integer iarray(n) integer ican integer ifree(n) integer k integer ncan(n) integer nfree integer nstack integer stack((n*(n+1)/2)) ! ! Consider all the integers from 1 through N that have not been used yet. ! nfree = n - k + 1 call perm_free ( iarray, k-1, ifree, nfree ) ! ! Everything but K is a legitimate candidate for the K-th entry. ! ncan(k) = 0 do ican = 1, nfree if ( ifree(ican) /= k ) then ncan(k) = ncan(k) + 1 nstack = nstack + 1 stack(nstack) = ifree(ican) end if end do return end subroutine derange_back_next ( n, iarray, more ) ! !******************************************************************************* ! !! DERANGE_BACK_NEXT returns the next derangement of N items. ! ! ! Discussion: ! ! This routine uses backtracking. ! ! Modified: ! ! 26 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items to be deranged. ! ! Input/output, integer IARRAY(N). ! On the first call, the input value of IARRAY is not important. ! On return with MORE = .TRUE., IARRAY contains the next derangement. ! On subsequent input, IARRAY should not be changed. ! ! Input/output, logical MORE. ! On first call, set MORE to .FALSE, and do not alter it after. ! On return, MORE is TRUE if another derangement was found, and FALSE ! if there are no more. ! implicit none ! integer n ! integer i integer iarray(n) integer, save :: indx = 0 integer, save :: k = 0 integer, save :: maxstack = 0 logical more integer, save, allocatable, dimension (:) :: ncan integer, save :: nstack = 0 integer, save, allocatable, dimension (:) :: stack ! if ( .not. more ) then indx = 0 k = 0 maxstack = ( n * ( n + 1 ) ) / 2 nstack = 0 if ( allocated ( stack ) ) then deallocate ( stack ) end if allocate ( stack(1:(n*(n+1))/2) ) stack(1:maxstack) = 0 if ( allocated ( ncan ) ) then deallocate ( ncan ) end if allocate ( ncan(1:n) ) ncan(1:n) = 0 more = .true. end if do call ivec_backtrack ( n, iarray, indx, k, nstack, stack, maxstack, ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call derange_back_candidate ( n, iarray, k, nstack, stack, ncan ) else more = .false. exit end if end do return end subroutine derange_check ( n, iarray, deranged ) ! !******************************************************************************* ! !! DERANGE_CHECK determines whether a permutation is a derangement. ! ! ! Definition: ! ! A derangement of the integers 1 through N is a permutation of the ! integers such that the first value is not 1, the second is not 2, ! and so on. ! ! Modified: ! ! 22 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects permuted. ! ! Input, integer IARRAY(N), a permutation of the integers 1 through N. ! ! Output, logical DERANGED, is TRUE if IARRAY is a derangement, and ! FALSE otherwise. ! implicit none ! integer n ! logical deranged integer i integer iarray(n) ! do i = 1, n if ( iarray(i) == i ) then deranged = .false. return end if end do deranged = .true. return end function derange_enum ( n ) ! !******************************************************************************* ! !! DERANGE_ENUM returns the number of derangements of N objects. ! ! ! Definition: ! ! A derangement of N objects is a permutation with no fixed ! points. If we symbolize the permutation operation by "P", ! then for a derangment, P(I) is never equal to I. ! ! Recursion: ! ! D(0) = 1 ! D(1) = 0 ! D(2) = 1 ! D(N) = (N-1) * ( D(N-1) + D(N-2) ) ! ! or ! ! D(0) = 1 ! D(1) = 0 ! D(N) = N * D(N-1) + (-1)**N ! ! Formula: ! ! D(N) = N! * ( 1 - 1/1! + 1/2! - 1/3! ... 1/N! ) ! ! Based on the inclusion/exclusion law. ! ! Comments: ! ! D(N) is the number of ways of placing N non-attacking rooks on ! an N by N chessboard with one diagonal deleted. ! ! Limit ( N -> Infinity ) D(N)/N! = 1 / e. ! ! The number of permutations with exactly K items in the right ! place is COMB(N,K) * D(N-K). ! ! First values: ! ! N D(N) ! 0 1 ! 1 0 ! 2 1 ! 3 2 ! 4 9 ! 5 44 ! 6 265 ! 7 1854 ! 8 14833 ! 9 133496 ! 10 1334961 ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Output, integer DERANGE_ENUM, the number of derangements of N objects. ! implicit none ! integer derange_enum integer dn integer dnm1 integer dnm2 integer i integer n ! if ( n < 0 ) then dn = 0 else if ( n == 0 ) then dn = 1 else if ( n == 1 ) then dn = 0 else if ( n == 2 ) then dn = 1 else dnm1 = 0 dn = 1 do i = 3, n dnm2 = dnm1 dnm1 = dn dn = ( i - 1 ) * ( dnm1 + dnm2 ) end do end if derange_enum = dn return end subroutine derange_enum2 ( n, d ) ! !******************************************************************************* ! !! DERANGE_ENUM2 returns the number of derangements of 0 through N objects. ! ! ! Definition: ! ! A derangement of N objects is a permutation with no fixed ! points. If we symbolize the permutation operation by "P", ! then for a derangment, P(I) is never equal to I. ! ! Recursion: ! ! D(0) = 1 ! D(1) = 0 ! D(2) = 1 ! D(N) = (N-1) * ( D(N-1) + D(N-2) ) ! ! or ! ! D(0) = 1 ! D(1) = 0 ! D(N) = N * D(N-1) + (-1)**N ! ! Formula: ! ! D(N) = N! * ( 1 - 1/1! + 1/2! - 1/3! ... 1/N! ) ! ! Based on the inclusion/exclusion law. ! ! Comments: ! ! D(N) is the number of ways of placing N non-attacking rooks on ! an N by N chessboard with one diagonal deleted. ! ! Limit ( N -> Infinity ) D(N)/N! = 1 / e. ! ! The number of permutations with exactly K items in the right ! place is COMB(N,K) * D(N-K). ! ! First values: ! ! N D(N) ! 0 1 ! 1 0 ! 2 1 ! 3 2 ! 4 9 ! 5 44 ! 6 265 ! 7 1854 ! 8 14833 ! 9 133496 ! 10 1334961 ! ! Modified: ! ! 28 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the maximum number of objects to be permuted. ! ! Output, integer D(0:N); D(I) is the number of derangements of ! I objects. ! implicit none ! integer n ! integer d(0:n) integer i ! d(0) = 1 d(1) = 0 do i = 2, n d(i) = ( i - 1 ) * ( d(i-1) + d(i-2) ) end do return end subroutine derange_weed_next ( n, iarray, more ) ! !******************************************************************************* ! !! DERANGE_WEED_NEXT computes all of the derangements of N objects, one at a time. ! ! ! Definition: ! ! A derangement of the integers 1 through N is a permutation of the ! integers such that the first value is not 1, the second is not 2, ! and so on. ! ! Discussion: ! ! This routine simply generates all permutations, one at a time, ! and weeds out those that are not derangements. ! ! Examples: ! ! Here are the derangements when N = 4: ! ! 2143 3142 4123 ! 2341 3412 4312 ! 2413 3421 4321 ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer IARRAY(N). ! ! On first call, the input contents of IARRAY are unimportant. But ! on the second and later calls, the input value of IARRAY should be ! the output value returned on the previous call. ! ! On output, IARRAY contains the next derangement. ! ! Input/output, logical MORE. ! ! Set MORE = .FALSE. before the first call. ! ! MORE will be reset to .TRUE. and a derangement will be returned. ! ! Each new call produces a new derangement until MORE is returned .FALSE. ! implicit none ! integer n ! logical deranged integer derange_enum integer iarray(n) integer, save :: maxder = 0 logical more integer, save :: numder = 0 ! ! Initialization on call with MORE = .FALSE. ! if ( .not. more ) then maxder = derange_enum ( n ) numder = 0 end if ! ! Watch out for cases where there are no derangements. ! if ( maxder == 0 ) then more = .false. return end if ! ! Get the next permutation. ! do call perm_lex ( n, iarray, more ) ! ! See if it is a derangment. ! call derange_check ( n, iarray, deranged ) if ( deranged ) then exit end if end do numder = numder + 1 if ( numder >= maxder ) then more = .false. end if return end subroutine digit_to_ch ( digit, c ) ! !******************************************************************************* ! !! DIGIT_TO_CH returns the character representation of a decimal digit. ! ! ! Example: ! ! DIGIT C ! ----- --- ! 0 '0' ! 1 '1' ! ... ... ! 9 '9' ! 17 '*' ! ! Modified: ! ! 04 August 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIGIT, the digit value between 0 and 9. ! ! Output, character C, the corresponding character, or '*' if DIGIT ! was illegal. ! implicit none ! character c integer digit ! if ( 0 <= digit .and. digit <= 9 ) then c = char ( digit + 48 ) else c = '*' end if return end subroutine digraph_arc_euler ( nnode, nedge, inode, jnode, success, trail ) ! !******************************************************************************* ! !! DIGRAPH_ARC_EULER returns an Euler circuit in a digraph. ! ! ! Description: ! ! An Euler circuit of a digraph is a path which starts and ends at ! the same node and uses each directed edge exactly once. A digraph is ! eulerian if it has an Euler circuit. The problem is to decide whether ! a given digraph is eulerian and to find an Euler circuit if the ! answer is affirmative. ! ! Method: ! ! A digraph has an Euler circuit if and only if the number of incoming ! edges is equal to the number of outgoing edges at each node. ! ! This characterization gives a straightforward procedure to decide whether ! a digraph is eulerian. Furthermore, an Euler circuit in an eulerian digraph ! G of NEDGE edges can be determined by the following method: ! ! STEP 1: Choose any node U as the starting node, and traverse any edge ! ( U, V ) incident to node U, and than traverse any unused edge incident ! to node U. Repeat this process of traversing unused edges until the ! starting node U is reached. Let P be the resulting walk consisting of ! all used edges. If all edges of G are in P, than stop. ! ! STEP 2: Choose any unused edge ( X, Y) in G such that X is ! in P and Y is not in P. Use node X as the starting node and ! find another walk Q using all unused edges as in step 1. ! ! STEP 3: Walk P and walk Q share a common node X, they can be merged ! to form a walk R by starting at any node S of P and to traverse P ! until node X is reached; than, detour and traverse all edges of Q ! until node X is reached and continue to traverse the edges of P until ! the starting node S is reached. Set P = R. ! ! STEP 4: Repeat steps 2 and 3 until all edges are used. ! ! The running time of the algorithm is O ( NEDGE ). ! ! Note: ! ! The digraph is assumed to be connected. ! ! Reference: ! ! Hang Tong Lau, ! Algorithms on Graphs, ! Tab Books, 1989. ! ! Modified: ! ! 25 July 2000 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE); the I-th edge starts at node ! INODE(I) and ends at node JNODE(I). ! ! Output, logical SUCCESS, is TRUE if an Euler circuit was found, ! and FALSE otherwise. ! ! Output, integer TRAIL(NEDGE). TRAIL(I) is the edge number of the I-th ! edge in the Euler circuit. ! implicit none ! integer nedge ! logical candid(nedge) integer endnod(nedge) integer i integer inode(nedge) integer istak integer j integer jnode(nedge) integer k integer l integer len integer lensol integer lenstk integer nnode integer stack(2*nedge) logical success integer trail(nedge) ! ! Check if the digraph is eulerian. ! trail(1:nedge) = 0 endnod(1:nedge) = 0 do i = 1, nedge j = inode(i) trail(j) = trail(j) + 1 j = jnode(i) endnod(j) = endnod(j) + 1 end do do i = 1, nnode if ( trail(i) /= endnod(i) ) then success = .false. return end if end do ! ! The digraph is eulerian; find an Euler circuit. ! success = .true. lensol = 1 lenstk = 0 ! ! Find the next edge. ! do if ( lensol == 1 ) then endnod(1) = inode(1) stack(1) = 1 stack(2) = 1 lenstk = 2 else l = lensol - 1 if ( lensol /= 2 ) then endnod(l) = inode(trail(l)) + jnode(trail(l)) - endnod(l-1) end if k = endnod(l) do i = 1, nedge candid(i) = ( k == jnode(i) ) end do do i = 1, l candid(trail(i)) = .false. end do len = lenstk do i = 1, nedge if ( candid(i) ) then len = len + 1 stack(len) = i end if end do stack(len+1) = len - lenstk lenstk = len + 1 end if do istak = stack(lenstk) lenstk = lenstk - 1 if ( istak /= 0 ) then exit end if lensol = lensol - 1 if ( lensol == 0 ) then call ivec_reverse ( nedge, trail ) return end if end do trail(lensol) = stack(lenstk) stack(lenstk) = istak - 1 if ( lensol == nedge ) then exit end if lensol = lensol + 1 end do call ivec_reverse ( nedge, trail ) return end subroutine digraph_arc_print ( nedge, inode, jnode, title ) ! !******************************************************************************* ! !! DIGRAPH_ARC_PRINT prints out a digraph from an edge list. ! ! ! Modified: ! ! 04 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NEDGE, the number of edges. ! ! Input, integer INODE(NEDGE), JNODE(NEDGE), the beginning and end ! nodes of the edges. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none ! integer nedge ! integer i integer inode(nedge) integer jnode(nedge) character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, nedge write ( *, '(i6,4x,2i6)' ) i, inode(i), jnode(i) end do return end subroutine diophantine ( a, b, c, ierror, x, y ) ! !******************************************************************************* ! !! DIOPHANTINE solves a Diophantine equation A * X + B * Y = C. ! ! ! Discussion: ! ! Given integers A, B and C, produce X and Y so that ! ! A * X + B * Y = C. ! ! In general, the equation is solvable if and only if the ! greatest common divisor of A and B also divides C. ! ! A solution (X,Y) of the Diophantine equation also gives the solution ! X to the congruence equation: ! ! A * X = C mod ( B ). ! ! Generally, if there is one nontrivial solution, there are an infinite ! number of solutions to a Diophantine problem. ! If (X0,Y0) is a solution, then so is ( X0+T*B/D, Y0-T*A/D ) where ! T is any integer, and D is the greatest common divisor of A and B. ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998, page 446. ! ! Modified: ! ! 02 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, C, the coefficients of the Diophantine equation. ! ! Output, integer IERROR, error flag. ! 0, no error, X and Y were computed. ! 1, A = B = 0, C is nonzero. ! 2, A = 0, B and C nonzero, but C is not a multiple of B. ! 3, A nonzero, B zero, C nonzero, but C is not a multiple of A. ! 4, A, B, C nonzero, but GCD of A and B does not divide C. ! 5, the algorithm ran out of internal space. ! ! Output, integer X, Y, the solution of the Diophantine equation. ! Note that the algorithm will attempt to return a solution with ! smallest Euclidean norm. ! implicit none ! integer, parameter :: nmax = 100 ! integer a integer a_copy integer a_mag integer a_sign integer b integer b_copy integer b_mag integer b_sign integer c integer c_copy integer g integer i_gcd integer ierror integer k integer n real norm_new real norm_old integer q(nmax) logical swap integer temp integer x integer xnew integer y integer ynew ! ! Defaults for output parameters. ! ierror = 0 x = 0 y = 0 ! ! Special cases. ! if ( a == 0 .and. b == 0 .and. c == 0 ) then x = 0 y = 0 return else if ( a == 0 .and. b == 0 .and. c /= 0 ) then ierror = 1 x = 0 y = 0 return else if ( a == 0 .and. b /= 0 .and. c == 0 ) then x = 0 y = 0 return else if ( a == 0 .and. b /= 0 .and. c /= 0 ) then x = 0 y = c / b if ( mod ( c, b ) /= 0 ) then ierror = 2 end if return else if ( a /= 0 .and. b == 0 .and. c == 0 ) then x = 0 y = 0 return else if ( a /= 0 .and. b == 0 .and. c /= 0 ) then x = c / a y = 0 if ( mod ( c, a ) /= 0 ) then ierror = 3 end if return else if ( a /= 0 .and. b /= 0 .and. c == 0 ) then g = i_gcd ( a, b ) x = b / g y = - a / g return end if ! ! Now handle the "general" case: A, B and C are nonzero. ! ! Step 1: Compute the GCD of A and B, which must also divide C. ! g = i_gcd ( a, b ) if ( mod ( c, g ) /= 0 ) then ierror = 4 return end if a_copy = a / g b_copy = b / g c_copy = c / g ! ! Step 2: Split A and B into sign and magnitude. ! a_mag = abs ( a_copy ) a_sign = sign ( 1, a_copy ) b_mag = abs ( b_copy ) b_sign = sign ( 1, b_copy ) ! ! Another special case, A_MAG = 1 or B_MAG = 1. ! if ( a_mag == 1 ) then x = a_sign * c_copy y = 0 return else if ( b_mag == 1 ) then x = 0 y = b_sign * c_copy return end if ! ! Step 3: Produce the Euclidean remainder sequence. ! if ( a_mag >= b_mag ) then swap = .false. q(1) = a_mag q(2) = b_mag else swap = .true. q(1) = b_mag q(2) = a_mag end if n = 3 do q(n) = mod ( q(n-2), q(n-1) ) if ( q(n) == 1 ) then exit end if n = n + 1 if ( n > nmax ) then ierror = 5 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DIOPHANTINE - Fatal error!' write ( *, '(a)' ) ' Exceeded number of iterations.' stop end if end do ! ! Step 4: Now go backwards to solve X * A_MAG + Y * B_MAG = 1. ! y = 0 do k = n, 2, -1 x = y y = ( 1 - x * q(k-1) ) / q(k) end do ! ! Step 5: Undo the swapping. ! if ( swap ) then call i_swap ( x, y ) end if ! ! Step 6: Now apply signs to X and Y so that X * A + Y * B = 1. ! x = x * a_sign y = y * b_sign ! ! Step 7: Multiply by C, so that X * A + Y * B = C. ! x = x * c_copy y = y * c_copy ! ! Step 8: Given a solution (X,Y), try to find the solution of ! minimal magnitude. ! call diophantine_solution_minimize ( a_copy, b_copy, x, y ) return end subroutine diophantine_solution_minimize ( a, b, x, y ) ! !******************************************************************************* ! !! DIOPHANTINE_SOLUTION_MINIMIZE seeks a minimal solution of a Diophantine equation. ! ! ! Discussion: ! ! Given a solution (X,Y) of a Diophantine equation: ! ! A * X + B * Y = C. ! ! then there are an infinite family of solutions of the form ! ! ( X(i), Y(i) ) = ( X + i * B, Y - i * A ) ! ! An integral solution of minimal Euclidean norm can be found by ! tentatively moving along the vectors (B,-A) and (-B,A) one step ! at a time. ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998, page 446. ! ! Modified: ! ! 03 October 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the coefficients of the Diophantine equation. ! A and B are assumed to be relatively prime. ! ! Input/output, integer X, Y, on input, a solution of the Diophantine ! equation. On output, a solution of minimal Euclidean norm. ! implicit none ! integer a integer b real norm real norm_new real t integer x integer xnew integer y integer ynew ! ! Compute the minimum for T real, and then look nearby. ! t = ( - real ( b ) * real ( x ) + real ( a ) * real ( y ) ) & / ( real ( a )**2 + real ( b )**2 ) x = x + nint ( t ) * b y = y - nint ( t ) * a ! ! Now look nearby. ! norm = ( real ( x ) )**2 + ( real ( y ) )**2 do xnew = x + b ynew = y - a norm_new = ( real ( xnew ) )**2 + ( real ( ynew ) )**2 if ( norm_new >= norm ) then exit end if x = xnew y = ynew norm = norm_new end do do xnew = x - b ynew = y + a norm_new = ( real ( xnew ) )**2 + ( real ( ynew ) )**2 if ( norm_new >= norm ) then exit end if x = xnew y = ynew norm = norm_new end do return end subroutine equiv_next ( n, npart, jarray, iarray, more ) ! !******************************************************************************* ! !! EQUIV_NEXT computes the partitions of a set one at a time. ! ! ! Definition: ! ! A partition of a set assigns each element to exactly one subset. ! ! Comments: ! ! The number of partitions of a set of size N is the Bell number B(N). ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 18 July 2000 ! ! Parameters: ! ! Input, integer N, number of elements in the set to be partitioned. ! ! Output, integer NPART, number of subsets in the partition. ! ! Output, integer JARRAY(N). JARRAY(I) is the number of elements ! in the I-th subset of the partition. ! ! Output, integer IARRAY(N). IARRAY(I) is the class to which ! element I belongs. ! ! Input/output, logical MORE. Set MORE = .FALSE. before first call. ! It is reset and held at .TRUE. as long as ! the partition returned is not the last one. ! When MORE is returned .FALSE., all the partitions ! have been computed and returned. ! implicit none ! integer n ! integer i integer iarray(n) integer jarray(n) integer l integer m logical more integer npart ! if ( .not. more ) then npart = 1 iarray(1:n) = 1 jarray(1) = n else m = n do while ( jarray(iarray(m)) == 1 ) iarray(m) = 1 m = m - 1 end do l = iarray(m) npart = npart + m - n jarray(1) = jarray(1) + n - m if ( l == npart ) then npart = npart + 1 jarray(npart) = 0 end if iarray(m) = l + 1 jarray(l) = jarray(l) - 1 jarray(l+1) = jarray(l+1) + 1 end if more = npart /= n return end subroutine equiv_next2 ( done, iarray, n ) ! !******************************************************************************* ! !! EQUIV_NEXT2 computes, one at a time, the partitions of a set. ! ! ! Definition: ! ! A partition of a set assigns each element to exactly one subset. ! ! Comments: ! ! The number of partitions of a set of size N is the Bell number B(N). ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input/output, logical DONE. Before the very first call, the ! user should set DONE to .TRUE., which prompts the program ! to initialize its data, and return the first partition. ! ! Thereafter, the user should call again, for the next ! partition, and so on, until the routine returns with DONE ! equal to .TRUE., at which point there are no more partitions ! to compute. ! ! Input/output, integer IARRAY(N), contains the information ! defining the current partition. The user should not alter ! IARRAY between calls. Except for the very first ! call, the routine uses the previous output value of IARRAY to compute ! the next value. ! ! The entries of IARRAY are the partition subset to which each ! element of the original set belongs. If there are NPART distinct ! parts of the partition, then each entry of IARRAY will be a ! number between 1 and NPART. Every number from 1 to NPART will ! occur somewhere in the list. If the entries of IARRAY are ! examined in order, then each time a new partition subset occurs, ! it will be the next unused integer. ! ! For instance, for N = 4, the program will describe the set ! where each element is in a separate subset as 1, 2, 3, 4, ! even though such a partition might also be described as ! 4, 3, 2, 1 or even 1, 5, 8, 19. ! ! Input, integer N, the number of elements in the set. ! implicit none ! integer n ! logical done integer i integer iarray(n) integer imax integer j integer jmax ! if ( done ) then done = .false. iarray(1:n) = 1 else ! ! Find the last element J that can be increased by 1. ! This is the element that is not equal to its maximum possible value, ! which is the maximum value of all preceding elements +1. ! jmax = iarray(1) imax = 1 do j = 2, n if ( iarray(j) > jmax ) then jmax = iarray(j) else imax = j end if end do ! ! If no element can be increased by 1, we are done. ! if ( imax == 1 ) then done = .true. return end if ! ! Increase the value of the IMAX-th element by 1, set its successors to 1. ! done = .false. iarray(imax) = iarray(imax) + 1 iarray(imax+1:n) = 1 end if return end subroutine equiv_print ( n, iarray ) ! !******************************************************************************* ! !! EQUIV_PRINT prints a partition of a set. ! ! ! Modified: ! ! 11 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, number of elements in set to be partitioned. ! ! Input, integer IARRAY(N), defines the partition or set of equivalence ! classes. Element I belongs to subset IARRAY(I). ! implicit none ! integer n ! integer iarray(n) integer karray(n) integer j integer k integer s integer s_max integer s_min ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Set partition:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Set Size' s_min = minval ( iarray(1:n) ) s_max = maxval ( iarray(1:n) ) do s = s_min, s_max k = 0 do j = 1, n if ( iarray(j) == s ) then k = k + 1 karray(k) = j end if end do if ( k > 0 ) then write ( *, '(2i6,4x,(10i4))' ) s, k, karray(1:k) end if end do return end subroutine equiv_random ( n, npart, iarray, b ) ! !******************************************************************************* ! !! EQUIV_RANDOM selects a random partition of a set. ! ! ! Discussion: ! ! The user does not control the number of parts in the partition. ! ! The equivalence classes are numbered in no particular order. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 12 May 2002 ! ! Parameters: ! ! Input, integer N, the number of elements in the set to be partitioned. ! ! Output, integer NPART, the number of classes or parts in the ! partition. NPART will be between 1 and N. ! ! Output, integer IARRAY(N), indicates the class to which each element ! is assigned. ! ! Output, real B(N). B(K) = A(K)/(K!), where ! A(K) = number of partitions of a set of K objects. ! implicit none ! integer n ! real b(n) integer iarray(n) integer k integer l integer m integer npart real sum1 real z real, parameter :: zhi = 1.0E+00 real, parameter :: zlo = 0.0E+00 ! b(1) = 1.0E+00 do l = 1, n-1 sum1 = 1.0E+00 / real ( l ) do k = 1, l-1 sum1 = ( sum1 + b(k) ) / real ( l - k ) end do b(l+1) = ( sum1 + b(l) ) / real ( l + 1 ) end do m = n npart = 0 do call r_random ( zlo, zhi, z ) z = real ( m ) * b(m) * z k = 0 npart = npart + 1 do while ( z >= 0.0E+00 ) iarray(m) = npart m = m - 1 if ( m == 0 ) then exit end if z = z - b(m) k = k + 1 z = z * k end do if ( m == 0 ) then exit end if end do ! ! Randomly permute the assignments. ! call perm_random2 ( n, iarray ) return end subroutine euler ( ieuler, n ) ! !******************************************************************************* ! !! EULER returns the N-th row of Euler's triangle. ! ! ! Definition: ! ! E(N,K) counts the number of permutations of the N digits that have ! exactly K "ascents", that is, K places where the Ith digit is ! less than the (I+1)th digit. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer IEULER(0:N), the N-th row of Euler's ! triangle, IEULER(K) contains the value of E(N,K). Note ! that IEULER(0) should be 1 and IEULER(N) should be 0. ! ! Input, integer N, the row of Euler's triangle desired. ! implicit none ! integer n ! integer ieuler(0:n) integer irow integer k ! ieuler(0) = 1 if ( n > 0 ) then ieuler(1) = 0 do irow = 2, n ieuler(irow) = 0 do k = irow-1, 1, -1 ieuler(k) = ( k + 1 ) * ieuler(k) + ( irow - k ) * ieuler(k-1) end do ieuler(0) = 1 end do end if return end function fall ( x, n ) ! !******************************************************************************* ! !! FALL computes the falling factorial function [X]_N. ! ! ! Discussion: ! ! Note that the number of "injections" or 1-to-1 mappings from ! a set of N elements to a set of M elements is [M]_N. ! ! The number of permutations of N objects out of M is [M}_N. ! ! Moreover, the Stirling numbers of the first kind can be used ! to convert a falling factorial into a polynomial, as follows: ! ! [X]_N = S^0_N + S^1_N * X + S^2_N * X^2 + ... + S^N_N X^N. ! ! Formula: ! ! [X]_N = X * ( X - 1 ) * ( X - 2 ) * ... * ( X - N + 1 ). ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X, the argument of the falling factorial function. ! ! Input, integer N, the order of the falling factorial function. ! If N = 0, FALL = 1, if N = 1, FALL = X. Note that if N is ! negative, a "rising" factorial will be computed. ! ! Output, real FALL, the value of the falling factorial function. ! implicit none ! real arg real fall integer i integer n real x ! fall = 1.0E+00 arg = x if ( n > 0 ) then do i = 1, n fall = fall * arg arg = arg - 1.0E+00 end do else if ( n < 0 ) then do i = -1, n fall = fall * arg arg = arg + 1.0E+00 end do end if return end function gamma_log ( x ) ! !******************************************************************************* ! !! GAMMA_LOG calculates the natural logarithm of GAMMA ( X ) for positive X. ! ! ! Discussion: ! ! Computation is based on an algorithm outlined in references 1 and 2. ! The program uses rational functions that theoretically approximate ! LOG(GAMMA(X)) to at least 18 significant decimal digits. The ! approximation for X > 12 is from reference 3, while approximations ! for X < 12.0 are similar to those in reference 1, but are unpublished. ! The accuracy achieved depends on the arithmetic system, the compiler, ! intrinsic functions, and proper selection of the machine-dependent ! constants. ! ! Modified: ! ! 16 June 1999 ! ! Authors: ! ! W. J. Cody and L. Stoltz ! Argonne National Laboratory ! ! References: ! ! # 1) ! W. J. Cody and K. E. Hillstrom, ! Chebyshev Approximations for the Natural Logarithm of the Gamma Function, ! Math. Comp. ! Volume 21, 1967, pages 198-203. ! ! # 2) ! K. E. Hillstrom, ! ANL/AMD Program ANLC366S, DGAMMA/DLGAMA, ! May 1969. ! ! # 3) ! Hart, Et. Al., ! Computer Approximations, ! Wiley and sons, New York, 1968. ! ! Parameters: ! ! Input, real X, the argument of the Gamma function. X must be positive. ! ! Output, real GAMMA_LOG, the logarithm of the Gamma function of X. ! If X <= 0.0, or if overflow would occur, the program returns the ! value XINF, the largest representable floating point number. ! !******************************************************************************* ! ! Explanation of machine-dependent constants ! ! BETA - radix for the floating-point representation. ! ! MAXEXP - the smallest positive power of BETA that overflows. ! ! XBIG - largest argument for which LN(GAMMA(X)) is representable ! in the machine, i.e., the solution to the equation ! LN(GAMMA(XBIG)) = BETA**MAXEXP. ! ! FRTBIG - Rough estimate of the fourth root of XBIG ! ! ! Approximate values for some important machines are: ! ! BETA MAXEXP XBIG ! ! CRAY-1 (S.P.) 2 8191 9.62E+2461 ! Cyber 180/855 ! under NOS (S.P.) 2 1070 1.72E+319 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 2 128 4.08E+36 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2 1024 2.55D+305 ! IBM 3033 (D.P.) 16 63 4.29D+73 ! VAX D-Format (D.P.) 2 127 2.05D+36 ! VAX G-Format (D.P.) 2 1023 1.28D+305 ! ! ! FRTBIG ! ! CRAY-1 (S.P.) 3.13E+615 ! Cyber 180/855 ! under NOS (S.P.) 6.44E+79 ! IEEE (IBM/XT, ! SUN, etc.) (S.P.) 1.42E+9 ! IEEE (IBM/XT, ! SUN, etc.) (D.P.) 2.25D+76 ! IBM 3033 (D.P.) 2.56D+18 ! VAX D-Format (D.P.) 1.20D+9 ! VAX G-Format (D.P.) 1.89D+76 ! implicit none ! real, parameter, dimension ( 7 ) :: c = (/ & -1.910444077728E-03, & 8.4171387781295E-04, & -5.952379913043012E-04, & 7.93650793500350248E-04, & -2.777777777777681622553E-03, & 8.333333333333333331554247E-02, & 5.7083835261E-03 /) real corr real, parameter :: d1 = - 5.772156649015328605195174E-01 real, parameter :: d2 = 4.227843350984671393993777E-01 real, parameter :: d4 = 1.791759469228055000094023E+00 real, parameter :: frtbig = 1.42E+09 integer i real gamma_log real, parameter, dimension ( 8 ) :: p1 = (/ & 4.945235359296727046734888E+00, & 2.018112620856775083915565E+02, & 2.290838373831346393026739E+03, & 1.131967205903380828685045E+04, & 2.855724635671635335736389E+04, & 3.848496228443793359990269E+04, & 2.637748787624195437963534E+04, & 7.225813979700288197698961E+03 /) real, parameter, dimension ( 8 ) :: p2 = (/ & 4.974607845568932035012064E+00, & 5.424138599891070494101986E+02, & 1.550693864978364947665077E+04, & 1.847932904445632425417223E+05, & 1.088204769468828767498470E+06, & 3.338152967987029735917223E+06, & 5.106661678927352456275255E+06, & 3.074109054850539556250927E+06 /) real, parameter, dimension ( 8 ) :: p4 = (/ & 1.474502166059939948905062E+04, & 2.426813369486704502836312E+06, & 1.214755574045093227939592E+08, & 2.663432449630976949898078E+09, & 2.940378956634553899906876E+010, & 1.702665737765398868392998E+011, & 4.926125793377430887588120E+011, & 5.606251856223951465078242E+011 /) real, parameter :: pnt68 = 0.6796875E+00 real, parameter, dimension ( 8 ) :: q1 = (/ & 6.748212550303777196073036E+01, & 1.113332393857199323513008E+03, & 7.738757056935398733233834E+03, & 2.763987074403340708898585E+04, & 5.499310206226157329794414E+04, & 6.161122180066002127833352E+04, & 3.635127591501940507276287E+04, & 8.785536302431013170870835E+03 /) real, parameter, dimension ( 8 ) :: q2 = (/ & 1.830328399370592604055942E+02, & 7.765049321445005871323047E+03, & 1.331903827966074194402448E+05, & 1.136705821321969608938755E+06, & 5.267964117437946917577538E+06, & 1.346701454311101692290052E+07, & 1.782736530353274213975932E+07, & 9.533095591844353613395747E+06 /) real, parameter, dimension ( 8 ) :: q4 = (/ & 2.690530175870899333379843E+03, & 6.393885654300092398984238E+05, & 4.135599930241388052042842E+07, & 1.120872109616147941376570E+09, & 1.488613728678813811542398E+010, & 1.016803586272438228077304E+011, & 3.417476345507377132798597E+011, & 4.463158187419713286462081E+011 /) real res real, parameter :: sqrtpi = 0.9189385332046727417803297E+00 real x real, parameter :: xbig = 4.08E+36 real xden real xm1 real xm2 real xm4 real xnum real xsq ! ! Return immediately if the argument is out of range. ! if ( x <= 0.0E+00 .or. x > xbig ) then gamma_log = huge ( gamma_log ) return end if if ( x <= epsilon ( x ) ) then res = - log ( x ) else if ( x <= 1.5E+00 ) then if ( x < pnt68 ) then corr = - log ( x ) xm1 = x else corr = 0.0E+00 xm1 = ( x - 0.5E+00 ) - 0.5E+00 end if if ( x <= 0.5E+00 .or. x >= pnt68 ) then xden = 1.0E+00 xnum = 0.0E+00 do i = 1, 8 xnum = xnum * xm1 + p1(i) xden = xden * xm1 + q1(i) end do res = corr + ( xm1 * ( d1 + xm1 * ( xnum / xden ) ) ) else xm2 = ( x - 0.5E+00 ) - 0.5E+00 xden = 1.0E+00 xnum = 0.0E+00 do i = 1, 8 xnum = xnum * xm2 + p2(i) xden = xden * xm2 + q2(i) end do res = corr + xm2 * ( d2 + xm2 * ( xnum / xden ) ) end if else if ( x <= 4.0E+00 ) then xm2 = x - 2.0E+00 xden = 1.0E+00 xnum = 0.0E+00 do i = 1, 8 xnum = xnum * xm2 + p2(i) xden = xden * xm2 + q2(i) end do res = xm2 * ( d2 + xm2 * ( xnum / xden ) ) else if ( x <= 12.0E+00 ) then xm4 = x - 4.0E+00 xden = - 1.0E+00 xnum = 0.0E+00 do i = 1, 8 xnum = xnum * xm4 + p4(i) xden = xden * xm4 + q4(i) end do res = d4 + xm4 * ( xnum / xden ) else res = 0.0E+00 if ( x <= frtbig ) then res = c(7) xsq = x * x do i = 1, 6 res = res / xsq + c(i) end do end if res = res / x corr = log ( x ) res = res + sqrtpi - 0.5E+00 * corr res = res + x * ( corr - 1.0E+00 ) end if gamma_log = res return end subroutine gray_rank ( gray, rank ) ! !******************************************************************************* ! !! GRAY_RANK ranks a Gray code. ! ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer GRAY, the Gray code to be ranked. ! ! Output, integer RANK, the rank of GRAY, and the integer whose Gray ! code is GRAY. ! implicit none ! integer gray integer i integer ii integer j integer, parameter :: nbits = 32 integer rank ! j = 0 if ( btest ( gray, nbits-1 ) ) then j = ibset ( j, nbits-1 ) end if do i = 2, nbits ii = nbits - i if ( btest ( j, ii+1 ) .and. ( .not. btest ( gray, ii ) ) ) then j = ibset ( j, ii ) end if if ( ( .not. btest ( j, ii+1 ) ) .and. btest ( gray, ii ) ) then j = ibset ( j, ii ) end if end do rank = j return end subroutine gray_unrank ( rank, gray ) ! !******************************************************************************* ! !! GRAY_UNRANK unranks a Gray code. ! ! ! Comments: ! ! The binary values of the Gray codes of successive integers differ in ! just one bit. ! ! The sequence of Gray codes for 0 to (2**N)-1 can be interpreted as a ! Hamiltonian cycle on a graph of the cube in N dimensions. ! ! Examples: ! ! RANK IGRAY BINARY ! 0 0 0 ! 1 1 1 ! 2 3 11 ! 3 2 10 ! 4 6 110 ! 5 7 111 ! 6 5 101 ! 7 4 100 ! 8 12 1100 ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer RANK, the integer whose Gray code is desired. ! ! Output, integer GRAY, the Gray code of the given rank. ! implicit none ! integer gray integer i integer ii integer j integer, parameter :: nbits = 32 integer rank ! j = 0 if ( btest ( rank, nbits-1 ) ) then j = ibset ( j, nbits-1 ) end if do i = 2, nbits ii = nbits - i if ( btest ( rank, ii+1 ) .neqv. btest ( rank, ii ) ) then j = ibset ( j, ii ) end if end do gray = j return end subroutine i_data ( op, var, ival ) ! !******************************************************************************* ! !! I_DATA stores and retrieves common data items. ! ! ! Discussion: ! ! This routine works like a sort of COMMON block. It stores or returns ! the values of certain variables. Thus, it allows routines ! to "communicate" without having to have data passed up and ! down the calling tree in argument lists. ! ! The variables stored by this version of the routine are: ! ! 'DEC_DIGIT', the number of digits stored for decimals; ! 'DEC_DIGIT_MAX', the maximum number of digits stored for decimals; ! 'I_BIG', the biggest integer to use in calculations. ! ! Modified: ! ! 20 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) OP, describes the operation to be done. ! 'SET' means set a value. ! 'INC' means increment a value (and return its new value) ! 'GET' means get a value. ! ! Input, character ( len = * ) VAR, the name of the variable. ! ! Input/output, integer IVAL. ! If OP is 'SET', then the variable named in VAR is set to the ! value IVAL. ! If OP is 'GET', then the value of IVAL is set to the value of ! the variable named in VAR. ! If OP is 'INC', then the value of IVAL is incremented by 1, ! and its new value is returned in VAR. ! implicit none ! integer, save :: dec_digit = 7 integer, save :: dec_digit_max = 7 integer, save :: i_big = huge ( i_big ) integer ival character ( len = * ) op logical s_eqi character ( len = * ) var ! if ( s_eqi ( op, 'SET' ) ) then if ( s_eqi ( var, 'DEC_DIGIT' ) ) then dec_digit = ival else if ( s_eqi ( var, 'DEC_DIGIT_MAX' ) ) then dec_digit_max = ival else if ( s_eqi ( var, 'I_BIG' ) ) then i_big = ival end if else if ( s_eqi ( op, 'GET' ) ) then if ( s_eqi ( var, 'DEC_DIGIT' ) ) then ival = dec_digit else if ( s_eqi ( var, 'DEC_DIGIT_MAX' ) ) then ival = dec_digit_max else if ( s_eqi ( var, 'I_BIG' ) ) then ival = i_big end if else if ( s_eqi ( op, 'INC' ) ) then if ( s_eqi ( var, 'DEC_DIGIT' ) ) then dec_digit = dec_digit + 1 ival = dec_digit else if ( s_eqi ( var, 'DEC_DIGIT_MAX' ) ) then dec_digit_max = dec_digit_max + 1 ival = dec_digit_max else if ( s_eqi ( var, 'I_BIG' ) ) then i_big = i_big + 1 ival = i_big end if end if return end subroutine i_factor ( n, maxfactor, nfactor, factor, power, nleft ) ! !******************************************************************************* ! !! I_FACTOR factors an integer into prime factors. ! ! ! Formula: ! ! N = NLEFT * Product ( I = 1 to NFACTOR ) FACTOR(I)**POWER(I). ! ! Modified: ! ! 20 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer to be factored. N may be positive, ! negative, or 0. ! ! Input, integer MAXFACTOR, the maximum number of prime factors for ! which storage has been allocated. ! ! Output, integer NFACTOR, the number of prime factors of N discovered ! by the routine. ! ! Output, integer FACTOR(MAXFACTOR), the prime factors of N. ! ! Output, integer POWER(MAXFACTOR). POWER(I) is the power of ! the FACTOR(I) in the representation of N. ! ! Output, integer NLEFT, the factor of N that the routine could not ! divide out. If NLEFT is 1, then N has been completely factored. ! Otherwise, NLEFT represents factors of N involving large primes. ! implicit none ! integer maxfactor ! integer factor(maxfactor) integer i integer maxprime integer n integer nleft integer nfactor integer p integer power(maxfactor) integer prime ! nfactor = 0 factor(1:maxfactor) = 0 power(1:maxfactor) = 0 nleft = n if ( n == 0 ) then return end if if ( abs ( n ) == 1 ) then nfactor = 1 factor(1) = 1 power(1) = 1 return end if ! ! Find out how many primes we stored. ! maxprime = prime ( -1 ) ! ! Try dividing the remainder by each prime. ! do i = 1, maxprime p = prime ( i ) if ( mod ( abs ( nleft ), p ) == 0 ) then if ( nfactor < maxfactor ) then nfactor = nfactor + 1 factor(nfactor) = p do power(nfactor) = power(nfactor) + 1 nleft = nleft / p if ( mod ( abs ( nleft ), p ) /= 0 ) then exit end if end do if ( abs ( nleft ) == 1 ) then exit end if end if end if end do return end function i_gcd ( i, j ) ! !******************************************************************************* ! !! I_GCD finds the greatest common divisor of I and J. ! ! ! Modified: ! ! 03 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, J, two numbers whose greatest common divisor ! is desired. ! ! Output, integer I_GCD, the greatest common divisor of I and J. ! ! Note that only the absolute values of I and J are ! considered, so that the result is always nonnegative. ! ! If I or J is 0, I_GCD is returned as max ( 1, abs ( I ), abs ( J ) ). ! ! If I and J have no common factor, I_GCD is returned as 1. ! ! Otherwise, using the Euclidean algorithm, I_GCD is the ! largest common factor of I and J. ! implicit none ! integer i integer i_gcd integer ip integer iq integer ir integer j ! i_gcd = 1 ! ! Return immediately if either I or J is zero. ! if ( i == 0 ) then i_gcd = max ( 1, abs ( j ) ) return else if ( j == 0 ) then i_gcd = max ( 1, abs ( i ) ) return end if ! ! Set IP to the larger of I and J, IQ to the smaller. ! This way, we can alter IP and IQ as we go. ! ip = max ( abs ( i ), abs ( j ) ) iq = min ( abs ( i ), abs ( j ) ) ! ! Carry out the Euclidean algorithm. ! do ir = mod ( ip, iq ) if ( ir == 0 ) then exit end if ip = iq iq = ir end do i_gcd = iq return end function i_modp ( i, j ) ! !******************************************************************************* ! !! I_MODP returns the nonnegative remainder of integer division. ! ! ! Formula: ! ! If ! NREM = I_MODP ( I, J ) ! NMULT = ( I - NREM ) / J ! then ! I = J * NMULT + NREM ! where NREM is always nonnegative. ! ! Comments: ! ! The MOD function computes a result with the same sign as the ! quantity being divided. Thus, suppose you had an angle A, ! and you wanted to ensure that it was between 0 and 360. ! Then mod(A,360) would do, if A was positive, but if A ! was negative, your result would be between -360 and 0. ! ! On the other hand, I_MODP(A,360) is between 0 and 360, always. ! ! Examples: ! ! I J MOD I_MODP I_MODP Factorization ! ! 107 50 7 7 107 = 2 * 50 + 7 ! 107 -50 7 7 107 = -2 * -50 + 7 ! -107 50 -7 43 -107 = -3 * 50 + 43 ! -107 -50 -7 43 -107 = 3 * -50 + 43 ! ! Modified: ! ! 02 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the number to be divided. ! ! Input, integer J, the number that divides I. ! ! Output, integer I_MODP, the nonnegative remainder when I is divided by J. ! implicit none ! integer i integer i_modp integer j ! if ( j == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_MODP - Fatal error!' write ( *, '(a,i6)' ) ' I_MODP ( I, J ) called with J = ', j stop end if i_modp = mod ( i, j ) if ( i_modp < 0 ) then i_modp = i_modp + abs ( j ) end if return end subroutine i_moebius ( n, mu ) ! !******************************************************************************* ! !! I_MOEBIUS returns the value of MU(N), the Moebius function of N. ! ! ! Definition: ! ! MU(N) is defined as follows: ! ! MU(N) = 1 if N = 1; ! 0 if N is divisible by the square of a prime; ! (-1)**K, if N is the product of K distinct primes. ! ! First values: ! ! N MU(N) ! ! 1 1 ! 2 -1 ! 3 -1 ! 4 0 ! 5 -1 ! 6 1 ! 7 -1 ! 8 0 ! 9 0 ! 10 1 ! 11 -1 ! 12 0 ! 13 -1 ! 14 1 ! 15 1 ! 16 0 ! 17 -1 ! 18 0 ! 19 -1 ! 20 0 ! ! Note: ! ! As special cases, MU(N) is -1 if N is a prime, and MU(N) is 0 ! if N is a square, cube, etc. ! ! Formula: ! ! The Moebius function is related to Euler's totient function: ! ! PHI(N) = sum ( D divides N ) MU(D) * ( N / D ). ! ! Modified: ! ! 01 March 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the value to be analyzed. ! ! Output, integer MU, the value of MU(N). ! If N is less than or equal to 0, MU will be returned as -2. ! If there was not enough internal space for factoring, MU ! is returned as -3. ! implicit none ! integer, parameter :: maxfactor = 20 ! integer factor(maxfactor) integer i integer mu integer n integer nfactor integer nleft integer power(maxfactor) ! if ( n <= 0 ) then mu = - 2 return end if if ( n == 1 ) then mu = 1 return end if ! ! Factor N. ! call i_factor ( n, maxfactor, nfactor, factor, power, nleft ) if ( nleft /= 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_MOEBIUS - Fatal error!' write ( *, '(a)' ) ' Not enough factorization space.' mu = - 3 return end if mu = 1 do i = 1, nfactor mu = - mu if ( power(i) > 1 ) then mu = 0 return end if end do return end subroutine i_random ( ilo, ihi, i ) ! !******************************************************************************* ! !! I_RANDOM returns a random integer in a given range. ! ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ILO, IHI, the minimum and maximum acceptable values. ! ! Output, integer I, the randomly chosen integer. ! implicit none ! integer i integer ihi integer ilo real r real rhi real rlo ! ! Pick a random number in (0,1). ! call random_number ( harvest = r ) ! ! Set a real interval [RLO,RHI] which contains the integers [ILO,IHI], ! each with a "neighborhood" of width 1. ! rlo = real ( ilo ) - 0.5E+00 rhi = real ( ihi ) + 0.5E+00 ! ! Set I to the integer that is nearest the scaled value of R. ! i = nint ( ( 1.0E+00 - r ) * rlo + r * rhi ) ! ! In case of oddball events at the boundary, enforce the limits. ! i = max ( i, ilo ) i = min ( i, ihi ) return end subroutine i_sqrt ( n, q, r ) ! !******************************************************************************* ! !! I_SQRT finds the integer square root of N by solving N = Q**2 + R. ! ! ! Discussion: ! ! The integer square root of N is an integer Q such that ! Q**2 <= N but (Q+1)**2 > N. ! ! A simpler calculation would be something like ! ! Q = INT ( SQRT ( REAL ( N ) ) ) ! ! but this calculation has the virtue of using only integer arithmetic. ! ! To avoid the tedium of worrying about negative arguments, the routine ! automatically considers the absolute value of the argument. ! ! Reference: ! ! Mark Herkommer, ! Number Theory, A Programmer's Guide, ! McGraw Hill, 1999, pages 294-307. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number whose integer square root is desired. ! Actually, only the absolute value of N is considered. ! ! Output, integer Q, R, the integer square root, and positive remainder, ! of N. ! implicit none ! integer n integer n_abs integer q integer r ! n_abs = abs ( n ) q = n_abs if ( n_abs > 0 ) then do while ( q > n_abs / q ) q = ( q + ( n_abs / q ) ) / 2 end do end if r = n_abs - q**2 return end subroutine i_sqrt_cf ( n, max_term, n_term, b ) ! !******************************************************************************* ! !! I_SQRT_CF finds the continued fraction representation of a square root of an integer. ! ! ! Discussion: ! ! The continued fraction representation of the square root of an integer ! has the form ! ! [ B0, (B1, B2, B3, ..., BM), ... ] ! ! where ! ! B0 = int ( sqrt ( real ( N ) ) ) ! BM = 2 * B0 ! the sequence ( B1, B2, B3, ..., BM ) repeats in the representation. ! the value M is termed the period of the representation. ! ! Examples: ! ! N Period Continued Fraction ! ! 2 1 [ 1, 2, 2, 2, ... ] ! 3 2 [ 1, 1, 2, 1, 2, 1, 2... ] ! 4 0 [ 2 ] ! 5 1 [ 2, 4, 4, 4, ... ] ! 6 2 [ 2, 2, 4, 2, 4, 2, 4, ... ] ! 7 4 [ 2, 1, 1, 1, 4, 1, 1, 4, 1, 1, 4... ] ! 8 2 [ 2, 1, 4, 1, 4, 1, 4, 1, 4, ... ] ! 9 0 [ 3 ] ! 10 1 [ 3, 6, 6, 6, ... ] ! ! Reference: ! ! Mark Herkommer, ! Number Theory, A Programmer's Guide, ! McGraw Hill, 1999, pages 294-307. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number whose continued fraction square root ! is desired. ! ! Input, integer MAX_TERM, the maximum number of terms that may ! be computed. ! ! Output, integer N_TERM, the number of terms computed beyond the ! 0 term. The routine should stop if it detects that the period ! has been reached. ! ! Output, integer B(0:MAX_TERM), contains the continued fraction ! coefficients in entries B(0:N_TERM). ! implicit none ! integer max_term ! integer b(0:max_term) integer k integer n integer n_term integer p integer q integer r integer s ! n_term = 0 call i_sqrt ( n, s, r ) b(0) = s if ( r > 0 ) then p = 0 q = 1 do p = b(n_term) * q - p q = ( n - p**2 ) / q if ( n_term >= max_term ) then return end if n_term = n_term + 1 b(n_term) = ( p + s ) / q if ( q == 1 ) then exit end if end do end if return end subroutine i_swap ( i, j ) ! !******************************************************************************* ! !! I_SWAP switches two integer values. ! ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J. On output, the values of I and ! J have been interchanged. ! implicit none ! integer i integer j integer k ! k = i i = j j = k return end subroutine i_to_chinese ( j, n, m, r ) ! !******************************************************************************* ! !! I_TO_CHINESE converts an integer to its Chinese remainder form. ! ! ! Discussion: ! ! Modified: ! ! 05 July 2000 ! ! Parameters: ! ! Input, integer J, the integer to be converted. ! ! Input, integer N, the number of moduluses. ! ! Input, integer M(N), the moduluses. These should be positive ! and pairwise prime. ! ! Output, integer R(N), the Chinese remainder representation of the integer. ! implicit none ! integer n ! integer i integer ierror integer i_modp integer j integer m(n) integer r(n) ! call chinese_check ( n, m, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I_TO_CHINESE - Fatal error!' write ( *, '(a)' ) ' The moduluses are not legal.' stop end if do i = 1, n r(i) = i_modp ( j, m(i) ) end do return end subroutine i_to_halton ( n, p, r ) ! !******************************************************************************* ! !! I_TO_HALTON computes an element of a Halton sequence. ! ! ! Discussion: ! ! The Halton sequence is often used to generate a "subrandom" ! sequence of points which have a better covering property ! than pseudorandom points. ! ! The Halton sequence generates a sequence of points in [0,1] ! which (theoretically) never repeats. ! ! To generate a sequence of points in a 2 dimensional space, ! it is typical practice to generate a pair of Halton sequences, ! the first with prime base 2, the second with prime base 3. ! Similarly, by using the first K primes, a suitable sequence ! in K-dimensional space can be generated. ! ! The generation is quite simple. Given an integer N, the expansion ! of N in base P is generated. Then, essentially, the result R ! is generated by writing a decimal point followed by the digits of ! the expansion of N, in reverse order. This decimal value is actually ! still in base P, so it must be properly interpreted to generate ! a usable value. ! ! Example: ! ! P = 2 ! ! N N Halton Halton ! decimal binary binary decimal ! ------- ------ ------ ------- ! 1 = 1 => .1 = 0.5 ! 2 = 10 => .01 = 0.25 ! 3 = 11 => .11 = 0.75 ! 4 = 100 => .001 = 0.125 ! 5 = 101 => .101 = 0.625 ! 6 = 110 => .011 = 0.375 ! 7 = 111 => .111 = 0.875 ! 8 = 1000 => .0001 = 0.0625 ! ! Reference: ! ! J H Halton, ! Numerische Mathematik, ! Volume 2, pages 84-90. ! ! Modified: ! ! 17 December 2000 ! ! Author: ! ! Lili Ju ! ! Parameters: ! ! Input, integer N, the index of the desired element. ! ! Input, integer P, the Halton base, which should be a prime number. ! ! Output, real R, the N-th element of the Halton sequence ! for base P. ! implicit none ! integer digit integer n integer n2 integer p real pp real r ! n2 = abs ( n ) r = 0.0E+00 pp = 1.0E+00 / real ( p ) do while ( n2 /= 0 ) digit = mod ( n2, p ) r = r + digit * pp pp = pp / real ( p ) n2 = n2 / p end do if ( n < 0 ) then r = - r end if return end subroutine i_to_ivec_binary ( i, n, ivec ) ! !******************************************************************************* ! !! I_TO_IVEC_BINARY makes a vector binary representation of an integer. ! ! ! Example: ! ! I IVEC ! -- -------------- ! 1 0,0,...0,0,0,1 ! 2 0,0,...0,0,1,0 ! 3 0,0,...0,0,1,1 ! 4 0,0,...0,1,0,0 ! 9 0,0,...1,0,0,1 ! -9 1,1,...0,1,1,1 ! ! Discussion: ! ! The vector is assumed to have dimension 32. Negative values have ! a two's complement operation applied. ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, an integer to be represented. ! ! Input, integer N, the dimension of the vector, which should be 32. ! ! Output, integer IVEC(N), the binary representation. ! implicit none ! integer n ! integer i integer i_copy integer ivec(n) integer j ! i_copy = abs ( i ) do j = n, 2, -1 ivec(j) = mod ( i_copy, 2 ) i_copy = i_copy / 2 end do ivec(1) = 0 if ( i < 0 ) then call ivec_binary_complement2 ( n, ivec ) end if return end subroutine i_to_s_left ( intval, s ) ! !******************************************************************************* ! !! I_TO_S_LEFT converts an integer to a left-justified string. ! ! ! Examples: ! ! Assume that S is 6 characters long: ! ! INTVAL S ! ! 1 1 ! -1 -1 ! 0 0 ! 1952 1952 ! 123456 123456 ! 1234567 ****** <-- Not enough room! ! ! Modified: ! ! 28 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer INTVAL, an integer to be converted. ! ! Output, character ( len = * ) S, the representation of the integer. ! The integer will be left-justified. If there is not enough space, ! the string will be filled with stars. ! implicit none ! character c integer i integer idig integer ihi integer ilo integer intval integer ipos integer ival character ( len = * ) s ! s = ' ' ilo = 1 ihi = len ( s ) if ( ihi <= 0 ) then return end if ! ! Make a copy of the integer. ! ival = intval ! ! Handle the negative sign. ! if ( ival < 0 ) then if ( ihi <= 1 ) then s(1:1) = '*' return end if ival = - ival s(1:1) = '-' ilo = 2 end if ! ! The absolute value of the integer goes into S(ILO:IHI). ! ipos = ihi ! ! Find the last digit of IVAL, strip it off, and stick it into the string. ! do idig = mod ( ival, 10 ) ival = ival / 10 if ( ipos < ilo ) then do i = 1, ihi s(i:i) = '*' end do return end if call digit_to_ch ( idig, c ) s(ipos:ipos) = c ipos = ipos - 1 if ( ival == 0 ) then exit end if end do ! ! Shift the string to the left. ! s(ilo:ilo+ihi-ipos-1) = s(ipos+1:ihi) s(ilo+ihi-ipos:ihi) = ' ' return end subroutine imat_01_rowcolsum ( m, n, r, c, a, ierror ) ! !******************************************************************************* ! !! IMAT_01_ROWCOLSUM creates a 0/1 matrix with given row and column sums. ! ! ! Discussion: ! ! Given an M vector R and N vector C, there may exist one or more ! M by N matrices with entries that are 0 or 1, whose row sums are R ! and column sums are C. ! ! For convenience, this routine requires that the entries of R and C ! be given in nonincreasing order. ! ! There are several requirements on R and C. The simple requirements ! are that the entries of R and C must be nonnegative, that the entries ! of R must each be no greater than N, and those of C no greater than M, ! and that the sum of the entries of R must equal the sum of the entries ! of C. ! ! The final technical requirement is that if we form R*, the conjugate ! partition of R, then C is majorized by R*, that is, that every partial ! sum from 1 to K of the entries of C is no bigger than the sum of the same ! entries of R*, for every K from 1 to N. ! ! Given these conditions on R and C, there is at least one 0/1 matrix ! with the given row and column sums. ! ! The conjugate partition of R is constructed as follows: ! R*(1) is the number of entries of R that are 1 or greater. ! R*(2) is the number of entries of R that are 2 or greater. ! ... ! R*(N) is the number of entries of R that are N (can't be greater). ! ! Example: ! ! M = N = 5 ! R = ( 3, 2, 2, 1, 1 ) ! C = ( 2, 2, 2, 2, 1 ) ! ! A = ! 1 0 1 0 1 ! 1 0 0 1 0 ! 0 1 0 1 0 ! 0 1 0 0 0 ! 0 0 1 0 0 ! ! Reference: ! ! J H van Lint and R M Wilson, ! A Course in Combinatorics, ! Oxford, 1992, pages 148-156. ! ! James Sandeson, ! Testing Ecological Patterns, ! American Scientist, ! Volume 88, July-August 2000, pages 332-339. ! ! Ian Saunders, ! Algorithm AS 205, ! Enumeration of R x C Tables with Repeated Row Totals, ! Applied Statistics, ! Volume 33, Number 3, pages 340-352, 1984. ! ! Modified: ! ! 26 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! ! Input, integer R(M), C(N), the row and column sums desired for the array. ! Both vectors must be arranged in descending order. ! The elements of R must be between 0 and N. ! The elements of C must be between 0 and M. ! ! Output, integer A(M,N), the M by N matrix with the given row and ! column sums. ! Each entry of A is 0 or 1. ! ! Output, integer IERROR, an error flag. ! 0, no error was encountered, and the array was computed. ! 1, R and C do not have the same total. ! 2, R is not monotone decreasing, or has illegal entries. ! 3, C is not monotone decreasing, or has illegal entries. ! 4, R and C are not a possible set of row and column sums. ! implicit none ! integer m integer n ! integer a(m,n) integer c(n) integer c_sum integer i integer ierror logical ivec_descends integer ivec_imax_last integer j integer k integer r(m) integer r_conj(n) integer r_sum integer r2(m) ! a(1:m,1:n) = 0 ! ! Check conditions. ! ierror = 0 if ( sum ( r(1:m) ) /= sum ( c(1:n) ) ) then ierror = 1 return end if if ( .not. ivec_descends ( m, r ) ) then ierror = 2 return end if if ( r(1) > n .or. r(m) < 0 ) then ierror = 2 return end if if ( .not. ivec_descends ( n, c ) ) then ierror = 3 return end if if ( c(1) > m .or. c(n) < 0 ) then ierror = 3 return end if ! ! Compute the conjugate of R. ! r_conj(1:n) = 0 do i = 1, m do j = 1, r(i) r_conj(j) = r_conj(j) + 1 end do end do ! ! C must be majorized by R_CONJ. ! r_sum = 0 c_sum = 0 do i = 1, n r_sum = r_sum + r_conj(i) c_sum = c_sum + c(i) if ( c_sum > r_sum ) then ierror = 4 return end if end do ! ! We need a temporary copy of R that we can decrement. ! r2(1:m) = r(1:m) do j = n, 1, -1 i = ivec_imax_last ( m, r2 ) do k = 1, c(j) ! ! By adding 1 rather than setting A(I,J) to 1, we were able to spot ! an error where the index was "sticking". ! a(i,j) = a(i,j) + 1 r2(i) = r2(i) - 1 ! ! There's a special case you have to watch out for. ! If I was 1, and when you decrement R2(1), I is going to be 1 again, ! and you're staying in the same column, that's not good. ! if ( i > 1 ) then i = i - 1 else i = ivec_imax_last ( m, r2 ) if ( i == 1 .and. k < c(j) ) then i = 1 + ivec_imax_last ( m-1, r2(2:m) ) end if end if end do end do return end subroutine imat_01_rowcolsum2 ( m, n, r, c, a, ierror ) ! !******************************************************************************* ! !! IMAT_01_ROWCOLSUM2 creates a 0/1 matrix with given row and column sums. ! ! ! Discussion: ! ! This routine uses network flow optimization to compute the results. ! ! Given an M vector R and N vector C, there may exist one or more ! M by N matrices with entries that are 0 or 1, whose row sums are R ! and column sums are C. ! ! For convenience, this routine requires that the entries of R and C ! be given in nonincreasing order. ! ! There are several requirements on R and C. The simple requirements ! are that the entries of R and C must be nonnegative, that the entries ! of R must each no greater than N, and those of C no greater than M, ! and that the sum of the entries of R must equal the sum of the ! entries of C. ! ! The final technical requirement is that if we form R*, the conjugate ! partition of R, then C is majorized by R*, that is, that every partial ! sum from 1 to K of the entries of C is no bigger than the sum of the same ! entries of R*, for every K from 1 to N. ! ! Given these conditions on R and C, there is at least one 0/1 matrix ! with the given row and column sums. ! ! The conjugate partition of R is constructed as follows: ! R*(1) is the number of entries of R that are 1 or greater. ! R*(2) is the number of entries of R that are 2 or greater. ! ... ! R*(N) is the number of entries of R that are N (can't be greater). ! ! Example: ! ! M = N = 5 ! R = ( 3, 2, 2, 1, 1 ) ! C = ( 2, 2, 2, 2, 1 ) ! ! A = ! 1 0 1 0 1 ! 1 0 0 1 0 ! 0 1 0 1 0 ! 0 1 0 0 0 ! 0 0 1 0 0 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! J H van Lint and R M Wilson, ! A Course in Combinatorics, ! Oxford, 1992, pages 148-156. ! ! James Sandeson, ! Testing Ecological Patterns, ! American Scientist, ! Volume 88, July-August 2000, pages 332-339. ! ! Modified: ! ! 27 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the array. ! These values do not have to be equal. ! ! Input, integer R(M), C(N), the row and column sums desired for the array. ! Both vectors must be arranged in descending order. ! The elements of R must be between 0 and N. ! The elements of C must be between 0 and M. ! One of the conditions for a solution to exist is that the sum of the ! elements in R equal the sum of the elements in C. ! ! Output, integer A(M,N), the matrix with the given row and column sums. ! Each entry of A is 0 or 1. ! ! Output, integer IERROR, an error flag. ! 0, no error was encountered, and the array was computed. ! 1, R and C are not consistent. A partial solution may be constructed. ! implicit none ! integer m integer n ! integer a(m,n) integer c(n) integer capflo(2,2*(m+m*n+n)) integer flow(2*(m+m*n+n)) integer i integer icut(m+n+2) integer iendpt(2,2*(m+m*n+n)) integer ierror integer isink integer isorce integer j integer k integer nedge integer nnode integer node_flow(m+n+2) integer r(m) ! ierror = 0 ! ! There are M + N + 2 nodes. The last two are the special source and sink. ! isorce = m + n + 1 isink = m + n + 2 nnode = m + n + 2 ! ! The source is connected to each of the R nodes. ! k = 0 do i = 1, m k = k + 1 iendpt(1,k) = isorce iendpt(2,k) = i capflo(1,k) = r(i) capflo(2,k) = 0 k = k + 1 iendpt(1,k) = i iendpt(2,k) = isorce capflo(1,k) = r(i) capflo(2,k) = 0 end do ! ! Every R node is connected to every C node, with capacity 1. ! do i = 1, m do j = 1, n k = k + 1 iendpt(1,k) = i iendpt(2,k) = j+m capflo(1,k) = 1 capflo(2,k) = 0 k = k + 1 iendpt(1,k) = j+m iendpt(2,k) = i capflo(1,k) = 1 capflo(2,k) = 0 end do end do ! ! Every C node is connected to the sink. ! do j = 1, n k = k + 1 iendpt(1,k) = j+m iendpt(2,k) = isink capflo(1,k) = c(j) capflo(2,k) = 0 k = k + 1 iendpt(1,k) = isink iendpt(2,k) = j+m capflo(1,k) = c(j) capflo(2,k) = 0 end do ! ! Determine the maximum flow on the network. ! nedge = k call network_flow_max ( nnode, nedge, iendpt, capflo, isorce, isink, & icut, node_flow ) ! ! We have a perfect solution if, and only if, the edges leading from the ! source, and the edges leading to the sink, are all saturated. ! do k = 1, nedge i = iendpt(1,k) j = iendpt(2,k) - m if ( i <= m .and. 1 <= j .and. j <= n ) then if ( capflo(2,k) /= 0 .and. capflo(2,k) /= 1 ) then ierror = 1 end if end if if ( iendpt(1,k) == isorce ) then if ( capflo(1,k) /= capflo(2,k) ) then ierror = 1 end if end if if ( iendpt(2,k) == isink ) then if ( capflo(1,k) /= capflo(2,k) ) then ierror = 1 end if end if end do ! ! If we have a solution, then A(I,J) = the flow on the edge from ! R node I to C node J. ! a(1:m,1:n) = 0 do k = 1, nedge i = iendpt(1,k) j = iendpt(2,k) - m if ( i <= m .and. 1 <= j .and. j <= n ) then a(i,j) = capflo(2,k) end if end do return end subroutine imat_inverse ( n, a, b ) ! !******************************************************************************* ! !! IMAT_INVERSE inverts a unit upper triangular matrix. ! ! ! Discussion: ! ! A unit upper triangular matrix is a matrix with only 1's on the main ! diagonal, and only 0's below the main diagonal. Above the main ! diagonal, the entries may be assigned any value. ! ! It may be surprising to note that the inverse of an integer unit upper ! triangular matrix is also an integer unit upper triangular matrix. ! ! Note that this routine can invert a matrix in place, that is, with no ! extra storage. If the matrix is stored in A, then the call ! ! call imat_inverse ( n, a, a ) ! ! will result in A being overwritten by its inverse, which can ! save storage if the original value of A is not needed later. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 05 March 1999 ! ! Parameters: ! ! Input, integer N, number of rows and columns in matrix. ! ! Input, integer A(N,N). Unit upper triangular matrix ! to be inverted. ! ! Output, integer B(N,N), the inverse matrix. ! implicit none ! integer n ! integer a(n,n) integer b(n,n) integer i integer isum integer j integer k ! do j = n, 1, -1 do i = n, 1, -1 if ( i == j ) then isum = 1 else isum = 0 end if do k = i + 1, j isum = isum - a(i,k) * b(k,j) end do b(i,j) = isum end do end do return end subroutine imat_perm ( n, a, p ) ! !******************************************************************************* ! !! IMAT_PERM permutes the rows and columns of a square integer matrix. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 27 July 2000 ! ! Parameters: ! ! Input, integer N, the order of the matrix. ! ! Input/output, integer A(N,N). ! On input, the matrix to be permuted. ! On output, the permuted matrix. ! ! Input, integer P(N), the permutation. P(I) is the new number of row ! and column I. ! implicit none ! integer n ! integer a(n,n) integer i integer i1 integer is integer it integer j integer j1 integer j2 integer k integer lc integer nc integer p(n) ! call perm_cycle ( n, p, is, nc, 1 ) do i = 1, n i1 = - p(i) if ( i1 > 0 ) then lc = 0 do i1 = p(i1) lc = lc + 1 if ( i1 <= 0 ) then exit end if end do i1 = i do j = 1, n if ( p(j) <= 0 ) then j2 = j k = lc do j1 = j2 it = a(i1,j1) do i1 = abs ( p(i1) ) j1 = abs ( p(j1) ) call i_swap ( a(i1,j1), it ) if ( j1 /= j2 ) then cycle end if k = k - 1 if ( i1 == i ) then exit end if end do j2 = abs ( p(j2) ) if ( k == 0 ) then exit end if end do end if end do end if end do ! ! Restore the positive signs of the data. ! p(1:n) = abs ( p(1:n) ) return end subroutine imat_perm2 ( m, n, a, p, q ) ! !******************************************************************************* ! !! IMAT_PERM2 permutes the rows and columns of a rectangular integer matrix. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 28 October 1999 ! ! Parameters: ! ! Input, integer M, number of rows in the matrix. ! ! Input, integer N, number of columns in the matrix. ! ! Input/output, integer A(M,N). ! On input, the matrix to be permuted. ! On output, the permuted matrix. ! ! Input, integer P(M), the row permutation. P(I) is the new number of row I. ! ! Input, integer Q(N). The column permutation. Q(I) is the new number ! of column I. Note that this routine allows you to pass a single array ! as both P and Q. ! implicit none ! integer m integer n ! integer a(m,n) integer i integer i1 integer is integer it integer j integer j1 integer j2 integer k integer lc integer nc integer p(m) integer q(n) ! call perm_cycle ( m, p, is, nc, 1 ) if ( q(1) > 0 ) then call perm_cycle ( n, q, is, nc, 1 ) end if do i = 1, m i1 = - p(i) if ( i1 > 0 ) then lc = 0 do i1 = p(i1) lc = lc + 1 if ( i1 <= 0 ) then exit end if end do i1 = i do j = 1, n if ( q(j) <= 0 ) then j2 = j k = lc do j1 = j2 it = a(i1,j1) do i1 = abs ( p(i1) ) j1 = abs ( q(j1) ) call i_swap ( a(i1,j1), it ) if ( j1 /= j2 ) then cycle end if k = k - 1 if ( i1 == i ) then exit end if end do j2 = abs ( q(j2) ) if ( k == 0 ) then exit end if end do end if end do end if end do ! ! Restore the positive signs of the data. ! p(1:m) = abs ( p(1:m) ) if ( q(1) <= 0 ) then q(1:n) = abs ( q(1:n) ) end if return end subroutine imat_print ( m, n, a, title ) ! !******************************************************************************* ! !! IMAT_PRINT prints an integer matrix. ! ! ! Modified: ! ! 08 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A. ! ! Input, integer A(M,N), the matrix to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer m integer n ! integer a(m,n) integer i integer j integer jhi integer jlo character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) title end if do jlo = 1, n, 10 jhi = min ( jlo + 9, n ) write ( *, '(a)' ) ' ' write ( *, '(6x,10(i7))' ) ( j, j = jlo, jhi ) write ( *, '(a)' ) ' ' do i = 1, m write ( *, '(i6,10i7)' ) i, a(i,jlo:jhi) end do end do return end subroutine index_box2_next_2d ( n1, n2, ic, jc, i, j, more ) ! !******************************************************************************* ! !! INDEX_BOX2_NEXT_2D produces indices on the surface of a box in 2D. ! ! ! Discussion: ! ! The box is has center at (IC,JC), and has half-widths N1 and N2. ! The indices are exactly those which are between (IC-N1,JC-N1) and ! (IC+N1,JC+N2) with the property that at least one of I and J ! is an "extreme" value. ! ! Modified: ! ! 14 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N1, N2, the half-widths of the box, that is, the ! maximum distance allowed between (IC,JC) and (I,J). ! ! Input, integer IC, JC, the central cell of the box. ! ! Input/output, integer I, J. On input, the previous index set. ! On output, the next index set. On the first call, MORE should ! be set to FALSE, and the input values of I and J are ignored. ! ! Input/output, logical MORE. ! On the first call for a given box, the user should set MORE to FALSE. ! On return, the routine sets MORE to TRUE. ! When there are no more indices, the routine sets MORE to FALSE. ! implicit none ! integer i integer ic integer j integer jc logical more integer n1 integer n2 ! if ( .not. more ) then more = .true. i = ic - n1 j = jc - n2 return end if if ( i == ic + n1 .and. j == jc + n2 ) then more = .false. return end if ! ! Increment J. ! j = j + 1 ! ! Check J. ! if ( j > jc + n2 ) then j = jc - n2 i = i + 1 else if ( j < jc + n2 .and. ( i == ic - n1 .or. i == ic + n1 ) ) then return else j = jc + n2 return end if return end subroutine index_box2_next_3d ( n1, n2, n3, ic, jc, kc, i, j, k, more ) ! !******************************************************************************* ! !! INDEX_BOX2_NEXT_3D produces indices on the surface of a box in 3D. ! ! ! Discussion: ! ! The box has a central cell of (IC,JC,KC), with a half widths of ! (N1,N2,N3). The indices are exactly those between (IC-N1,JC-N2,KC-N3) and ! (IC+N1,JC+N2,KC+N3) with the property that at least one of I, J, and K ! is an "extreme" value. ! ! Modified: ! ! 14 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N1, N2, N3, the "half widths" of the box, that is, the ! maximum distances from the central cell allowed for I, J and K. ! ! Input, integer IC, JC, KC, the central cell of the box. ! ! Input/output, integer I, J, K. On input, the previous index set. ! On output, the next index set. On the first call, MORE should ! be set to FALSE, and the input values of I, J, and K are ignored. ! ! Input/output, logical MORE. ! On the first call for a given box, the user should set MORE to FALSE. ! On return, the routine sets MORE to TRUE. ! When there are no more indices, the routine sets MORE to FALSE. ! implicit none ! integer i integer ic integer j integer jc integer k integer kc logical more integer n1 integer n2 integer n3 ! if ( .not. more ) then more = .true. i = ic - n1 j = jc - n2 k = kc - n3 return end if if ( i == ic + n1 .and. j == jc + n2 .and. k == kc + n3 ) then more = .false. return end if ! ! Increment K. ! k = k + 1 ! ! Check K. ! if ( k > kc + n3 ) then k = kc - n3 j = j + 1 else if ( k < kc + n3 .and. & ( i == ic - n1 .or. i == ic + n1 .or. & j == jc - n2 .or. j == jc + n2 ) ) then return else k = kc + n3 return end if ! ! Check J. ! if ( j > jc + n2 ) then j = jc - n2 i = i + 1 else if ( j < jc + n2 .and. & ( i == ic - n1 .or. i == ic + n1 .or. & k == kc - n3 .or. k == kc + n3 ) ) then return else j = jc + n2 return end if return end subroutine index_box_next_2d ( n1, n2, i, j, more ) ! !******************************************************************************* ! !! INDEX_BOX_NEXT_2D produces indices on the surface of a box in 2D. ! ! ! Discussion: ! ! The indices are exactly those which are between (1,1) and ! (N1,N2) with the property that at least one of I and J ! is an "extreme" value. ! ! Modified: ! ! 13 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N1, N2, the "dimensions" of the box, that is, the ! maximum values allowed for I and J. The minimum values are ! assumed to be 1. ! ! Input/output, integer I, J. On input, the previous index set. ! On output, the next index set. On the first call, MORE should ! be set to FALSE, and the input values of I and J are ignored. ! ! Input/output, logical MORE. ! On the first call for a given box, the user should set MORE to FALSE. ! On return, the routine sets MORE to TRUE. ! When there are no more indices, the routine sets MORE to FALSE. ! implicit none ! integer i integer j logical more integer n1 integer n2 ! if ( .not. more ) then more = .true. i = 1 j = 1 return end if if ( i == n1 .and. j == n2 ) then more = .false. return end if ! ! Increment J. ! j = j + 1 ! ! Check J. ! if ( j > n2 ) then j = 1 i = i + 1 else if ( j < n2 .and. ( i == 1 .or. i == n1 ) ) then return else j = n2 return end if return end subroutine index_box_next_3d ( n1, n2, n3, i, j, k, more ) ! !******************************************************************************* ! !! INDEX_BOX_NEXT_3D produces indices on the surface of a box in 3D. ! ! ! Discussion: ! ! The indices are exactly those which are between (1,1,1) and ! (N1,N2,N3) with the property that at least one of I, J, and K ! is an "extreme" value. ! ! Modified: ! ! 13 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N1, N2, N3, the "dimensions" of the box, that is, the ! maximum values allowed for I, J and K. The minimum values are ! assumed to be 1. ! ! Input/output, integer I, J, K. On input, the previous index set. ! On output, the next index set. On the first call, MORE should ! be set to FALSE, and the input values of I, J, and K are ignored. ! ! Input/output, logical MORE. ! On the first call for a given box, the user should set MORE to FALSE. ! On return, the routine sets MORE to TRUE. ! When there are no more indices, the routine sets MORE to FALSE. ! implicit none ! integer i integer j integer k logical more integer n1 integer n2 integer n3 ! if ( .not. more ) then more = .true. i = 1 j = 1 k = 1 return end if if ( i == n1 .and. j == n2 .and. k == n3 ) then more = .false. return end if ! ! Increment K. ! k = k + 1 ! ! Check K. ! if ( k > n3 ) then k = 1 j = j + 1 else if ( k < n3 .and. & ( i == 1 .or. i == n1 .or. j == 1 .or. j == n2 ) ) then return else k = n3 return end if ! ! Check J. ! if ( j > n2 ) then j = 1 i = i + 1 else if ( j < n2 .and. & ( i == 1 .or. i == n1 .or. k == 1 .or. k == n3 ) ) then return else j = n2 return end if return end subroutine index_next0 ( n, hi, iarray, more ) ! !******************************************************************************* ! !! INDEX_NEXT0 generates all indices within given upper limits. ! ! ! Discussion: ! ! The indices are generated in such a way that the reversed ! sequences are produced in lexicographic order. ! ! Example: ! ! N = 3, ! HI = 3 ! ! 1 2 3 ! --------- ! 1 1 1 ! 2 1 1 ! 3 1 1 ! 1 2 1 ! 2 2 1 ! 3 2 1 ! 1 3 1 ! 2 3 1 ! 3 3 1 ! 1 1 2 ! 2 1 2 ! 3 1 2 ! 1 2 2 ! 2 2 2 ! 3 2 2 ! 1 3 2 ! 2 3 2 ! 3 3 2 ! 1 1 3 ! 2 1 3 ! 3 1 3 ! 1 2 3 ! 2 2 3 ! 3 2 3 ! 1 3 3 ! 2 3 3 ! 3 3 3 ! ! Modified: ! ! 05 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer HI, the upper limit for the array indices. ! The lower limit is implicitly 1 and HI must be at least 1. ! ! Input/output, integer IARRAY(N). ! On startup calls, with MORE = .FALSE., the input value of IARRAY ! doesn't matter, because the routine initializes it. ! On calls with MORE = .TRUE., the input value of IARRAY must be ! the output value of IARRAY from the previous call. (In other words, ! just leave it alone!). ! On output, IARRAY contains the successor set of indices to the input ! value. ! ! Input/output, logical MORE. Set this variable .FALSE. before ! the first call. Normally, MORE will be returned .TRUE. but ! once all the vectors have been generated, MORE will be ! reset .FALSE. and you should stop calling the program. ! implicit none ! integer n ! integer hi integer i integer iarray(n) integer inc logical more ! if ( .not. more ) then iarray(1:n) = 1 if ( hi < 1 ) then more = .false. write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INDEX_NEXT0 - Fatal error!' write ( *, '(a,i6)' ) ' HI is ', hi write ( *, '(a)' ) ' but HI must be at least 1.' return end if else inc = 1 do while ( iarray(inc) >= hi ) iarray(inc) = 1 inc = inc + 1 end do iarray(inc) = iarray(inc) + 1 end if ! ! See if there are more entries to compute. ! more = .false. do i = 1, n if ( iarray(i) < hi ) then more = .true. end if end do return end subroutine index_next1 ( n, hi, iarray, more ) ! !******************************************************************************* ! !! INDEX_NEXT1 generates all indices within given upper limits. ! ! ! Discussion: ! ! The indices are generated in such a way that the reversed ! sequences are produced in lexicographic order. ! ! Example: ! ! N = 3, ! HI(1) = 4, HI(2) = 2, HI(3) = 3 ! ! 1 2 3 ! --------- ! 1 1 1 ! 2 1 1 ! 3 1 1 ! 4 1 1 ! 1 2 1 ! 2 2 1 ! 3 2 1 ! 4 2 1 ! 1 1 2 ! 2 1 2 ! 3 1 2 ! 4 1 2 ! 1 2 2 ! 2 2 2 ! 3 2 2 ! 4 2 2 ! 1 1 3 ! 2 1 3 ! 3 1 3 ! 4 1 3 ! 1 2 3 ! 2 2 3 ! 3 2 3 ! 4 2 3 ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer HI(N), the upper limits for the array indices. ! The lower limit is implicitly 1, and each HI(I) should be at least 1. ! ! Input/output, integer IARRAY(N). ! On startup calls, with MORE = .FALSE., the input value of IARRAY ! doesn't matter, because the routine initializes it. ! On calls with MORE = .TRUE., the input value of IARRAY must be ! the output value of IARRAY from the previous call. (In other words, ! just leave it alone!). ! On output, IARRAY contains the successor set of indices to the input ! value. ! ! Input/output, logical MORE. Set this variable .FALSE. before ! the first call. Normally, MORE will be returned .TRUE. but ! once all the vectors have been generated, MORE will be ! reset .FALSE. and you should stop calling the program. ! implicit none ! integer n ! integer hi(n) integer i integer iarray(n) integer inc logical more ! if ( .not. more ) then iarray(1:n) = 1 do i = 1, n if ( hi(i) < 1 ) then more = .false. write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INDEX_NEXT1 - Fatal error!' write ( *, '(a,i6,a,i6)' ) ' Entry ', i, ' of HI is ', hi(i) write ( *, '(a)' ) ' but all entries must be at least 1.' return end if end do else inc = 1 do while ( iarray(inc) >= hi(inc) ) iarray(inc) = 1 inc = inc + 1 end do iarray(inc) = iarray(inc) + 1 end if ! ! See if there are more entries to compute. ! more = .false. do i = 1, n if ( iarray(i) < hi(i) ) then more = .true. end if end do return end subroutine index_next2 ( n, lo, hi, iarray, more ) ! !******************************************************************************* ! !! INDEX_NEXT2 generates all indices within given lower and upper limits. ! ! ! Example: ! ! N = 3, ! LO(1) = 1, LO(2) = 10, LO(3) = 4 ! HI(1) = 2, HI(2) = 11, HI(3) = 6 ! ! 1 2 3 ! --------- ! 1 10 4 ! 2 10 4 ! 1 11 4 ! 2 11 4 ! 1 10 5 ! 2 10 5 ! 1 11 5 ! 2 11 5 ! 1 10 6 ! 2 10 6 ! 1 11 6 ! 2 11 6 ! ! Modified: ! ! 21 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. The rank of ! the object being indexed. ! ! Input, integer LO(N), HI(N), the lower and upper limits for the array ! indices. LO(I) should be less than or equal to HI(I), for each I. ! ! Input/output, integer IARRAY(N). ! On startup calls, with MORE = .FALSE., the input value of IARRAY ! doesn't matter, because the routine initializes it. ! On calls with MORE = .TRUE., the input value of IARRAY must be ! the output value of IARRAY from the previous call. (In other words, ! just leave it alone!). ! On output, IARRAY contains the successor set of indices to the input ! value. ! ! Input/output, logical MORE. Set this variable .FALSE. before ! the first call. Normally, MORE will be returned .TRUE. but ! once all the vectors have been generated, MORE will be ! reset .FALSE. and you should stop calling the program. ! implicit none ! integer n ! integer hi(n) integer i integer iarray(n) integer inc integer lo(n) logical more ! if ( .not. more ) then iarray(1:n) = lo(1:n) do i = 1, n if ( hi(i) < lo(i) ) then more = .false. write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INDEX_NEXT2 - Fatal error!' write ( *, '(a,i6,a,i6)' ) ' Entry ', i, ' of HI is ', hi(i) write ( *, '(a,i6,a,i6)' ) ' Entry ', i, ' of LO is ', lo(i) write ( *, '(a)' ) ' but LO(I) <= HI(I) is required.' return end if end do else inc = 1 do while ( iarray(inc) >= hi(inc) ) iarray(inc) = lo(inc) inc = inc + 1 end do iarray(inc) = iarray(inc) + 1 end if ! ! See if there are more entries to compute. ! more = .false. do i = 1, n if ( iarray(i) < hi(i) ) then more = .true. end if end do return end subroutine index_rank0 ( n, hi, iarray, rank ) ! !******************************************************************************* ! !! INDEX_RANK0 ranks an index within given upper limits. ! ! ! Example: ! ! N = 3, ! HI = 3 ! IARRAY = ( 3, 1, 2 ) ! ! RANK = 12 ! ! Modified: ! ! 05 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer HI, the upper limit for the array indices. ! The lower limit is implicitly 1, and HI should be at least 1. ! ! Input, integer IARRAY(N), the index to be ranked. ! ! Output, integer RANK, the rank of the index, or -1 if IARRAY ! is not a legal index. ! implicit none ! integer n ! integer hi integer i integer iarray(n) integer range integer rank ! rank = - 1 do i = 1, n if ( iarray(i) < 1 .or. iarray(i) > hi ) then return end if end do rank = 0 do i = n, 1, -1 rank = hi * rank + iarray(i) end do rank = 1 range = 1 do i = 1, n rank = rank + ( iarray(i) - 1 ) * range range = range * hi end do return end subroutine index_rank1 ( n, hi, iarray, rank ) ! !******************************************************************************* ! !! INDEX_RANK1 ranks an index within given upper limits. ! ! ! Example: ! ! N = 3, ! HI(1) = 4, HI(2) = 2, HI(3) = 3 ! IARRAY = ( 4, 1, 2 ) ! ! RANK = 12 ! ! Modified: ! ! 22 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer HI(N), the upper limits for the array indices. ! The lower limit is implicitly 1, and each HI(I) should be at least 1. ! ! Input, integer IARRAY(N), the index to be ranked. ! ! Output, integer RANK, the rank of the index, or -1 if IARRAY ! is not a legal index. ! implicit none ! integer n ! integer hi(n) integer i integer iarray(n) integer range integer rank ! rank = - 1 do i = 1, n if ( iarray(i) < 1 .or. iarray(i) > hi(i) ) then return end if end do rank = 0 do i = n, 1, -1 rank = hi(i) * rank + iarray(i) end do rank = 1 range = 1 do i = 1, n rank = rank + ( iarray(i) - 1 ) * range range = range * hi(i) end do return end subroutine index_rank2 ( n, lo, hi, iarray, rank ) ! !******************************************************************************* ! !! INDEX_RANK2 ranks an index within given lower and upper limits. ! ! ! Example: ! ! N = 3, ! LO(1) = 1, LO(2) = 10, LO(3) = 4 ! HI(1) = 2, HI(2) = 11, HI(3) = 6 ! IARRAY = ( 1, 11, 5 ) ! ! RANK = 7 ! ! Modified: ! ! 22 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer LO(N), HI(N), the lower and upper limits for the array ! indices. LO(I) should be less than or equal to HI(I), for each I. ! ! Input, integer IARRAY(N), the index to be ranked. ! ! Output, integer RANK, the rank of the index, or -1 if IARRAY ! is not a legal index. ! implicit none ! integer n ! integer hi(n) integer i integer iarray(n) integer lo(n) integer range integer rank ! rank = - 1 do i = 1, n if ( iarray(i) < lo(i) .or. iarray(i) > hi(i) ) then return end if end do rank = 1 range = 1 do i = 1, n rank = rank + ( iarray(i) - lo(i) ) * range range = range * ( hi(i) + 1 - lo(i) ) end do return end subroutine index_unrank0 ( n, hi, rank, iarray ) ! !******************************************************************************* ! !! INDEX_UNRANK0 unranks an index within given upper limits. ! ! ! Example: ! ! N = 3, ! HI = 3 ! RANK = 12 ! ! IARRAY = ( 3, 1, 2 ) ! ! Modified: ! ! 05 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer HI, the upper limit for the array indices. ! The lower limit is implicitly 1, and HI should be at least 1. ! ! Input, integer RANK, the rank of the desired index. ! ! Output, integer IARRAY(N), the index of the given rank. ! implicit none ! integer n ! integer hi integer i integer iarray(n) integer j integer k integer range integer rank ! iarray(1:n) = 0 ! ! The rank might be too small. ! if ( rank < 1 ) then return end if range = hi**n ! ! The rank might be too large. ! if ( rank > range ) then return end if k = rank - 1 do i = n, 1, -1 range = range / hi j = k / range iarray(i) = j + 1 k = k - j * range end do return end subroutine index_unrank1 ( n, hi, rank, iarray ) ! !******************************************************************************* ! !! INDEX_UNRANK1 unranks an index within given upper limits. ! ! ! Example: ! ! N = 3, ! HI(1) = 4, HI(2) = 2, HI(3) = 3 ! RANK = 11 ! ! IARRAY = ( 3, 1, 2 ) ! ! Modified: ! ! 24 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer HI(N), the upper limits for the array indices. ! The lower limit is implicitly 1, and each HI(I) should be at least 1. ! ! Input, integer RANK, the rank of the desired index. ! ! Output, integer IARRAY(N), the index of the given rank. ! implicit none ! integer n ! integer hi(n) integer i integer iarray(n) integer j integer k integer range integer rank ! iarray(1:n) = 0 ! ! The rank might be too small. ! if ( rank < 1 ) then return end if range = product ( hi ) ! ! The rank might be too large. ! if ( rank > range ) then return end if k = rank - 1 do i = n, 1, -1 range = range / hi(i) j = k / range iarray(i) = j + 1 k = k - j * range end do return end subroutine index_unrank2 ( n, lo, hi, rank, iarray ) ! !******************************************************************************* ! !! INDEX_UNRANK2 unranks an index within given lower and upper limits. ! ! ! Example: ! ! N = 3, ! LO(1) = 1, LO(2) = 10, LO(3) = 4 ! HI(1) = 2, HI(2) = 11, HI(3) = 6 ! RANK = 7 ! ! IARRAY = ( 1, 11, 5 ) ! ! Modified: ! ! 24 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in IARRAY. ! ! Input, integer LO(N), HI(N), the lower and upper limits for the array ! indices. It should be the case that LO(I) <= HI(I) for each I. ! ! Input, integer RANK, the rank of the desired index. ! ! Output, integer IARRAY(N), the index of the given rank. ! implicit none ! integer n ! integer hi(n) integer i integer iarray(n) integer j integer k integer lo(n) integer range integer rank ! iarray(1:n) = 0 ! ! The rank might be too small. ! if ( rank < 1 ) then return end if range = 1 do i = 1, n range = range * ( hi(i) + 1 - lo(i) ) end do ! ! The rank might be too large. ! if ( rank > range ) then return end if k = rank - 1 do i = n, 1, -1 range = range / ( hi(i) + 1 - lo(i) ) j = k / range iarray(i) = j + lo(i) k = k - j * range end do return end subroutine ins_perm ( n, ins, p ) ! !******************************************************************************* ! !! INS_PERM computes a permutation from its inversion sequence. ! ! ! Definition: ! ! For a given permutation P acting on objects 1 through N, the ! inversion sequence INS is defined as: ! ! INS(1) = 0 ! INS(I) = number of values J < I for which P(J) > P(I). ! ! Example: ! ! Input: ! ! ( 0, 0, 2, 1, 3 ) ! ! Output: ! ! ( 3, 5, 1, 4, 2 ) ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 17 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer INS(N), the inversion sequence of a permutation. ! It must be the case that 0 <= INS(I) < I for I = 1 to N. ! ! Output, integer P(N), the permutation. ! implicit none ! integer n ! integer i integer ins(n) integer itemp integer j integer p(n) ! call ivec_identity ( n, p ) do i = n, 2, -1 itemp = p(i-ins(i)) do j = i-ins(i), i-1 p(j) = p(j+1) end do p(i) = itemp end do return end subroutine intp_conj ( iarray1, mult1, npart1, iarray2, mult2, npart2, n ) ! !******************************************************************************* ! !! INTP_CONJ computes the conjugate of a partition. ! ! ! Definition: ! ! A partition of an integer N is a set of positive integers which ! add up to N. The conjugate of a partition P1 of N is another partition ! P2 of N obtained in the following way: ! ! The first element of P2 is the number of parts of P1 greater than ! or equal to 1. ! ! The K-th element of P2 is the number of parts of P1 greater than ! or equal to K. ! ! Clearly, P2 will have no more than N elements; it may be surprising ! to find that P2 is guaranteed to be a partition of N. However, if ! we symbolize the initial partition P1 by rows of X's, then we can ! see that P2 is simply produced by grouping by columns: ! ! 6 3 2 2 1 ! 5 X X X X X ! 4 X X X X ! 2 X X ! 1 X ! 1 X ! 1 X ! ! Example: ! ! 14 = 5 + 4 + 2 + 1 + 1 + 1 ! ! The conjugate partition is: ! ! 14 = 6 + 3 + 2 + 2 + 1 ! ! Modified: ! ! 20 May 1999 ! ! Author: ! ! John Burkardt ! ! Parameters ! ! Input, integer IARRAY1(NPART1). IARRAY1 contains the parts of ! the partition. The value of N is represented by ! ! sum ( 1 <= I <= NPART1 ) MULT1(I) * IARRAY1(I). ! ! Intput, integer MULT1(NPART1). MULT1 counts the multiplicity of ! the parts of the partition. MULT1(I) is the multiplicity ! of the part IARRAY1(I), for I = 1 to NPART1. ! ! Input, integer N, the integer to be partitioned. ! ! Input, integer NPART1, the number of "parts" in the partition. ! ! Output, integer IARRAY2(N). IARRAY contains the parts of ! the conjugate partition in entries 1 through NPART2. ! ! Output, integer MULT2(N). MULT2 counts the multiplicity of ! the parts of the conjugate partition in entries 1 through NPART2. ! ! Output, integer NPART2, the number of "parts" in the conjugate partition. ! ! Input, integer N, the integer to be partitioned. ! implicit none ! integer n integer npart1 ! integer i integer iarray1(npart1) integer iarray2(n) integer itemp integer itest integer mult1(npart1) integer mult2(n) integer npart2 ! iarray2(1:n) = 0 mult2(1:n) = 0 npart2 = 0 itest = 0 do itest = itest + 1 itemp = 0 do i = 1, npart1 if ( iarray1(i) >= itest ) then itemp = itemp + mult1(i) end if end do if ( itemp <= 0 ) then exit end if if ( npart2 > 0 ) then if ( itemp == iarray2(npart2) ) then mult2(npart2) = mult2(npart2) + 1 else npart2 = npart2 + 1 iarray2(npart2) = itemp mult2(npart2) = 1 end if else npart2 = npart2 + 1 iarray2(npart2) = itemp mult2(npart2) = 1 end if end do return end subroutine intp_enum ( n, p ) ! !******************************************************************************* ! !! INTP_ENUM computes the number of partitions of an integer. ! ! ! Method: ! ! Partition numbers are difficult to compute. This routine uses ! Euler's method, which observes that: ! ! P(0) = 1 ! P(N) = P(N-1) + P(N-2) ! - P(N-5) - P(N-7) ! + P(N-12) + P(N-15) ! - ... ! where the numbers subtracted from N are the pentagonal numbers, ! (with both positive and negative indices) with the computation ! stopping when a negative index is reached. ! ! First values: ! ! N P ! ! 0 1 ! 1 1 ! 2 2 ! 3 3 ! 4 5 ! 5 7 ! 6 11 ! 7 15 ! 8 22 ! 9 30 ! 10 42 ! ! Reference: ! ! John Conway and Richard Guy, ! The Book of Numbers, ! Springer Verlag, 1996, page 95. ! ! Modified: ! ! 18 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the index of the highest partition number desired. ! ! Output, integer P(0:N), the partition numbers. ! implicit none ! integer n ! integer i integer j integer p(0:n) integer pj integer sgn ! p(0) = 1 do i = 1, n p(i) = 0 j = 0 sgn = 1 do j = j + 1 call pent_enum ( j, pj ) if ( pj > i ) then exit end if p(i) = p(i) + sgn * p(i-pj) sgn = - sgn end do j = 0 sgn = 1 do j = j - 1 call pent_enum ( j, pj ) if ( pj > i ) then exit end if p(i) = p(i) + sgn * p(i-pj) sgn = - sgn end do end do return end subroutine intp_next ( done, iarray, mult, n, npart ) ! !******************************************************************************* ! !! INTP_NEXT generates the partitions of an integer, one at a time. ! ! ! Comments: ! ! The number of partitions of N is: ! ! 1 1 ! 2 2 ! 3 3 ! 4 5 ! 5 7 ! 6 11 ! 7 15 ! 8 22 ! 9 30 ! 10 42 ! 11 56 ! 12 77 ! 13 101 ! 14 135 ! 15 176 ! 16 231 ! 17 297 ! 18 385 ! 19 490 ! 20 627 ! 21 792 ! 22 1002 ! 23 1255 ! 24 1575 ! 25 1958 ! 26 2436 ! 27 3010 ! 28 3718 ! 29 4565 ! 30 5604 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input/output, logical DONE. ! ! On first call, the user should set DONE to .TRUE. to signal ! that the program should initialize data. ! ! On each return, the programs sets DONE to .FALSE. if it ! has another partition to return. If the program returns ! with DONE .TRUE., then there are no more partitions. ! ! Output, integer IARRAY(N). IARRAY contains the parts of ! the partition. The value of N is represented by ! ! sum ( 1 <= I <= NPART ) MULT(I) * IARRAY(I). ! ! Output, integer MULT(N). MULT counts the multiplicity of ! the parts of the partition. MULT(I) is the multiplicity ! of the part IARRAY(I), for I = 1 to NPART. ! ! Input, integer N, the integer to be partitioned. ! ! Output, integer NPART, the number of "parts" in the partition. ! implicit none ! integer n ! logical done integer i integer iarray(n) integer is integer iu integer iv integer iw integer k integer k1 integer mult(n) integer npart ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'INTP_NEXT - Fatal error!' write ( *, '(a)' ) ' N must be positive.' write ( *, '(a,i6)' ) ' The input value of N was ', n stop end if if ( done ) then iarray(1) = n iarray(2:n) = 0 mult(1) = 1 mult(2:n) = 0 npart = 1 done = .false. else if ( iarray(npart) > 1 .or. npart > 1 ) then done = .false. if ( iarray(npart) == 1 ) then is = iarray(npart-1) + mult(npart) k = npart - 1 else is = iarray(npart) k = npart end if iw = iarray(k) - 1 iu = is / iw iv = mod ( is, iw ) mult(k) = mult(k) - 1 if ( mult(k) == 0 ) then k1 = k else k1 = k + 1 end if mult(k1) = iu iarray(k1) = iw if ( iv == 0 ) then npart = k1 else mult(k1+1) = 1 iarray(k1+1) = iv npart = k1 + 1 end if else done = .true. end if end if return end subroutine intp_next2 ( n, iarray, mult, npart, more ) ! !******************************************************************************* ! !! INTP_NEXT2 computes the partitions of the integer N one at a time. ! ! ! Discussion: ! ! Unlike compositions, order is not important in a partition. Thus ! the sequences 3+2+1 and 1+2+3 represent distinct compositions, but ! not distinct partitions. Also 0 is never returned as one of the ! elements of the partition. ! ! Examples: ! ! Sample partitions of 6 include: ! ! 6 = 4+1+1 = 3+2+1 = 2+2+2 ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the integer whose partitions are desired. ! ! Output, integer IARRAY(N). IARRAY(I) is the I-th distinct part ! of the partition, for I = 1, NPART. Note that if a certain number ! shows up several times in the partition, it is listed only ! once in IARRAY, and its multiplicity is counted in MULT. ! ! Output, integer MULT(N). MULT(I) is the multiplicity of IARRAY(I) ! in the partition, for I = 1, NPART; that is, the number of repeated ! times that IARRAY(I) is used in the partition. ! ! Output, integer NPART, the number of distinct, nonzero parts in the ! output partition. ! ! Input/output, logical MORE. Set MORE = .FALSE. on first call. It ! will be reset .TRUE. on return with the first partition. ! Keep calling for more partitions until MORE ! is returned .FALSE. ! implicit none ! integer n ! integer iarray(n) integer iff integer is integer isum logical more integer mult(n) integer, save :: nlast = 0 integer npart ! ! On the first call, set NLAST to 0. ! if ( .not. more ) then nlast = 0 end if if ( n /= nlast .or. ( .not. more ) ) then nlast = n npart = 1 iarray(npart) = n mult(npart) = 1 more = mult(npart) /= n return end if isum = 1 if ( iarray(npart) <= 1 ) then isum = mult(npart) + 1 npart = npart - 1 end if iff = iarray(npart) - 1 if ( mult(npart) /= 1 ) then mult(npart) = mult(npart) - 1 npart = npart + 1 end if iarray(npart) = iff mult(npart) = 1 + ( isum / iff ) is = mod ( isum, iff ) if ( is > 0 ) then npart = npart + 1 iarray(npart) = is mult(npart) = 1 end if ! ! There are more partitions, as long as we haven't just computed ! the last one, which is N copies of 1. ! more = mult(npart) /= n return end subroutine intp_random ( n, iarray, mult, npart ) ! !******************************************************************************* ! !! INTP_RANDOM selects a random partition of the integer N. ! ! ! Discussion: ! ! Note that some elements of the partition may be 0. The partition is ! returned as (MULT(I),I), with NPART nonzero entries in MULT, and ! ! N = sum ( 1 <= I <= N ) MULT(I) * I. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 29 March 2001 ! ! Parameters: ! ! Input, integer N, the integer to be partitioned. ! ! Output, integer IARRAY(N), returns the number of partitions of each ! integer from 1 to N. ! ! Output, integer MULT(N). MULT(I) is the multiplicity of I ! in the chosen partition. ! ! Output, integer NPART, the number of parts in the partition chosen, ! that is, the number of integers I with nonzero multiplicity MULT(I). ! implicit none ! integer n ! integer i integer i1 integer iarray(n) integer id integer is integer isum integer j integer m integer mult(n) integer, save :: nlast = 0 integer npart real z real, parameter :: zhi = 1.0E+00 real, parameter :: zlo = 0.0E+00 ! if ( n > nlast ) then iarray(1) = 1 m = nlast + 1 nlast = n if ( n > 1 ) then do i = m, n isum = 0 do id = 1, i is = 0 i1 = i do i1 = i1 - id if ( i1 > 0 ) then is = is + iarray(i1) else if ( i1 == 0 ) then is = is + 1 end if exit end if end do isum = isum + is * id end do iarray(i) = isum / i end do end if end if m = n npart = 0 mult(1:n) = 0 do while ( m > 0 ) call r_random ( zlo, zhi, z ) z = m * iarray(m) * z id = 0 30 continue id = id + 1 i1 = m j = 0 do j = j + 1 i1 = i1 - id if ( i1 < 0 ) then go to 30 end if if ( i1 == 0 ) then z = z - id if ( z > 0.0E+00 ) then go to 30 else exit end if end if if ( i1 > 0 ) then z = z - id * iarray(i1) if ( z <= 0.0E+00 ) then exit end if end if end do mult(id) = mult(id) + j npart = npart + j m = i1 end do return end subroutine involute_enum ( n, s ) ! !******************************************************************************* ! !! INVOLUTE_ENUM enumerates the involutions of N objects. ! ! ! Definition: ! ! An involution is a permutation consisting only of fixed points and ! pairwise transpositions. ! ! Comments: ! ! An involution is its own inverse permutation. ! ! Recursion: ! ! S(0) = 1 ! S(1) = 1 ! S(N) = S(N-1) + (N-1) * S(N-2) ! ! First values: ! ! N S(N) ! 0 1 ! 1 1 ! 2 2 ! 3 4 ! 4 10 ! 5 26 ! 6 76 ! 7 232 ! 8 764 ! 9 2620 ! 10 9496 ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Output, integer S(0:N), the number of involutions of 0, 1, 2, ... N ! objects. ! implicit none ! integer n ! integer i integer s(0:n) ! if ( n < 0 ) then return end if s(0) = 1 if ( n <= 0 ) then return end if s(1) = 1 do i = 2, n s(i) = s(i-1) + real ( i - 1 ) * s(i-2) end do return end subroutine ipoly ( n, a, x0, iopt, val ) ! !******************************************************************************* ! !! IPOLY performs operations on integer polynomials in power or factorial form. ! ! ! Discussion: ! ! The power sum form of a polynomial is ! ! P(X) = A1 + A2*X + A3*X**2 + ... + (AN+1)*X**N ! ! The Taylor expansion at C has the form ! ! P(X) = A1 + A2*(X-C) + A3*(X-C)**2 + ... + (AN+1)*(X-C)**N ! ! The factorial form of a polynomial is ! ! P(X) = A1 + A2*X + A3*(X)*(X-1) + A4*(X)*(X-1)*(X-2)+... ! + (AN+1)*(X)*(X-1)*...*(X-N+1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of coefficients in the polynomial ! (in other words, the polynomial degree + 1) ! ! Input/output, integer A(N), the coefficients of the polynomial. Depending ! on the option chosen, these coefficients may be overwritten by those ! of a different form of the polynomial. ! ! Input, integer X0, for IOPT = -1, 0, or positive, the value of the ! argument at which the polynomial is to be evaluated, or the ! Taylor expansion is to be carried out. ! ! Input, integer IOPT, a flag describing which algorithm is to ! be carried out: ! ! -3: Reverse Stirling. Input the coefficients of the polynomial in ! factorial form, output them in power sum form. ! ! -2: Stirling. Input the coefficients in power sum form, output them ! in factorial form. ! ! -1: Evaluate a polynomial which has been input in factorial form. ! ! 0: Evaluate a polynomial input in power sum form. ! ! 1 or more: Given the coefficients of a polynomial in ! power sum form, compute the first IOPT coefficients of ! the polynomial in Taylor expansion form. ! ! Output, integer VAL, for IOPT = -1 or 0, the value of the ! polynomial at the point X0. ! implicit none ! integer n ! integer a(n) integer eps integer i integer iopt integer m integer n1 integer val integer w integer x0 integer z ! n1 = min ( n, iopt ) n1 = max ( 1, n1 ) if ( iopt < -1 ) then n1 = n end if eps = mod ( max ( -iopt, 0 ), 2 ) w = - n * eps if ( iopt > -2 ) then w = w + x0 end if do m = 1, n1 val = 0 z = w do i = m, n z = z + eps val = a(n+m-i) + z * val if ( iopt /= 0 .and. iopt /= -1 ) then a(n+m-i) = val end if end do if ( iopt < 0 ) then w = w + 1 end if end do return end subroutine ipoly_cyclo ( n, phi ) ! !******************************************************************************* ! !! IPOLY_CYCLO computes a cyclotomic polynomial. ! ! ! Discussion: ! ! For N >= 1, let ! ! I = SQRT ( - 1 ) ! L = EXP ( 2 * PI * I / N ) ! ! Then the N-th cyclotomic polynomial is defined by ! ! PHI(N;X) = Product ( 1 <= K <= N and GCD(K,N) = 1 ) ( X - L**K ) ! ! We can use the Moebius MU function to write ! ! PHI(N;X) = Product ( mod ( D, N ) = 0 ) ( X**D - 1 )**MU(N/D) ! ! There is a sort of inversion formula: ! ! X**N - 1 = Product ( mod ( D, N ) = 0 ) PHI(D;X) ! ! Example: ! ! N PHI ! ! 0 1 ! 1 X - 1 ! 2 X + 1 ! 3 X**2 + X + 1 ! 4 X**2 + 1 ! 5 X**4 + X**3 + X**2 + X + 1 ! 6 X**2 - X + 1 ! 7 X**6 + X**5 + X**4 + X**3 + X**2 + X + 1 ! 8 X**4 + 1 ! 9 X**6 + X**3 + 1 ! 10 X**4 - X**3 + X**2 - X + 1 ! ! Reference: ! ! Raymond Seroul, ! Programming for Mathematicians, ! Springer Verlag, 2000, page 269. ! ! Modified: ! ! 08 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the index of the cyclotomic polynomial desired. ! ! Output, integer PHI(0:N), the N-th cyclotomic polynomial. ! implicit none ! integer n integer, parameter :: max_poly = 100 ! integer d integer den(0:max_poly) integer den_n integer factor(0:n) integer mu integer nq integer nr integer num(0:max_poly) integer num_n integer phi(0:n) integer rem(0:n) ! num(0) = 1 num(1:max_poly) = 0 num_n = 0 den(0) = 1 den(1:max_poly) = 0 den_n = 0 phi(0:n) = 0 do d = 1, n ! ! For each divisor D of N, ... ! if ( mod ( n, d ) == 0 ) then call i_moebius ( n / d, mu ) ! ! ...multiply the numerator or denominator by (X^D-1). ! factor(0) = -1 factor(1:d-1) = 0 factor(d) = 1 if ( mu == + 1 ) then if ( num_n + d > max_poly ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IPOLY_CYCLO - Fatal error!' write ( *, '(a)' ) ' Numerator polynomial degree too high.' return end if call ipoly_mul ( num_n, num, d, factor, num ) num_n = num_n + d else if ( mu == -1 ) then if ( num_n + d > max_poly ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IPOLY_CYCLO - Fatal error!' write ( *, '(a)' ) ' Denominator polynomial degree too high.' return end if call ipoly_mul ( den_n, den, d, factor, den ) den_n = den_n + d end if end if end do ! ! PHI = NUM / DEN ! call ipoly_div ( num_n, num, den_n, den, nq, phi, nr, rem ) return end subroutine ipoly_degree ( na, a, degree ) ! !******************************************************************************* ! !! IPOLY_DEGREE returns the degree of a polynomial. ! ! ! Discussion: ! ! The degree of a polynomial is the index of the highest power ! of X with a nonzero coefficient. ! ! The degree of a constant polynomial is 0. The degree of the ! zero polynomial is debatable, but this routine returns the ! degree as 0. ! ! Modified: ! ! 20 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, integer A(0:NA), the coefficients of the polynomials. ! ! Output, integer DEGREE, the degree of A. ! implicit none ! integer na ! integer a(0:na) integer degree ! degree = na do while ( degree > 0 ) if ( a(degree) /= 0 ) then return end if degree = degree - 1 end do return end subroutine ipoly_div ( na, a, nb, b, nq, q, nr, r ) ! !******************************************************************************* ! !! IPOLY_DIV computes the quotient and remainder of two polynomials. ! ! ! Discussion: ! ! Normally, the quotient and remainder would have rational coefficients. ! This routine assumes that the special case applies that the quotient ! and remainder are known beforehand to be integral. ! ! The polynomials are assumed to be stored in power sum form. ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 23 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, integer A(0:NA), the coefficients of the polynomial to be divided. ! ! Input, integer NB, the dimension of B. ! ! Input, integer B(0:NB), the coefficients of the divisor polynomial. ! ! Output, integer NQ, the degree of Q. ! If the divisor polynomial is zero, NQ is returned as -1. ! ! Output, integer Q(0:NA-NB), contains the quotient of A/B. ! If A and B have full degree, Q should be dimensioned Q(0:NA-NB). ! In any case, Q(0:NA) should be enough. ! ! Output, integer NR, the degree of R. ! If the divisor polynomial is zero, NR is returned as -1. ! ! Output, integer R(0:NB-1), contains the remainder of A/B. ! If B has full degree, R should be dimensioned R(0:NB-1). ! Otherwise, R will actually require less space. ! implicit none ! integer na integer nb ! integer a(0:na) integer a2(0:na) integer b(0:nb) integer i integer na2 integer nb2 integer nq integer nr integer q(0:*) integer r(0:*) ! call ipoly_degree ( na, a, na2 ) call ipoly_degree ( nb, b, nb2 ) if ( b(nb2) == 0 ) then nq = -1 nr = -1 return end if a2(0:na2) = a(0:na2) nq = na2 - nb2 nr = nb2 - 1 do i = nq, 0, -1 q(i) = a2(i+nb2) / b(nb2) a2(i+nb2) = 0 a2(i:i+nb2-1) = a2(i:i+nb2-1) - q(i) * b(0:nb2-1) end do r(0:nr) = a2(0:nr) return end subroutine ipoly_mul ( na, a, nb, b, c ) ! !******************************************************************************* ! !! IPOLY_MUL computes the product of two integer polynomials A and B. ! ! ! Discussion: ! ! The polynomials are in power sum form. ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 29 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, integer A(0:NA), the coefficients of the first polynomial factor. ! ! Input, integer NB, the dimension of B. ! ! Input, integer B(0:NB), the coefficients of the second polynomial factor. ! ! Output, integer C(0:NA+NB), the coefficients of A * B. ! implicit none ! integer na integer nb ! integer a(0:na) integer b(0:nb) integer c(0:na+nb) integer d(0:na+nb) integer i integer j ! d(0:na+nb) = 0 do i = 0, na d(i:i+nb) = d(i:i+nb) + a(i) * b(0:nb) end do c(0:na+nb) = d(0:na+nb) return end subroutine ipoly_print ( n, a, title ) ! !******************************************************************************* ! !! IPOLY_PRINT prints out a polynomial. ! ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 06 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, integer A(0:N), the polynomial coefficients. ! A(0) is the constant term and ! A(N) is the coefficient of X**N. ! ! Input, character ( len = * ) TITLE, an optional title. ! implicit none ! integer n ! integer a(0:n) integer i integer mag integer n2 character plus_minus character ( len = * ) title ! if ( len_trim ( title ) > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' call ipoly_degree ( n, a, n2 ) if ( a(n2) < 0 ) then plus_minus = '-' else plus_minus = ' ' end if mag = abs ( a(n2) ) if ( n2 >= 2 ) then write ( *, '( '' p(x) = '', a1, i6, '' * x ^ '', i3 )' ) & plus_minus, mag, n2 else if ( n2 == 1 ) then write ( *, '( '' p(x) = '', a1, i6, '' * x'' )' ) plus_minus, mag else if ( n2 == 0 ) then write ( *, '( '' p(x) = '', a1, i6 )' ) plus_minus, mag end if do i = n2-1, 0, -1 if ( a(i) < 0.0E+00 ) then plus_minus = '-' else plus_minus = '+' end if mag = abs ( a(i) ) if ( mag /= 0 ) then if ( i >= 2 ) then write ( *, ' ( '' '', a1, i6, '' * x ^ '', i3 )' ) & plus_minus, mag, i else if ( i == 1 ) then write ( *, ' ( '' '', a1, i6, '' * x'' )' ) plus_minus, mag else if ( i == 0 ) then write ( *, ' ( '' '', a1, i6 )' ) plus_minus, mag end if end if end do return end subroutine ivec_backtrack ( n, x, indx, k, nstack, stack, maxstack, ncan ) ! !******************************************************************************* ! !! IVEC_BACKTRACK supervises a backtrack search for an integer vector. ! ! ! Discussion: ! ! The routine tries to construct an integer vector one index at a time, ! using possible candidates as supplied by the user. ! ! At any time, the partially constructed vector may be discovered to be ! unsatisfactory, but the routine records information about where the ! last arbitrary choice was made, so that the search can be ! carried out efficiently, rather than starting out all over again. ! ! First, call the routine with INDX = 0 so it can initialize itself. ! ! Now, on each return from the routine, if INDX is: ! 1, you've just been handed a complete candidate vector; ! Admire it, analyze it, do what you like. ! 2, please determine suitable candidates for position X(K). ! Return the number of candidates in NCAN(K), adding each ! candidate to the end of STACK, and increasing NSTACK. ! 3, you're done. Stop calling the routine; ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 24 July 2000 ! ! Parameters: ! ! Input, integer N, the number of positions to be filled in the vector. ! ! Input/output, integer X(N), the partial or complete candidate vector. ! ! Input/output, integer INDX, a communication flag. ! On input, ! 0 to start a search. ! On output: ! 1, a complete output vector has been determined and returned in X(1:N); ! 2, candidates are needed for position X(K); ! 3, no more possible vectors exist. ! ! Output, integer K, if INDX=2, the current vector index being considered. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input, integer STACK(MAXSTACK), a list of all current candidates for ! all positions 1 through K. ! ! Input, integer MAXSTACK, the maximum length of the stack. ! ! Input/output, integer NCAN(N), lists the current number of candidates for ! positions 1 through K. ! implicit none ! integer n integer maxstack ! integer indx integer k integer ncan(n) integer nstack integer stack(maxstack) integer x(n) ! ! If this is the first call, request a candidate for position 1. ! if ( indx == 0 ) then k = 1 nstack = 0 indx = 2 return end if ! ! Examine the stack. ! do ! ! If there are candidates for position K, take the first available ! one off the stack, and increment K. ! ! This may cause K to reach the desired value of N, in which case ! we need to signal the user that a complete set of candidates ! is being returned. ! if ( ncan(k) > 0 ) then x(k) = stack(nstack) nstack = nstack - 1 ncan(k) = ncan(k) - 1 if ( k /= n ) then k = k + 1 indx = 2 else indx = 1 end if exit ! ! If there are no candidates for position K, then decrement K. ! If K is still positive, repeat the examination of the stack. ! else k = k - 1 if ( k <= 0 ) then indx = 3 exit end if end if end do return end subroutine ivec_binary_add ( n, ivec, jvec, kvec ) ! !******************************************************************************* ! !! IVEC_BINARY_ADD adds two binary vectors. ! ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer IVEC(N), JVEC(N), the vectors to be added. ! ! Output, integer KVEC(N), the sum of the two input vectors. ! implicit none ! integer n ! integer i integer ivec(n) integer jvec(n) integer kvec(n) logical overflow ! overflow = .false. ! kvec(1:n) = ivec(1:n) + jvec(1:n) do i = n, 1, -1 if ( kvec(i) == 2 ) then kvec(i) = 0 if ( i > 1 ) then kvec(i-1) = kvec(i-1) + 1 else overflow = .true. end if end if end do return end subroutine ivec_binary_complement2 ( n, ivec ) ! !******************************************************************************* ! !! IVEC_BINARY_COMPLEMENT2 computes the two's complement of a binary vector. ! ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input/output, integer IVEC(N), the vector to be two's complemented. ! implicit none ! integer n ! integer ivec(n) integer jvec(n) integer kvec(n) ! ivec(1:n) = 1 - ivec(1:n) jvec(1:n-1) = 0 jvec(n) = 1 call ivec_binary_add ( n, ivec, jvec, ivec ) ivec(1:n) = kvec(1:n) return end subroutine ivec_binary_print ( n, a, title ) ! !******************************************************************************* ! !! IVEC_BINARY_PRINT prints a binary integer vector, with an optional title. ! ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! integer a(n) integer i integer ihi integer ilo character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' end if do ilo = 1, n, 80 ihi = min ( ilo + 79, n ) write ( *, '(80i1)' ) a(ilo:ihi) end do return end subroutine ivec_binary_to_i ( n, ivec, i ) ! !******************************************************************************* ! !! IVEC_BINARY_TO_I makes an integer from a vector binary representation. ! ! ! Example: ! ! IVEC I ! -------------- -- ! 0,0,...0,0,0,1 1 ! 0,0,...0,0,1,0 2 ! 0,0,...0,0,1,1 3 ! 0,0,...0,1,0,0 4 ! 0,0,...1,0,0,1 9 ! 1,1,...0,1,1,1 -9 ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, an integer to be represented. ! ! Input, integer N, the dimension of the vector, which should be 32. ! ! Output, integer IVEC(N), the binary representation. ! implicit none ! integer n ! integer i integer i_sign integer ivec(n) integer j integer jvec(n) ! jvec(1:n) = ivec(1:n) i_sign = 1 if ( jvec(1) == 1 ) then i_sign = -1 call ivec_binary_complement2 ( n, jvec ) end if i = 0 do j = 2, n i = 2 * i + jvec(j) end do i = i_sign * i return end subroutine ivec_binary_xor ( n, ivec, jvec, kvec ) ! !******************************************************************************* ! !! IVEC_BINARY_XOR computes the exclusive OR of two binary vectors. ! ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer IVEC(N), JVEC(N), the binary vectors to be XOR'ed. ! ! Input, integer KVEC(N), the exclusive OR of the two vectors. ! implicit none ! integer n ! integer ivec(n) integer jvec(n) integer kvec(n) ! kvec(1:n) = mod ( ivec(1:n) + jvec(1:n), 2 ) return end function ivec_descends ( n, x ) ! !******************************************************************************* ! !! IVEC_DESCENDS determines if an integer vector is decreasing. ! ! ! Example: ! ! X = ( 9, 7, 7, 3, 2, 1, -8 ) ! ! IVEC_DESCEND = TRUE ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the array. ! ! Input, integer X(N), the array to be examined. ! ! Output, logical IVEC_DESCEND, is TRUE if the entries of X descend. ! implicit none ! integer n ! integer i logical ivec_descends integer x(n) ! ivec_descends = .false. do i = 1, n-1 if ( x(i) < x(i+1) ) then return end if end do ivec_descends = .true. return end subroutine ivec_frac ( n, a, k, iafrac ) ! !******************************************************************************* ! !! IVEC_FRAC searches for the K-th smallest element in an N-vector. ! ! ! Discussion: ! ! Hoare's algorithm is used. ! ! Modified: ! ! 17 July 2000 ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Input/output, integer A(N), array to search. On output, ! the elements of A have been somewhat rearranged. ! ! Input, integer K, the fractile to be sought. If K = 1, the ! minimum entry is sought. If K = N, the maximum is sought. ! Other values of K search for the entry which is K-th in size. ! K must be at least 1, and no greater than N. ! ! Output, integer IAFRAC, the value of the K-th fractile of A. ! implicit none ! integer n ! integer i integer a(n) integer iafrac integer iryt integer iw integer ix integer j integer k integer left ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IVEC_FRAC - Fatal error!' write ( *, '(a,i6)' ) ' Illegal nonpositive value of N = ', n stop end if if ( k <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IVEC_FRAC - Fatal error!' write ( *, '(a,i6)' ) ' Illegal nonpositive value of K = ', k stop end if if ( k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'IVEC_FRAC - Fatal error!' write ( *, '(a,i6)' ) ' Illegal K > N, K = ', k stop end if left = 1 iryt = n do if ( left >= iryt ) then iafrac = a(k) exit end if ix = a(k) i = left j = iryt do if ( i > j ) then if ( j < k ) then left = i end if if ( k < i ) then iryt = j end if exit end if ! ! Find I so that IX <= A(I). ! do while ( a(i) < ix ) i = i + 1 end do ! ! Find J so that A(J) <= IX. ! do while ( ix < a(j) ) j = j - 1 end do if ( i <= j ) then call i_swap ( a(i), a(j) ) i = i + 1 j = j - 1 end if end do end do return end subroutine ivec_identity ( n, a ) ! !******************************************************************************* ! !! IVEC_IDENTITY sets an integer vector to the identity vector A(I)=I. ! ! ! Modified: ! ! 09 November 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Output, integer A(N), the array to be initialized. ! implicit none ! integer n ! integer a(n) integer i ! do i = 1, n a(i) = i end do return end function ivec_imax_last ( n, x ) ! !******************************************************************************* ! !! IVEC_MAX_LAST returns the index of the last maximal integer vector element. ! ! ! Example: ! ! X = ( 5, 1, 2, 5, 0, 5, 3 ) ! ! IVEC_IMAX_LAST = 6 ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the array. ! ! Input, integer X(N), the array to be examined. ! ! Output, integer IVEC_IMAX_LAST, the index of the last element of ! X of maximal value. ! implicit none ! integer n ! integer i integer ivec_imax_last integer max_last integer x(n) ! ivec_imax_last = 0 do i = 1, n if ( i == 1 ) then ivec_imax_last = 1 max_last = x(1) else if ( x(i) >= max_last ) then ivec_imax_last = i max_last = x(i) end if end do return end function ivec_index ( n, a, aval ) ! !******************************************************************************* ! !! IVEC_INDEX returns the location of the first occurrence of a given value. ! ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, integer A(N), the vector to be searched. ! ! Input, integer AVAL, the value to be indexed. ! ! Output, integer IVEC_INDEX, the first location in A which has the ! value AVAL, or 0 if no such index exists. ! implicit none ! integer n ! integer a(n) integer aval integer i integer ivec_index ! do i = 1, n if ( a(i) == aval ) then ivec_index = i return end if end do ivec_index = 0 return end function ivec_pairwise_prime ( n, a ) ! !******************************************************************************* ! !! IVEC_PAIRWISE_PRIME checks whether a vector of integers is pairwise prime. ! ! ! Discussion: ! ! Two positive integers I and J are pairwise prime if they have no common ! factor greater than 1. ! ! Modified: ! ! 05 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of values to check. ! ! Input, integer A(N), the vector of integers. ! ! Output, logical IVEC_PAIRWISE_PRIME, is TRUE if the vector of integers ! is pairwise prime. ! implicit none ! integer n ! integer a(n) integer i integer i_gcd logical ivec_pairwise_prime integer j ! ivec_pairwise_prime = .false. do i = 1, n do j = i+1, n if ( i_gcd ( a(i), a(j) ) /= 1 ) then return end if end do end do ivec_pairwise_prime = .true. return end subroutine ivec_print ( n, a, title ) ! !******************************************************************************* ! !! IVEC_PRINT prints an integer vector, with an optional title. ! ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! integer a(n) integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,i10)' ) i, a(i) end do return end subroutine ivec_random ( n, a, alo, ahi ) ! !******************************************************************************* ! !! IVEC_RANDOM returns a random integer vector in a given range. ! ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Output, integer A(N), the vector of randomly chosen integers. ! ! Input, integer ALO, AHI, the range allowed for the entries. ! implicit none ! integer n ! integer a(n) integer ahi integer alo integer i ! do i = 1, n call i_random ( alo, ahi, a(i) ) end do return end subroutine ivec_reverse ( n, a ) ! !******************************************************************************* ! !! IVEC_REVERSE reverses the elements of an integer vector. ! ! ! Example: ! ! Input: ! ! N = 5, ! A = ( 11, 12, 13, 14, 15 ). ! ! Output: ! ! A = ( 15, 14, 13, 12, 11 ). ! ! Modified: ! ! 26 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer A(N), the array to be reversed. ! implicit none ! integer n ! integer a(n) integer i ! do i = 1, n/2 call i_swap ( a(i), a(n+1-i) ) end do return end subroutine ivec_sort_heap_index_d ( n, a, indx ) ! !******************************************************************************* ! !! IVEC_SORT_HEAP_INDEX_D does an indexed heap descending sort of an integer vector. ! ! ! Discussion: ! ! The sorting is not actually carried out. Rather an index array is ! created which defines the sorting. This array may be used to sort ! or index the array, or to sort or index related arrays keyed on the ! original array. ! ! Once the index array is computed, the sorting can be carried out ! "implicitly: ! ! A(INDX(I)), I = 1 to N is sorted, ! ! after which A(I), I = 1 to N is sorted. ! ! Modified: ! ! 07 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, integer A(N), an array to be index-sorted. ! ! Output, integer INDX(N), contains the sort index. The ! I-th element of the sorted array is A(INDX(I)). ! implicit none ! integer n ! integer a(n) integer aval integer i integer indx(n) integer indxt integer ir integer j integer l ! call ivec_identity ( n, indx ) l = n / 2 + 1 ir = n do if ( l > 1 ) then l = l - 1 indxt = indx(l) aval = a(indxt) else indxt = indx(ir) aval = a(indxt) indx(ir) = indx(1) ir = ir - 1 if ( ir == 1 ) then indx(1) = indxt return end if end if i = l j = l + l do while ( j <= ir ) if ( j < ir ) then if ( a(indx(j)) > a(indx(j+1)) ) then j = j + 1 end if end if if ( aval > a(indx(j)) ) then indx(i) = indx(j) i = j j = j + j else j = ir + 1 end if end do indx(i) = indxt end do return end subroutine jfrac_to_rfrac ( m, r, s, p, q ) ! !******************************************************************************* ! !! JFRAC_TO_RFRAC converts a J-fraction into a rational polynomial fraction. ! ! ! Discussion: ! ! The routine accepts a J-fraction: ! ! R(1) / ( X + S(1) ! + R(2) / ( X + S(2) ! + R(3) / ... ! + R(M) / ( X + S(M) )... )) ! ! and returns the equivalent rational polynomial fraction: ! ! P(1) + P(2) * X + ... + P(M) * X**(M-1) ! ------------------------------------------------------- ! Q(1) + Q(2) * X + ... + Q(M) * X**(M-1) + Q(M+1) * X**M ! ! Reference: ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Modified: ! ! 17 April 2000 ! ! Parameters: ! ! Input, integer M, defines the number of P, R, and S ! coefficients, and is one less than the number of Q ! coefficients. ! ! Input, real R(M), S(M), the coefficients defining the J-fraction. ! ! Output, real P(M), Q(M+1), the coefficients defining the rational ! polynomial fraction. The algorithm used normalizes the coefficients ! so that Q(M+1) = 1.0. ! implicit none ! integer m ! real a(m,m) real b(m,m) integer i integer k real p(m) real q(m+1) real r(m) real s(m) ! a(1,1) = r(1) b(1,1) = s(1) if ( m > 1 ) then do k = 2, m a(k,k) = r(1) b(k,k) = b(k-1,k-1) + s(k) end do a(1,2) = r(1) * s(2) b(1,2) = r(2) + s(1) * s(2) do k = 3, m a(1,k) = s(k) * a(1,k-1) + r(k) * a(1,k-2) a(k-1,k) = a(k-2,k-1) + s(k) * r(1) b(1,k) = s(k) * b(1,k-1) + r(k) * b(1,k-2) b(k-1,k) = b(k-2,k-1) + s(k) * b(k-1,k-1) + r(k) end do do k = 4, m do i = 2, k-2 a(i,k) = a(i-1,k-1) + s(k)*a(i,k-1) + r(k) * a(i,k-2) b(i,k) = b(i-1,k-1) + s(k)*b(i,k-1) + r(k) * b(i,k-2) end do end do end if p(1:m) = a(1:m,m) q(1:m) = b(1:m,m) q(m+1) = 1.0E+00 return end subroutine josephus ( n, m, k, x ) ! !******************************************************************************* ! !! JOSEPHUS returns the position X of the K-th man to be executed. ! ! ! Discussion: ! ! The classic Josephus problem concerns a circle of 41 men. ! Every third man is killed and removed from the circle. Counting ! and executing continues until all are dead. Where was the last ! survivor sitting? ! ! Note that the first person killed was sitting in the third position. ! Moreover, when we get down to 2 people, and we need to count the ! "third" one, we just do the obvious thing, which is to keep counting ! around the circle until our count is completed. ! ! The process may be regarded as generating a permutation of ! the integers from 1 to N. The permutation would be the execution ! list, that is, the list of the executed men, by position number. ! ! Reference: ! ! W W Rouse Ball, ! Mathematical Recreations and Essays, ! Macmillan, 1962, pages 32-36. ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, pages 158-159. ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 3, Sorting and Searching, ! Addison Wesley, 1968, pages 18-19. ! ! Modified: ! ! 03 April 2000 ! ! Parameters: ! ! Input, integer N, the number of men. ! N must be positive. ! ! Input, integer M, the counting index. ! M must not be zero. Ordinarily, M is positive, and no greater than N. ! ! Input, integer K, the index of the executed man of interest. ! K must be between 1 and N. ! ! Output, integer X, the position of the K-th man. ! X will be between 1 and N. ! implicit none ! integer i_modp integer k integer m integer m2 integer n integer x ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JOSEPHUS - Fatal error!' write ( *, '(a)' ) ' N <= 0.' stop end if if ( m == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JOSEPHUS - Fatal error!' write ( *, '(a)' ) ' M = 0.' stop end if if ( k <= 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'JOSEPHUS - Fatal error!' write ( *, '(a)' ) ' J <= 0 or K > N.' stop end if ! ! In case M is bigger than N, or negative, get the ! equivalent positive value between 1 and N. ! You can skip this operation if 1 <= M <= N. ! m2 = i_modp ( m, n ) x = k * m2 do while ( x > n ) x = ( m2 * ( x - n ) - 1 ) / ( m2 - 1 ) end do return end subroutine ksub_next ( n, k, iarray, more ) ! !******************************************************************************* ! !! KSUB_NEXT generates the K subsets of an N set, one at a time. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! ! Input, integer K, the desired size of the subsets. K must ! be between 0 and N. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th element of the ! subset. Thus IARRAY(I) will be an integer between 1 and N. ! Note that the routine will return the values in IARRAY ! in sorted order: 1 <= IARRAY(1) < IARRAY(2) < ... < IARRAY(K) <= N ! ! Input/output, logical MORE. Set MORE = .FALSE. before first call ! for a new sequence of subsets. It then is set and remains ! .TRUE. as long as the subset computed on this call is not the ! final one. When the final subset is computed, MORE is set to ! .FALSE. as a signal that the computation is done. ! implicit none ! integer k ! integer iarray(k) integer j integer, save :: m = 0 integer, save :: m2 = 0 logical more integer n ! if ( k < 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_NEXT - Fatal error!' write ( *, '(a,i6)' ) 'N = ', n write ( *, '(a,i6)' ) 'K = ', k write ( *, '(a)' ) 'but 0 <= K <= N is required!' stop end if if ( .not. more ) then m2 = 0 m = k else if ( m2 < n-m ) then m = 0 end if m = m + 1 m2 = iarray(k+1-m) end if do j = 1, m iarray(k+j-m) = m2 + j end do more = iarray(1) /= (n-k+1) return end subroutine ksub_next2 ( n, k, iarray, in, iout ) ! !******************************************************************************* ! !! KSUB_NEXT2 computes the next K subset of an N set. ! ! ! Discussion: ! ! This routine uses the revolving door method. It has no "memory". ! It simply calculates the successor of the input set, ! and will start from the beginning after the last set. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 29 March 2001 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! N must be positive. ! ! Input, integer K, the size of the desired subset. K must be ! between 0 and N. ! ! Input/output, integer IARRAY(K). On input, the user must ! supply a subset of size K in IARRAY. That is, IARRAY must ! contain K unique numbers, in order, between 1 and N. On ! output, IARRAY(I) is the I-th element of the output subset. ! The output array is also in sorted order. ! ! Output, integer IN, the element of the output subset which ! was not in the input set. Each new subset differs from the ! last one by adding one element and deleting another. ! ! Output, integer IOUT, the element of the input subset which ! is not in the output subset. ! implicit none ! integer k ! integer iarray(k) integer in integer iout integer j integer m integer n ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_NEXT2 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a)' ) ' but 0 < N is required!' stop end if if ( k < 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_NEXT2 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K <= N is required!' stop end if j = 0 do if ( j > 0 .or. mod ( k, 2 ) == 0 ) then j = j + 1 if ( j > k ) then iarray(k) = k in = k iout = n return end if if ( iarray(j) /= j ) then iout = iarray(j) in = iout - 1 iarray(j) = in if ( j /= 1 ) then in = j - 1 iarray(j-1) = in end if return end if end if j = j + 1 m = n if ( j < k ) then m = iarray(j+1) - 1 end if if ( m /= iarray(j) ) then exit end if end do in = iarray(j) + 1 iarray(j) = in iout = in - 1 if ( j /= 1 ) then iarray(j-1) = iout iout = j - 1 end if return end subroutine ksub_next3 ( n, k, iarray, more, in, iout ) ! !******************************************************************************* ! !! KSUB_NEXT3 computes the K subsets of an N set. ! ! ! Discussion: ! ! The routine uses the revolving door method. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 30 March 2001 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! N must be positive. ! ! Input, integer K, the size of the desired subsets. K must be ! between 0 and N. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th element of the ! output subset. The elements of IARRAY are sorted. ! ! Input/output, logical MORE. On first call, set MORE = .FALSE. ! to signal the beginning. MORE will be set to .TRUE., and on ! each call, the routine will return another K-subset. ! Finally, when the last subset has been returned, ! MORE will be set .FALSE. and you may stop calling. ! ! Output, integer IN, the element of the output subset which ! was not in the input set. Each new subset differs from the ! last one by adding one element and deleting another. IN is not ! defined the first time that the routine returns, and is ! set to zero. ! ! Output, integer IOUT, the element of the input subset which is ! not in the output subset. IOUT is not defined the first time ! the routine returns, and is set to zero. ! implicit none ! integer k ! integer i integer iarray(k) integer in integer iout integer j integer m logical more integer n ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_NEXT3 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a)' ) ' but 0 < N is required!' stop end if if ( k < 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_NEXT3 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K <= N is required!' stop end if if ( .not. more ) then in = 0 iout = 0 call ivec_identity ( k, iarray ) more = ( k /= n ) return end if j = 0 do if ( j > 0 .or. mod ( k, 2 ) == 0 ) then j = j + 1 if ( iarray(j) /= j ) then iout = iarray(j) in = iout - 1 iarray(j) = in if ( j /= 1 ) then in = j - 1 iarray(j-1) = in end if if ( k /= 1 ) then more = ( iarray(k-1) == k-1 ) end if more = ( .not. more ) .or. ( iarray(k) /= n ) return end if end if j = j + 1 m = n if ( j < k ) then m = iarray(j+1) - 1 end if if ( m /= iarray(j) ) then exit end if end do in = iarray(j) + 1 iarray(j) = in iout = in - 1 if ( j /= 1 ) then iarray(j-1) = iout iout = j - 1 end if if ( k /= 1 ) then more = ( iarray(k-1) == k-1 ) end if more = ( .not. more ) .or. ( iarray(k) /= n ) return end subroutine ksub_next4 ( done, iarray, k, n ) ! !******************************************************************************* ! !! KSUB_NEXT4 generates the subsets of size K of a set of N elements. ! ! ! Discussion: ! ! The subsets are generated one at a time. ! ! The routine should be used by setting DONE to .TRUE., and then calling ! repeatedly. Each call returns with DONE equal to .FALSE., the array ! IARRAY contains information defining a new subset. When DONE returns ! equal to .TRUE., there are no more subsets. ! ! There are ( N*(N-1)*...*(N+K-1)) / ( K*(K-1)*...*2*1) such subsets. ! ! Modified: ! ! 31 July 2000 ! ! Parameters: ! ! Input/output, logical DONE. ! ! On the first call, DONE is an input quantity with a value ! of .TRUE. which tells the program to initialize data and ! return the first subset. ! ! On return, DONE is an output quantity that is .TRUE. as long as ! the routine is returning another subset, and .FALSE. when ! there are no more. ! ! Input/output, integer IARRAY(K), contains information about ! the subsets. On the first call with DONE = .TRUE., the input contents ! of IARRAY don't matter. Thereafter, the input value of IARRAY ! should be the same as the output value of the previous call. ! In other words, leave the array alone! ! ! On output, as long as DONE is returned .FALSE., IARRAY contains ! information defining a subset of K elements of a set of N elements. ! In other words, IARRAY will contain K distinct numbers (in order) ! between 1 and N. ! ! Input, integer K, the size of the desired subset. K must be ! between 0 and N. ! ! Input, integer N, the size of the entire set. ! implicit none ! integer k ! logical done integer i integer iarray(k) integer j integer jsave integer n ! if ( k < 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_NEXT4 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K <= N is required!' stop end if ! ! First call: ! if ( done ) then call ivec_identity ( k, iarray ) if ( n > 0 ) then done = .false. else done = .true. end if ! ! Next call. ! else if ( iarray(1) < n-k+1 ) then done = .false. jsave = k do j = 1, k-1 if ( iarray(j+1) > iarray(j)+1 ) then jsave = j exit end if end do call ivec_identity ( jsave-1, iarray ) iarray(jsave) = iarray(jsave) + 1 else done = .true. end if end if return end subroutine ksub_random ( n, k, iarray ) ! !******************************************************************************* ! !! KSUB_RANDOM selects a random subset of size K from a set of size N. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 01 December 2000 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! ! Input, integer K, number of elements in desired subsets. K must ! be between 0 and N. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th element of the ! output set. The elements of IARRAY are in order. ! implicit none ! integer k ! integer i integer iarray(k) integer ids integer ihi integer ip integer ir integer is integer ix integer l integer ll integer m integer m0 integer n real r ! if ( k < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop else if ( k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_RANDOM - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' K <= N is required!' stop end if if ( k == 0 ) then return end if do i = 1, k iarray(i) = ( ( i - 1 ) * n ) / k end do do i = 1, k do call i_random ( 1, n, ix ) l = 1 + ( ix * k - 1 ) / n if ( ix > iarray(l) ) then exit end if end do iarray(l) = iarray(l) + 1 end do ip = 0 is = k do i = 1, k m = iarray(i) iarray(i) = 0 if ( m /= ( ( i - 1 ) * n ) / k ) then ip = ip + 1 iarray(ip) = m end if end do ihi = ip do i = 1, ihi ip = ihi + 1 - i l = 1 + ( iarray(ip) * k - 1 ) / n ids = iarray(ip) - ( ( l - 1 ) * n ) / k iarray(ip) = 0 iarray(is) = l is = is - ids end do do ll = 1, k l = k + 1 - ll if ( iarray(l) /= 0 ) then ir = l m0 = 1 + ( ( iarray(l) - 1 ) * n ) / k m = ( iarray(l) * n ) / k - m0 + 1 end if call i_random ( m0, m0 + m - 1, ix ) i = l + 1 do while ( i <= ir ) if ( ix < iarray(i) ) then exit end if ix = ix + 1 iarray(i-1) = iarray(i) i = i + 1 end do iarray(i-1) = ix m = m - 1 end do return end subroutine ksub_random2 ( n, k, iarray ) ! !******************************************************************************* ! !! KSUB_RANDOM2 selects a random subset of size K from a set of size N. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 25 July 2000 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! ! Input, integer K, number of elements in desired subsets. K must ! be between 0 and N. ! ! Output, integer IARRAY(K). IARRAY(I) is the I-th element of the ! output set. The elements of IARRAY are in order. ! implicit none ! integer k ! integer i integer iarray(k) integer ic1 integer ic2 integer k0 integer n real r real, parameter :: rhi = 1.0E+00 real, parameter :: rlo = 0.0E+00 ! if ( k < 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_RANDOM2 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K <= N is required!' stop end if if ( k == 0 ) then return end if ic1 = k ic2 = n k0 = 0 i = 0 do i = i + 1 call r_random ( rlo, rhi, r ) if ( real ( ic2 ) * r <= real ( ic1 ) ) then ic1 = ic1 - 1 k0 = k0 + 1 iarray(k0) = i if ( ic1 <= 0 ) then exit end if end if ic2 = ic2 - 1 end do return end subroutine ksub_random3 ( n, k, iarray ) ! !******************************************************************************* ! !! KSUB_RANDOM3 selects a random subset of size K from a set of size N. ! ! ! Discussion: ! ! This routine uses Floyd's algorithm. ! ! Modified: ! ! 01 December 2000 ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets are drawn. ! ! Input, integer K, number of elements in desired subsets. K must ! be between 0 and N. ! ! Output, integer IARRAY(N). I is an element of the subset ! if IARRAY(I) = 1, and I is not an element if IARRAY(I)=0. ! implicit none ! integer n ! integer i integer iarray(n) integer j integer k real r ! if ( k < 0 .or. k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'KSUB_RANDOM3 - Fatal error!' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a,i6)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K <= N is required!' stop end if iarray(1:n) = 0 if ( k == 0 ) then return end if do i = n-k+1, n call i_random ( 1, i, j ) if ( iarray(j) == 0 ) then iarray(j) = 1 else iarray(i) = 1 end if end do return end subroutine matrix_product_opt ( n, rank, cost, order ) ! !******************************************************************************* ! !! MATRIX_PRODUCT_OPT determines the optimal cost of a matrix product. ! ! ! Discussion: ! ! The cost of multiplying an LxM matrix by an M by N matrix is ! assessed as L*M*N. ! ! Any particular order of multiplying a set of N matrices is equivalent ! to parenthesizing an expression of N objects. ! ! The actual number of ways of parenthesizing an expression ! of N objects is C(N), the N-th Catalan number. ! ! Reference: ! ! Robert Sedgewick, ! Algorithms, ! Addison-Wesley, 1984, pages 486-489. ! ! Modified: ! ! 17 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of matrices to be multiplied. ! ! Input, integer RANK(N+1), the rank information for the matrices. ! Matrix I has RANK(I) rows and RANK(I+1) columns. ! ! Output, integer COST, the cost of the multiplication if the optimal ! order is used. ! ! Output, integer ORDER(N-1), indicates the order in which the N-1 ! multiplications are to be carried out. ORDER(1) is the first ! multiplication to do, and so on. ! implicit none ! integer, parameter :: stack_max = 100 integer n ! integer best(n,n) integer cost integer cost2(n,n) integer cost3 integer i integer i_inf integer i1 integer i2 integer i3 integer j integer k integer order(n-1) integer rank(n+1) integer stack(stack_max) integer stack_num integer step ! ! Initialize the cost matrix. ! do i = 1, n cost2(i,1:i) = 0 cost2(i,i+1:n) = huge ( 1 ) end do ! ! Initialize the BEST matrix. ! best(1:n,1:n) = 0 ! ! Compute the cost and best matrices. ! do j = 1, n-1 do i = 1, n-j do k = i+1, i+j cost3 = cost2(i,k-1) + cost2(k,i+j) + rank(i) * rank(k) * rank(i+j+1) if ( cost3 < cost2(i,i+j) ) then cost2(i,i+j) = cost3 best(i,i+j) = k end if end do end do end do ! ! Pick off the optimal cost. ! cost = cost2(1,n) ! ! Backtrack to determine the optimal order. ! stack_num = 0 i1 = 1 i2 = n if ( i1+1 < i2 ) then stack_num = stack_num + 1 stack(stack_num) = i1 stack_num = stack_num + 1 stack(stack_num) = i2 end if step = n - 1 ! ! Take an item off the stack. ! do while ( stack_num > 0 ) i3 = stack(stack_num) stack_num = stack_num - 1 i1 = stack(stack_num) stack_num = stack_num - 1 i2 = best(i1,i3) order(step) = i2 - 1 step = step - 1 ! ! The left chunk is matrices (I1...I2-1) ! if ( i1 == i2-1 ) then else if ( i1+1 == i2-1 ) then order(step) = i2 - 2 step = step - 1 else stack_num = stack_num + 1 stack(stack_num) = i1 stack_num = stack_num + 1 stack(stack_num) = i2 - 1 end if ! ! The right chunk is matrices (I2...I3) ! if ( i2 == i3 ) then else if ( i2+1 == i3 ) then order(step) = i2 step = step - 1 else stack_num = stack_num + 1 stack(stack_num) = i2 stack_num = stack_num + 1 stack(stack_num) = i3 end if end do return end subroutine moebius_matrix ( n, a, mu ) ! !******************************************************************************* ! !! MOEBIUS_MATRIX finds the Moebius matrix from a covering relation. ! ! ! Discussion: ! ! This routine can be called with MATRIX and MU being the same matrix. ! The routine will correctly compute the Moebius matrix, which ! will, in this case, overwrite the input matrix. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, number of elements in the partially ordered set. ! ! Input, integer A(N,N). A(I,J) = 1 if I is covered by J, ! 0 otherwise. ! ! Output, integer MU(N,N), the Moebius matrix as computed by the routine. ! implicit none ! integer n ! integer a(n,n) integer i integer iwork(n,2) integer j integer mu(n,n) ! ! Compute a reordering of the elements of the partially ordered matrix. ! call triang ( n, a, iwork(1,1) ) ! ! Copy the matrix. ! mu(1:n,1:n) = a(1:n,1:n) ! ! Apply the reordering to MU. ! call imat_perm2 ( n, n, mu, iwork(1,1), iwork(1,1) ) ! ! Negate the (strict) upper triangular elements of MU. ! do i = 1, n-1 mu(i,i+1:n) = - mu(i,i+1:n) end do ! ! Compute the inverse of MU. ! call imat_inverse ( n, mu, mu ) ! ! All nonzero elements are reset to 1. ! do i = 1, n do j = i, n if ( mu(i,j) /= 0 ) then mu(i,j) = 1 end if end do end do ! ! Invert the matrix again. ! call imat_inverse ( n, mu, mu ) ! ! Compute the inverse permutation. ! do i = 1, n iwork(iwork(i,1),2) = i end do ! ! Unpermute the rows and columns of MU. ! call imat_perm2 ( n, n, mu, iwork(1,2), iwork(1,2) ) return end subroutine morse_thue ( i, s ) ! !******************************************************************************* ! !! MORSE_THUE generates a Morse_Thue number. ! ! ! Definition: ! ! The Morse_Thue sequence can be defined in a number of ways. ! ! A) Start with the string containing the single letter '0'; then ! repeatedly apply the replacement rules '0' -> '01' and ! '1' -> '10' to the letters of the string. The Morse_Thue sequence ! is the resulting letter sequence. ! ! B) Starting with the string containing the single letter '0', ! repeatedly append the binary complement of the string to itself. ! Thus, '0' becomes '0' + '1' or '01', then '01' becomes ! '01' + '10', which becomes '0110' + '1001', and so on. ! ! C) Starting with I = 0, the I-th Morse-Thue number is determined ! by taking the binary representation of I, adding the digits, ! and computing the remainder modulo 2. ! ! Example: ! ! I binary S ! -- ------ -- ! 0 0 0 ! 1 1 1 ! 2 10 1 ! 3 11 0 ! 4 100 1 ! 5 101 0 ! 6 110 0 ! 7 111 1 ! 8 1000 1 ! ! Modified: ! ! 17 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, the index of the Morse-Thue number. ! Normally, I is 0 or greater, but any value is allowed. ! ! Output, integer S, the Morse-Thue number of index I. ! implicit none ! integer, parameter :: nbits = 32 ! integer b(nbits) integer i integer i_copy integer s ! i_copy = abs ( i ) ! ! Expand I into binary form. ! call i_to_ivec_binary ( i_copy, nbits, b ) ! ! Sum the 1's in the binary representation. ! s = sum ( b(1:nbits) ) ! ! Take the value modulo 2. ! s = mod ( s, 2 ) return end subroutine multinomial_coef1 ( nfactor, factor, ncomb ) ! !******************************************************************************* ! !! MULTINOMIAL_COEF1 computes a multinomial coefficient. ! ! ! Definition: ! ! The multinomial coefficient is a generalization of the binomial ! coefficient. It may be interpreted as the number of combinations of ! N objects, where FACTOR(1) objects are indistinguishable of type 1, ! ... and FACTOR(NFACTOR) are indistinguishable of type NFACTOR, ! and N is the sum of FACTOR(1) through FACTOR(NFACTOR). ! ! Formula: ! ! NCOMB = N! / ( FACTOR(1)! FACTOR(2)! ... FACTOR(NFACTOR)! ) ! ! Method: ! ! The log of the gamma function is used, to avoid overflow. ! ! Modified: ! ! 16 June 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NFACTOR, the number of factors. ! ! Input, integer FACTOR(NFACTOR), contains the factors. ! 0 <= FACTOR(I) ! ! Output, integer NCOMB, the value of the multinomial coefficient. ! implicit none ! integer nfactor ! real arg real fack real facn integer factor(nfactor) real gamma_log integer i integer n integer ncomb ! ! Each factor must be nonnegative. ! do i = 1, nfactor if ( factor(i) < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_COEF1 - Fatal error' write ( *, '(a,i6,a,i6)' ) ' Factor ', I, ' = ', factor(i) write ( *, '(a)' ) ' But this value must be nonnegative.' stop end if end do ! ! The factors sum to N. ! n = sum ( factor(1:nfactor) ) arg = real ( n + 1 ) facn = gamma_log ( arg ) do i = 1, nfactor arg = real ( factor(i) + 1 ) fack = gamma_log ( arg ) facn = facn - fack end do ncomb = nint ( exp ( facn ) ) return end subroutine multinomial_coef2 ( nfactor, factor, ncomb ) ! !******************************************************************************* ! !! MULTINOMIAL_COEF2 computes a multinomial coefficient. ! ! ! Definition: ! ! The multinomial coefficient is a generalization of the binomial ! coefficient. It may be interpreted as the number of combinations of ! N objects, where FACTOR(1) objects are indistinguishable of type 1, ! ... and FACTOR(NFACTOR) are indistinguishable of type NFACTOR, ! and N is the sum of FACTOR(1) through FACTOR(NFACTOR). ! ! Formula: ! ! NCOMB = N! / ( FACTOR(1)! FACTOR(2)! ... FACTOR(NFACTOR)! ) ! ! Method: ! ! A direct method is used, which should be exact. However, there ! is a possibility of intermediate overflow of the result. ! ! Modified: ! ! 01 February 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NFACTOR, the number of factors. ! ! Input, integer FACTOR(NFACTOR), contains the factors. ! 0 <= FACTOR(I) ! ! Output, integer NCOMB, the value of the multinomial coefficient. ! implicit none ! integer nfactor ! integer factor(nfactor) integer i integer j integer k integer ncomb ! ! Each factor must be nonnegative. ! do i = 1, nfactor if ( factor(i) < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MULTINOMIAL_COEF2 - Fatal error' write ( *, '(a,i6,a,i6)' ) ' Factor ', I, ' = ', factor(i) write ( *, '(a)' ) ' But this value must be nonnegative.' stop end if end do ncomb = 1 k = 0 do i = 1, nfactor do j = 1, factor(i) k = k + 1 ncomb = ( ncomb * k ) / j end do end do return end subroutine network_flow_max ( nnode, nedge, iendpt, icpflo, isorce, isink, & icut, node_flow ) ! !******************************************************************************* ! !! NETWORK_FLOW_MAX finds the maximal flow and a minimal cut in a network. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 31 July 2000 ! ! Parameters: ! ! Input, integer NNODE, the number of nodes. ! ! Input, integer NEDGE, the number of edges. ! ! Input/output, integer IENDPT(2,NEDGE), the edges of the network, ! defined as pairs of nodes. Each edge should be listed TWICE, ! the second time in reverse order. On output, the edges have ! been reordered, and so the columns of IENDPT have been rearranged. ! ! Input/output, integer ICPFLO(2,NEDGE). Capacities and flows. ! On input, ICPFLO(1,I) is the capacity of edge I. On output, ! ICPFLO(2,I) is the flow on edge I and ICPFLO(1,I) has ! been rearranged to match the reordering of IENDPT. ! ! Input, integer ISORCE, the designated source node. ! ! Input, integer ISINK, the designated sink node. ! ! Output, integer ICUT(NNODE). ICUT(I) = 1 if node I is in the ! minimal cut set, otherwise 0. ! ! Output, integer NODE_FLOW(NNODE). NODE_FLOW(I) is the value of the flow ! through node I. ! implicit none ! integer nedge integer nnode ! integer i integer iarray(nnode) integer icpflo(2,nedge) integer icut(nnode) integer idel integer ien1 integer ien2 integer iendpt(2,nedge) integer indx integer ip integer iparm integer iq integer ir integer iread integer irite integer is integer isink integer isorce integer isort integer it integer iwork(nnode,2) integer j integer kz integer lst integer m integer node_flow(nnode) ! iarray(1:nnode) = 0 idel = 0 do i = 1, nedge icpflo(2,i) = 0 ip = iendpt(1,i) if ( ip == isorce ) then idel = idel + icpflo(1,i) end if iarray(ip) = iarray(ip) + 1 end do node_flow(isorce) = idel is = 1 do i = 1, nnode it = iarray(i) iarray(i) = is iwork(i,1) = is is = is + it end do isort = 0 ien1 = 0 ien2 = 0 10 continue indx = 0 50 continue do call sort_heap_external ( nedge, indx, ien1, ien2, is ) if ( indx < 0 ) then is = iendpt(1,ien1) - iendpt(1,ien2) if ( is == 0 ) then is = iendpt(2,ien1) - iendpt(2,ien2) end if else if ( indx > 0 ) then do ir = 1, 2 call i_swap ( iendpt(ir,ien1), iendpt(ir,ien2) ) call i_swap ( icpflo(ir,ien1), icpflo(ir,ien2) ) end do else if ( isort > 0 ) then return end if do i = 1, nedge iq = iendpt(2,i) iendpt(1,i) = iwork(iq,1) iwork(iq,1) = iwork(iq,1) + 1 end do go to 100 end if end do 80 continue iendpt(1,iendpt(1,ien1)) = ien2 iendpt(1,iendpt(1,ien2)) = ien1 do ir = 1, 2 call i_swap ( iendpt(ir,ien1), iendpt(ir,ien2) ) call i_swap ( icpflo(ir,ien1), icpflo(ir,ien2) ) end do if ( indx < 0 ) then go to 270 end if if ( indx == 0 ) then go to 170 end if go to 50 100 continue indx = 0 do i = 1, nnode if ( i /= isorce ) then node_flow(i) = 0 end if iwork(i,2) = nedge + 1 if ( i < nnode ) then iwork(i,2) = iarray(i+1) end if icut(i) = 0 end do iread = 0 irite = 1 iwork(1,1) = isorce icut(isorce) = - 1 120 continue iread = iread + 1 if ( iread <= irite ) then ip = iwork(iread,1) lst = iwork(ip,2) - 1 i = iarray(ip) - 1 do i = i + 1 if ( i > lst ) then go to 120 end if iq = iendpt(2,i) idel = icpflo(1,i) - icpflo(2,i) if ( icut(iq) == 0 .and. idel /= 0 ) then if ( iq /= isink ) then irite = irite + 1 iwork(irite,1) = iq end if icut(iq) = - 1 end if end do end if if ( icut(isink) == 0 ) then icut(1:nnode) = - icut(1:nnode) do i = 1, nedge ip = iendpt(2,iendpt(1,i)) if ( icpflo(2,i) < 0 ) then node_flow(ip) = node_flow(ip) - icpflo(2,i) end if iendpt(1,i) = ip end do node_flow(isorce) = node_flow(isink) isort = 1 go to 10 end if icut(isink) = 1 160 continue iread = iread - 1 if ( iread == 0 ) then go to 180 end if ip = iwork(iread,1) ien1 = iarray(ip) - 1 ien2 = iwork(ip,2) - 1 170 continue if ( ien1 /= ien2 ) then iq = iendpt(2,ien2) if ( icut(iq) <= 0 .or. icpflo(1,ien2) == icpflo(2,ien2) ) then ien2 = ien2 - 1 go to 170 end if iendpt(2,ien2) = - iq icpflo(1,ien2) = icpflo(1,ien2) - icpflo(2,ien2) icpflo(2,ien2) = 0 ien1 = ien1 + 1 if ( ien1 < ien2 ) then go to 80 end if end if if ( ien1 >= iarray(ip) ) then icut(ip) = ien1 end if go to 160 180 continue kz = 0 do ir = 1, irite if ( icut(iwork(ir,1)) > 0 ) then kz = kz + 1 iwork(kz,1) = iwork(ir,1) end if end do indx = - 1 m = 1 200 continue ip = iwork(m,1) if ( node_flow(ip) > 0 ) then go to 250 end if 210 continue m = m + 1 if ( m <= kz ) then go to 200 end if iparm = 0 220 continue m = m - 1 if ( m == 1 ) then do i = 1, nedge iq = - iendpt(2,i) if ( iq >= 0 ) then iendpt(2,i) = iq j = iendpt(1,i) icpflo(1,i) = icpflo(1,i) - icpflo(2,j) idel = icpflo(2,i) - icpflo(2,j) icpflo(2,i) = idel icpflo(2,j) = - idel end if end do go to 100 end if ip = iwork(m,1) if ( node_flow(ip) < 0 ) then go to 220 end if if ( node_flow(ip) == 0 ) then lst = nedge + 1 if ( ip < nnode ) then lst = iarray(ip+1) end if i = iwork(ip,2) iwork(ip,2) = lst do if ( i == lst ) then go to 220 end if j = iendpt(1,i) idel = icpflo(2,j) icpflo(2,j) = 0 icpflo(1,j) = icpflo(1,j) - idel icpflo(2,i) = icpflo(2,i) - idel i = i + 1 end do end if if ( iarray(ip) > icut(ip) ) then go to 300 end if 250 continue i = icut(ip) + 1 260 continue do i = i - 1 if ( i < iarray(ip) ) then go to 290 end if iq = - iendpt(2,i) if ( node_flow(iq) >= 0 ) then exit end if end do idel = icpflo(1,i) - icpflo(2,i) if ( node_flow(ip) < idel ) then idel = node_flow(ip) end if icpflo(2,i) = icpflo(2,i) + idel node_flow(ip) = node_flow(ip) - idel node_flow(iq) = node_flow(iq) + idel iparm = 1 ien1 = iendpt(1,i) ien2 = iwork(iq,2) - 1 if ( ien1 < ien2 ) then go to 80 end if if ( ien1 /= ien2 ) then go to 280 end if 270 continue iwork(iq,2) = ien2 280 continue if ( node_flow(ip) > 0 ) then go to 260 end if if ( icpflo(1,i) == icpflo(2,i) ) then i = i - 1 end if 290 continue icut(ip) = i if ( iparm /= 0 ) then go to 210 end if 300 continue i = iwork(ip,2) 310 continue j = iendpt(1,i) idel = icpflo(2,j) if ( node_flow(ip) < idel ) then idel = node_flow(ip) end if icpflo(2,j) = icpflo(2,j) - idel node_flow(ip) = node_flow(ip) - idel iq = iendpt(2,i) node_flow(iq) = node_flow(iq) + idel i = i + 1 if ( node_flow(ip) > 0 ) then go to 310 end if node_flow(ip) = - 1 go to 220 end subroutine nim_sum ( i, j, k ) ! !******************************************************************************* ! !! NIM_SUM computes the Nim sum of two integers. ! ! ! Discussion: ! ! If K is the Nim sum of I and J, then each bit of K is the exclusive ! OR of the corresponding bits of I and J. ! ! Example: ! ! I J K I_2 J_2 K_2 ! ---- ---- ---- ---------- ---------- ---------- ! 0 0 0 0 0 0 ! 1 0 1 1 0 1 ! 1 1 0 1 1 0 ! 2 7 5 10 111 101 ! 11 28 23 1011 11100 10111 ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, J, the integers to be Nim-summed. ! ! Input, integer K, the Nim sum of I and J. ! implicit none ! integer, parameter :: nbits = 32 ! integer i integer ivec(nbits) integer j integer jvec(nbits) integer k integer kvec(nbits) ! call i_to_ivec_binary ( i, nbits, ivec ) call i_to_ivec_binary ( j, nbits, jvec ) call ivec_binary_xor ( nbits, ivec, jvec, kvec ) call ivec_binary_to_i ( nbits, kvec, k ) return end subroutine pell_basic ( d, x0, y0 ) ! !******************************************************************************* ! !! PELL_BASIC returns the fundamental solution for Pell's basic equation. ! ! ! Discussion: ! ! Pell's equation has the form: ! ! X**2 - D * Y**2 = 1 ! ! where D is a given non-square integer, and X and Y may be assumed ! to be positive integers. ! ! Example: ! ! D X0 Y0 ! ! 2 3 2 ! 3 2 1 ! 5 9 4 ! 6 5 2 ! 7 8 3 ! 8 3 1 ! 10 19 6 ! 11 10 3 ! 12 7 2 ! 13 649 180 ! 14 15 4 ! 15 4 1 ! 17 33 8 ! 18 17 4 ! 19 170 39 ! 20 9 2 ! ! Reference: ! ! Mark Herkommer, ! Number Theory, A Programmer's Guide, ! McGraw Hill, 1999, pages 294-307 ! ! Modified: ! ! 19 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer D, the coefficient in Pell's equation. D should be ! positive, and not a perfect square. ! ! Output, integer X0, Y0, the fundamental or 0'th solution. ! If X0 = Y0 = 0, then the calculation was canceled because of an error. ! Both X0 and Y0 will be nonnegative. ! implicit none ! integer, parameter :: max_term = 100 ! integer b(0:max_term) integer d integer i integer n_term integer p integer pm1 integer pm2 integer q integer qm1 integer qm2 integer r integer x0 integer y0 ! ! If these values are returned, an error has occurred. ! x0 = 0 y0 = 0 ! ! Check D. ! if ( d <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PELL_BASIC - Fatal error!' write ( *, '(a)' ) ' Pell coefficient D <= 0.' return end if call i_sqrt ( d, q, r ) if ( r == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PELL_BASIC - Fatal error!' write ( *, '(a)' ) ' Pell coefficient is a perfect square.' return end if ! ! Find the continued fraction representation of sqrt ( D ). ! call i_sqrt_cf ( d, max_term, n_term, b ) ! ! If necessary, go for two periods. ! if ( mod ( n_term, 2 ) == 1 ) then do i = n_term + 1, 2*n_term b(i) = b(i-n_term) end do n_term = 2 * n_term end if ! ! Evaluate the continued fraction using the forward recursion algorithm. ! pm2 = 0 pm1 = 1 qm2 = 1 qm1 = 0 do i = 0, n_term-1 p = b(i) * pm1 + pm2 q = b(i) * qm1 + qm2 pm2 = pm1 pm1 = p qm2 = qm1 qm1 = q end do ! ! Get the fundamental solution. ! x0 = p y0 = q return end subroutine pell_next ( d, x0, y0, xn, yn, xnp1, ynp1 ) ! !******************************************************************************* ! !! PELL_NEXT returns the next solution of Pell's equation. ! ! ! Discussion: ! ! Pell's equation has the form: ! ! X**2 - D * Y**2 = 1 ! ! where D is a given non-square integer, and X and Y may be assumed ! to be positive integers. ! ! To compute X0, Y0, call PELL_BASIC. ! To compute X1, Y1, call this routine, with XN and YN set to X0 and Y0. ! To compute further solutions, call again with X0, Y0 and the previous ! solution. ! ! Example: ! ! ------INPUT-------- --OUTPUT-- ! ! D X0 Y0 XN YN XNP1 YNP1 ! ! 2 3 2 3 2 17 12 ! 2 3 2 17 12 99 70 ! 2 3 2 99 70 577 408 ! 2 3 2 577 408 3363 2378 ! ! Reference: ! ! Mark Herkommer, ! Number Theory, A Programmer's Guide, ! McGraw Hill, 1999, pages 294-307 ! ! Modified: ! ! 16 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer D, the coefficient in Pell's equation. ! ! Input, integer X0, Y0, the fundamental or 0'th solution. ! ! Input, integer XN, YN, the N-th solution. ! ! Output, integer XNP1, YNP1, the N+1-th solution. ! implicit none ! integer d integer x0 integer xn integer xnp1 integer y0 integer yn integer ynp1 ! xnp1 = x0 * xn + d * y0 * yn ynp1 = x0 * yn + y0 * xn return end subroutine pent_enum ( n, p ) ! !******************************************************************************* ! !! PENT_ENUM computes the N-th pentagonal number. ! ! ! Definition: ! ! The pentagonal number P(N) counts the number of dots in a figure of ! N nested pentagons. The pentagonal numbers are defined for both ! positive and negative N. ! ! First values: ! ! N P ! ! -5 40 ! -4 26 ! -3 15 ! -2 7 ! -1 2 ! 0 0 ! 1 1 ! 2 5 ! 3 12 ! 4 22 ! 5 35 ! ! Formula: ! ! P(N) = ( N * ( 3 * N - 1 ) ) / 2 ! ! Modified: ! ! 22 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the index of the pentagonal number desired. ! ! Output, integer P, the value of the N-th pentagonal number. ! implicit none ! integer n integer p ! p = ( n * ( 3 * n - 1 ) ) / 2 return end subroutine perm_ascend ( n, a, length, sub ) ! !******************************************************************************* ! !! PERM_ASCEND computes the longest ascending subsequence of permutation. ! ! ! Discussion: ! ! Although this routine is intended to be applied to a permutation, ! it will work just as well for an arbitrary vector. ! ! Modified: ! ! 07 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the permutation. ! ! Input, integer A(N), the permutation to be examined. ! ! Output, integer LENGTH, the length of the longest increasing subsequence. ! ! Output, integer SUB(N), contains in entries 1 through LENGTH ! a longest increasing subsequence of A. ! implicit none ! integer n ! integer a(n) integer a1 integer a2 integer i integer j integer k integer length integer sub(n) integer top(n) integer top_prev(n) ! top(1:n) = 0 top_prev(1:n) = 0 sub(1:n) = 0 if ( n <= 0 ) then length = 0 return end if length = 0 do i = 1, n k = 0 do j = 1, length if ( a(i) <= a(top(j)) ) then k = j exit end if end do if ( k == 0 ) then length = length + 1 k = length end if top(k) = i if ( k > 1 ) then top_prev(i) = top(k-1) else top_prev(i) = 0 end if end do j = top(length) sub(length) = a(j) do i = length-1, 1, -1 j = top_prev(j) sub(i) = a(j) end do return end subroutine perm_break_count ( n, p, break_count ) ! !******************************************************************************* ! !! PERM_BREAK_COUNT counts the number of "breaks" in a permutation. ! ! ! Discussion: ! ! We begin with a permutation of order N. We prepend an element ! labeled "0" and append an element labeled "N+1". There are now ! N+1 pairs of neighbors. A "break" is a pair of neighbors whose ! value differs by more than 1. ! ! The identity permutation has a break count of 0. The maximum ! break count is N+1. ! ! Modified: ! ! 25 October 2001 ! ! Parameters: ! ! Input, integer N, the order of the permutation. ! ! Input, integer P(N), a permutation, in standard index form. ! ! Output, integer BREAK_COUNT, the number of breaks in the permutation. ! implicit none ! integer n ! integer break_count integer i integer ierror integer p(n) ! break_count = 0 ! ! Make sure the permutation is a legal one. ! (This is not an efficient way to do so!) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_BREAK_COUNT - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if if ( p(1) /= 1 ) then break_count = break_count + 1 end if do i = 1, n-1 if ( abs ( p(i+1) - p(i) ) /= 1 ) then break_count = break_count + 1 end if end do if ( p(n) /= n ) then break_count = break_count + 1 end if return end subroutine perm_canon_to_cycle ( n, p1, p2 ) ! !******************************************************************************* ! !! PERM_CANON_TO_CYCLE converts a permutation from canonical to cycle form. ! ! ! Example: ! ! Input: ! ! 4 5 2 1 6 3 ! ! Output: ! ! -4 5 -2 -1 6 3, ! indicating the cycle structure ! ( 4, 5 ) ( 2 ) ( 1, 6, 3 ) ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, page 176. ! ! Modified: ! ! 30 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects permuted. ! ! Input, integer P1(N), the permutation, in canonical form. ! ! Output, integer P2(N), the permutation, in cycle form. ! implicit none ! integer n ! integer i integer p1(n) integer p2(n) integer pmin ! p2(1:n) = p1(1:n) pmin = p2(1) + 1 do i = 1, n if ( p2(i) < pmin ) then pmin = p2(i) p2(i) = - p2(i) end if end do return end subroutine perm_check ( n, p, ierror ) ! !******************************************************************************* ! !! PERM_CHECK checks that a vector represents a permutation. ! ! ! Discussion: ! ! The routine verifies that each of the integers from 1 ! to N occurs among the N entries of the permutation. ! ! Modified: ! ! 06 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries. ! ! Input, integer P(N), the permutation, in standard index form. ! ! Output, integer IERROR, error flag. ! 0, the array does represent a permutation. ! nonzero, the array does not represent a permutation. The smallest ! missing value is equal to IERROR. ! implicit none ! integer n ! integer ierror integer ifind integer iseek integer p(n) ! ierror = 0 do iseek = 1, n ierror = iseek do ifind = 1, n if ( p(ifind) == iseek ) then ierror = 0 exit end if end do if ( ierror /= 0 ) then return end if end do return end subroutine perm_cycle ( n, p, isgn, ncycle, iopt ) ! !******************************************************************************* ! !! PERM_CYCLE analyzes a permutation. ! ! ! Discussion: ! ! The routine will count cycles, find the sign of a permutation, ! and tag a permutation. ! ! Example: ! ! Input: ! ! N = 9 ! IOPT = 1 ! P = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Output: ! ! NCYCLE = 3 ! ISGN = +1 ! P = -2, 3, 9, -6, -7, 8, 5, 4, 1 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer P(N). On input, P describes a ! permutation, in the sense that entry I is to be moved to P(I). ! If IOPT = 0, then P will not be changed by this routine. ! If IOPT = 1, then on output, P will be "tagged". That is, ! one element of every cycle in P will be negated. In this way, ! a user can traverse a cycle by starting at any entry I1 of P ! which is negative, moving to I2 = ABS(P(I1)), then to ! P(I2), and so on, until returning to I1. ! ! Output, integer ISGN, the "sign" of the permutation, which is ! +1 if the permutation is even, -1 if odd. Every permutation ! may be produced by a certain number of pairwise switches. ! If the number of switches is even, the permutation itself is ! called even. ! ! Output, integer NCYCLE, the number of cycles in the permutation. ! ! Input, integer IOPT, requests tagging. ! 0, the permutation will not be tagged. ! 1, the permutation will be tagged. ! implicit none ! integer n ! integer i integer i1 integer i2 integer ierror integer iopt integer is integer isgn integer ncycle integer p(n) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_CYCLE - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if is = 1 ncycle = n do i = 1, n i1 = p(i) do while ( i1 > i ) ncycle = ncycle - 1 i2 = p(i1) p(i1) = - i2 i1 = i2 end do if ( iopt /= 0 ) then is = - sign ( 1, p(i) ) end if p(i) = sign ( p(i), is ) end do isgn = 1 - 2 * mod ( n - ncycle, 2 ) return end subroutine perm_cycle_to_canon ( n, p1, p2 ) ! !******************************************************************************* ! !! PERM_CYCLE_TO_CANON converts a permutation from cycle to canonical form. ! ! ! Example: ! ! Input: ! ! -6 3 1 -5, 4 -2, ! indicating the cycle structure ! ( 6, 3, 1 ) ( 5, 4 ) ( 2 ) ! ! Output: ! ! 4 5 2 1 6 3 ! ! Discussion: ! ! The procedure is to "rotate" the elements of each cycle so that ! the smallest element is first: ! ! ( 1, 6, 3 ) ( 4, 5 ) ( 2 ) ! ! and then to sort the cycles in decreasing order of their first ! (and lowest) element: ! ! ( 4, 5 ) ( 2 ) ( 1, 6, 3 ) ! ! and then to drop the parentheses: ! ! 4 5 2 1 6 3 ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, pages 176. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects permuted. ! ! Input, integer P1(N), the permutation, in cycle form. ! ! Output, integer P2(N), the permutation, in canonical form. ! implicit none ! integer n ! integer hi(n) integer i integer indx(n) integer j integer k integer lo(n) integer ncycle integer next integer nhi integer nlo integer nmin integer p1(n) integer p2(n) integer pmin(n) integer ptemp(n) ! p2(1:n) = p1(1:n) ! ! Work on the next cycle. ! nlo = 1 ncycle = 0 do while ( nlo <= n ) ! ! Identify NHI, the last index in this cycle. ! ncycle = ncycle + 1 nhi = nlo do while ( nhi < n ) if ( p2(nhi+1) < 0 ) then exit end if nhi = nhi + 1 end do ! ! Identify the smallest value in this cycle. ! p2(nlo) = - p2(nlo) pmin(ncycle) = p2(nlo) nmin = nlo do i = nlo+1, nhi if ( p2(i) < pmin(ncycle) ) then pmin(ncycle) = p2(i) nmin = i end if end do ! ! Rotate the cycle so A_MIN occurs first. ! ptemp(nlo+nhi+1-nmin:nhi) = p2(nlo:nmin-1) ptemp(nlo:nlo+nhi-nmin) = p2(nmin:nhi) lo(ncycle) = nlo hi(ncycle) = nhi ! ! Prepare to operate on the next cycle. ! nlo = nhi + 1 end do ! ! Compute a sorting index for the cycle minima. ! call ivec_sort_heap_index_d ( ncycle, pmin, indx ) ! ! Copy the cycles out of the temporary array in sorted order. ! j = 0 do i = 1, ncycle next = indx(i) nlo = lo(next) nhi = hi(next) do k = nlo, nhi j = j + 1 p2(j) = ptemp(k) end do end do return end subroutine perm_cycle_to_index ( n, p1, p2 ) ! !******************************************************************************* ! !! PERM_CYCLE_TO_INDEX converts a permutation from cycle to standard index form. ! ! ! Example: ! ! Input: ! ! N = 9 ! P1 = -1, 2, 3, 9, -4, 6, 8, -5, 7 ! ! Output: ! ! P2 = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer P1(N), the permutation, in cycle form. ! ! Output, integer P2(N), the permutation, in standard index form. ! implicit none ! integer n ! integer j integer k1 integer k2 integer k3 integer p1(n) integer p2(n) ! do j = 1, n k1 = p1(j) if ( k1 < 0 ) then k1 = - k1 k3 = k1 end if if ( j + 1 <= n ) then k2 = p1(j+1) if ( k2 < 0 ) then k2 = k3 end if else k2 = k3 end if p2(k1) = k2 end do return end subroutine perm_distance ( n, a, b, k ) ! !******************************************************************************* ! !! PERM_DISTANCE computes the Ulam metric distance of two permutations. ! ! ! Discussion: ! ! If we let N be the order of the permutations A and B, and L(P) be ! the length of the longest ascending subsequence of a permutation P, ! then the Ulam metric distance between A and B is ! ! N - L ( A * inverse ( B ) ). ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the permutation. ! ! Input, integer A(N), B(N), the permutations to be examined. ! ! Output, integer K, the Ulam metric distance between A and B. ! implicit none ! integer n ! integer a(n) integer b(n) integer binv(n) integer c(n) integer k integer length integer sub(n) ! binv(1:n) = b(1:n) call perm_inv ( n, binv ) call perm_mul ( n, a, binv, c ) call perm_ascend ( n, c, length, sub ) k = n - length return end subroutine perm_fixed_enum ( n, m, fnm ) ! !******************************************************************************* ! !! PERM_FIXED_ENUM enumerates the permutations of N objects with M fixed. ! ! ! Definition: ! ! A permutation of N objects with M fixed is a permutation in which ! exactly M of the objects retain their original positions. If ! M = 0, the permutation is a "derangement". If M = N, the ! permutation is the identity. ! ! Formula: ! ! F(N,M) = ( N! / M! ) * ( 1 - 1/1! + 1/2! - 1/3! ... 1/(N-M)! ) ! = COMB(N,M) * D(N-M) ! where D(N-M) is the number of derangements of N-M objects. ! ! Modified: ! ! 31 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! N should be at least 1. ! ! Input, integer M, the number of objects that retain their ! position. M should be between 0 and N. ! ! Output, integer FNM, the number of derangements of N objects ! in which M objects retain their positions. ! implicit none ! integer derange_enum integer fnm integer icnm integer m integer n ! if ( n <= 0 ) then fnm = 1 else if ( m < 0 ) then fnm = 0 else if ( m > n ) then fnm = 0 else if ( m == n ) then fnm = 1 else if ( n == 1 ) then if ( m == 1 ) then fnm = 1 else fnm = 0 end if else call combin2 ( n, m, icnm ) fnm = icnm * derange_enum ( n - m ) end if return end subroutine perm_free ( ipart, npart, ifree, nfree ) ! !******************************************************************************* ! !! PERM_FREE reports the number of unused items in a partial permutation. ! ! ! Discussion: ! ! It is assumed that the N objects being permuted are the integers ! from 1 to N, and that IPART contains a "partial" permutation, that ! is, the NPART entries of IPART represent the beginning of a ! permutation of all N items. ! ! The routine returns in IFREE the items that have not been used yet. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IPART(NPART), the partial permutation, which should ! contain, at most once, some of the integers between 1 and ! NPART+NFREE. ! ! Input, integer NPART, the number of entries in IPART. NPART may be 0. ! ! Output, integer IFREE(NFREE), the integers between 1 and NPART+NFREE ! that were not used in IPART. ! ! Input, integer NFREE, the number of integers that have not been ! used in IPART. This is simply N - NPART. NFREE may be zero. ! implicit none ! integer nfree integer npart ! integer i integer ifree(nfree) integer ipart(npart) integer j integer k integer match integer n ! n = npart + nfree if ( npart < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_FREE - Fatal error!' write ( *, '(a)' ) ' NPART < 0.' stop else if ( npart == 0 ) then call ivec_identity ( n, ifree ) else if ( nfree < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_FREE - Fatal error!' write ( *, '(a)' ) ' NFREE < 0.' stop else if ( nfree == 0 ) then return else k = 0 do i = 1, n match = 0 do j = 1, npart if ( ipart(j) == i ) then match = j exit end if end do if ( match == 0 ) then k = k + 1 if ( k > nfree ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_FREE - Fatal error!' write ( *, '(a)' ) ' The partial permutation is illegal.' write ( *, '(a)' ) ' It should contain, at most once, some of' write ( *, '(a,i6)' ) ' the integers between 1 and ', n stop end if ifree(k) = i end if end do end if return end subroutine perm_index_to_cycle ( n, p1, p2 ) ! !******************************************************************************* ! !! PERM_INDEX_TO_CYCLE converts a permutation from standard index to cycle form. ! ! ! Example: ! ! Input: ! ! N = 9 ! P1 = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Output: ! ! P2 = -1, 2, 3, 9, -4, 6, 8, -5, 7 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer P1(N), the permutation, in standard index form. ! ! Output, integer P2(N), the permutation, in cycle form. ! implicit none ! integer n ! integer i integer j integer k integer p1(n) integer p2(n) ! i = 0 j = 1 do while ( j <= n ) if ( p1(j) < 0 ) then j = j + 1 else k = j i = i + 1 p2(i) = - k do while ( p1(k) /= j ) i = i + 1 p2(i) = p1(k) p1(k) = - p1(k) k = abs ( p1(k) ) end do p1(k) = - p1(k) end if end do p1(1:n) = abs ( p1(1:n) ) return end subroutine perm_ins ( n, p, ins ) ! !******************************************************************************* ! !! PERM_INS computes the inversion sequence of a permutation. ! ! ! Definition: ! ! For a given permutation P acting on objects 1 through N, the inversion ! sequence INS is defined as: ! ! INS(1) = 0 ! INS(I) = number of values J < I for which P(J) > P(I). ! ! Example: ! ! Input: ! ! ( 3, 5, 1, 4, 2 ) ! ! Output: ! ! ( 0, 0, 2, 1, 3 ) ! ! Note: ! ! The original permutation can be recovered from the inversion sequence. ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer P(N), the permutation, in standard index form. ! The I-th item has been mapped to P(I). ! ! Output, integer INS(N), the inversion sequence of the permutation. ! implicit none ! integer n ! integer i integer ierror integer ins(n) integer j integer p(n) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INS - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if ins(1:n) = 0 do i = 1, n do j = 1, i-1 if ( p(j) > p(i) ) then ins(i) = ins(i) + 1 end if end do end do return end subroutine perm_inv ( n, p ) ! !******************************************************************************* ! !! PERM_INV inverts a permutation "in place". ! ! ! Modified: ! ! 25 July 2000 ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer P(N), the permutation, in standard index form. ! On output, P describes the inverse permutation ! implicit none ! integer n ! integer i integer i0 integer i1 integer i2 integer ierror integer is integer p(n) ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INV - Fatal error!' write ( *, '(a,i6)' ) ' Input value of N = ', n stop end if call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INV - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if is = 1 do i = 1, n i1 = p(i) do while ( i1 > i ) i2 = p(i1) p(i1) = - i2 i1 = i2 end do is = - sign ( 1, p(i) ) p(i) = sign ( p(i), is ) end do do i = 1, n i1 = - p(i) if ( i1 >= 0 ) then i0 = i do i2 = p(i1) p(i1) = i0 if ( i2 < 0 ) then exit end if i0 = i1 i1 = i2 end do end if end do return end subroutine perm_inv2 ( n, p ) ! !***************************************************************************** ! !! PERM_INV2 inverts a permutation "in place". ! ! ! Discussion: ! ! The routine needs no extra vector storage in order to compute the ! inverse of a permutation. ! ! This feature might be useful if the permutation is large. ! ! Modified: ! ! 25 July 2000 ! ! Parameters: ! ! Input, integer N, the number of objects in the permutation. ! ! Input/output, integer P(N), the permutation, in standard index form. ! On output, the inverse permutation. ! implicit none ! integer n ! integer i integer ierror integer ii integer j integer k integer m integer p(n) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_INV2 - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if ! do ii = 1, n m = n + 1 - ii i = p(m) if ( i < 0 ) then p(m) = - i else if ( i /= m ) then k = m do j = p(i) p(i) = - k if ( j == m ) then p(m) = i exit end if k = i i = j end do end if end do return end subroutine perm_lex ( n, p, more ) ! !******************************************************************************* ! !! PERM_LEX generates permutations in lexical order, one at a time. ! ! ! Example: ! ! N = 3 ! ! 1 1 2 3 ! 2 1 3 2 ! 3 2 1 3 ! 4 2 3 1 ! 5 3 1 2 ! 6 3 2 1 ! ! Reference: ! ! Mok-Kong Shen, ! Algorithm 202: Generation of Permutations in Lexicographical Order, ! Communications of the ACM, ! Volume 6, September 1963, page 517. ! ! Modified: ! ! 24 September 1998 ! ! Parameters: ! ! Input, integer N, the number of elements being permuted. ! ! Input/output, integer P(N), the permutation, in standard index form. ! ! The user should not alter the elements of Pbetween successive ! calls. The routine uses the input value of P to determine ! the output value. ! ! Input/output, logical MORE. ! ! On the first call, the user should set MORE = FALSE, which signals ! the routine to do initialization. ! ! On return, if MORE is TRUE, then another permutation has been ! computed and returned, while if MORE is FALSE, there are no more ! permutations. ! implicit none ! integer n ! integer i integer j integer k logical more integer p(n) integer u integer w ! ! Initialization. ! if ( .not. more ) then call ivec_identity ( n, p ) more = .true. else if ( n <= 1 ) then more = .false. return end if w = n do while ( p(w) < p(w-1) ) if ( w == 2 ) then more = .false. return end if w = w - 1 end do u = p(w-1) do j = n, w, -1 if ( p(j) > u ) then p(w-1) = p(j) p(j) = u do k = 0, ( n - w - 1 ) / 2 call i_swap ( p(n-k), p(w+k) ) end do return end if end do end if return end subroutine perm_mul ( n, p1, p2, p3 ) ! !******************************************************************************* ! !! PERM_MUL "multiplies" two permutations. ! ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the permutations. ! ! Input, integer P1(N), P2(N), the permutations, in standard index form. ! ! Output, integer P3(N), the product permutation. ! implicit none ! integer n ! integer i integer ierror integer p1(n) integer p2(n) integer p3(n) ! call perm_check ( n, p1, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_MUL - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if call perm_check ( n, p2, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_MUL - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if p3(1:n) = p2(p1(1:n)) return end subroutine perm_next ( n, p, more, even ) ! !******************************************************************************* ! !! PERM_NEXT computes all of the permutations of N objects, one at a time. ! ! ! Discussion: ! ! The routine is initialized by calling with MORE = TRUE, in which case ! it returns the identity permutation. ! ! If the routine is called with MORE = FALSE, then the successor of the ! input permutation is computed. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 30 March 2001 ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer P(N), the permutation, in standard index form. ! ! On the first call, the input value is unimportant. ! On subsequent calls, the input value should be the same ! as the output value from the previous call. In other words, the ! user should just leave P alone. ! ! On output, contains the "next" permutation. ! ! Input/output, logical MORE. ! ! Set MORE = .FALSE. before the first call. ! ! MORE will be reset to .TRUE. and a permutation will be returned. ! ! Each new call produces a new permutation until ! MORE is returned .FALSE. ! ! Input/output, logical EVEN. ! ! The input value of EVEN should simply be its output value from the ! previous call; (the input value on the first call doesn't matter.) ! ! On output, EVEN is .TRUE. if the output permutation is even, that is, ! involves an even number of transpositions. ! implicit none ! integer n ! logical even integer i integer i1 integer ia integer id integer is integer j integer l integer m logical more integer p(n) ! if ( .not. more ) then call ivec_identity ( n, p ) more = .true. even = .true. if ( n == 1 ) then more = .false. return end if if ( p(n) /= 1 .or. p(1) /= 2 + mod ( n, 2 ) ) then return end if do i = 1, n-3 if ( p(i+1) /= p(i)+1 ) then return end if end do more = .false. else if ( n == 1 ) then p(1) = 0 more = .false. return end if if ( even ) then ia = p(1) p(1) = p(2) p(2) = ia even = .false. if ( p(n) /= 1 .or. p(1) /= 2 + mod ( n, 2 ) ) then return end if do i = 1, n-3 if ( p(i+1) /= p(i)+1 ) then return end if end do more = .false. return else more = .false. is = 0 do i1 = 2, n ia = p(i1) i = i1 - 1 id = 0 do j = 1, i if ( p(j) > ia ) then id = id + 1 end if end do is = id + is if ( id /= i * mod ( is, 2 ) ) then more = .true. exit end if end do if ( .not. more ) then p(1) = 0 return end if end if m = mod ( is+1, 2 ) * ( n + 1 ) do j = 1, i if ( sign ( 1, p(j)-ia ) /= sign ( 1, p(j)-m ) ) then m = p(j) l = j end if end do p(l) = ia p(i1) = m even = .true. end if return end subroutine perm_next2 ( n, p, done, iactiv, idir, invers ) ! !******************************************************************************* ! !! PERM_NEXT2 generates all the permutations of N objects. ! ! ! Discussion: ! ! The routine generates the permutations one at a time. It uses a ! particular ordering of permutations, generating them from the first ! (which is the identity permutation) to the N!-th. The same ordering ! is used by the routines PERM_RANK and PERM_UNRANK. ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of elements in the set to be permuted. ! ! Input/output, integer P(N), the permutation, in standard index form. ! ! Input/output, logical DONE. The user should set the input value of ! DONE only once, before the first call to compute the permutations. ! The user should set DONE to .TRUE., which signals the routine ! that it is to initialize itself. ! ! Thereafter, the routine will set DONE to .FALSE. and will ! compute a new permutation on each call. ! ! However, when there are no more permutations to compute, the ! routine will not return a new permutation, but instead will ! return DONE with the value .TRUE.. At this point, all the ! permutations have been computed. ! ! Workspace, integer IACTIV(N). ! ! On each call, as long as DONE is not returned as ! .TRUE., P will contain a new permutation. Since this ! permutation is computed in part from the previous one, the user ! should not overwrite or alter the contents of P during ! the computation. ! ! Workspace, integer IDIR(N). ! ! Output, integer INVERS(N). This array, which is computed as a ! byproduct of the main computation, contains the inverse permutation ! to that contained in P. In particular, INVERS(P(I)) = I. ! implicit none ! integer n ! logical done integer i integer iactiv(n) integer idir(n) integer invers(n) integer j integer nactiv integer p(n) ! ! An input value of .FALSE. for DONE is assumed to mean a new ! computation is beginning. ! if ( done ) then call ivec_identity ( n, p ) invers(1:n) = p(1:n) idir(1:n) = -1 iactiv(1) = 0 iactiv(2:n) = 1 ! ! Set the DONE flag to .FALSE., signifying there are more permutations ! to come. Except, of course, that we must take care of the trivial case! ! if ( n > 1 ) then done = .false. else done = .true. end if ! ! Otherwise, assume we are in a continuing computation ! else nactiv = 0 do i = 1, n if ( iactiv(i) /= 0 ) then nactiv = i end if end do if ( nactiv <= 0 ) then done = .true. else j = invers(nactiv) p(j) = p(j+idir(nactiv)) p(j+idir(nactiv)) = nactiv invers(nactiv) = invers(nactiv) + idir(nactiv) invers(p(j)) = j if ( j+2*idir(nactiv) < 1.or.j+2*idir(nactiv) > n ) then idir(nactiv) = - idir(nactiv) iactiv(nactiv) = 0 else if ( nactiv < p(j+2*idir(nactiv)) ) then idir(nactiv) = - idir(nactiv) iactiv(nactiv) = 0 end if iactiv(nactiv+1:n) = 1 end if end if return end subroutine perm_next3 ( n, p, more ) ! !******************************************************************************* ! !! PERM_NEXT3 computes all of the permutations of N objects, one at a time. ! ! ! Discussion: ! ! The routine is initialized by calling with MORE = TRUE, in which case ! it returns the identity permutation. ! ! If the routine is called with MORE = FALSE, then the successor of the ! input permutation is computed. ! ! Trotter's algorithm is used. ! ! Reference: ! ! H Trotter, ! PERM, Algorithm 115, ! Communications of the Association for Computing Machinery, ! Volume 5, 1962, pages 434-435. ! ! Modified: ! ! 25 July 2000 ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer P(N), the permutation, in standard index form. ! If MORE is .TRUE., then P is assumed to contain the ! "previous" permutation, and on P(I) is the value ! of the I-th object under the next permutation. ! Otherwise, P will be set to the "first" permutation. ! ! Input/output, logical MORE. ! Set MORE = .FALSE. before first calling this routine. ! MORE will be reset to .TRUE. and a permutation will be returned. ! Each new call produces a new permutation until MORE is returned .FALSE. ! implicit none ! integer n ! integer i integer, save :: irank = 0 integer m2 logical more integer n2 integer, save :: nfact = 0 integer p(n) integer q integer s integer t ! if ( .not. more ) then call ivec_identity ( n, p ) more = .true. irank = 1 nfact = 1 do i = 1, n nfact = nfact * i end do else n2 = n m2 = irank s = n do q = mod ( m2, n2 ) t = mod ( m2, 2 * n2 ) if ( q /= 0 ) then exit end if if ( t == 0 ) then s = s - 1 end if m2 = m2 / n2 n2 = n2 - 1 end do if ( q == t ) then s = s - q else s = s + q - n2 end if call i_swap ( p(s), p(s+1) ) irank = irank + 1 if ( irank == nfact ) then more = .false. end if end if return end subroutine perm_print ( n, p, title ) ! !******************************************************************************* ! !! PERM_PRINT prints a permutation. ! ! ! Example: ! ! Input: ! ! P = 7 2 4 1 5 3 6 ! ! Printed output: ! ! "This is the permutation:" ! ! 1 2 3 4 5 6 7 ! 7 2 4 1 5 3 6 ! ! Modified: ! ! 25 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects permuted. ! ! Input, integer P(N), the permutation, in standard index form. ! ! Input, character ( len = * ) TITLE, an optional title. ! If no title is supplied, then only the permutation is printed. ! implicit none ! integer n ! integer i integer ihi integer ilo integer, parameter :: inc = 20 integer p(n) character ( len = * ) title ! if ( len_trim ( title ) /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) do ilo = 1, n, inc ihi = min ( n, ilo + inc - 1 ) write ( *, '(a)' ) ' ' write ( *, '(20i4)' ) ( i, i = ilo, ihi ) write ( *, '(20i4)' ) p(ilo:ihi) end do else do ilo = 1, n, inc ihi = min ( n, ilo + inc - 1 ) write ( *, '(20i4)' ) p(ilo:ihi) end do end if return end subroutine perm_random ( n, p ) ! !******************************************************************************* ! !! PERM_RANDOM selects a random permutation of N objects. ! ! ! Discussion: ! ! The routine assumes the objects are labeled 1, 2, ... N. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 12 May 2002 ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Output, integer P(N), a permutation of ( 1, 2, ..., N ), in standard ! index form. ! implicit none ! integer n ! integer i integer j integer p(n) ! call ivec_identity ( n, p ) do i = 1, n call i_random ( i, n, j ) call i_swap ( p(i), p(j) ) end do return end subroutine perm_random2 ( n, p ) ! !******************************************************************************* ! !! PERM_RANDOM2 selects a random permutation of N objects. ! ! ! Discussion: ! ! The input values of P are used as labels; that is, the I-th object ! is labeled P(I). ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 12 May 2002 ! ! Parameters: ! ! Input, integer N, the number of objects to be permuted. ! ! Input/output, integer P(N), on input, a list of labels. On output, ! the list has been permuted randomly. ! implicit none ! integer n ! integer i integer j integer p(n) ! do i = 1, n call i_random ( i, n, j ) call i_swap ( p(i), p(j) ) end do return end subroutine perm_random3 ( n, p ) ! !******************************************************************************* ! !! PERM_RANDOM3 selects a random permutation of N elements. ! ! ! Reference: ! ! K L Hoffman and D R Shier, ! Algorithm 564, ! A Test Problem Generator for Discrete Linear L1 Approximation Problems, ! ACM Transactions on Mathematical Software, ! Volume 6, Number 4, December 1980, pages 615-617. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! James Filliben ! National Bureau of Standards. ! ! Parameters: ! ! Input, integer N, the number of elements of the array. ! ! Output, integer P(N), a permutation, in standard index form. ! implicit none ! integer n ! integer i integer iadd integer j integer p(n) ! if ( n < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_RANDOM3 - Fatal error!' write ( *, '(a,i6)' ) ' Illegal input value of N = ', n write ( *, '(a)' ) ' N must be at least 1!' stop end if if ( n == 1 ) then p(1) = 1 return end if call ivec_identity ( n, p ) do i = 1, n call i_random ( 1, n, iadd ) j = i + iadd if ( j > n ) then j = j - n end if if ( i /= j ) then call i_swap ( p(j), p(i) ) end if end do return end subroutine perm_rank ( n, p, ierror, invers, irank ) ! !******************************************************************************* ! !! PERM_RANK computes the rank of a given permutation. ! ! ! Discussion: ! ! This is the same as asking for the step at which PERM_NEXT2 ! would compute the permutation. The value of the rank will be ! between 1 and N!. ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of elements in the set that ! is permuted by P. ! ! Input, integer P(N), a permutation, in standard index form. ! ! Output, integer IERROR, error flag. ! 0, no error. ! nonzero, IARRAY does not represent a permutation of the integers ! from 1 to N. In particular, the value IERROR is missing. ! ! Output, integer INVERS(N), the inverse permutation of P. ! It is computed as part of the algorithm, and may be of use ! to the user. INVERS(P(I)) = I for each entry I. ! ! Output, integer IRANK, the rank of the permutation. This ! gives the order of the given permutation in the set of all ! the permutations on N elements. ! implicit none ! integer n ! integer i integer icount integer ierror integer invers(n) integer irank integer irem integer j integer p(n) ! ! Make sure the permutation is a legal one. ! (This is not an efficient way to do so!) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_RANK - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if ! ! Compute the inverse permutation ! invers(1:n) = p(1:n) call perm_inv2 ( n, invers ) irank = 0 do i = 1, n icount = 0 do j = 1, invers(i) if ( p(j) < i ) then icount = icount + 1 end if end do if ( mod ( irank, 2 ) == 1 ) then irem = icount else irem = i - 1 - icount end if irank = i * irank + irem end do irank = irank + 1 return end subroutine perm_sign ( n, p, p_sign ) ! !******************************************************************************* ! !! PERM_SIGN returns the sign of a permutation. ! ! ! Discussion: ! ! A permutation can always be replaced by a sequence of pairwise ! transpositions. A given permutation can be represented by ! many different such transposition sequences, but the number of ! such transpositions will always be odd or always be even. ! If the number of transpositions is even or odd, the permutation is ! said to be even or odd. ! ! Example: ! ! Input: ! ! N = 9 ! P = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Output: ! ! P_SIGN = +1 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 01 February 2000 ! ! Parameters: ! ! Input, integer N, the number of objects permuted. ! ! Input, integer P(N), a permutation, in standard index form. ! ! Output, integer P_SIGN, the "sign" of the permutation. ! +1, the permutation is even, ! -1, the permutation is odd. ! implicit none ! integer n ! integer i integer ierror integer ivec_index integer j integer p(n) integer p_sign integer q(n) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_SIGN - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if ! ! Make a temporary copy of the permutation. ! q(1:n) = p(1:n) ! ! Start with P_SIGN indicating an even permutation. ! Restore each element of the permutation to its correct position, ! updating P_SIGN as you go. ! p_sign = 1 do i = 1, n-1 j = ivec_index ( n, q, i ) if ( j /= i ) then call i_swap ( q(i), q(j) ) p_sign = - p_sign end if end do return end subroutine perm_to_equiv ( n, p, npart, jarray, iarray ) ! !******************************************************************************* ! !! PERM_TO_EQUIV computes the partition induced by a permutation. ! ! ! Example: ! ! Input: ! ! N = 9 ! P = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Output: ! ! NPART = 3 ! JARRAY = 4, 3, 2 ! IARRAY = 1, 1, 1, 2 3 2 3 2, 1 ! ! Modified: ! ! 26 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer P(N), a permutation, in standard index form. ! ! Output, integer NPART, number of subsets in the partition. ! ! Output, integer JARRAY(N). JARRAY(I) is the number of elements ! in the I-th subset of the partition. ! ! Output, integer IARRAY(N). IARRAY(I) is the class to which ! element I belongs. ! implicit none ! integer n ! integer i integer iarray(n) integer ierror integer j integer jarray(n) integer k integer npart integer p(n) ! call perm_check ( n, p, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM__TO_EQUIV - Fatal error!' write ( *, '(a)' ) ' The input array does not represent' write ( *, '(a)' ) ' a proper permutation. In particular, the' write ( *, '(a,i6)' ) ' array is missing the value ', ierror stop end if ! ! Initialize. ! iarray(1:n) = 0 jarray(1:n) = 0 npart = 0 ! ! Search for the next item J which has not been assigned a subset/orbit. ! do j = 1, n if ( iarray(j) /= 0 ) then cycle end if ! ! Begin a new subset/orbit. ! npart = npart + 1 k = j ! ! Add the item to the subset/orbit. ! do jarray(npart) = jarray(npart) + 1 iarray(k) = npart ! ! Apply the permutation. If the permuted object isn't already in the ! subset/orbit, add it. ! k = p(k) if ( iarray(k) /= 0 ) then exit end if end do end do return end subroutine perm_to_ytb ( n, p, lambda, iarray ) ! !******************************************************************************* ! !! PERM_TO_YTB converts a permutation to a Young tableau. ! ! ! Discussion: ! ! The mapping is not invertible. In most cases, several permutations ! correspond to the same tableau. ! ! Example: ! ! N = 7 ! P = 7 2 4 1 5 3 6 ! ! YTB = ! 1 2 3 6 ! 4 5 ! 7 ! ! LAMBDA = 4 2 1 0 0 0 0 ! ! IARRAY = 1 1 1 2 2 1 3 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 11 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer to be partitioned. ! ! Input, integer P(N), a permutation, in standard index form. ! ! Output, integer LAMBDA(N). LAMBDA(I) is the length of the I-th row. ! ! Output, integer IARRAY(N). IARRAY(I) is the row containing I. ! implicit none ! integer n ! logical another integer compare integer i integer iarray(n) integer lambda(n) integer p(n) integer put_index integer put_row integer put_value ! ! Initialize. ! lambda(1:n) = 0 iarray(1:n) = 0 ! ! Now insert each item of the permutation. ! do put_index = 1, n put_value = p(put_index) put_row = 1 do another = .false. do compare = put_value+1, n if ( iarray(compare) == put_row ) then another = .true. iarray(put_value) = put_row iarray(compare) = 0 put_value = compare put_row = put_row + 1 exit end if end do if ( .not. another ) then exit end if end do iarray(put_value) = put_row lambda(put_row) = lambda(put_row) + 1 end do return end subroutine perm_unrank ( n, p, irank ) ! !******************************************************************************* ! !! PERM_UNRANK "unranks" a permutation. ! ! ! Discussion: ! ! That is, given a rank, it computes the corresponding permutation. ! This is the same as asking for the permutation which PERM_NEXT2 ! would compute at the IRANK-th step. ! ! The value of the rank should be between 1 and N!. ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 25 July 2000 ! ! Parameters: ! ! Input, integer N, the number of elements in the set. ! ! Output, integer P(N), the permutation, in standard index form. ! ! Input, integer IRANK, the desired rank of the permutation. This ! gives the order of the given permutation in the set of all ! the permutations on N elements, using the order of PERM_NEXT2. ! implicit none ! integer n ! integer i integer icount integer iprev integer irank integer irem integer j integer jdir integer jrank integer nfact integer p(n) ! p(1:n) = 0 nfact = 1 do i = 1, n nfact = nfact * i end do if ( irank < 1 .or. irank > nfact ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PERM_UNRANK - Fatal error!' write ( *, '(a)' ) ' Illegal input value for IRANK.' write ( *, '(a,i6)' ) ' IRANK must be between 1 and ', nfact write ( *, '(a,i6)' ) ' but the input value is ', irank stop end if jrank = irank - 1 do i = 1, n iprev = n + 1 - i irem = mod ( jrank, iprev ) jrank = jrank / iprev if ( mod ( jrank, 2 ) == 1 ) then j = 0 jdir = 1 else j = n + 1 jdir = -1 end if icount = 0 do j = j + jdir if ( p(j) == 0 ) then icount = icount + 1 end if if ( icount > irem ) then exit end if end do p(j) = iprev end do return end subroutine pord_check ( n, a, ierror ) ! !******************************************************************************* ! !! PORD_CHECK checks a matrix representing a partial ordering. ! ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements in the set. The number ! of rows and columns used in IZETA. ! ! Input, integer A(N,N). Contains the description of the ! partial ordering. A(I,J) = 1 if I is less than J ! in the partial ordering, 0 otherwise. ! ! Output, integer IERROR, error flag. ! 0, no errors detected. ! 1, N <= 0. ! 2, A(I,J) > 0 and A(J,I) > 0 for some I and J. ! implicit none ! integer n ! integer a(n,n) integer i integer ierror integer j ! ierror = 0 if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PORD_CHECK - Fatal error!' write ( *, '(a,i6)' ) ' N must be positive, but N = ', n ierror = 1 return end if do i = 1, n do j = i+1, n if ( a(i,j) > 0 ) then if ( a(j,i) > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PORD_CHECK - Fatal error!' write ( *, '(a,i6)' ) ' For indices I = ', i write ( *, '(a,i6)' ) ' and J = ', j write ( *, '(a,i6)' ) ' A(I,J) = ', a(i,j) write ( *, '(a,i6)' ) ' A(J,I) = ', a(j,i) ierror = 2 return end if end if end do end do return end subroutine power_mod ( a, n, m, x ) ! !******************************************************************************* ! !! POWER_MOD computes mod ( A**N, M ). ! ! ! Discussion: ! ! Some programming tricks are used to speed up the computation, and to ! allow computations in which A**N is much too large to store in a ! real word. ! ! First, for efficiency, the power A**N is computed by determining ! the binary expansion of N, then computing A, A**2, A**4, and so on ! by repeated squaring, and multiplying only those factors that ! contribute to A**N. ! ! Secondly, the intermediate products are immediately "mod'ed", which ! keeps them small. ! ! For instance, to compute mod ( A**13, 11 ), we essentially compute ! ! 13 = 1 + 4 + 8 ! ! A**13 = A * A**4 * A**8 ! ! mod ( A**13, 11 ) = mod ( A, 11 ) * mod ( A**4, 11 ) * mod ( A**8, 11 ). ! ! Fermat's little theorem says that if P is prime, and A is not divisible ! by P, then ( A**(P-1) - 1 ) is divisible by P. ! ! Modified: ! ! 29 July 1999 ! ! Parameters: ! ! Input, integer A, the base of the expression to be tested. ! A should be nonnegative. ! ! Input, integer N, the power to which the base is raised. ! N should be nonnegative. ! ! Input, integer M, the divisor against which the expression is tested. ! M should be positive. ! ! Output, integer X, the remainder when A**N is divided by M. ! implicit none ! integer a integer a_square integer d integer m integer n integer ncopy integer x ! x = - 1 if ( a < 0 ) then return end if if ( m < 0 ) then return end if if ( n < 0 ) then return end if ! ! A_SQUARE contains the successive squares of A. ! a_square = a ncopy = n x = 1 do while ( ncopy > 0 ) d = mod ( ncopy, 2 ) if ( d == 1 ) then x = mod ( x * a_square, m ) end if a_square = mod ( a_square * a_square, m ) ncopy = ( ncopy - d ) / 2 end do return end subroutine power_series1 ( a, c, n, alpha ) ! !******************************************************************************* ! !! POWER_SERIES1 computes a power series for a function F(Z) = (1+H(Z))**ALPHA. ! ! ! Discussion: ! ! The power series for H(Z) is given. ! ! The form of the power series are: ! ! F(Z) = A1*Z + A2*Z**2 + A3*Z**3 + ... + AN*Z**N ! ! H(Z) = C1*Z + C2*Z**2 + C3*Z**3 + ... + CN*Z**N ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Output, real A(N), the power series coefficients for F(Z). ! ! Input, real C(N), the power series coefficients for H(Z). ! ! Input, integer N, the number of terms in the power series. ! ! Input, real ALPHA, the exponent of 1+H(Z) in the definition of F(Z). ! implicit none ! integer n ! real a(n) real alpha real c(n) integer i integer j real v ! do j = 1, n v = 0.0E+00 do i = 1, j-1 v = v + a(i) * c(j-i) * ( alpha * ( j - i ) - i ) end do a(j) = ( alpha * c(j) + v / real(j) ) end do return end subroutine power_series2 ( a, c, n ) ! !******************************************************************************* ! !! POWER_SERIES2 computes the power series for a function F(Z) = EXP(H(Z)) - 1. ! ! ! Discussion: ! ! The power series for H(Z) is given. ! ! The power series have the form: ! ! F(Z) = A1*Z + A2*Z**2 + A3*Z**3 + ... + AN*Z**N ! ! H(Z) = C1*Z + C2*Z**2 + C3*Z**3 + ... + CN*Z**N ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Output, real A(N), the power series coefficients for F(Z). ! ! Input, real C(N), the power series coefficients for H(Z). ! ! Input, integer N, the number of terms in the power series. ! implicit none ! integer n ! real a(n) real c(n) integer i integer j real v ! do j = 1, n v = 0.0E+00 do i = 1, j-1 v = v + a(i) * c(j-i) * real ( j - i ) end do a(j) = c(j) + v / real ( j ) end do return end subroutine power_series3 ( a, b, c, n ) ! !******************************************************************************* ! !! POWER_SERIES3 computes the power series for a function F(Z) = G(H(Z)). ! ! ! Discussion: ! ! The power series for G and H are given. ! ! We assume that ! ! F(Z) = A1*Z + A2*Z**2 + A3*Z**3 + ... + AN*Z**N ! G(Z) = B1*Z + B2*Z**2 + B3*Z**3 + ... + BN*Z**N ! H(Z) = C1*Z + C2*Z**2 + C3*Z**3 + ... + CN*Z**N ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 02 November 2001 ! ! Parameters: ! ! Output, real A(N), the power series for F. ! ! Input, real B(N), the power series for G. ! ! Input, real C(N), the power series for H. ! ! Input, integer N, the number of terms in the power series. ! implicit none ! integer n ! real a(n) real b(n) real c(n) integer i integer iq integer j integer m real r real v real work(n) ! work(1:n) = b(1) * c(1:n) ! ! Search for IQ, the index of the first nonzero entry in C. ! iq = 0 do i = 1, n if ( c(i) /= 0.0E+00 ) then iq = i exit end if end do if ( iq /= 0 ) then m = 1 do m = m + 1 if ( m * iq > n ) then exit end if if ( b(m) == 0.0E+00 ) then cycle end if r = b(m) * c(iq)**m work(m*iq) = work(m*iq) + r do j = 1, n-m*iq v = 0.0E+00 do i = 1, j-1 v = v + a(i) * c(j-i+iq) * real ( m * ( j - i ) - i ) end do a(j) = ( real ( m ) * c(j) + v / real ( j ) ) / c(iq) end do do i = 1, n-m*iq work(i+m*iq) = work(i+m*iq) + a(i) * r end do end do end if a(1:n) = work(1:n) return end subroutine power_series4 ( a, b, c, n ) ! !******************************************************************************* ! !! POWER_SERIES4 computes the power series for a function G(Z) = F ( 1/H(Z) ). ! ! ! Discussion: ! ! POWER_SERIES4 is given the power series for the functions F and H. ! ! We assume that ! ! F(Z) = A1*Z + A2*Z**2 + A3*Z**3 + ... + AN*Z**N ! G(Z) = B1*Z + B2*Z**2 + B3*Z**3 + ... + BN*Z**N ! H(Z) = C1*Z + C2*Z**2 + C3*Z**3 + ... + CN*Z**N ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, real A(N). Power series for F. ! ! Output, real B(N). Power series for G. ! ! Input, real C(N). Power series for H. For this problem, C(1) ! may not be 0.0. ! ! Input, integer N, the number of terms in the power series. ! implicit none ! integer n ! real a(n) real b(n) real c(n) integer i integer l integer m real s real t real work(n) ! if ( c(1) == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'POWER_SERIES4 - Fatal error!' write ( *, '(a)' ) ' C(1) is zero.' stop end if t = 1.0E+00 do i = 1, n t = t / c(1) b(i) = a(i) * t work(i) = c(i) * t end do do m = 2, n s = - work(m) do i = m, n do l = i, n b(l) = b(l) + s * b(l+1-m) work(l) = work(l) + s * work(l+1-m) end do end do end do return end function prime ( n ) ! !******************************************************************************* ! !! PRIME returns any of the first MAXPRIME prime numbers. ! ! ! Note: ! ! MAXPRIME is 1500, and the largest prime stored is 12553. ! ! Modified: ! ! 21 October 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964, pages 870-873. ! ! Daniel Zwillinger, ! CRC Standard Mathematical Tables and Formulae, ! 30th Edition, ! CRC Press, 1996, pages 95-98. ! ! Parameters: ! ! Input, integer N, the index of the desired prime number. ! N = -1 returns MAXPRIME, the index of the largest prime available. ! N = 0 is legal, returning PRIME = 1. ! It should generally be true that 0 <= N <= MAXPRIME. ! ! Output, integer PRIME, the N-th prime. If N is out of range, PRIME ! is returned as 0. ! implicit none ! integer, parameter :: maxprime = 1500 ! integer i integer n integer, save, dimension ( maxprime ) :: npvec integer prime ! data ( npvec(i), i = 1, 100 ) / & 2, 3, 5, 7, 11, 13, 17, 19, 23, 29, & 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, & 73, 79, 83, 89, 97, 101, 103, 107, 109, 113, & 127, 131, 137, 139, 149, 151, 157, 163, 167, 173, & 179, 181, 191, 193, 197, 199, 211, 223, 227, 229, & 233, 239, 241, 251, 257, 263, 269, 271, 277, 281, & 283, 293, 307, 311, 313, 317, 331, 337, 347, 349, & 353, 359, 367, 373, 379, 383, 389, 397, 401, 409, & 419, 421, 431, 433, 439, 443, 449, 457, 461, 463, & 467, 479, 487, 491, 499, 503, 509, 521, 523, 541 / data ( npvec(i), i = 101, 200 ) / & 547, 557, 563, 569, 571, 577, 587, 593, 599, 601, & 607, 613, 617, 619, 631, 641, 643, 647, 653, 659, & 661, 673, 677, 683, 691, 701, 709, 719, 727, 733, & 739, 743, 751, 757, 761, 769, 773, 787, 797, 809, & 811, 821, 823, 827, 829, 839, 853, 857, 859, 863, & 877, 881, 883, 887, 907, 911, 919, 929, 937, 941, & 947, 953, 967, 971, 977, 983, 991, 997, 1009, 1013, & 1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, & 1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, & 1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223 / data ( npvec(i), i = 201, 300 ) / & 1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, & 1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, & 1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, & 1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, & 1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, & 1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, & 1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, & 1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, & 1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, & 1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987 / data ( npvec(i), i = 301, 400 ) / & 1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, & 2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, & 2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, & 2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, & 2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, & 2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, & 2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, & 2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, & 2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, & 2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741 / data ( npvec(i), i = 401, 500 ) / & 2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, & 2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, & 2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, & 3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, & 3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, & 3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, & 3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, & 3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, & 3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, & 3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571 / data ( npvec(i), i = 501, 600 ) / & 3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, & 3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, & 3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, & 3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, & 3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, & 4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, & 4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, & 4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, & 4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, & 4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409 / data ( npvec(i), i = 601, 700 ) / & 4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, & 4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, & 4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, & 4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, & 4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, & 4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, & 4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, & 5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, & 5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, & 5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279 / data ( npvec(i), i = 701, 800 ) / & 5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, & 5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, & 5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, & 5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, & 5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, & 5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, & 5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, & 5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, & 5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, & 6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133 / data ( npvec(i), i = 801, 900 ) / & 6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, & 6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, & 6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, & 6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, & 6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, & 6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, & 6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, & 6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, & 6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, & 6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997 / data ( npvec(i), i = 901, 1000 ) / & 7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, & 7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, & 7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, & 7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, & 7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, & 7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, & 7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, & 7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, & 7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, & 7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919 / data ( npvec(i), i = 1001, 1100 ) / & 7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, & 8039, 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, & 8117, 8123, 8147, 8161, 8167, 8171, 8179, 8191, 8209, 8219, & 8221, 8231, 8233, 8237, 8243, 8263, 8269, 8273, 8287, 8291, & 8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, 8377, 8387, & 8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, 8501, & 8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, & 8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, & 8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, & 8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831 / data ( npvec(i), i = 1101, 1200 ) / & 8837, 8839, 8849, 8861, 8863, 8867, 8887, 8893, 8923, 8929, & 8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, 9011, & 9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, & 9127, 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, & 9203, 9209, 9221, 9227, 9239, 9241, 9257, 9277, 9281, 9283, & 9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, & 9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439, & 9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, & 9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, & 9643, 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733 / data ( npvec(i), i = 1201, 1300 ) / & 9739, 9743, 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, & 9817, 9829, 9833, 9839, 9851, 9857, 9859, 9871, 9883, 9887, & 9901, 9907, 9923, 9929, 9931, 9941, 9949, 9967, 9973,10007, & 10009,10037,10039,10061,10067,10069,10079,10091,10093,10099, & 10103,10111,10133,10139,10141,10151,10159,10163,10169,10177, & 10181,10193,10211,10223,10243,10247,10253,10259,10267,10271, & 10273,10289,10301,10303,10313,10321,10331,10333,10337,10343, & 10357,10369,10391,10399,10427,10429,10433,10453,10457,10459, & 10463,10477,10487,10499,10501,10513,10529,10531,10559,10567, & 10589,10597,10601,10607,10613,10627,10631,10639,10651,10657 / data ( npvec(i), i = 1301, 1400 ) / & 10663,10667,10687,10691,10709,10711,10723,10729,10733,10739, & 10753,10771,10781,10789,10799,10831,10837,10847,10853,10859, & 10861,10867,10883,10889,10891,10903,10909,19037,10939,10949, & 10957,10973,10979,10987,10993,11003,11027,11047,11057,11059, & 11069,11071,11083,11087,11093,11113,11117,11119,11131,11149, & 11159,11161,11171,11173,11177,11197,11213,11239,11243,11251, & 11257,11261,11273,11279,11287,11299,11311,11317,11321,11329, & 11351,11353,11369,11383,11393,11399,11411,11423,11437,11443, & 11447,11467,11471,11483,11489,11491,11497,11503,11519,11527, & 11549,11551,11579,11587,11593,11597,11617,11621,11633,11657 / data ( npvec(i),i = 1401, 1500 ) / & 11677,11681,11689,11699,11701,11717,11719,11731,11743,11777, & 11779,11783,11789,11801,11807,11813,11821,11827,11831,11833, & 11839,11863,11867,11887,11897,11903,11909,11923,11927,11933, & 11939,11941,11953,11959,11969,11971,11981,11987,12007,12011, & 12037,12041,12043,12049,12071,12073,12097,12101,12107,12109, & 12113,12119,12143,12149,12157,12161,12163,12197,12203,12211, & 12227,12239,12241,12251,12253,12263,12269,12277,12281,12289, & 12301,12323,12329,12343,12347,12373,12377,12379,12391,12401, & 12409,12413,12421,12433,12437,12451,12457,12473,12479,12487, & 12491,12497,12503,12511,12517,12527,12539,12541,12547,12553 / ! if ( n == -1 ) then prime = maxprime else if ( n == 0 ) then prime = 1 else if ( n <= maxprime ) then prime = npvec(n) else prime = 0 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PRIMES - Fatal error!' write ( *, '(a)' ) ' Illegal prime index N = ', n write ( *, '(a,i6)' ) ' but N must be between 0 and MAXPRIME =', maxprime stop end if return end subroutine pythag_triple_next ( i, j, a, b, c ) ! !******************************************************************************* ! !! PYTHAG_TRIPLE_NEXT computes the next Pythagorean triple. ! ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J, the generators. ! On first call, set I = J = 0. On repeated calls, leave I and J ! at their output values from the previous call. ! ! Output, integer A, B, C, the next Pythagorean triple. ! A, B, and C are positive integers which have no common factors, ! and A**2 + B**2 = C**2. ! implicit none ! integer a integer b integer c integer i integer j ! ! I starts at 2 and increases; ! ! J starts out at 2 if I is odd, or 1 if I is even, increases by 2, ! but is always less than I. ! if ( i == 0 .and. j == 0 ) then i = 2 j = 1 else if ( j + 2 < i ) then j = j + 2 else i = i + 1 j = mod ( i, 2 ) + 1 end if a = i**2 - j**2 b = 2 * i * j c = i**2 + j**2 return end function r_agm ( a, b ) ! !******************************************************************************* ! !! R_AGM finds the arithmetic-geometric mean of two numbers. ! ! ! Discussion: ! ! The AGM of (A,B) is produced by the following iteration: ! ! (A,B) -> ( (A+B)/2, SQRT(A*B) ). ! ! The sequence of successive values of (A,B) quickly converge to the AGM. ! ! Modified: ! ! 02 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real A, B, the numbers whose AGM is desired. A and B should ! both be non-negative. ! ! Output, real R_AGM, the AGM of the two numbers. ! implicit none ! real a real a1 real a2 real b real b1 real b2 real tol real r_agm ! if ( a < 0.0E+00 ) then r_agm = -1.0E+00 return end if if ( b < 0.0E+00 ) then r_agm = -1.0E+00 return end if if ( a == 0.0E+00 .or. b == 0.0E+00 ) then r_agm = 0.0E+00 return end if if ( a == b ) then r_agm = a return end if tol = epsilon ( tol ) * ( a + b + 1.0E+00 ) a1 = a b1 = b do a2 = ( a1 + b1 ) / 2.0E+00 b2 = sqrt ( a1 * b1 ) if ( abs ( a2 - b2 ) < tol ) then r_agm = ( a2 + b2 ) / 2.0E+00 exit end if a1 = a2 b1 = b2 end do return end function r_pi ( ) ! !******************************************************************************* ! !! R_PI returns the value of pi. ! ! ! Modified: ! ! 04 December 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real R_PI, the value of pi. ! implicit none ! real r_pi ! r_pi = 3.14159265358979323846264338327950288419716939937510E+00 return end subroutine r_random ( rlo, rhi, r ) ! !******************************************************************************* ! !! R_RANDOM returns a random real in a given range. ! ! ! Modified: ! ! 26 October 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RLO, RHI, the minimum and maximum values. ! ! Output, real R, the randomly chosen value. ! implicit none ! real r real rhi real rlo real t ! ! Pick a random number in (0,1). ! call random_number ( harvest = t ) ! ! Set R. ! r = ( 1.0E+00 - t ) * rlo + t * rhi return end subroutine r_swap ( x, y ) ! !******************************************************************************* ! !! R_SWAP switches two real values. ! ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none ! real x real y real z ! z = x x = y y = z return end subroutine r_to_cfrac ( r, n, a, p, q ) ! !******************************************************************************* ! !! R_TO_CFRAC converts a real value to a continued fraction. ! ! ! Discussion: ! ! The routine is given a real number R. It computes a sequence of ! continued fraction approximations to R, returning the results as ! simple fractions of the form P(I) / Q(I). ! ! Example: ! ! X = 2 * PI ! N = 7 ! ! A = [ *, 6, 3, 1, 1, 7, 2, 146, 3 ] ! P = [ 1, 6, 19, 25, 44, 333, 710, 103993, 312689 ] ! Q = [ 0, 1, 3, 4, 7, 53, 113, 16551, 49766 ] ! ! (This ignores roundoff error, which will cause later terms to differ). ! ! Reference: ! ! Norman Richert, ! Strang's Strange Figures, ! American Mathematical Monthly, ! Volume 99, Number 2, February 1992, pages 101-107. ! ! Modified: ! ! 10 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real R, the real value. ! ! Input, integer N, the number of convergents to compute. ! ! Output, integer A(0:N), the partial quotients. ! ! Output, integer P(-1:N), Q(-1:N), the numerators and denominators ! of the continued fraction approximations. ! implicit none ! integer n ! integer a(0:n) integer i integer p(-1:n) integer q(-1:n) real r real r_copy real x(0:n) ! if ( r == 0.0E+00 ) then a(0:n) = 0 p(-1:n) = 0 q(-1:n) = 1 return end if r_copy = abs ( r ) p(-1) = 1 q(-1) = 0 p(0) = int ( r_copy ) q(0) = 1 x(0) = r_copy a(0) = int ( x(0) ) do i = 1, n x(i) = 1.0E+00 / ( x(i-1) - real ( a(i-1) ) ) a(i) = int ( x(i) ) p(i) = a(i) * p(i-1) + p(i-2) q(i) = a(i) * q(i-1) + q(i-2) end do if ( r < 0.0E+00 ) then p(-1:n) = - p(-1:n) end if return end subroutine r_to_dec ( rval, itop, ibot ) ! !******************************************************************************* ! !! R_TO_DEC converts a real value to a decimal fraction form. ! ! ! Discussion: ! ! The routine computes ITOP and IBOT, so that approximately: ! ! RVAL = ITOP * 10 ** IBOT ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RVAL, the real number whose decimal ! representation is desired. ! ! Output, integer ITOP, IBOT, form the decimal ! representation of RVAL, approximately. ! ! ITOP is an integer, strictly between -10**NDIG and 10**NDIG. ! IBOT is an integer exponent of 10. ! implicit none ! integer dec_digit integer ibot integer itop real rtop real rval real ten1 real ten2 ! dec_digit = 0 call i_data ( 'GET', 'DEC_DIGIT', dec_digit ) ! ! Special cases. ! if ( rval == 0.0E+00 ) then itop = 0 ibot = 0 return end if ! ! Factor RVAL = RTOP * 10**IBOT ! rtop = rval ibot = 0 ! ! Now normalize so that 10**(DEC_DIGIT-1) <= ABS(RTOP) < 10**(DEC_DIGIT) ! ten1 = 10.0E+00**( dec_digit - 1 ) ten2 = 10.0E+00**dec_digit do while ( abs ( rtop ) < ten1 ) rtop = rtop * 10.0E+00 ibot = ibot - 1 end do do while ( abs ( rtop ) >= ten2 ) rtop = rtop / 10.0E+00 ibot = ibot + 1 end do ! ! ITOP is the integer part of RTOP, rounded. ! itop = nint ( rtop ) ! ! Now divide out any factors of ten from ITOP. ! if ( itop /= 0 ) then do while ( 10 * ( itop / 10 ) == itop ) itop = itop / 10 ibot = ibot + 1 end do end if return end subroutine r_to_rat ( a, iatop, iabot, ndig ) ! !******************************************************************************* ! !! R_TO_RAT converts a real value to a rational value. ! ! ! Discussion: ! ! The rational value (IATOP/IABOT) is essentially computed by truncating ! the decimal representation of the real value after a given number of ! decimal digits. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real A, the real value to be converted. ! ! Output, integer IATOP, IABOT, the numerator and denominator ! of the rational value that approximates A. ! ! Input, integer NDIG, the number of decimal digits used. ! implicit none ! real a real factor integer i_gcd integer iabot integer iatop integer ibot integer ifac integer itemp integer itop integer jfac integer ndig ! factor = 10.0E+00**ndig if ( ndig > 0 ) then ifac = 10**ndig jfac = 1 else ifac = 1 jfac = 10**(-ndig) end if itop = nint ( a * factor ) * jfac ibot = ifac ! ! Factor out the greatest common factor. ! itemp = i_gcd ( itop, ibot ) iatop = itop / itemp iabot = ibot / itemp return end subroutine r_to_s_left ( rval, s ) ! !******************************************************************************* ! !! R_TO_S_LEFT represents a real using 14 left_justified characters. ! ! ! Modified: ! ! 22 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RVAL, a real number. ! ! Output, character ( len = * ) S, a left-justified character variable ! containing the representation of RVAL. ! implicit none ! character ( len = 14 ) chrtmp integer i real rval character ( len = * ) s ! ! We can't seem to write directly into the string because of compiler ! quibbles. ! if ( real ( int ( rval ) ) == rval .and. abs ( rval ) < 1.0E+13 ) then write ( chrtmp, '(i14)' ) int ( rval ) else write ( chrtmp, '(g14.6)' ) rval end if do i = 1, len ( chrtmp ) if ( chrtmp(i:i) /= ' ' ) then s = chrtmp(i:) return end if end do s = ' ' return end subroutine random_initialize ( seed ) ! !******************************************************************************* ! !! RANDOM_INITIALIZE initializes the FORTRAN 90 random number seed. ! ! ! Discussion: ! ! If you don't initialize the random number generator, its behavior ! is not specified. If you initialize it simply by: ! ! call random_seed ! ! its behavior is not specified. On the DEC ALPHA, if that's all you ! do, the same random number sequence is returned. In order to actually ! try to scramble up the random number generator a bit, this routine ! goes through the tedious process of getting the size of the random ! number seed, making up values based on the current time, and setting ! the random number seed. ! ! Modified: ! ! 03 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer SEED. ! If SEED is zero on input, then you're asking this routine to come up ! with a seed value, which is returned as output. ! If SEED is nonzero on input, then you're asking this routine to ! use the input value of SEED to initialize the random number generator. ! implicit none ! integer count integer count_max integer count_rate integer i integer seed integer, allocatable :: seed_vector(:) integer seed_size real t ! ! Initialize the random number seed. ! call random_seed ( ) ! ! Determine the size of the random number seed. ! call random_seed ( size = seed_size ) ! ! Allocate a seed of the right size. ! allocate ( seed_vector(seed_size) ) if ( seed /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RANDOM_INITIALIZE' write ( *, '(a,i12)' ) ' Initialize RANDOM_NUMBER with user SEED = ', seed else call system_clock ( count, count_rate, count_max ) seed = count write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RANDOM_INITIALIZE' write ( *, '(a,i12)' ) & ' Initialize RANDOM_NUMBER with arbitrary SEED = ', seed end if ! ! Now set the seed. ! seed_vector(1:seed_size) = seed call random_seed ( put = seed_vector(1:seed_size) ) ! ! Free up the seed space. ! deallocate ( seed_vector ) ! ! Call the random number routine a bunch of times. ! do i = 1, 100 call random_number ( harvest = t ) end do return end subroutine rat_add ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) ! !******************************************************************************* ! !! RAT_ADD adds two rational values. ! ! ! Discussion: ! ! The routine computes ! ! ITOP/IBOT = ITOP1/IBOT1 + ITOP2/IBOT2 ! ! while trying to avoid integer overflow. ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITOP1, IBOT1, the first value to add. ! ! Input, integer ITOP2, IBOT2, the second value to add. ! ! Output, integer ITOP, IBOT, the sum. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred. The addition of the two values ! requires a numerator or denominator larger than the ! maximum legal integer. ! ! Output, integer ITOP, the numerator of the result. ! ! Input, integer ITOP1, ITOP2, the numerators of the ! two rational values to be added. ! implicit none ! integer i_gcd integer ibot integer ibot1 integer ibot2 integer ierror integer i_max integer itemp integer itop integer itop1 integer itop2 integer jbot1 integer jbot2 integer jbot3 integer jtop1 integer jtop2 ! i_max = huge ( i_max ) ierror = 0 if ( itop1 == 0 ) then itop = itop2 ibot = ibot2 return else if ( itop2 == 0 ) then itop = itop1 ibot = ibot1 return end if ! ! Make copies of the input arguments, since we will change them. ! jbot1 = ibot1 jbot2 = ibot2 jtop1 = itop1 jtop2 = itop2 ! ! Compute the greatest common factor of the two denominators, ! and factor it out. ! jbot3 = i_gcd ( jbot1, jbot2 ) jbot1 = jbot1 / jbot3 jbot2 = jbot2 / jbot3 ! ! The fraction may now be formally written as: ! ! (jtop1*jbot2 + jtop2*jbot1) / (jbot1*jbot2*jbot3) ! ! Check the tops for overflow. ! if ( abs ( real ( jtop1 ) * real ( jbot2 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational sum.' itop = 0 stop end if jtop1 = jtop1 * jbot2 if ( abs ( real ( jtop2 ) * real ( jbot1 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational sum.' itop = 0 stop end if jtop2 = jtop2 * jbot1 if ( abs ( real ( jtop1 ) + real ( jtop2 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational sum.' itop = 0 stop end if itop = jtop1 + jtop2 ! ! Check the bottom for overflow. ! if ( abs ( real ( jbot1 ) * real ( jbot2 ) * real ( jbot3 ) ) > & real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of bottom of rational sum.' ibot = 1 stop end if ibot = jbot1 * jbot2 * jbot3 ! ! Put the fraction in lowest terms. ! itemp = i_gcd ( itop, ibot ) itop = itop / itemp ibot = ibot / itemp ! ! The bottom should be positive. ! if ( ibot < 0 ) then ibot = - ibot itop = - itop end if return end subroutine rat_div ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) ! !******************************************************************************* ! !! RAT_DIV divides one rational value by another. ! ! ! Discussion: ! ! The routine computes ! ! ITOP / IBOT = ( ITOP1 / IBOT1 ) / ( ITOP2 / IBOT2 ). ! ! while avoiding integer overflow. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITOP1, IBOT1, the numerator. ! ! Input, integer ITOP2, IBOT2, the denominator. ! ! Output, integer ITOP, IBOT, the result. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred. One of the quantities IBOT1, IBOT2, ! or ITOP2 is zero, or the result of the division ! requires a numerator or denominator larger than the ! maximum legal integer. ! implicit none ! integer i_gcd integer i_max integer ibot integer ibot1 integer ibot2 integer ierror integer itemp integer itop integer itop1 integer itop2 integer jbot1 integer jbot2 integer jtop1 integer jtop2 ! ierror = 0 i_max = huge ( i_max ) if ( ibot1 == 0 .or. itop2 == 0 .or. ibot2 == 0 ) then ierror = 1 return end if if ( itop1 == 0 ) then itop = 0 ibot = 1 return end if ! ! Make copies of the input arguments, since we will change them. ! Implicitly invert the divisor fraction here. The rest of ! the code will be a multiply operation. ! jbot1 = ibot1 jbot2 = itop2 jtop1 = itop1 jtop2 = ibot2 ! ! Get rid of all common factors in top and bottom. ! itemp = i_gcd ( jtop1, jbot1 ) jtop1 = jtop1 / itemp jbot1 = jbot1 / itemp itemp = i_gcd ( jtop1, jbot2 ) jtop1 = jtop1 / itemp jbot2 = jbot2 / itemp itemp = i_gcd ( jtop2, jbot1 ) jtop2 = jtop2 / itemp jbot1 = jbot1 / itemp itemp = i_gcd ( jtop2, jbot2 ) jtop2 = jtop2 / itemp jbot2 = jbot2 / itemp ! ! The fraction (ITOP1*IBOT2)/(IBOT1*ITOP2) is in lowest terms. ! ! Check the top for overflow. ! if ( abs ( real ( jtop1 ) * abs ( jtop2 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_DIV - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational fraction.' itop = 0 return end if itop = jtop1 * jtop2 ! ! Check the bottom IBOT1*ITOP2 for overflow. ! if ( abs ( real ( jbot1 ) * real ( jbot2 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_DIV - Fatal error!' write ( *, '(a)' ) ' Overflow of bottom of rational fraction.' ibot = 1 return end if ibot = jbot1 * jbot2 ! ! The bottom should be positive. ! if ( ibot < 0 ) then ibot = - ibot itop = - itop end if ! ! The fraction is ITOP/IBOT with no loss of accuracy. ! return end subroutine rat_farey ( n, max_frac, num_frac, a, b ) ! !******************************************************************************* ! !! RAT_FAREY computes the N-th row of the Farey fraction table. ! ! ! Example: ! ! N = 5 ! ! NUM_FRAC = 11 ! A = 0 1 1 1 2 1 3 2 3 4 1 ! B = 1 5 4 3 5 2 5 3 4 5 1 ! ! Discussion: ! ! In this form of the Farey fraction table, fractions in row N lie between ! 0 and 1, are in lowest terms, and have a denominator that is no greater ! than N. Row N is computed directly, and does not require the computation ! of previous rows. ! ! The data satisfy the relationship: ! ! A(K+1) * B(K) - A(K) * B(K+1) = 1 ! ! The number of items in the N-th row is roughly N**2 / PI**2. ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, page 157. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the desired row number. N must be positive. ! ! Input, integer MAX_FRAC, the maximum number of fractions to compute. ! ! Output, integer NUM_FRAC, the number of fractions computed. ! ! Output, integer A(MAX_FRAC), B(MAX_FRAC), contains the NUM_FRAC ! numerators and denominators of the N-th row of the Farey fraction table. ! implicit none ! integer max_frac ! integer a(max_frac) integer b(max_frac) integer c integer k integer n integer num_frac ! if ( n <= 0 ) then num_frac = 0 return end if if ( max_frac <= 0 ) then num_frac = k return end if k = 1 a(k) = 0 b(k) = 1 if ( max_frac <= 1 ) then num_frac = k return end if k = 2 a(k) = 1 b(k) = n do while ( k < max_frac ) if ( a(k) == 1 .and. b(k) == 1 ) then exit end if k = k + 1 c = int ( ( b(k-2) + n ) / b(k-1) ) a(k) = c * a(k-1) - a(k-2) b(k) = c * b(k-1) - b(k-2) end do num_frac = k return end subroutine rat_farey2 ( n, a, b ) ! !******************************************************************************* ! !! RAT_FAREY2 computes the next row of the Farey fraction table. ! ! ! Example: ! ! Input: ! ! N = 3 ! A = 0 1 1 2 1 ! B = 1 3 2 3 1 ! ! Output: ! ! A = 0 1 1 2 1 3 2 3 1 ! B = 1 4 3 5 2 5 3 4 1 ! ! Discussion: ! ! In this form of the Farey fraction table, fractions in row N lie between ! 0 and 1, and are in lowest terms. For every adjacent pair of input ! fractions, A1/B1 and A2/B2, the mediant (A1+A2)/(B1+B2) is computed ! and inserted between them. ! ! The number of items in the N-th row is 1+2**(N-1). ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the input row number. N must be nonnegative. ! If N is zero, then the input is ignored, and the entries of ! row 1 are computed directly. ! ! Input/output, integer A(1+2**N), B(1+2**N). ! On input, entries 1 through 1+2**(N-1) contain the entries of row N. ! On output, entries 1 through 1+2**N contain the entries of row N+1. ! implicit none ! integer n ! integer a(1+2**n) integer b(1+2**n) integer i if ( n == 0 ) then a(1) = 0 b(1) = 1 a(2) = 1 b(2) = 1 return end if ! ! Shift the current data. ! do i = 1+2**(n-1), 1, -1 a(2*i-1) = a(i) b(2*i-1) = b(i) end do ! ! Compute the mediants. ! do i = 2, 2**n, 2 a(i) = a(i-1) + a(i+1) b(i) = b(i-1) + b(i+1) end do return end subroutine rat_mul ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) ! !******************************************************************************* ! !! RAT_MUL multiplies two fractions. ! ! ! Discussion: ! ! The routine computes ! ! ITOP / IBOT = ( ITOP1 / IBOT1 ) * ( ITOP2 / IBOT2 ). ! ! while avoiding integer overflow. ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ITOP1, IBOT1, the first factor. ! ! Input, integer ITOP2, IBOT2, the second factor. ! ! Output, integer ITOP, IBOT, the product. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred. The multiplication of the two values ! requires a numerator or denominator larger than the ! maximum legal integer. ! implicit none ! integer i_gcd integer i_max integer ibot integer ibot1 integer ibot2 integer ierror integer itemp integer itop integer itop1 integer itop2 integer jbot1 integer jbot2 integer jtop1 integer jtop2 ! ierror = 0 i_max = huge ( i_max ) if ( itop1 == 0 .or. itop2 == 0 ) then itop = 0 ibot = 1 return end if ! ! Make copies of the input arguments, since we will change them. ! jbot1 = ibot1 jbot2 = ibot2 jtop1 = itop1 jtop2 = itop2 ! ! Get rid of all common factors in top and bottom. ! itemp = i_gcd ( jtop1, jbot1 ) jtop1 = jtop1 / itemp jbot1 = jbot1 / itemp itemp = i_gcd ( jtop1, jbot2 ) jtop1 = jtop1 / itemp jbot2 = jbot2 / itemp itemp = i_gcd ( jtop2, jbot1 ) jtop2 = jtop2 / itemp jbot1 = jbot1 / itemp itemp = i_gcd ( jtop2, jbot2 ) jtop2 = jtop2 / itemp jbot2 = jbot2 / itemp ! ! The fraction (ITOP1*ITOP2)/(IBOT1*IBOT2) is in lowest terms. ! ! Check the top ITOP1*ITOP2 for overflow. ! if ( abs ( real ( jtop1 ) * real ( jtop2 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_MUL - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational product.' itop = 0 return end if itop = jtop1 * jtop2 ! ! Check the bottom IBOT1*IBOT2 for overflow. ! if ( abs ( real ( jbot1 ) * real ( jbot2 ) ) > real ( i_max ) ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_MUL - Fatal error!' write ( *, '(a)' ) ' Overflow of bottom of rational product.' ibot = 1 return end if ibot = jbot1 * jbot2 ! ! The bottom should be positive. ! if ( ibot < 0 ) then ibot = - ibot itop = - itop end if ! ! The fraction is ITOP/IBOT with no loss of accuracy. ! return end subroutine rat_sum_formula ( n, a, b ) ! !******************************************************************************* ! !! RAT_SUM_FORMULA computes the formulas for sums of powers of integers. ! ! ! Example: ! ! N = 6 ! ! 1 2 3 4 5 6 7 ! ----------------------------------- ! 0 | 1 0 0 0 0 0 0 ! | ! 1 | 1 1 0 0 0 0 0 ! | 2 2 ! | ! 2 | 1 1 1 0 0 0 0 ! | 3 2 6 ! | ! 3 | 1 1 1 0 0 0 0 ! | 4 2 4 ! | ! 4 | 1 1 1 0 -1 0 0 ! | 5 2 3 30 ! | ! 5 | 1 1 5 0 -1 0 0 ! | 6 2 12 12 ! | ! 6 | 1 1 1 0 -1 0 1 ! | 7 2 2 6 42 ! ! The interpretation of row 2, for instance, is: ! ! sum ( 1 <= I <= N ) I**2 = 1/3 N**3 + 1/2 N**2 + 1/6 N ! ! This suggests that a more sensible way to display the table ! is to reverse the order of the entries in the row, so that ! the entry in column J is the coeeficient of N**J, which is ! not the case now. ! ! Reference: ! ! Robert Owens, ! Sums of Powers of Integers, ! Mathematics Magazine, ! Volume 65, Number 1, February 1992, pages 38-40. ! ! Modified: ! ! 11 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of rows of coefficients to compute. ! ! Output, integer A(0:N,N+1), B(0:N,N+1), the numerator and denominator ! of the coefficients. ! implicit none ! integer n ! integer a(0:n,1:n+1) integer asum integer b(0:n,1:n+1) integer bsum integer i integer ierror integer j ! a(0,1) = 1 b(0,1) = 1 a(0,2:n+1) = 0 b(0,2:n+1) = 1 do i = 1, n asum = 0 bsum = 0 ! ! Subdiagonal entries are multiples of entries above them. ! do j = 1, i call rat_mul ( a(i-1,j), b(i-1,j), i, i+2-j, a(i,j), b(i,j), ierror ) call rat_add ( asum, bsum, a(i,j), b(i,j), asum, bsum, ierror ) end do ! ! Diagonal entry is 1 - sum of previous entries in row. ! asum = - asum call rat_add ( 1, 1, asum, bsum, a(i,i+1), b(i,i+1), ierror ) ! ! Superdiagonal entries are zero. ! a(i,i+2:n+1) = 0 b(i,i+2:n+1) = 1 end do return end subroutine rat_to_cfrac ( a, ierror, m, n, ip, iq ) ! !******************************************************************************* ! !! RAT_TO_CFRAC converts a rational value to a continued fraction. ! ! ! Discussion: ! ! The routine is given a rational number represented by IP/IQ, and ! computes the monic or "simple" continued fraction representation ! with integer coefficients of the number: ! ! A(1) + 1/ (A(2) + 1/ (A(3) + ... + 1/A(N) ...)) ! ! The user must dimension A to a value M which is "large enough". ! The actual number of terms needed in the continued fraction ! representation cannot be known beforehand. ! ! Reference: ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Output, integer A(M), contains the continued fraction ! representation of the number. ! ! Output, integer IERROR, error indicator. 0 if no error, ! 1 if there was an error, namely, M is not large enough. ! ! Input, integer M, the dimension of A. If M is not great ! enough, the algorithm may run out of space. ! ! Output, integer N, the actual number of entries used in A. ! ! Input, integer IP, IQ, the numerator and denominator of the ! rational value whose continued fraction representation is ! desired. ! implicit none ! integer m ! integer a(m) integer ierror integer ip integer iq integer jp integer jq integer n ! jp = ip jq = iq n = 0 do n = n + 1 if ( n > m ) then ierror = 1 return end if a(n) = jp / jq jp = mod ( jp, jq ) if ( jp == 0 ) then return end if n = n + 1 if ( n > m ) then ierror = 1 return end if a(n) = jq / jp jq = mod ( jq, jp ) if ( jq == 0 ) then exit end if end do return end subroutine rat_to_r ( a, iatop, iabot ) ! !******************************************************************************* ! !! RAT_TO_R converts rational values to real values. ! ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real A, the value of the rational quantity. ! ! Input, integer IATOP, IABOT, the rational quantity ! (IATOP/IABOT) that is to be converted. ! implicit none ! real a integer iabot integer iatop ! if ( iabot == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RAT_TO_R - Warning!' write ( *, '(a)' ) ' The input fraction to be converted had a' write ( *, '(a)' ) ' zero denominator.' a = 0.0E+00 else a = real ( iatop ) / real ( iabot ) end if return end subroutine rat_to_s_left ( ival, jval, s ) ! !******************************************************************************* ! !! RAT_TO_S_LEFT returns a left-justified representation of IVAL/JVAL. ! ! ! Discussion: ! ! If the ratio is negative, a minus sign precedes IVAL. ! A slash separates IVAL and JVAL. ! ! Modified: ! ! 13 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IVAL, JVAL, the two integers whose ! ratio IVAL/JVAL is to be represented. ! ! Note that if IVAL is nonzero and JVAL is 0, STRING will ! be returned as "Inf" or "-Inf" (Infinity), and if both ! IVAL and JVAL are zero, STRING will be returned as "NaN" ! (Not-a-Number). ! ! Output, character ( len = * ) S, a left-justified string ! containing the representation of IVAL/JVAL. ! implicit none ! integer ival integer ival2 integer jval integer jval2 character ( len = * ) s character ( len = 22 ) s2 ! ! Take care of simple cases right away. ! if ( ival == 0 ) then if ( jval /= 0 ) then s2 = '0' else s2= 'NaN' end if else if ( jval == 0 ) then if ( ival > 0 ) then s2 = 'Inf' else s2 = '-Inf' end if ! ! Make copies of IVAL and JVAL. ! else ival2 = ival jval2 = jval if ( jval2 == 1 ) then write ( s2, '(i11)' ) ival2 else write ( s2, '(i11, ''/'', i10)' ) ival2, jval2 end if call s_blank_delete ( s2 ) end if s = s2 return end subroutine ratmat_det ( n, iatop, iabot, idtop, idbot, ierror ) ! !******************************************************************************* ! !! RATMAT_DET finds the determinant of an N by N matrix of rational entries. ! ! ! Discussion: ! ! The brute force method is used. ! ! This routine should only be used for small matrices, since this ! calculation requires the summation of N! products of N numbers. ! ! Modified: ! ! 17 April 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of rows and columns of A. ! ! Input, integer IATOP(N,N), IABOT(N,N), the numerators ! and denominators of the entries of the matrix. ! ! Output, integer IDTOP, IDBOT, the determinant of the matrix, ! expressed as IDTOP/IDBOT. ! ! Output, integer IERROR. ! 0, the determinant was computed. ! 1, an overflow error occurred, and the determinant was not ! computed. ! implicit none ! integer n ! logical even integer i integer iabot(n,n) integer iatop(n,n) integer iarray(n) integer ibot integer ibot1 integer ibot2 integer idbot integer idtop integer ierror integer itop integer itop1 integer itop2 logical more ! ierror = 0 more = .false. idtop = 0 idbot = 1 do call perm_next ( n, iarray, more, even ) if ( even ) then itop = 1 else itop = -1 end if ibot = 1 do i = 1, n itop1 = itop ibot1 = ibot itop2 = iatop(i,iarray(i)) ibot2 = iabot(i,iarray(i)) call rat_mul ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RATMAT_DET - Fatal error!' write ( *, '(a)' ) ' An overflow occurred.' write ( *, '(a)' ) ' The determinant calculation cannot be done' write ( *, '(a)' ) ' for this matrix.' idtop = 0 idbot = 1 return end if end do itop1 = itop ibot1 = ibot itop2 = idtop ibot2 = idbot call rat_add ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) if ( ierror == 0 ) then idtop = itop idbot = ibot else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RATMAT_DET - Fatal error!' write ( *, '(a)' ) ' An overflow occurred.' write ( *, '(a)' ) ' The determinant calculation cannot be done' write ( *, '(a)' ) ' for this matrix.' idtop = 0 idbot = 1 return end if if ( .not. more ) then exit end if end do ! ! The bottom should be positive. ! if ( idbot < 0 ) then idbot = - idbot idtop = - idtop end if return end subroutine ratmat_print ( m, n, a, b, title ) ! !******************************************************************************* ! !! RATMAT_PRINT prints out rational vectors or matrices. ! ! ! Modified: ! ! 12 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns in the matrix. ! ! Input, integer A(M,N), B(M,N), the current rational or decimal ! matrix. ! ! Input, character ( len = * ) TITLE, a label for the object being printed. ! implicit none ! integer m integer n ! integer a(m,n) integer b(m,n) character ( len = 10 ) chrtmp1 character ( len = 10 ) chrtmp2 character ( len = 10 ) chrtmp3 character ( len = 40 ) format1 character ( len = 40 ) format2 integer i integer ichi integer iclo integer imax integer imin integer ione integer itemp integer izhi integer izlo integer j integer jmax integer jmin integer kmax integer, parameter :: ncolum = 80 integer none integer npline character ( len = 100 ) output character ( len = * ) title ! ! Figure out how many rationals we can get in NCOLUM columns. ! kmax = 3 do i = 1, m do j = 1, n itemp = abs ( a(i,j) ) do while ( itemp >= 10**(kmax-2) ) kmax = kmax + 1 end do itemp = abs ( b(i,j) ) do while ( itemp > 10**(kmax-2) ) kmax = kmax + 1 end do end do end do kmax = kmax + 1 npline = ncolum / kmax ! ! Create the formats. ! call i_to_s_left ( npline, chrtmp2 ) call i_to_s_left ( kmax, chrtmp3 ) format1 = '(' // chrtmp2 // 'i' // chrtmp3 // ')' call s_blank_delete ( format1 ) format2 = '(' // chrtmp2 // 'i' // chrtmp3 // ')' call s_blank_delete ( format2 ) do jmin = 1, n, npline jmax = min ( jmin+npline-1, n ) write ( *, '(a)' ) ' ' if ( jmin == 1 ) then write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' end if if ( jmin > 1 .or. jmax < n ) then write ( output, * ) 'Columns ', jmin, ' to ', jmax call s_blanks_delete ( output ) write ( *, '(a)' ) trim ( output ) write ( *, '(a)' ) ' ' end if do i = 1, m write ( *, format1 ) a(i,jmin:jmax) write ( output, format1 ) b(i,jmin:jmax) ! ! Delete each denominator that is 1. If all are 1, don't ! even print out the line. ! none = 0 do j = jmin, jmax if ( b(i,j) == 1 ) then ione = (j-jmin+1) * kmax output(ione:ione) = ' ' else none = 1 end if end do write ( *, '(a)' ) trim ( output ) if ( jmax == n .and. i == m ) then else write ( *, '(a)' ) ' ' end if end do end do return end subroutine regro_next ( done, n, v, vmax ) ! !******************************************************************************* ! !! REGRO_NEXT computes restricted growth functions one at a time. ! ! ! Definition: ! ! A restricted growth function on N is a vector (V(1), ..., V(N) ) ! of values V(I) between 1 and N, satisfying the requirements: ! V(1) = 1; ! V(I) <= 1 + max ( V(1), V(2), ..., V(I-1) ). ! ! Comments: ! ! The number of restricted growth functions on N is equal to ! the Bell number B(N). ! ! There is a bijection between restricted growth functions on N ! and set partitions of N. ! ! Examples: ! ! The 15 restricted growth functions for N = 4 are: ! ! (1111), (1112), (1121), (1122), (1123), ! (1211), (1212), (1213), (1221), (1222), ! (1223), (1231), (1232), (1233), (1234). ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986, page 19. ! ! Modified: ! ! 15 July 1998 ! ! Parameters: ! ! Input/output, logical DONE. ! On first call, set DONE to .TRUE., and then do not alter it. ! ! On output, DONE will be .FALSE. if the routine has computed another ! restricted growth function, or .TRUE. if all the restricted ! growth functions have been returned. ! ! Input, integer N, the number of components in the restricted growth ! function. ! ! Input/output, integer V(N). The user need not set this quantity ! before the initial call, and should not alter it between successive ! calls. On each return from the routine, with DONE = .FALSE., ! V will contain the componentwise values of the next restricted ! growth function. ! ! Input/output, integer VMAX(N). The user need not set this quantity ! before the initial call, and should not alter it between calls. ! VMAX(I) records the largest value that component V(I) could take, ! given the values of components 1 through I-1. ! implicit none ! integer n ! logical done integer i integer j integer v(n) integer vmax(n) ! ! First call: ! if ( done ) then v(1:n) = 1 vmax(1) = 1 vmax(2:n) = 2 done = .false. ! ! Later calls. ! else j = n do if ( j == 1 ) then done = .true. return end if if ( v(j) /= vmax(j) ) then exit end if j = j - 1 end do v(j) = v(j) + 1 do i = j+1, n v(i) = 1 if ( v(j) == vmax(j) ) then vmax(i) = vmax(j) + 1 else vmax(i) = vmax(j) end if end do end if return end subroutine rfrac_to_cfrac ( m, p, q, t, ierror ) ! !******************************************************************************* ! !! RFRAC_TO_CFRAC converts a rational polynomial fraction to a continued fraction. ! ! ! Discussion: ! ! That is, it accepts ! ! P(1) + P(2) * X + ... + P(M) * X**(M-1) ! ------------------------------------------------------- ! Q(1) + Q(2) * X + ... + Q(M) * X**(M-1) + Q(M+1) * X**M ! ! and returns the equivalent continued fraction: ! ! 1 / (T(1) + X/(T(2) + X/(...T(2*M-1)+X/(T(2*M) ... ))) ! ! Reference: ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Modified: ! ! 17 April 2000 ! ! Parameters: ! ! Input, integer M, defines the number of P coefficients, ! and is one less than the number of Q coefficients, and one ! half the number of T coefficients. ! ! Input, real P(M), Q(M+1), the coefficients defining the rational ! polynomial fraction. ! ! Output, real T(2*M), the coefficients defining the continued fraction. ! ! Output, integer IERROR, error flag. ! 0, no error; ! nonzero, the algorithm broke down at some point with a zero divisor. ! implicit none ! integer m ! real a(m+1,2*m+1) integer i integer ierror integer k real p(m) real q(m+1) real t(2*m) real ta ! ierror = 0 a(1:m+1,1) = q(1:m+1) a(1:m, 2) = p(1:m) t(1) = a(1,1) / a(1,2) ta = a(m+1,1) do i = 1, m a(m-i+1,2*i+1) = ta end do do k = 1, 2*m-2 do i = 1, (2*m-k)/2 a(i,k+2) = a(i+1,k) - t(k) * a(i+1,k+1) end do if ( a(1,k+2) == 0.0E+00 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RFRAC_TO_CFRAC - Fatal error!' write ( *, '(a,i6)' ) ' A(1,K+2) is zero for K = ', k stop end if t(k+1) = a(1,k+1) / a(1,k+2) end do t(2*m) = a(1,2*m) / a(1,2*m+1) return end subroutine rfrac_to_jfrac ( m, p, q, r, s, ierror ) ! !******************************************************************************* ! !! RFRAC_TO_JFRAC converts a rational polynomial fraction to a J fraction. ! ! ! Discussion: ! ! The routine accepts ! ! P(1) + P(2) * X + ... + P(M) * X**(M-1) ! ------------------------------------------------------- ! Q(1) + Q(2) * X + ... + Q(M) * X**(M-1) + Q(M+1) * X**M ! ! and returns the equivalent J-fraction: ! ! R(1)/ (X + S(1) + R(2)/(X + S(2) + R(3)/ ... + R(M)/(X+S(M))... )) ! ! Reference: ! ! Hart, Cheney, Lawson, Maehly, Mesztenyi, Rice, Thacher, Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Modified: ! ! 17 April 2000 ! ! Parameters: ! ! Input, integer M, defines the number of P, R, and S coefficients, ! and is one less than the number of Q coefficients. ! ! Input, real P(M), Q(M+1), the coefficients defining the rational ! polynomial fraction. ! ! Output, real R(M), S(M), the coefficients defining the ! J-fraction. ! ! Output, integer IERROR, error flag. ! IERROR is zero on return, unless the algorithm broke down at ! some point with a zero divisor, in which case IERROR = 1. ! implicit none ! integer m ! real a(m+1,m+1) integer i integer ierror integer k real p(m) real q(m+1) real r(m) real s(m) ! ierror = 0 a(1:m+1,1) = q(1:m+1) a(1:m, 2) = p(1:m) if ( m > 1 ) then r(1) = a(m,2) / a(m+1,1) s(1) = ( r(1) * a(m,1) - a(m-1,2) ) / a(m,2) do k = 1, m-2 a(1,k+2) = r(k) * a(1,k) - s(k) * a(1,k+1) do i = 2, m-k a(i,k+2) = r(k) * a(i,k) - a(i-1,k+1) - s(k) * a(i,k+1) if ( a(m-k,k+2) == 0.0E+00 ) then ierror = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RFRAC_TO_JFRAC - Fatal error!' write ( *, '(a,i6)' ) ' A(M-K,K+2) = 0 for K=', k stop end if r(k+1) = a(m-k,k+2) / a(m-k+1,k+1) s(k+1) = ( r(k+1) * a(m-k,k+1) - a(m-k-1,k+2) ) / a(m-k,k+2) end do end do a(1,m+1) = r(m-1) * a(1,m-1) - s(m-1) * a(1,m) end if r(m) = a(1,m+1) / a(2,m) s(m) = a(1,m) / a(2,m) return end function rise ( x, n ) ! !******************************************************************************* ! !! RISE computes the rising factorial function [X]^N. ! ! ! Discussion: ! ! [X}^N = X * ( X + 1 ) * ( X + 2 ) * ... * ( X + N - 1 ). ! ! Note that the number of ways of arranging N objects in M ordered ! boxes is [M}^N. (Here, the ordering in each box matters). Thus, ! 2 objects in 2 boxes have the following 6 possible arrangements: ! ! -/12, 1/2, 12/-, -/21, 2/1, 21/-. ! ! Moreover, the number of non-decreasing maps from a set of ! N to a set of M ordered elements is [M]^N / N!. Thus the set of ! nondecreasing maps from (1,2,3) to (a,b,c,d) is the 20 elements: ! ! aaa, abb, acc, add, aab, abc, acd, aac, abd, aad ! bbb, bcc, bdd, bbc, bcd, bbd, ccc, cdd, ccd, ddd. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real X, the argument of the rising factorial function. ! ! Input, integer N, the order of the rising factorial function. ! If N = 0, RISE = 1, if N = 1, RISE = X. Note that if N is ! negative, a "falling" factorial will be computed. ! ! Output, real RISE, the value of the rising factorial function. ! implicit none ! real arg integer i integer n real rise real x ! rise = 1.0E+00 arg = x if ( n > 0 ) then do i = 1, n rise = rise * arg arg = arg + 1.0E+00 end do else if ( n < 0 ) then do i = -1, n rise = rise * arg arg = arg - 1.0E+00 end do end if return end subroutine rmat_det ( n, a, det ) ! !******************************************************************************* ! !! RMAT_DET finds the determinant of a real N by N matrix. ! ! ! Discussion: ! ! A brute force calculation is made. ! ! This routine should only be used for small matrices, since this ! calculation requires the summation of N! products of N numbers. ! ! Modified: ! ! 10 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of rows and columns of A. ! ! Input, real A(N,N), the matrix whose determinant is desired. ! ! Output, real DET, the determinant of the matrix. ! implicit none ! integer n ! real a(n,n) real det logical even integer i integer iarray(n) logical more real term ! more = .false. det = 0.0E+00 do call perm_next ( n, iarray, more, even ) if ( even ) then term = 1.0E+00 else term = -1.0E+00 end if do i = 1, n term = term * a(i,iarray(i)) end do det = det + term if ( .not. more ) then exit end if end do return end subroutine rmat_perm ( n, a, p ) ! !******************************************************************************* ! !! RMAT_PERM permutes the rows and columns of a square real matrix. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 10 June 2002 ! ! Parameters: ! ! Input, integer N, the order of the matrix. ! ! Input/output, real A(N,N). ! On input, the matrix to be permuted. ! On output, the permuted matrix. ! ! Input, integer P(N), a permutation to be applied to the rows ! and columns. P(I) is the new number of row and column I. ! implicit none ! integer n ! real a(n,n) integer i integer i1 integer is real it integer j integer j1 integer j2 integer k integer lc integer nc integer p(n) ! call perm_cycle ( n, p, is, nc, 1 ) do i = 1, n i1 = - p(i) if ( i1 > 0 ) then lc = 0 do i1 = p(i1) lc = lc + 1 if ( i1 <= 0 ) then exit end if end do i1 = i do j = 1, n if ( p(j) <= 0 ) then j2 = j k = lc do j1 = j2 it = a(i1,j1) do i1 = abs ( p(i1) ) j1 = abs ( p(j1) ) call r_swap ( a(i1,j1), it ) if ( j1 /= j2 ) then cycle end if k = k - 1 if ( i1 == i ) then exit end if end do j2 = abs ( p(j2) ) if ( k == 0 ) then exit end if end do end if end do end if end do ! ! Restore the positive signs of the data. ! p(1:n) = abs ( p(1:n) ) return end subroutine rmat_perm2 ( m, n, a, p, q ) ! !******************************************************************************* ! !! RMAT_PERM2 permutes rows and columns of a real rectangular matrix, in place. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 28 October 1999 ! ! Parameters: ! ! Input, integer M, number of rows in the matrix. ! ! Input, integer N, number of columns in the matrix. ! ! Input/output, real A(M,N). ! On input, the matrix to be permuted. ! On output, the permuted matrix. ! ! Input, integer P(M), the row permutation. P(I) is the new number of row I. ! ! Input, integer Q(N), the column permutation. Q(I) is the new number of ! column I. Note that the routine allows you to pass a single array as both ! P and Q. ! implicit none ! integer m integer n ! real a(m,n) integer i integer i1 integer is integer j integer j1 integer j2 integer k integer lc integer nc integer p(m) integer q(n) real t ! call perm_cycle ( m, p, is, nc, 1 ) if ( q(1) > 0 ) then call perm_cycle ( n, q, is, nc, 1 ) end if do i = 1, m i1 = - p(i) if ( i1 > 0 ) then lc = 0 do i1 = p(i1) lc = lc + 1 if ( i1 <= 0 ) then exit end if end do i1 = i do j = 1, n if ( q(j) <= 0 ) then j2 = j k = lc do j1 = j2 t = a(i1,j1) do i1 = abs ( p(i1) ) j1 = abs ( q(j1) ) call r_swap ( a(i1,j1), t ) if ( j1 /= j2 ) then cycle end if k = k - 1 if ( i1 == i ) then exit end if end do j2 = abs ( q(j2) ) if ( k == 0 ) then exit end if end do end if end do end if end do p(1:m) = abs ( p(1:m) ) if ( q(1) <= 0 ) then q(1:n) = abs ( q(1:n) ) end if return end subroutine rmat_permanent ( n, a, perm ) ! !******************************************************************************* ! !! RMAT_PERMANENT computes the permanent of a real matrix. ! ! ! Discussion: ! ! The permanent function is similar to the determinant. Recall that ! the determinant of a matrix may be defined as the sum of all the ! products: ! ! S * A(1,I(1)) * A(2,I(2)) * ... * A(N,I(N)) ! ! where I is any permutation of the columns of the matrix, and S is the ! sign of the permutation. By contrast, the permanent function is ! the (unsigned) sum of all the products ! ! A(1,I(1)) * A(2,I(2)) * ... * A(N,I(N)) ! ! where I is any permutation of the columns of the matrix. The only ! difference is that there is no permutation sign multiplying each summand. ! ! Symbolically, then, the determinant of a 2 by 2 matrix ! ! a b ! c d ! ! is a*d-b*c, whereas the permanent of the same matrix is a*d+b*c. ! ! ! The permanent is invariant under row and column permutations. ! If a row or column of the matrix is multiplied by S, then the ! permanent is likewise multiplied by S. ! If the matrix is square, then the permanent is unaffected by ! transposing the matrix. ! Unlike the determinant, however, the permanent does change if ! one row is added to another, and it is not true that the ! permanent of the product is the product of the permanents. ! ! ! Note that if A is a matrix of all 1's and 0's, then the permanent ! of A counts exactly which permutations hit exactly 1's in the matrix. ! This fact can be exploited for various combinatorial purposes. ! ! For instance, setting the diagonal of A to 0, and the offdiagonals ! to 1, the permanent of A counts the number of derangements of N ! objects. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, number of rows and columns in matrix. ! ! Input, real A(N,N). The matrix whose permanent is desired. ! ! Output, real PERM, the value of the permanent function of A. ! implicit none ! integer n ! real a(n,n) integer i integer iadd integer iwork(n) integer j logical more integer ncard real p real perm real prod real sgn real work(n) real z ! more = .false. do i = 1, n work(i) = a(i,n) do j = 1, n work(i) = work(i) - 0.5E+00 * a(i,j) end do end do p = 0.0E+00 sgn = - 1.0E+00 do sgn = - sgn call sub_next ( n-1, iwork, more, ncard, iadd ) if ( ncard /= 0 ) then z = real ( 2 * iwork(iadd) - 1 ) work(1:n) = work(1:n) + z * a(1:n,iadd) end if p = p + sgn * product ( work ) if ( .not. more ) then exit end if end do perm = p * real ( 4 * mod ( n, 2 ) - 2 ) return end subroutine rmat_print ( m, n, a, title ) ! !******************************************************************************* ! !! RMAT_PRINT prints a real matrix. ! ! ! Modified: ! ! 24 March 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A. ! ! Input, real A(M,N), the matrix to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer m integer n ! real a(m,n) integer i integer j integer jhi integer jlo character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) title end if do jlo = 1, n, 5 jhi = min ( jlo + 4, n ) write ( *, '(a)' ) ' ' write ( *, '(6x,5(i7,7x))' ) ( j, j = jlo, jhi ) write ( *, '(a)' ) ' ' do i = 1, m write ( *, '(i6,5g14.6)' ) i, a(i,jlo:jhi) end do end do return end subroutine rpoly ( n, a, x0, iopt, val ) ! !******************************************************************************* ! !! RPOLY performs operations on real polynomials in power or factorial form. ! ! ! Discussion: ! ! The power sum form of a polynomial is ! ! P(X) = A1 + A2*X + A3*X**2 + ... + (AN+1)*X**N ! ! The Taylor expansion at C has the form ! ! P(X) = A1 + A2*(X-C) + A3*(X-C)**2+... + (AN+1)*(X-C)**N ! ! The factorial form of a polynomial is ! ! P(X) = A1 + A2*X + A3*(X)*(X-1) + A4*(X)*(X-1)*(X-2) + ... ! + (AN+1)*(X)*(X-1)*...*(X-N+1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of coefficients in the polynomial ! (in other words, the polynomial degree + 1) ! ! Input/output, real A(N), the coefficients of the polynomial. Depending ! on the option chosen, these coefficients may be overwritten by those ! of a different form of the polynomial. ! ! Input, real X0, for IOPT = -1, 0, or positive, the value of the ! argument at which the polynomial is to be evaluated, or the ! Taylor expansion is to be carried out. ! ! Input, integer IOPT, a flag describing which algorithm is to ! be carried out: ! ! -3: Reverse Stirling. Input the coefficients of the polynomial in ! factorial form, output them in power sum form. ! ! -2: Stirling. Input the coefficients in power sum ! form, output them in factorial form. ! ! -1: Evaluate a polynomial which has been input ! in factorial form. ! ! 0: Evaluate a polynomial input in power sum form. ! ! 1 or more: Given the coefficients of a polynomial in ! power sum form, compute the first IOPT coefficients of ! the polynomial in Taylor expansion form. ! ! Output, real VAL, for IOPT = -1 or 0, the value of the ! polynomial at the point X0. ! implicit none ! integer n ! real a(n) real eps integer i integer iopt integer m integer n1 real val real w real x0 real z ! n1 = min ( n, iopt ) n1 = max ( 1, n1 ) if ( iopt < -1 ) then n1 = n end if eps = real ( mod ( max ( -iopt, 0 ), 2 ) ) w = - real ( n ) * eps if ( iopt > -2 ) then w = w + x0 end if do m = 1, n1 val = 0.0E+00 z = w do i = m, n z = z + eps val = a(n+m-i) + z * val if ( iopt /= 0 .and. iopt /= -1 ) then a(n+m-i) = val end if end do if ( iopt < 0 ) then w = w + 1.0E+00 end if end do return end subroutine rpoly_degree ( na, a, degree ) ! !******************************************************************************* ! !! RPOLY_DEGREE returns the degree of a polynomial. ! ! ! Discussion: ! ! The degree of a polynomial is the index of the highest power ! of X with a nonzero coefficient. ! ! The degree of a constant polynomial is 0. The degree of the ! zero polynomial is debatable, but this routine returns the ! degree as 0. ! ! Modified: ! ! 20 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, real A(0:NA), the coefficients of the polynomials. ! ! Output, integer DEGREE, the degree of A. ! implicit none ! integer na ! real a(0:na) integer degree ! degree = na do while ( degree > 0 ) if ( a(degree) /= 0.0E+00 ) then return end if degree = degree - 1 end do return end subroutine rpoly_div ( na, a, nb, b, nq, q, nr, r ) ! !******************************************************************************* ! !! RPOLY_DIV computes the quotient and remainder of two polynomials. ! ! ! Discussion: ! ! The polynomials are assumed to be stored in power sum form. ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 23 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, real A(0:NA), the coefficients of the polynomial to be divided. ! ! Input, integer NB, the dimension of B. ! ! Input, real B(0:NB), the coefficients of the divisor polynomial. ! ! Output, integer NQ, the degree of Q. ! If the divisor polynomial is zero, NQ is returned as -1. ! ! Output, real Q(0:NA-NB), contains the quotient of A/B. ! If A and B have full degree, Q should be dimensioned Q(0:NA-NB). ! In any case, Q(0:NA) should be enough. ! ! Output, integer NR, the degree of R. ! If the divisor polynomial is zero, NR is returned as -1. ! ! Output, real R(0:NB-1), contains the remainder of A/B. ! If B has full degree, R should be dimensioned R(0:NB-1). ! Otherwise, R will actually require less space. ! implicit none ! integer na integer nb ! real a(0:na) real a2(0:na) real b(0:nb) integer i integer na2 integer nb2 integer nq integer nr real q(0:*) real r(0:*) ! call rpoly_degree ( na, a, na2 ) call rpoly_degree ( nb, b, nb2 ) if ( b(nb2) == 0.0E+00 ) then nq = -1 nr = -1 return end if a2(0:na) = a(0:na) nq = na2 - nb2 nr = nb2 - 1 do i = nq, 0, -1 q(i) = a2(i+nb2) / b(nb2) a2(i+nb2) = 0.0E+00 a2(i:i+nb2-1) = a2(i:i+nb2-1) - q(i) * b(0:nb2-1) end do r(0:nr) = a2(0:nr) return end subroutine rpoly_f2p ( n, a ) ! !******************************************************************************* ! !! RPOLY_F2P converts a real polynomial from factorial form to power sum form. ! ! ! Discussion: ! ! The factorial form is ! ! p(x) = a(1) ! + a(2) * x ! + a(3) * x*(x-1) ! ... ! + a(n) * x*(x-1)*...*(x-(n-2)) ! ! The power sum form is ! ! p(x) = a(1) + a(2)*x + a(3)*x**2 + ... + a(n)*x**(n-1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, real N, the dimension of A. ! ! Input/output, real A(N), on input, the polynomial ! coefficients in factorial form. On output, the polynomial ! coefficients in power sum form. ! implicit none ! integer n ! real a(n) integer i integer m real val real w real z ! w = - n do m = 1, n val = 0.0E+00 z = w do i = m, n z = z + 1.0E+00 val = a(n+m-i) + z * val a(n+m-i) = val end do w = w + 1.0E+00 end do return end subroutine rpoly_fval ( n, a, x, val ) ! !******************************************************************************* ! !! RPOLY_FVAL evaluates a real polynomial in factorial form. ! ! ! Discussion: ! ! The factorial form of a polynomial is: ! ! p(x) = a(1) ! + a(2) *x ! + a(3) *x*(x-1) ! +... ! + a(n-1)*x*(x-1)*(x-2)...*(x-(n-3)) ! + a(n) *x*(x-1)*(x-2)...*(x-(n-3))*(x-(n-2)) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real A(N), the coefficients of the polynomial. ! A(1) is the constant term. ! ! Input, real X, the point at which the polynomial is to be evaluated. ! ! Output, real VAL, the value of the polynomial at X. ! implicit none ! integer n ! real a(n) integer i real val real x ! val = 0.0E+00 do i = 1, n val = a(n+1-i) + ( x - n + i ) * val end do return end subroutine rpoly_mul ( na, a, nb, b, c ) ! !******************************************************************************* ! !! RPOLY_MUL computes the product of two real polynomials A and B. ! ! ! Discussion: ! ! The polynomials are in power sum form. ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 20 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, real A(0:NA), the coefficients of the first polynomial factor. ! ! Input, integer NB, the dimension of B. ! ! Input, real B(0:NB), the coefficients of the second polynomial factor. ! ! Output, real C(0:NA+NB), the coefficients of A * B. ! implicit none ! integer na integer nb ! real a(0:na) real b(0:nb) real c(0:na+nb) real d(0:na+nb) integer i integer j ! d(0:na+nb) = 0.0E+00 do i = 0, na d(i:i+nb) = d(i:i+nb) + a(i) * b(0:nb) end do c(0:na+nb) = d(0:na+nb) return end subroutine rpoly_n2p ( n, a, xarray ) ! !******************************************************************************* ! !! RPOLY_N2P converts a real polynomial from Newton form to power sum form. ! ! ! Discussion: ! ! This is done by shifting all the Newton abscissas to zero. ! ! Actually, what happens is that the abscissas of the Newton form ! are all shifted to zero, which means that A is the power sum ! polynomial description and A, XARRAY is the Newton polynomial ! description. It is only because all the abscissas are shifted to ! zero that A can be used as both a power sum and Newton polynomial ! coefficient array. ! ! The Newton form of a polynomial is described by an array of N coefficients ! A and N abscissas X: ! ! p(x) = a(1) ! + a(2) * (x-x(1)) ! + a(3) * (x-x(1)) * (x-x(2)) ! ... ! + a(n) * (x-x(1)) * (x-x(2)) * ... * (x-x(n-1)) ! ! X(N) does not occur explicitly in the formula for the evaluation of p(x), ! although it is used in deriving the coefficients A. ! ! The power sum form of a polynomial is: ! ! p(x) = a(1) + a(2)*x + ... + a(n-1)*x**(n-2) + a(n)*x**(n-1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real A(N). On input, the coefficients ! of the polynomial in Newton form, and on output, the coefficients ! in power sum form. ! ! Input/output, real XARRAY(N). On input, the abscissas of ! the Newton form of the polynomial. On output, these values ! have all been set to zero. ! implicit none ! integer n ! real a(n) integer i real xarray(n) real, parameter :: zero = 0.0E+00 ! do i = 1, n call rpoly_nx ( n, a, xarray, zero ) end do return end subroutine rpoly_nval ( n, a, xarray, x, val ) ! !******************************************************************************* ! !! RPOLY_NVAL evaluates a real polynomial in Newton form. ! ! ! Definition: ! ! The Newton form of a polynomial is; ! ! p(x) = a(1) ! + a(2) *(x-x1) ! + a(3) *(x-x1)*(x-x2) ! +... ! + a(n-1)*(x-x1)*(x-x2)*(x-x3)...*(x-x(n-2)) ! + a(n) *(x-x1)*(x-x2)*(x-x3)...*(x-x(n-2))*(x-x(n-1)) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real A(N), the coefficients of the polynomial. ! A(1) is the constant term. ! ! Input, real XARRAY(N-1), the N-1 points X which are part ! of the definition of the polynomial. ! ! Input, real X, the point at which the polynomial is to be evaluated. ! ! Output, real VAL, the value of the polynomial at X. ! implicit none ! integer n ! real a(n) integer i real val real x real xarray(n-1) ! val = a(n) do i = n-1, 1, -1 val = a(i) + ( x - xarray(i) ) * val end do return end subroutine rpoly_nx ( n, a, xarray, x ) ! !******************************************************************************* ! !! RPOLY_NX replaces one of the base points in a polynomial in Newton form. ! ! ! Discussion: ! ! The Newton form of a polynomial is described by an array of N coefficients ! A and N abscissas X: ! ! p(x) = a(1) ! + a(2) * (x-x(1)) ! + a(3) * (x-x(1)) * (x-x(2)) ! ... ! + a(n) * (x-x(1)) * (x-x(2)) * ... * (x-x(n-1)) ! ! X(N) does not occur explicitly in the formula for the evaluation of p(x), ! although it is used in deriving the coefficients A. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real A(N), the polynomial coefficients of the Newton form. ! ! Input/output, real XARRAY(N), the set of abscissas that ! are part of the Newton form of the polynomial. On output, ! the abscissas have been shifted up one index, so that ! the first location now holds X, and the original contents ! of XARRAY(N) have been discarded. ! ! Input, real X, the new point to be shifted into XARRAY. ! implicit none ! integer n ! real a(n) integer i real x real xarray(n) ! do i = n-1, 1, -1 a(i) = a(i) + ( x - xarray(i) ) * a(i+1) end do do i = n, 2, -1 xarray(i) = xarray(i-1) end do xarray(1) = x return end subroutine rpoly_p2f ( n, a ) ! !******************************************************************************* ! !! RPOLY_P2F converts a real polynomial from power sum form to factorial form. ! ! ! Discussion: ! ! The power sum form is ! ! p(x) = a(1) + a(2)*x + a(3)*x**2 + ... + a(n)*x**(n-1) ! ! The factorial form is ! ! p(x) = a(1) ! + a(2) * x ! + a(3) * x*(x-1) ! ... ! + a(n) * x*(x-1)*...*(x-(n-2)) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, real N, the dimension of A. ! ! Input/output, real A(N), on input, the polynomial ! coefficients in the power sum form, on output, the polynomial ! coefficients in factorial form. ! implicit none ! integer n ! real a(n) integer i integer m real val ! do m = 1, n val = 0.0E+00 do i = m, n val = a(n+m-i) + real ( m - 1 ) * val a(n+m-i) = val end do end do return end subroutine rpoly_p2n ( n, a, xarray ) ! !******************************************************************************* ! !! RPOLY_P2N converts a real polynomial from power sum form to Newton form. ! ! ! Discussion: ! ! This is done by shifting all the Newton abscissas from zero. ! ! The power sum form of a polynomial is: ! ! p(x) = a(1) + a(2)*x + ... + a(n-1)*x**(n-2) + a(n)*x**(n-1) ! ! The Newton form of a polynomial is described by an array of N coefficients ! A and N abscissas X: ! ! p(x) = a(1) ! + a(2) * (x-x(1)) ! + a(3) * (x-x(1)) * (x-x(2)) ! ... ! + a(n) * (x-x(1)) * (x-x(2)) * ... * (x-x(n-1)) ! ! X(N) does not occur explicitly in the formula for the evaluation of p(x), ! although it is used in deriving the coefficients A. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real A(N). On input, the coefficients ! of the polynomial in power sum form, and on output, the ! coefficients in Newton form. ! ! Input/output, real XARRAY(N). On input, the desired abscissas of ! the Newton form of the polynomial. ! implicit none ! integer n ! real a(n) integer i real xarray(n) real work(n) ! work(1:n) = 0.0E+00 do i = n, 1, -1 call rpoly_nx ( n, a, work, xarray(i) ) end do return end subroutine rpoly_p2t ( n, a, x ) ! !******************************************************************************* ! !! RPOLY_P2T converts a real polynomial from power sum form to Taylor form. ! ! ! Discussion: ! ! The power sum form is ! ! p(x) = a(1) + a(2)*x + a(3)*x**2 + ... + a(n)*x**(n-1) ! ! The Taylor form is ! ! p(x) = a(1) ! + a(2) * (x-x0) ! + a(3) * (x-x0)**2 ! ... ! + a(n) * (x-x0)**(n-1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, real N, the dimension of A. ! ! Input/output, real A(N), on input, the coefficients in ! power sum form, and on output, the coefficients in Taylor form. ! ! Input, real X, the point at which the Taylor form of the ! polynomial is to be based. ! implicit none ! integer n ! real a(n) integer i integer m real val real x ! do m = 1, n val = 0.0E+00 do i = m, n val = a(n+m-i) + x * val a(n+m-i) = val end do end do return end subroutine rpoly_power ( na, a, p, b ) ! !******************************************************************************* ! !! RPOLY_POWER computes a positive integer power of a polynomial. ! ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 20 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the dimension of A. ! ! Input, real A(0:NA), the polynomial to be raised to the power. ! ! Input, integer P, the nonnegative power to which A is raised. ! ! Output, real B(0:P*NA), the power of the polynomial. ! implicit none ! integer na integer p ! real a(0:na) real b(0:p*na) integer i integer j integer nonzer ! ! Zero out B. ! b(0:p*na) = 0.0E+00 ! ! Search for the first nonzero element in A. ! nonzer = 0 do i = 0, na if ( a(i) /= 0.0E+00 ) then nonzer = i exit end if end do if ( nonzer == 0 ) then return end if b(0) = a(nonzer)**p do i = 1, p*(na-nonzer) if ( i + nonzer <= na ) then b(i) = real ( i * p ) * b(0) * a(i+nonzer) else b(i) = 0.0E+00 end if do j = 1, i-1 if ( j+nonzer <= na ) then b(i) = b(i) - real ( i - j ) * a(j+nonzer) * b(i-j) end if if ( i-j+nonzer <= na ) then b(i) = b(i) + real ( i - j ) * real ( p ) * b(j) * a(i-j+nonzer) end if end do b(i) = b(i) / ( real ( i ) * a(nonzer) ) end do ! ! Shift B up. ! do i = p*nonzer, p*na b(i) = b(i-p*nonzer) end do do i = 0, p * nonzer-1 b(i) = 0.0E+00 end do return end subroutine rpoly_print ( n, a, title ) ! !******************************************************************************* ! !! RPOLY_PRINT prints out a polynomial. ! ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 06 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real A(0:N), the polynomial coefficients. ! A(0) is the constant term and ! A(N) is the coefficient of X**N. ! ! Input, character ( len = * ) TITLE, an optional title. ! implicit none ! integer n ! real a(0:n) integer i real mag integer n2 character plus_minus character ( len = * ) title ! if ( len_trim ( title ) > 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' call rpoly_degree ( n, a, n2 ) if ( a(n2) < 0.0E+00 ) then plus_minus = '-' else plus_minus = ' ' end if mag = abs ( a(n2) ) if ( n2 >= 2 ) then write ( *, '( '' p(x) = '', a1, g14.6, '' * x ^ '', i3 )' ) & plus_minus, mag, n2 else if ( n2 == 1 ) then write ( *, '( '' p(x) = '', a1, g14.6, '' * x'' )' ) plus_minus, mag else if ( n2 == 0 ) then write ( *, '( '' p(x) = '', a1, g14.6 )' ) plus_minus, mag end if do i = n2-1, 0, -1 if ( a(i) < 0.0E+00 ) then plus_minus = '-' else plus_minus = '+' end if mag = abs ( a(i) ) if ( mag /= 0.0E+00 ) then if ( i >= 2 ) then write ( *, ' ( '' '', a1, g14.6, '' * x ^ '', i3 )' ) & plus_minus, mag, i else if ( i == 1 ) then write ( *, ' ( '' '', a1, g14.6, '' * x'' )' ) plus_minus, mag else if ( i == 0 ) then write ( *, ' ( '' '', a1, g14.6 )' ) plus_minus, mag end if end if end do return end subroutine rpoly_pval ( n, a, x, val ) ! !******************************************************************************* ! !! RPOLY_PVAL evaluates a real polynomial in power sum form. ! ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x**(n-1) + a(n)*x**(n) ! ! Modified: ! ! 08 December 1999 ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real A(0:N), the coefficients of the polynomial. ! A(0) is the constant term. ! ! Input, real X, the point at which the polynomial is to be evaluated. ! ! Output, real VAL, the value of the polynomial at X. ! implicit none ! integer n ! real a(0:n) integer i real val real x ! val = 0.0E+00 do i = n, 0, -1 val = val * x + a(i) end do return end subroutine rpoly_t2p ( n, a, x ) ! !******************************************************************************* ! !! RPOLY_T2P converts a real polynomial from Taylor form to power sum form. ! ! ! Discussion: ! ! The Taylor form is ! ! p(x) = a(1) ! + a(2) * (x-x0) ! + a(3) * (x-x0)**2 ! ... ! + a(n) * (x-x0)**(n-1) ! ! The power sum form is ! ! p(x) = a(1) + a(2)*x + a(3)*x**2 + ... + a(n)*x**(n-1) ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, real N, the dimension of A. ! ! Input/output, real A(N). On input, the coefficients in Taylor form, ! and on output, the coefficients in power sum form. ! ! Input, real X, the point at which the Taylor form polynomial is based. ! implicit none ! integer n ! real a(n) integer i integer j real x ! do i = n, 1, -1 do j = i, n-1 a(j) = a(j) - a(j+1) * x end do end do return end subroutine rvec_backtrack ( n, x, indx, k, nstack, stack, maxstack, ncan ) ! !******************************************************************************* ! !! RVEC_BACKTRACK supervises a backtrack search for a real vector. ! ! ! Discussion: ! ! The routine tries to construct a real vector one index at a time, ! using possible candidates as supplied by the user. ! ! At any time, the partially constructed vector may be discovered to be ! unsatisfactory, but the routine records information about where the ! last arbitrary choice was made, so that the search can be ! carried out efficiently, rather than starting out all over again. ! ! First, call the routine with INDX = 0 so it can initialize itself. ! ! Now, on each return from the routine, if INDX is: ! 1, you've just been handed a complete candidate vector; ! Admire it, analyze it, do what you like. ! 2, please determine suitable candidates for position X(K). ! Return the number of candidates in NCAN(K), adding each ! candidate to the end of STACK, and increasing NSTACK. ! 3, you're done. Stop calling the routine; ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 24 July 2000 ! ! Parameters: ! ! Input, integer N, the number of positions to be filled in the vector. ! ! Input/output, real X(N), the partial or complete candidate vector. ! ! Input/output, integer INDX, a communication flag. ! On input, ! 0 to start a search. ! On output: ! 1, a complete output vector has been determined and returned in X(1:N); ! 2, candidates are needed for position X(K); ! 3, no more possible vectors exist. ! ! Output, integer K, if INDX=2, the current vector index being considered. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input, real STACK(MAXSTACK), a list of all current candidates for ! all positions 1 through K. ! ! Input, integer MAXSTACK, the maximum length of the stack. ! ! Input/output, integer NCAN(N), lists the current number of candidates for ! positions 1 through K. ! implicit none ! integer n integer maxstack ! integer indx integer k integer ncan(n) integer nstack real stack(maxstack) real x(n) ! ! If this is the first call, request a candidate for position 1. ! if ( indx == 0 ) then k = 1 nstack = 0 indx = 2 return end if ! ! Examine the stack. ! do ! ! If there are candidates for position K, take the first available ! one off the stack, and increment K. ! ! This may cause K to reach the desired value of N, in which case ! we need to signal the user that a complete set of candidates ! is being returned. ! if ( ncan(k) > 0 ) then x(k) = stack(nstack) nstack = nstack - 1 ncan(k) = ncan(k) - 1 if ( k /= n ) then k = k + 1 indx = 2 else indx = 1 end if exit ! ! If there are no candidates for position K, then decrement K. ! If K is still positive, repeat the examination of the stack. ! else k = k - 1 if ( k <= 0 ) then indx = 3 exit end if end if end do return end subroutine rvec_frac ( n, a, k, afrac ) ! !******************************************************************************* ! !! RVEC_FRAC searches for the K-th smallest entry in an N-vector. ! ! ! Discussion: ! ! Hoare's algorithm is used. ! ! Modified: ! ! 17 July 2000 ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Input/output, real A(N). ! ! On input, A is the array to search. ! ! On output, the elements of A have been somewhat rearranged. ! ! Input, integer K, the fractile to be sought. If K = 1, the minimum ! entry is sought. If K = N, the maximum is sought. Other values ! of K search for the entry which is K-th in size. K must be at ! least 1, and no greater than N. ! ! Output, real AFRAC, the value of the K-th fractile of A. ! implicit none ! integer n ! real a(n) real afrac integer i integer iryt integer j integer k integer left real w real x ! if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RVEC_FRAC - Fatal error!' write ( *, '(a,i6)' ) ' Illegal nonpositive value of N = ', n stop end if if ( k <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RVEC_FRAC - Fatal error!' write ( *, '(a,i6)' ) ' Illegal nonpositive value of K = ', k stop end if if ( k > n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'RVEC_FRAC - Fatal error!' write ( *, '(a,i6)' ) ' Illegal K > N, K = ', k stop end if left = 1 iryt = n do if ( left >= iryt ) then afrac = a(k) exit end if x = a(k) i = left j = iryt do if ( i > j ) then if ( j < k ) then left = i end if if ( k < i ) then iryt = j end if exit end if ! ! Find I so that X< = A(I) ! do while ( a(i) < x ) i = i + 1 end do ! ! Find J so that A(J) < = X ! do while ( x < a(j) ) j = j - 1 end do if ( i <= j ) then call r_swap ( a(i), a(j) ) i = i + 1 j = j - 1 end if end do end do return end subroutine rvec_identity ( n, a ) ! !******************************************************************************* ! !! RVEC_IDENTITY sets a real vector to the identity vector A(I)=I. ! ! ! Modified: ! ! 09 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Output, real A(N), the array to be initialized. ! implicit none ! integer n ! real a(n) integer i ! do i = 1, n a(i) = real ( i ) end do return end subroutine rvec_print ( n, a, title ) ! !******************************************************************************* ! !! RVEC_PRINT prints a real vector. ! ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, real A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none ! integer n ! real a(n) integer i character ( len = * ) title ! if ( title /= ' ' ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(i6,g14.6)' ) i, a(i) end do return end subroutine rvec_random ( n, a, alo, ahi ) ! !******************************************************************************* ! !! RVEC_RANDOM returns a random real vector in a given range. ! ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Output, real A(N), the vector of randomly chosen values. ! ! Input, real ALO, AHI, the range allowed for the entries. ! implicit none ! integer n ! real a(n) real ahi real alo integer i ! do i = 1, n call r_random ( alo, ahi, a(i) ) end do return end subroutine s_blank_delete ( s ) ! !******************************************************************************* ! !! S_BLANK_DELETE removes blanks from a string, left justifying the remainder. ! ! ! Comment: ! ! All TAB characters are also removed. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! character c integer iget integer iput character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! iput = 0 do iget = 1, len ( s ) c = s(iget:iget) if ( c /= ' ' .and. c /= TAB ) then iput = iput + 1 s(iput:iput) = c end if end do s(iput+1:) = ' ' return end subroutine s_blanks_delete ( s ) ! !******************************************************************************* ! !! S_BLANKS_DELETE replaces consecutive blanks by one blank. ! ! ! Discussion: ! ! The remaining characters are left justified and right padded with blanks. ! TAB characters are converted to spaces. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none ! integer i integer j character newchr character oldchr character ( len = * ) s character, parameter :: TAB = char ( 9 ) ! j = 0 newchr = ' ' do i = 1, len ( s ) oldchr = newchr newchr = s(i:i) if ( newchr == TAB ) then newchr = ' ' end if s(i:i) = ' ' if ( oldchr /= ' ' .or. newchr /= ' ' ) then j = j + 1 s(j:j) = newchr end if end do return end function s_eqi ( s1, s2 ) ! !******************************************************************************* ! !! S_EQI is a case insensitive comparison of two strings for equality. ! ! ! Examples: ! ! S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE. ! ! Modified: ! ! 14 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, character ( len = * ) S1, S2, the strings to compare. ! ! Output, logical S_EQI, the result of the comparison. ! implicit none ! character c1 character c2 integer i integer len1 integer len2 integer lenc logical s_eqi character ( len = * ) s1 character ( len = * ) s2 ! len1 = len ( s1 ) len2 = len ( s2 ) lenc = min ( len1, len2 ) s_eqi = .false. do i = 1, lenc c1 = s1(i:i) c2 = s2(i:i) call ch_cap ( c1 ) call ch_cap ( c2 ) if ( c1 /= c2 ) then return end if end do do i = lenc + 1, len1 if ( s1(i:i) /= ' ' ) then return end if end do do i = lenc + 1, len2 if ( s2(i:i) /= ' ' ) then return end if end do s_eqi = .true. return end subroutine schroeder ( n, s ) ! !******************************************************************************* ! !! SCHROEDER generates the Schroeder numbers. ! ! ! Definition: ! ! The Schroeder number S(N) counts the number of ways to insert ! parentheses into an expression of N items, with two or more items within ! a parenthesis. ! ! Note that the Catalan number C(N) counts the number of ways ! to legally arrange a set of N left and N right parentheses. ! ! Example: ! ! N = 4 ! ! 1234 ! 12(34) ! 1(234) ! 1(2(34)) ! 1(23)4 ! 1((23)4) ! (123)4 ! (12)34 ! (12)(34) ! (1(23))4 ! ((12)3)4 ! ! First Values: ! ! 1 ! 1 ! 3 ! 11 ! 45 ! 197 ! 903 ! 4279 ! 20793 ! 103049 ! 518859 ! 2646723 ! 13648869 ! 71039373 ! ! Formula: ! ! S(N) = ( P(N)(3.0) - 3 P(N-1)(3.0) ) / ( 4 * ( N - 1 ) ) ! where P(N)(X) is the N-th Legendre polynomial. ! ! Recursion: ! ! S(1) = 1 ! S(2) = 1 ! S(N) = ( ( 6 * N - 9 ) * S(N-1) - ( N - 3 ) * S(N-2) ) / N ! ! Reference: ! ! R P Stanley, ! Hipparchus, Plutarch, Schroeder, and Hough, ! American Mathematical Monthly, ! Volume 104, Number 4, 1997, pages 344-350. ! ! Laurent Habsieger, Maxim Kazarian, Sergei Lando, ! On the Second Number of Plutarch, ! American Mathematical Monthly, May 1998, page 446. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of Schroeder numbers desired. ! ! Output, integer S(N), the Schroeder numbers. ! implicit none ! integer n ! integer i integer s(n) ! if ( n <= 0 ) then return end if s(1) = 1 if ( n <= 1 ) then return end if s(2) = 1 if ( n <= 2 ) then return end if do i = 3, n s(i) = ( ( 6 * i - 9 ) * s(i-1) - ( i - 3 ) * s(i-2) ) / i end do return end subroutine sort_heap_external ( n, indx, i, j, isgn ) ! !******************************************************************************* ! !! SORT_HEAP_EXTERNAL externally sorts a list of items into linear order. ! ! ! Discussion: ! ! The actual list of data is not passed to the routine. Hence this ! routine may be used to sort integers, reals, numbers, names, ! dates, shoe sizes, and so on. After each call, the routine asks ! the user to compare or interchange two items, until a special ! return value signals that the sorting is completed. ! ! Modified: ! ! 19 May 1999 ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Parameters: ! ! Input, integer N, the number of items to be sorted. ! ! Input/output, integer INDX, the main communication signal. ! ! The user must set INDX to 0 before the first call. ! Thereafter, the user should not change the value of INDX until ! the sorting is done. ! ! On return, if INDX is ! ! greater than 0, ! * interchange items I and J; ! * call again. ! ! less than 0, ! * compare items I and J; ! * set ISGN = -1 if I < J, ISGN = +1 if I > J; ! * call again. ! ! equal to 0, the sorting is done. ! ! Output, integer I, J, the indices of two items. ! On return with INDX positive, elements I and J should be interchanged. ! On return with INDX negative, elements I and J should be compared, and ! the result reported in ISGN on the next call. ! ! Input, integer ISGN, results of comparison of elements I and J. ! (Used only when the previous call returned INDX less than 0). ! ISGN <= 0 means I is less than or equal to J; ! ISGN => 0 means I is greater than or equal to J. ! implicit none ! integer i integer indx integer isgn integer j integer, save :: k = 0 integer, save :: k1 = 0 integer n integer, save :: n1 = 0 ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then n1 = n k = n / 2 k1 = k ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 0 ) then i = i + 1 end if j = k1 k1 = i indx = - 1 return end if if ( isgn > 0 ) then indx = 2 return end if if ( k <= 1 ) then if ( n1 == 1 ) then indx = 0 else i = n1 n1 = n1 - 1 j = 1 indx = 1 end if return end if k = k - 1 k1 = k ! ! INDX > 0, the user was asked to make an interchange. ! else if ( indx == 1 ) then k1 = k end if do i = 2 * k1 if ( i == n1 ) then j = k1 k1 = i indx = - 1 return else if ( i <= n1 ) then j = i + 1 indx = - 2 return end if if ( k <= 1 ) then exit end if k = k - 1 k1 = k end do if ( n1 == 1 ) then indx = 0 else i = n1 n1 = n1 - 1 j = 1 indx = 1 end if return end subroutine sub_by_size_next ( n, iarray, size, more ) ! !******************************************************************************* ! !! SUB_BY_SIZE_NEXT returns all subsets of an N set, in order of size. ! ! ! Example: ! ! N = 4: ! ! 1 2 3 4 ! 1 2 3 ! 1 2 4 ! 1 3 4 ! 1 3 ! 1 4 ! 2 3 ! 1 ! 2 ! 3 ! (the empty set) ! ! Discussion: ! ! The subsets are returned in decreasing order of size, with the ! empty set last. ! ! For a given size K, the K subsets are returned in lexicographic order. ! ! Modified: ! ! 02 December 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the set. ! ! Output, integer IARRAY(N). The entries IARRAY(1:SIZE) contain ! the elements of the subset. The elements are given in ascending ! order. ! ! Output, integer SIZE, the number of elements in the subset. ! ! Input/output, logical MORE. Set MORE = .FALSE. before first call ! for a new sequence of subsets. It then is set and remains ! .TRUE. as long as the subset computed on this call is not the ! final one. When the final subset is computed, MORE is set to ! .FALSE. as a signal that the computation is done. ! implicit none ! integer n ! integer iarray(n) logical more logical, save :: more2 = .false. integer size ! if ( .not. more ) then more = .true. more2 = .false. size = n else if ( .not. more2 ) then size = size - 1 end if ! ! Compute the next subset of size SIZE. ! if ( size > 0 ) then call ksub_next ( n, size, iarray, more2 ) else if ( size == 0 ) then more = .false. end if return end subroutine sub_lex ( n, k, a, jmp, ndim ) ! !******************************************************************************* ! !! SUB_LEX generates the subsets of a set of N elements, one at a time. ! ! ! Discussion: ! ! The subsets are generated in lexical order. The routine can also be ! forced to generate only those subsets whose size is no greater than ! some user-specified maximum. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the order of the main set from which subsets ! are chosen. ! ! Input/output, integer K. On first call, the user must set K = 0 as ! a startup signal to the program. Thereafter, the routine returns ! the size of the computed subset in K. On the last return, ! the empty set is returned and K is 0, which is a signal to ! the user that the computation is complete. ! ! Output, integer A(NDIM). A(I) is the I-th element of the ! subset, listed in increasing order, with 0's in entries ! beyond entry K. ! ! Input, logical JMP. In the simplest case, set JMP = .FALSE. for ! a normal computation. But to jump over supersets of the input set, ! set JMP = .TRUE.. Setting JMP=K.EQ.3 before every new call ! will, for example, force all the subsets returned ! to have cardinality 3 or less. ! ! Input, integer NDIM, the allowed storage for A. If NDIM < N, ! JMP must be used to avoid creation of a subset too large to store in A. ! implicit none ! integer ndim ! integer a(ndim) integer is logical jmp integer k integer n ! if ( k == 0 ) then if ( jmp ) then return end if is = 0 k = k + 1 a(1) = 1 else if ( a(k) /= n ) then is = a(k) if ( .not. jmp ) then k = k + 1 end if a(k) = is + 1 else k = k - 1 if ( k /= 0 ) then a(k) = a(k) + 1 end if end if return end subroutine sub_next ( n, a, more, ncard, iadd ) ! !******************************************************************************* ! !! SUB_NEXT generates all subsets of a set of order N, one at a time. ! ! ! Discussion: ! ! It generates the subsets one at a time, by adding or subtracting ! exactly one element on each step. ! ! The user should set MORE = .FALSE. and the value of N before ! the first call. On return, the user may examine A which contains ! the definition of the new subset, and must check .MORE., because ! as soon as it is .FALSE. on return, all the subsets have been ! generated and the user probably should cease calling. ! ! The first set returned is the empty set. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the order of the total set from which ! subsets will be drawn. ! ! Output, integer A(N). On each return, the Gray code for the newly ! generated subset. A(I) = 0 if element I is in the subset, 1 otherwise. ! ! Input/output, logical MORE. Set this variable .FALSE. before ! the first call. Normally, MORE will be returned .TRUE. but once ! all the subsets have been generated, MORE will be ! reset .FALSE. on return and you should stop calling the program. ! ! Output, integer NCARD, the cardinality of the set returned, ! which may be any value between 0 (the empty set) and N (the ! whole set). ! ! Output, integer IADD, the element which was added or removed to the ! previous subset to generate the current one. Exception: ! the empty set is returned on the first call, and IADD is set to 0. ! implicit none ! integer n ! integer a(n) integer i integer iadd logical more integer ncard ! ! First set returned is the empty set. ! if ( .not. more ) then a(1:n) = 0 iadd = 0 ncard = 0 more = .true. else iadd = 1 if ( mod ( ncard, 2 ) /= 0 ) then do iadd = iadd + 1 if ( a(iadd-1) /= 0 ) then exit end if end do end if a(iadd) = 1 - a(iadd) ncard = ncard + 2 * a(iadd) - 1 ! ! Last set returned is the singleton A(N). ! if ( ncard == a(n) ) then more = .false. end if end if return end subroutine sub_random ( n, a ) ! !******************************************************************************* ! !! SUB_RANDOM selects a random subset of an N-set. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 01 December 2000 ! ! Parameters: ! ! Input, integer N, the size of the full set. ! ! Output, integer A(N). A vector to hold the information about ! the set chosen. On return, if A(I) = 1, then ! I is in the random subset, otherwise, A(I) = 0 ! and I is not in the random subset. ! implicit none ! integer n ! integer a(n) integer i real r ! do i = 1, n call i_random ( 0, 1, a(i) ) end do return end subroutine sub_rank ( a, irank, k ) ! !******************************************************************************* ! !! SUB_RANK computes the rank of a subset of an N set. ! ! ! Discussion: ! ! The routine accepts an array representing a subset of size K from a set ! of size N, and returns the rank (or order) of that subset. This ! is the same order in which routine SUB_NEXT2 would produce that subset. ! Note the value of N is not input, and is not, in fact, ! needed. ! ! Parameters: ! ! Input, integer A(K), contains K distinct numbers between ! 1 and N, in order. ! ! Output, integer IRANK, the rank of this subset. ! ! Input, integer K, the number of elements in the subset. ! implicit none ! integer k ! integer a(k) integer i integer iprod integer irank integer j ! irank = 0 do i = 1, k iprod = 1 do j = i+1, a(i)-1 iprod = iprod * j end do do j = 1, a(i)-i-1 iprod = iprod / j end do if ( a(i) == 1 ) then iprod = 0 end if irank = irank + iprod end do irank = irank + 1 return end subroutine sub_unrank ( a, irank, k ) ! !******************************************************************************* ! !! SUB_UNRANK returns the subset of a given rank. ! ! ! Discussion: ! ! SUB_UNRANK is given a rank and returns the corresponding subset of K ! elements of a set of N elements. It uses the same ranking that ! SUB_NEXT2 uses to generate all the subsets one at a time. Note that ! the value of N itself is not input, nor is it needed. ! ! Modified: ! ! 24 July 2000 ! ! Parameters: ! ! Output, integer A(K), K distinct integers in order between ! 1 and N, which define the subset. ! ! Input, integer IRANK, the rank of the desired subset. ! There are ( N*(N-1)*...*(N+K-1)) / ( K*(K-1)*...*2*1) such ! subsets, so IRANK must be between 1 and that value. ! ! Input, integer K, the number of elements in the subset. ! implicit none ! integer k ! integer a(k) integer i integer ii integer ip integer iprod integer irank integer jrank ! jrank = irank - 1 do ii = 1, k i = k + 1 - ii ip = i - 1 iprod = 1 do ip = ip + 1 if ( ip /= i ) then iprod = ( ip * iprod ) / ( ip - i ) end if if ( iprod > jrank ) then exit end if end do if ( ip /= i ) then iprod = ( ( ip - i ) * iprod ) / ip end if jrank = jrank - iprod a(i) = ip end do return end subroutine thue_binary_next ( n, thue ) ! !******************************************************************************* ! !! THUE_BINARY_NEXT returns the next element in a binary Thue sequence. ! ! ! Discussion: ! ! Thue demonstrated that arbitrarily long sequences of 0's and ! 1's could be generated which had the "cubefree" property. In ! other words, for a given string S, there was no substring W ! such that S contained "WWW". In fact, a stronger result holds: ! if "a" is the first letter of W, it is never the case that S ! contains the substring "WWa". ! ! In this example, the digits allowed are binary, that is, just ! "0" and "1". The replacement rules are: ! ! "0" -> "01" ! "1" -> "10" ! ! This routine produces the next binary Thue sequence in a given series. ! However, the input sequence must be a Thue sequence in order for ! us to guarantee that the output sequence will also have the ! cubic nonrepetition property. ! ! Also, enough space must be set aside in THUE to hold the ! output sequence. This will always be twice the input ! value of N. ! ! Modified: ! ! 05 November 2001 ! ! Parameters: ! ! Input/output, integer N. On input, the length of the input sequence. ! On output, the length of the output sequence. ! ! Input, integer THUE(N). On input, the initial Thue sequence, and on ! output, the result of applying the substitution rules once. ! implicit none ! integer n ! integer i integer n_out integer thue(*) integer thue_out(2*n) ! n_out = 0 do i = 1, n if ( thue(i) == 0 ) then n_out = n_out + 1 thue_out(n_out) = 0 n_out = n_out + 1 thue_out(n_out) = 1 else if ( thue(i) == 1 ) then n_out = n_out + 1 thue_out(n_out) = 1 n_out = n_out + 1 thue_out(n_out) = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'THUE_BINARY_NEXT - Fatal error!' write ( *, '(a)' ) ' The input sequence contains a non-binary digit' write ( *, '(a,i6,a,i6)' ) ' THUE(', i, ') = ', thue(i) stop end if end do n = n_out thue(1:n) = thue_out(1:n) return end subroutine thue_ternary_next ( n, thue ) ! !******************************************************************************* ! !! THUE_TERNARY_NEXT returns the next element in a ternary Thue sequence. ! ! ! Discussion: ! ! Thue was interested in showing that there were arbitrarily long ! sequences of digits which never displayed a pair of contiguous ! repetitions of any length. That is, there was no occurrence of ! "00" or "1010" or "121121", anywhere in the string. This makes ! the string "squarefree". ! ! To do this, he demonstrated a way to start with a single digit, ! and to repeatedly apply a series of transformation rules to each ! digit of the sequence, deriving nonrepeating sequences of ever ! greater length. ! ! In this example, the digits allowed are ternary, that is, just ! "0", "1" and "2". The replacement rules are: ! ! "0" -> "12" ! "1" -> "102" ! "2" -> "0" ! ! This routine produces the next Thue sequence in a given series. ! However, the input sequence must be a Thue sequence in order for ! us to guarantee that the output sequence will also have the ! nonrepetition property. ! ! Also, enough space must be set aside in THUE to hold the ! output sequence. This will never be more than 3 times the input ! value of N. ! ! Reference: ! ! Brian Hayes, ! Third Base, ! American Scientist, ! Volume 89, Number 6, pages 490-494, November-December 2001. ! ! Modified: ! ! 28 October 2001 ! ! Parameters: ! ! Input/output, integer N. On input, the length of the input sequence. ! On output, the length of the output sequence. ! ! Input, integer THUE(N). On input, the initial Thue sequence, and on ! output, the result of applying the substitution rules once. ! implicit none ! integer n ! integer i integer n_out integer thue(*) integer thue_out(3*n) ! n_out = 0 do i = 1, n if ( thue(i) == 0 ) then n_out = n_out + 1 thue_out(n_out) = 1 n_out = n_out + 1 thue_out(n_out) = 2 else if ( thue(i) == 1 ) then n_out = n_out + 1 thue_out(n_out) = 1 n_out = n_out + 1 thue_out(n_out) = 0 n_out = n_out + 1 thue_out(n_out) = 2 else if ( thue(i) == 2 ) then n_out = n_out + 1 thue_out(n_out) = 0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'THUE_TERNARY_NEXT - Fatal error!' write ( *, '(a)' ) ' The input sequence contains a non-ternary digit' write ( *, '(a,i6,a,i6)' ) ' THUE(', i, ') = ', thue(i) stop end if end do n = n_out thue(1:n) = thue_out(1:n) return end subroutine timestamp ( ) ! !******************************************************************************* ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Modified: ! ! 31 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none ! character ( len = 8 ) ampm integer d character ( len = 8 ) date integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s character ( len = 10 ) time integer values(8) integer y character ( len = 5 ) zone ! call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine triang ( n, izeta, p ) ! !******************************************************************************* ! !! TRIANG renumbers elements in accordance with a partial ordering. ! ! ! Discussion: ! ! TRIANG is given a partially ordered set, where the partial ordering ! is defined by a matrix IZETA, where element I is partially less than ! or equal to element J if and only if IZETA(I,J) = 1. ! ! TRIANG renumbers the elements with a permutation P so that if ! element I is partially less than element J in the partial ordering, ! then P(I) < P(J) in the usual, numerical ordering. ! ! In other words, the elements are relabeled so that their labels ! reflect their ordering. This is equivalent to relabeling the ! matrix so that, on unscrambling it, the matrix would be upper ! triangular. ! ! Calling IMAT_PERM or RMAT_PERM with P used for both the row ! and column permutations applied to matrix IZETA will result in ! an upper triangular matrix. ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the number of elements in the set. The number ! of rows and columns used in IZETA. ! ! Input, integer IZETA(N,N), contains the description of the ! partial ordering. To avoid confusion with the true "less than" ! relationship, symbolized by "<" or ".LT.", let us use ! "I .PLT. J" to mean that I is less than J in the partial ordering. ! ! The diagonal entries of IZETA are meaningless. ! ! Consider any two distinct elements, I and J. There are three ! possibilities: ! ! * I and J are not related in the partial ordering. That is, neither ! I .PLT. J nor J .PLT. I are true. In that case, ! set IZETA(I,J) = IZETA(J,I) = 0. ! ! * I and J are related, and I .PLT. J. In that case, set ! IZETA(I,J) = 1, IZETA(J,I) = 0. ! ! * I and J are related, and J .PLT. I. In that case, set ! IZETA(I,J) = 0, IZETA(J,I) = 1 ! ! Note that it should never happen that IZETA(I,J) and IZETA(J,I) ! are both nonzero. This would represent incorrect data. ! ! Thus, the values of IZETA(I,J) are: ! 0, for diagonal elements, or for unrelated elements, or if J .PLT. I. ! 1, (or any nonzero value) if I .PLT. J. ! ! Output, integer P(N), a permutation of the elements that reflects ! their partial ordering. P(I) is the new label of element I, with ! the property that if IZETA(I,J) = 1, that is, I .PLT. J, ! then P(I) < P(J) (in the usual ordering). ! implicit none ! integer n ! integer i integer ierror integer iq integer ir integer it integer izeta(n,n) integer l integer m integer p(n) ! ! Make sure IZETA represents a partially ordered set. In other words, ! if IZETA(I,J) = 1, then IZETA(J,I) must NOT be 1. ! call pord_check ( n, izeta, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TRIANG - Fatal error!' write ( *, '(a)' ) ' The matrix IZETA does not represent a' write ( *, '(a)' ) ' partial ordering.' stop end if m = 0 l = 0 p(1:n) = 0 ! ! Find the next value of M for which P(M) is 0. ! 10 continue do m = m + 1 if ( p(m) == 0 ) then exit end if if ( m == n ) then return end if end do it = m + 1 ir = m + 1 do if ( ir <= n ) then if ( p(ir) == 0 .and. izeta(ir,m) /= 0 ) then p(ir) = m m = ir ir = it else ir = ir + 1 end if else l = l + 1 iq = p(m) p(m) = l if ( iq == 0 ) then if ( m == n ) then exit end if go to 10 end if ir = m + 1 m = iq end if end do return end subroutine tuple_next ( m, n, k, x ) ! !******************************************************************************* ! !! TUPLE_NEXT computes the next element of a tuple space. ! ! ! Discussion: ! ! The elements are N vectors. Each entry is constrained to lie ! between 1 and M. The elements are produced one at a time. ! The first element is ! (1,1,...,1) ! and the last element is ! (M,M,...,M) ! Intermediate elements are produced in lexicographic order. ! ! Examples: ! ! N = 2, M = 3 ! ! K X ! 1 1 1 ! 2 1 2 ! 3 1 3 ! 4 2 1 ! 5 2 2 ! 6 2 3 ! 7 3 1 ! 8 3 2 ! 9 3 3 ! ! Modified: ! ! 30 October 2000 ! ! Parameters: ! ! Input, integer M, the maximum entry. ! ! Input, integer N, the number of components. ! ! Input/output, integer K, counts the elements. ! On first call, set K to 0. Thereafter, K will indicate the ! order of the element returned. When there are no more elements, ! K will be returned as 0. ! ! Input/output, integer X(N), on input the previous tuple. ! On output, the next tuple. ! implicit none ! integer n ! integer i integer k integer m integer x(n) ! if ( m < 1 ) then return end if if ( k <= 0 ) then x(1:n) = 1 k = 1 else k = k + 1 i = n do if ( x(i) < m ) then x(i) = x(i) + 1 exit end if x(i) = 1 if ( i == 1 ) then k = 0 exit end if i = i - 1 end do end if return end subroutine tuple_next_ge ( m, n, k, x ) ! !******************************************************************************* ! !! TUPLE_NEXT_GE computes the next "nondecreasing" element of a tuple space. ! ! ! Discussion: ! ! The elements are N vectors. Each element is constrained to lie ! between 1 and M, and to have components that are nondecreasing. ! That is, for an element X, and any positive K, ! X(I) <= X(I+K) ! ! The elements are produced one at a time. ! The first element is ! (1,1,...,1) ! and the last element is ! (M,M,...,M) ! Intermediate elements are produced in lexicographic order. ! ! Examples: ! ! N = 3, M = 3 ! ! K X ! 1 1 1 1 ! 2 1 1 2 ! 3 1 1 3 ! 4 1 2 2 ! 5 1 2 3 ! 6 1 3 3 ! 7 2 2 2 ! 8 2 2 3 ! 9 2 3 3 ! 10 3 3 3 ! ! Modified: ! ! 14 August 2001 ! ! Parameters: ! ! Input, integer M, the maximum entry. ! ! Input, integer N, the number of components. ! ! Input/output, integer K, counts the elements. ! On first call, set K to 0. Thereafter, K will indicate the ! order of the element returned. When there are no more elements, ! K will be returned as 0. ! ! Input/output, integer X(N), on input the previous tuple. ! On output, the next tuple. ! implicit none ! integer n ! integer i integer k integer m integer x(n) ! if ( m < 1 ) then return end if if ( k <= 0 ) then x(1:n) = 1 k = 1 return end if do i = n, 1, -1 if ( x(i) < m ) then x(i) = x(i) + 1 x(i+1:n) = x(i) k = k + 1 return end if end do k = 0 x(1:n) = 0 return end subroutine tuple_next2 ( n, xmin, xmax, x, rank ) ! !******************************************************************************* ! !! TUPLE_NEXT2 computes the next element of an integer tuple space. ! ! ! Discussion: ! ! The elements X are N vectors. ! ! Each entry X(I) is constrained to lie between XMIN(I) and XMAX(I). ! ! The elements are produced one at a time. ! ! The first element is ! (XMIN(1), XMIN(2), ..., XMIN(N)), ! the second is (probably) ! (XMIN(1), XMIN(2), ..., XMIN(N)+1), ! and the last element is ! (XMAX(1), XMAX(2), ..., XMAX(N)) ! ! Intermediate elements are produced in a lexicographic order, with ! the first index more important than the last, and the ordering of ! values at a fixed index implicitly defined by the sign of ! XMAX(I) - XMIN(I). ! ! Examples: ! ! N = 2, ! XMIN = (/ 1, 10 /) ! XMAX = (/ 3, 8 /) ! ! RANK X ! ---- ----- ! 1 1 10 ! 2 1 9 ! 3 1 8 ! 4 2 10 ! 5 2 9 ! 6 2 8 ! 7 3 10 ! 8 3 9 ! 9 3 8 ! ! Modified: ! ! 21 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, integer XMIN(N), XMAX(N), the "minimum" and "maximum" entry values. ! These values are minimum and maximum only in the sense of the lexicographic ! ordering. In fact, XMIN(I) may be less than, equal to, or greater ! than XMAX(I). ! ! Input/output, integer X(N), on input the previous tuple. ! On output, the next tuple. ! ! Input/output, integer RANK, the rank of the item. On first call, ! set RANK to 0 to start up the sequence. On return, if RANK is zero, ! there are no more items in the sequence. ! implicit none ! integer n ! integer i integer rank integer x(n) integer xmin(n) integer xmax(n) ! if ( rank < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TUPLE_NEXT2 - Fatal error!' write ( *, '(a,i6)' ) ' Illegal value of RANK = ', rank stop end if if ( rank > product ( 1 + abs ( xmax(1:n) - xmin(1:n) ) ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'TUPLE_NEXT2 - Fatal error!' write ( *, '(a,i6)' ) ' Illegal value of RANK = ', rank stop end if if ( rank == 0 ) then x(1:n) = xmin(1:n) rank = 1 return end if rank = rank + 1 i = n do if ( x(i) /= xmax(i) ) then x(i) = x(i) + sign ( 1, xmax(i) - xmin(i) ) exit end if x(i) = xmin(i) if ( i == 1 ) then rank = 0 exit end if i = i - 1 end do return end subroutine vec_next ( n, iarray, more, base ) ! !******************************************************************************* ! !! VEC_NEXT generates all N-vectors of integers modulo a given base. ! ! ! Examples: ! ! N = 2, BASE = 3 ! ! 0 0 ! 0 1 ! 0 2 ! 1 0 ! 1 1 ! 1 2 ! 2 0 ! 2 1 ! 2 2 ! ! Comment: ! ! The vectors are produced in lexical order, starting with ! (0,0,...,0), (0,0,...,1), ... through (BASE-1,BASE-1,...,BASE-1). ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input, integer N, the size of the vectors to be used. ! ! Output, integer IARRAY(N). On each return, IARRAY ! will contain entries in the range 0 to BASE-1. ! ! Input/output, logical MORE. Set this variable .FALSE. before ! the first call. Normally, MORE will be returned .TRUE. but ! once all the vectors have been generated, MORE will be ! reset .FALSE. and you should stop calling the program. ! ! Input, integer BASE, the base to be used. BASE = 2 will ! give vectors of 0's and 1's, for instance. ! implicit none ! integer n ! integer base integer i integer iarray(n) integer, save :: kount = 0 integer, save :: last = 0 logical more integer nn ! if ( .not. more ) then kount = 1 last = base**n more = .true. iarray(1:n) = 0 else kount = kount + 1 if ( kount == last ) then more = .false. end if iarray(n) = iarray(n) + 1 do i = 1, n nn = n - i if ( iarray(nn+1) < base ) then return end if iarray(nn+1) = 0 if ( nn /= 0 ) then iarray(nn) = iarray(nn) + 1 end if end do end if return end subroutine vec_next2 ( done, iactiv, iarray, idir, imax, n ) ! !******************************************************************************* ! !! VEC_NEXT2 computes the elements of a product space. ! ! ! Discussion: ! ! The elements are produced one at a time. ! ! This routine handles the case where the number of degrees of freedom may ! differ from one component to the next. ! ! Examples: ! ! N = 2, IMAX = ( 2, 3 ) ! ! 0 0 ! 0 1 ! 0 2 ! 1 2 ! 1 1 ! 1 0 ! ! Comments: ! ! A method similar to the Gray code is used, so that successive ! elements returned by this routine differ by only a single element. ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 15 April 1999 ! ! Parameters: ! ! Input/output, logical DONE. On the first call, the user must ! set DONE to .TRUE. This signals the program to initialize data. ! On every return, if DONE is .FALSE., the program has computed ! another entry, which is contained in IARRAY. If DONE is .TRUE., ! then there are no more entries, and the program should not be ! called for any more. ! ! Workspace, integer IACTIV(N). ! ! Input/output, integer IARRAY(N). On the first call, the input value ! of IARRAY doesn't matter. Thereafter, it should be the same as ! its output value from the previous call. On output, if DONE ! is .FALSE., then IARRAY contains the next element of the space. ! ! Workspace, integer IDIR(N). ! ! Input, integer IMAX(N), contains the number of degrees of ! freedom of each component. The output values of IARRAY will ! satisfy 0 <= IARRAY(I) < IMAX(I). ! ! Input, integer N, the number of components. ! implicit none ! integer n ! logical done integer i integer iactiv(n) integer iarray(n) integer idir(n) integer imax(n) integer ip integer maxact ! ! The user is calling for the first time. ! if ( done ) then done = .false. do i = 1, n iarray(i) = 0 idir(i) = 1 if ( imax(i) < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'VEC_NEXT2 - Warning!' write ( *, '(a,i6)' ) ' For index I = ',i write ( *, '(a,i6)' ) ' the nonpositive value of IMAX(I) = ', imax(i) write ( *, '(a)' ) ' which was reset to 1!' imax(i) = 1 iactiv(i) = 0 else if ( imax(i) == 1 ) then iactiv(i) = 0 else iactiv(i) = 1 end if end do ! ! The user is asking for the next vector. ! else ! ! Find the maximum active index. ! maxact = 0 do i = 1, n if ( iactiv(i) /= 0 ) then maxact = i end if end do if ( maxact /= 0 ) then done = .false. ip = maxact iarray(ip) = iarray(ip) + idir(ip) if ( iarray(ip) == imax(ip)-1 .or. iarray(ip) == 0 ) then idir(ip) = - idir(ip) iactiv(ip) = 0 end if do i = ip+1, n if ( imax(i) > 1 ) then iactiv(i) = i end if end do else done = .true. end if end if return end subroutine vec_random ( n, iarray, base ) ! !***************************************************************************** ! !! VEC_RANDOM selects a random N-vector of integers modulo a given base. ! ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the vector to be generated. ! ! Output, integer IARRAY(N), a list of N random values between ! 0 and BASE-1. ! ! Input, integer BASE, the base to be used. ! implicit none ! integer n ! integer base integer i integer iarray(n) integer ival ! do i = 1, n call i_random ( 0, base-1, ival ) iarray(i) = ival end do return end subroutine vec_rank ( iarray, imax, n, rank ) ! !******************************************************************************* ! !! VEC_RANK computes the rank of a product space element. ! ! ! Discussion: ! ! The rank applies only to the elements as produced by the routine ! VEC_NEXT2. ! ! Examples: ! ! N = 2, IMAX = ( 2, 3 ), IARRAY = ( 1, 2 ), ! ! RANK = 4. ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 27 July 1998 ! ! Parameters: ! ! Input, integer IARRAY(N), the product space element, with the ! property that 0 <= IARRAY(I) < IMAX(I) for each entry I. ! ! Input, integer IMAX(N), contains the number of degrees of ! freedom of each component. The output values of IARRAY will ! satisfy 0 <= IARRAY(I) < IMAX(I). ! ! Input, integer N, the number of components. ! ! Output, integer RANK, the rank, or order, of the element in ! the list of all elements. The rank count begins at 1. ! implicit none ! integer n ! integer c integer i integer iarray(n) integer imax(n) integer rank ! rank = 0 do i = 1, n if ( mod ( rank, 2 ) == 1 ) then c = imax(i) - iarray(i) - 1 else c = iarray(i) end if rank = imax(i) * rank + c end do rank = rank + 1 return end subroutine vec_unrank ( iarray, imax, n, rank ) ! !******************************************************************************* ! !! VEC_UNRANK computes the product space element of a given rank. ! ! ! Discussion: ! ! The rank applies only to the elements as produced by the routine ! VEC_NEXT2. ! ! Examples: ! ! N = 2, IMAX = ( 2, 3 ), RANK = 4. ! ! IARRAY = ( 1, 2 ). ! ! Reference: ! ! Dennis Stanton and Dennis White, ! Constructive Combinatorics, ! Springer Verlag, New York, 1986. ! ! Modified: ! ! 27 July 1998 ! ! Parameters: ! ! Output, integer IARRAY(N), the product space element of the given rank. ! ! Input, integer IMAX(N), contains the number of degrees of ! freedom of each component. The output values of IARRAY will ! satisfy 0 <= IARRAY(I) < IMAX(I). ! ! Input, integer N, the number of components. ! ! Input, integer RANK, the desired rank, or order, of the element in ! the list of all elements. The rank count begins at 1 and extends ! to MAXRANK = Product ( I = 1 to N ) IMAX(I). ! implicit none ! integer n ! integer i integer iarray(n) integer imax(n) integer rank integer s ! s = rank - 1 do i = n, 1, -1 iarray(i) = mod ( s, imax(i) ) s = s / imax(i) if ( mod ( s, 2 ) == 1 ) then iarray(i) = imax(i) - iarray(i) - 1 end if end do return end subroutine ytb_enum ( n, ytb_num ) ! !******************************************************************************* ! !! YTB_ENUM enumerates the Young tableau of size N. ! ! ! Discussion: ! ! If A(N) is the number of Young tableau of size N, then A(1) = 1, ! A(2) = 2, and ! ! A(N) = A(N-1) + (N-1) * A(N-2). ! ! Modified: ! ! 05 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer which is to be partitioned. ! ! Output, integer YTB_NUM, the number of Young tableau of N. ! implicit none ! integer a1 integer a2 integer a3 integer i integer n integer ytb_num ! if ( n <= 0 ) then ytb_num = 0 else if ( n == 1 ) then ytb_num = 1 else if ( n == 2 ) then ytb_num = 2 else a2 = 1 a3 = 2 do i = 3, n a1 = a2 a2 = a3 a3 = a2 + ( i - 1 ) * a1 end do ytb_num = a3 end if return end subroutine ytb_next ( n, lambda, iarray, more ) ! !******************************************************************************* ! !! YTB_NEXT computes the next Young tableau for a given shape. ! ! ! Discussion: ! ! When the routine is called with MORE = .FALSE. (the first time), and ! if LAMBDA on this call has M parts, with M n ) then exit end if if ( lambda(ir) /= 0 ) then iarray(l) = ir lambda(ir) = lambda(ir) - 1 l = l + 1 ir = ir + 1 cycle end if if ( l > it ) then exit end if ir = 1 end do if ( n == 1 ) then more = .false. return end if do j = 2, n if ( iarray(j) < iarray(j-1) ) then more = .true. return end if end do more = .false. return end subroutine ytb_print ( n, iarray ) ! !******************************************************************************* ! !! YTB_PRINT prints a Young tableau. ! ! ! Modified: ! ! 24 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer that is partitioned. ! ! Input, integer IARRAY(N), describes the Young tableau. ! IARRAY(I) is the row of the tableau on which I occurs. ! implicit none ! integer n ! integer iarray(n) integer j integer jarray(n) integer row_i integer row_length ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Young tableau:' write ( *, '(a)' ) ' ' row_i = 0 do row_i = row_i + 1 row_length = 0 do j = 1, n if ( iarray(j) == row_i ) then row_length = row_length + 1 jarray(row_length) = j end if end do if ( row_length <= 0 ) then exit end if write ( *, '(20i4)' ) jarray(1:row_length) end do return end subroutine ytb_random ( n, lambda, iarray ) ! !******************************************************************************* ! !! YTB_RANDOM selects a random Young tableau of a given shape. ! ! ! Reference: ! ! A Nijenhuis and H Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Modified: ! ! 01 December 2000 ! ! Parameters: ! ! Input, integer N, the integer which has been partitioned. ! ! Input, integer LAMBDA(N). N = LAMBDA(1)+LAMBDA(2)+...is the ! partition of N. ! ! Output, integer IARRAY(N). The vector describing the Young tableau. ! implicit none ! integer n real r ! integer i integer iarray(n) integer ih integer j integer l integer lambda(n) integer m ! iarray(1:n) = 0 i = 0 l = 0 do i = i + 1 do j = 1, lambda(i) iarray(j) = iarray(j) + 1 l = l + 1 end do if ( l >= n ) then exit end if end do do m = 1, n do call i_random ( 1, iarray(1), i ) call i_random ( 1, lambda(1), j ) if ( i <= iarray(j) .and. j <= lambda(i) ) then exit end if end do do ih = iarray(j) + lambda(i) - i - j if ( ih == 0 ) then exit end if call i_random ( 1, ih, l ) if ( l <= lambda(i)-j ) then j = j + l else i = l - lambda(i) + i + j end if end do lambda(i) = lambda(i) - 1 iarray(j) = iarray(j) - 1 iarray(n+1-m) = i end do do i = 1, n lambda(iarray(i)) = lambda(iarray(i)) + 1 end do return end