subroutine asm_enum ( n, asm_num ) !*****************************************************************************80 ! !! 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 )! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n+1) integer asm_num integer b(n+1) integer c(n+1) integer i integer nn asm_num = 0 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 ) !*****************************************************************************80 ! !! 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 ! ! 0 1 ! 1 1 1 ! 2 2 3 2 ! 3 7 14 14 7 ! 4 42 105 135 105 42 ! 5 429 1287 2002 2002 1287 429 ! 6 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 January 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the desired row. ! ! Output, integer A(N+1), the entries of the row. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n+1) integer b(n+1) integer c(n+1) integer i integer nn if ( n+1 <= 0 ) then return end if ! ! Row 1 ! a(1) = 1 if ( n + 1 == 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 + 1 == 2 ) then return end if ! ! Row 3 and on. ! do nn = 3, n + 1 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 ( n, b ) !*****************************************************************************80 ! !! bell() returns the Bell numbers from 0 to N. ! ! Discussion: ! ! 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. ! ! 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. ! ! Example: ! ! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of Bell numbers desired. ! ! Output, integer B(0:N), the Bell numbers from 0 to N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer b(0:n) integer combo integer i integer i4_choose integer j b(0) = 1 do i = 1, n b(i) = 0 do j = 1, i combo = i4_choose ( i-1, j-1 ) b(i) = b(i) + combo * b(i-j) end do end do return end subroutine bell_values ( n_data, n, c ) !*****************************************************************************80 ! !! bell_values() returns some values of the Bell numbers for testing. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Parameters: ! ! Input/output, integer N_DATA. ! On input, if N_DATA is 0, the first test data is returned, and N_DATA ! is set to 1. On each subsequent call, the input value of N_DATA is ! incremented and that test data item is returned, if available. When ! there is no more test data, N_DATA is set to 0. ! ! Output, integer N, the order of the Bell number. ! ! Output, integer C, the value of the Bell number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: nmax = 11 integer c integer, save, dimension ( nmax ) :: c_vec = (/ & 1, 1, 2, 5, 15, 52, 203, 877, 4140, 21147, 115975 /) integer n integer n_data integer, save, dimension ( nmax ) :: n_vec = (/ & 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( nmax < n_data ) then n_data = 0 n = 0 c = 0 else n = n_vec(n_data) c = c_vec(n_data) end if return end subroutine catalan ( n, c ) !*****************************************************************************80 ! !! catalan() computes the Catalan numbers, from C(0) to C(N). ! ! Discussion: ! ! 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 tables 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. ! ! When N = 3, here are the 5 well formed parentheses sets: ! ! ()()() ! ()(()) ! (()()) ! (())() ! ((())) ! ! Example: ! ! 0 1 ! 1 1 ! 2 2 ! 3 5 ! 4 14 ! 5 42 ! 6 132 ! 7 429 ! 8 1430 ! 9 4862 ! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 August 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer c(0:n) integer i if ( n < 0 ) then return end if 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 catalan_row_next ( ido, n, irow ) !*****************************************************************************80 ! !! catalan_row_next() computes row N of Catalan's triangle. ! ! Example: ! ! I\J 0 1 2 3 4 5 6 ! ! 0 1 ! 1 1 1 ! 2 1 2 2 ! 3 1 3 5 5 ! 4 1 4 9 14 14 ! 5 1 5 14 28 42 42 ! 6 1 6 20 48 90 132 132 ! ! Recursion: ! ! C(0,0) = 1 ! C(I,0) = 1 ! C(I,J) = 0 for I < J ! C(I,J) = C(I,J-1) + C(I-1,J) ! C(I,I) is the I-th Catalan number. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 December 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer IDO, indicates whether this is a call for ! the 'next' row of the triangle. ! IDO = 0, this is a startup call. Row N is desired, but ! presumably this is a first call, or row N-1 was not computed ! on the previous call. ! IDO = 1, this is not the first call, and row N-1 was computed ! on the previous call. In this case, much work can be avoided ! by using the information from the previous values of IROW ! to build the next values. ! ! Input, integer N, the index of the row of the triangle ! desired. ! ! Input/output, integer IROW(0:N), the row of coefficients. ! If IDO = 0, then IROW is not required to be set on input. ! If IDO = 1, then IROW must be set on input to the value of ! row N-1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ido integer irow(0:n) integer j if ( n < 0 ) then return end if if ( ido == 0 ) then irow(0) = 1 irow(1:n) = 0 do i = 1, n irow(0) = 1 do j = 1, i - 1 irow(j) = irow(j) + irow(j-1) end do irow(i) = irow(i-1) end do else irow(0) = 1 do j = 1, n - 1 irow(j) = irow(j) + irow(j-1) end do if ( 1 <= n ) then irow(n) = irow(n-1) end if end if return end subroutine catalan_values ( n_data, n, c ) !*****************************************************************************80 ! !! catalan_values() returns some values of the Catalan numbers for testing. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Parameters: ! ! Input/output, integer N_DATA. ! On input, if N_DATA is 0, the first test data is returned, and N_DATA ! is set to 1. On each subsequent call, the input value of N_DATA is ! incremented and that test data item is returned, if available. When ! there is no more test data, N_DATA is set to 0. ! ! Output, integer N, the order of the Catalan number. ! ! Output, integer C, the value of the Catalan number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: nmax = 11 integer c integer, save, dimension ( nmax ) :: c_vec = (/ & 1, 1, 2, 5, 14, 42, 132, 429, 1430, 4862, 16796 /) integer n integer n_data integer, save, dimension ( nmax ) :: n_vec = (/ & 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( nmax < n_data ) then n_data = 0 n = 0 c = 0 else n = n_vec(n_data) c = c_vec(n_data) end if return end subroutine cfrac_to_rat ( n, a, p, q ) !*****************************************************************************80 ! !! 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). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, Charles Mesztenyi, ! John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Parameters: ! ! Input, integer N, the number of continued fraction ! coefficients. ! ! Input, integer A(N), the continued fraction coefficients. ! ! Output, integer P(N), Q(N), the N successive approximations ! to the value of the continued fraction. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ( m, g, h, p, q ) !*****************************************************************************80 ! !! cfrac_to_rfrac() converts polynomial fractions 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2004 ! ! Author: ! ! Original FORTRAN77 version by John Hart, Ward Cheney, Charles Lawson, ! Hans Maehly, Charles Mesztenyi, John Rice, Henry Thatcher, ! Christoph Witzgall. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, Charles Mesztenyi, ! John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Parameters: ! ! Input, integer M, the number of continued fraction ! polynomial coefficients. ! ! Input, real ( kind = rk ) G(M), H(M), the continued polynomial ! fraction coefficients. ! ! Output, real ( kind = rk ) P((M+1)/2), Q((M+2)/2), the rational ! polynomial fraction coefficients. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m real ( kind = rk ) a(m,(m+2)/2) real ( kind = rk ) g(m) real ( kind = rk ) h(m) integer i integer j real ( kind = rk ) p((m+1)/2) real ( kind = rk ) 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.0D+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 j = 1, ( m + 1 ) / 2 p(j) = a(m,j) end do ! ! Solve for Q's. ! 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 j = 1, ( m + 2 ) / 2 q(j) = a(m,j) end do return end subroutine change_greedy ( total, coin_num, coin_value, change_num, change ) !*****************************************************************************80 ! !! change_greedy() makes change for a given total using the biggest coins first. ! ! Discussion: ! ! The algorithm is simply to use as many of the largest coin first, ! then the next largest, and so on. ! ! It is assumed that there is always a coin of value 1. The ! algorithm will otherwise fail! ! ! Example: ! ! Total = 17 ! COIN_NUM = 3 ! COIN_VALUE = (/ 1, 5, 10 /) ! ! ! # CHANGE COIN_VALUE(CHANGE) ! ! 4 3 2 1 1 10 5 1 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 November 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer TOTAL, the total for which change is to be ! made. ! ! Input, integer COIN_NUM, the number of types of coins. ! ! Input, integer COIN_VALUE(COIN_NUM), the value of each coin. ! The values should be in ascending order, and if they are not, ! they will be sorted. ! ! Output, integer CHANGE_NUM, the number of coins given in ! change. ! ! Output, integer CHANGE(TOTAL), the indices of the coins ! will be in entries 1 through CHANGE_NUM. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer coin_num integer total integer change(total) integer change_num integer coin_value(coin_num) integer j integer total_copy change_num = 0 ! ! Find the largest coin smaller than the total. ! j = coin_num do while ( 0 < j ) if ( coin_value(j) <= total ) then exit end if j = j - 1 end do if ( j <= 0 ) then return end if ! ! Subtract the current coin from the total. ! Once that coin is too big, use the next coin. ! total_copy = total do while ( 0 < total_copy ) if ( coin_value(j) <= total_copy ) then total_copy = total_copy - coin_value(j) change_num = change_num + 1 change(change_num) = j else j = j - 1 if ( j <= 0 ) then exit end if end if end do return end subroutine change_next ( total, coin_num, coin_value, change_num, change, & done ) !*****************************************************************************80 ! !! change_next() computes the next set of change for a given sum. ! ! Example: ! ! Total = 17 ! COIN_NUM = 3 ! COIN_VALUE = (/ 1, 5, 10 /) ! ! ! # CHANGE COIN_VALUE(CHANGE) ! ! 1 4 3 2 1 1 10 5 1 1 ! 2 8 3 1 1 1 1 1 1 1 10 1 1 1 1 1 1 1 ! 3 5 2 2 2 1 1 5 5 5 1 1 ! 4 9 2 2 1 1 1 1 1 1 1 5 5 1 1 1 1 1 1 1 ! 5 13 2 1 1 1 1 1 1 1 1 1 5 1 1 1 1 1 1 1 1 1 ! 1 1 1 1 1 1 ! 6 17 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 ! 1 1 1 1 1 1 1 1 1 1 1 1 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 June 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer TOTAL, the total for which change is to be ! made. ! ! Input, integer COIN_NUM, the number of types of coins. ! ! Input, integer COIN_VALUE(COIN_NUM), the value of each coin. ! The values must be in ascending order. ! ! Input/output, integer CHANGE_NUM, the number of coins given ! in change for this form of the change. ! ! Input/output, integer CHANGE(CHANGE_NUM), the indices of the ! coins. The user must dimension this array to have dimension TOTAL! ! ! Input/output, logical DONE. The user sets DONE = TRUE on ! first call to tell the routine this is the beginning of a computation. ! The program resets DONE to FALSE and it stays that way until ! the last possible change combination is made, at which point the ! program sets DONE to TRUE again. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer coin_num integer total integer change(total) integer change_num integer change_num2 integer coin_num2 integer coin_value(coin_num) logical done integer i logical i4vec_ascends integer last integer total2 if ( done ) then ! ! Make sure the coin values are sorted. ! if ( .not. i4vec_ascends ( coin_num, coin_value ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'CHANGE_NEXT - Fatal error!' write ( *, '(a)' ) ' The COIN_VALUE array is not in ascending order.' stop 1 end if ! ! Start with the greedy change. ! call change_greedy ( total, coin_num, coin_value, change_num, change ) ! ! In a few cases, like change for 4 cents, we're done after the first call. ! if ( change_num == total ) then done = .true. else done = .false. end if else ! ! Find the last location in the input change which is NOT a penny. ! last = 0 do i = change_num, 1, -1 if ( change(i) /= 1 ) then last = i exit end if end do ! ! If that location is still 0, an error was made. ! if ( last == 0 ) then done = .true. return end if ! ! Sum the entries from that point to the end. ! total2 = sum ( coin_value ( change(last:change_num) ) ) ! ! Make greedy change for the partial sum using coins smaller than that one. ! coin_num2 = change(last) - 1 call change_greedy ( total2, coin_num2, coin_value, change_num2, & change(last:total) ) change_num = ( last - 1 ) + change_num2 end if return end subroutine chinese_check ( n, m, ierror ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ierror logical i4vec_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. i4vec_pairwise_prime ( n, m ) ) then ierror = 3 return end if return end subroutine chinese_to_i4 ( n, m, r, j ) !*****************************************************************************80 ! !! chinese_to_i4() 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 R(I), this routine finds an ! integer J such that, for all I, ! ! J = R(I) mod M(I) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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_I4 - Fatal error!' write ( *, '(a)' ) ' The moduluses are not legal.' stop 1 end if ! ! Set BIG_M. ! big_m = product ( m(1:n) ) ! ! 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_next ( n, k, a, done ) !*****************************************************************************80 ! !! comb_next() computes combinations of K things out of N. ! ! Discussion: ! ! The combinations are computed one at a time, in lexicographical order. ! ! 10 April 1009: Thanks to "edA-qa mort-ora-y" for supplying a ! correction to this code! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 April 2009 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Charles Mifsud, ! Algorithm 154: ! Combination in Lexicographic Order, ! Communications of the ACM, ! March 1963. ! ! Parameters: ! ! Input, integer N, the total number of things. ! ! Input, integer K, the number of things in each combination. ! ! Input/output, integer A(K), contains the list of elements in ! the current combination. ! ! Input/output, logical DONE. On first call, set DONE to TRUE, ! and thereafter, its input value should be the output value from ! the previous call. The output value will normally be FALSE, ! indicating that there are further combinations that can be ! returned. When DONE is returned TRUE, the sequence is exhausted. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) logical done integer i integer j integer n if ( done ) then if ( k <= 0 ) then return end if call i4vec_indicator1 ( k, a ) done = .false. else if ( a(k) < n ) then a(k) = a(k) + 1 return end if do i = k, 2, -1 if ( a(i-1) < n-k+i-1 ) then a(i-1) = a(i-1) + 1 do j = i, k a(j) = a(i-1) + j - ( i-1 ) end do return end if end do done = .true. end if return end subroutine comb_row_next ( n, row ) !*****************************************************************************80 ! !! comb_row_next() computes the next row of Pascal's triangle. ! ! Discussion: ! ! Row N contains the combinatorial coefficients ! ! C(N,0), C(N,1), C(N,2), ... C(N,N) ! ! The sum of the elements of row N is equal to 2^N. ! ! The formula is ! ! C(N,K) = N! / ( K! * (N-K)! ) ! ! First terms: ! ! N K:0 1 2 3 4 5 6 7 8 9 10 ! ! 0 1 ! 1 1 1 ! 2 1 2 1 ! 3 1 3 3 1 ! 4 1 4 6 4 1 ! 5 1 5 10 10 5 1 ! 6 1 6 15 20 15 6 1 ! 7 1 7 21 35 35 21 7 1 ! 8 1 8 28 56 70 56 28 8 1 ! 9 1 9 36 84 126 126 84 36 9 1 ! 10 1 10 45 120 210 252 210 120 45 10 1 ! ! Recursion: ! ! C(N,K) = C(N-1,K-1)+C(N-1,K) ! ! Special values: ! ! C(N,0) = C(N,N) = 1 ! C(N,1) = C(N,N-1) = N ! C(N,N-2) = sum ( 1 <= I <= N ) N ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 December 2014 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, indicates the desired row. ! ! Input/output, integer ROW(0:N). On input, row N-1 is ! contained in entries 0 through N-1. On output, row N is contained ! in entries 0 through N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer row(0:n) if ( n < 0 ) then return end if row(n) = 1 do i = n - 1, 1, -1 row(i) = row(i) + row(i-1) end do row(0) = 1 return end subroutine comb_unrank ( m, n, rank, a ) !*****************************************************************************80 ! !! comb_unrank() returns the RANK-th combination of N things out of M. ! ! Discussion: ! ! Going from a rank to a thing is called "unranking". ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 December 2008 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Bill Buckles, Matthew 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. ! ! David Crouse, ! Remark on Algorithm 515, ! ACM Transactions on Mathematical Software, ! Volume 33, Number 2, Article 15, June 2007. ! ! 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 RANK, the lexicographical rank of the ! combination sought. RANK must be at least 1, and no greater ! than M!/(N!*(M-N)!). ! ! Output, integer A(N), the combination. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_choose integer j integer k integer m integer rank if ( n < 0 ) then return else if ( n == 0 ) then a(1) = rank return end if ! ! Initialize the lower bound index. ! k = 0 ! ! Select elements in ascending order. ! do i = 1, n - 1 ! ! Set the lower bound element number for next element value. ! a(i) = 0 if ( 1 < i ) then a(i) = a(i-1) end if ! ! Check each element value. ! do a(i) = a(i) + 1 j = i4_choose ( m-a(i), n-i ) k = k + j if ( rank <= k ) then exit end if end do k = k - j end do a(n) = a(n-1) + rank - k return end subroutine comp_enum ( n, k, number ) !*****************************************************************************80 ! !! comp_enum() returns the number of compositions of the integer N into K parts. ! ! Discussion: ! ! A composition of the integer N into K parts is an ordered sequence ! of K nonnegative integers which sum to N. The compositions (1,2,1) ! and (1,1,2) are considered to be distinct. ! ! 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. ! ! The formula for the number of compositions of N into K parts is ! ! Number = ( N + K - 1 )! / ( N! * ( K - 1 )! ) ! ! Describe the composition using N '1's and K-1 dividing lines '|'. ! The number of distinct permutations of these symbols is the number ! of compositions. This is equal to the number of permutations of ! N+K-1 things, with N identical of one kind and K-1 identical of another. ! ! Thus, for the above example, we have: ! ! Number = ( 6 + 3 - 1 )! / ( 6! * (3-1)! ) = 28 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer whose compositions are desired. ! ! Input, integer K, the number of parts in the composition. ! ! Output, integer NUMBER, the number of compositions of N ! into K parts. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i4_choose integer k integer n integer number number = i4_choose ( n + k - 1, n ) return end subroutine comp_next ( n, k, a, more, h, t ) !*****************************************************************************80 ! !! comp_next() computes the compositions of the integer N into K parts. ! ! Discussion: ! ! A composition of the integer N into K parts is an ordered sequence ! of K nonnegative integers which sum to N. The compositions (1,2,1) ! and (1,1,2) are considered to be distinct. ! ! 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. ! ! On the first call to this routine, set MORE = FALSE. The routine ! will compute the first element in the sequence of compositions, and ! return it, as well as setting MORE = TRUE. If more compositions ! are desired, call again, and again. Each time, the routine will ! return with a new composition. ! ! However, when the LAST composition in the sequence is computed ! and returned, the routine will reset MORE to FALSE, signaling that ! the end of the sequence has been reached. ! ! There are 28 compositions of 6 into three parts. This routine will ! produce those compositions in the following order: ! ! I A ! - --------- ! 1 6 0 0 ! 2 5 1 0 ! 3 4 2 0 ! 4 3 3 0 ! 5 2 4 0 ! 6 1 5 0 ! 7 0 6 0 ! 8 5 0 1 ! 9 4 1 1 ! 10 3 2 1 ! 11 2 3 1 ! 12 1 4 1 ! 13 0 5 1 ! 14 4 0 2 ! 15 3 1 2 ! 16 2 2 2 ! 17 1 3 2 ! 18 0 4 2 ! 19 3 0 3 ! 20 2 1 3 ! 21 1 2 3 ! 22 0 3 3 ! 23 2 0 4 ! 24 1 1 4 ! 25 0 2 4 ! 26 1 0 5 ! 27 0 1 5 ! 28 0 0 6 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 July 2008 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer whose compositions are desired. ! ! Input, integer K, the number of parts in the composition. ! ! Input/output, integer A(K), the parts of the composition. ! ! Input/output, logical MORE, set by the user to start the computation, ! and by the routine to terminate it. ! ! Input/output, integer H, T, two internal parameters needed ! for the computation. The user should allocate space for these in the ! calling program, include them in the calling sequence, but never alter ! them! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer h logical more integer n integer t ! ! The first computation. ! if ( .not. more ) then t = n h = 0 a(1) = n a(2:k) = 0 ! ! The next computation. ! else ! ! If the first entry A(1) is positive, then set H to zero, ! so that when we increment H, it points to A(1); we will decrement A(1) by 1 ! and increment A(2). ! if ( 1 < t ) then h = 0 end if ! ! Otherwise, A(1) is 0. Then by H + 1 is the entry we incremented last time. ! Set H = H + 1, zero A(H), adding all but one of its value to A(1), ! and incrementing A(H+1) by 1. ! h = h + 1 t = a(h) a(h) = 0 a(1) = t - 1 a(h+1) = a(h+1) + 1 end if ! ! This is the last element of the sequence if all the ! items are in the last slot. ! more = ( a(k) /= n ) return end subroutine comp_next_grlex ( kc, xc ) !*****************************************************************************80 ! !! comp_next_grlex() returns the next composition in grlex order. ! ! Discussion: ! ! Example: ! ! KC = 3 ! ! # XC(1 XC(2) XC(3) Degree ! +------------------------ ! 1 | 0 0 0 0 ! | ! 2 | 0 0 1 1 ! 3 | 0 1 0 1 ! 4 | 1 0 0 1 ! | ! 5 | 0 0 2 2 ! 6 | 0 1 1 2 ! 7 | 0 2 0 2 ! 8 | 1 0 1 2 ! 9 | 1 1 0 2 ! 10 | 2 0 0 2 ! | ! 11 | 0 0 3 3 ! 12 | 0 1 2 3 ! 13 | 0 2 1 3 ! 14 | 0 3 0 3 ! 15 | 1 0 2 3 ! 16 | 1 1 1 3 ! 17 | 1 2 0 3 ! 18 | 2 0 1 3 ! 19 | 2 1 0 3 ! 20 | 3 0 0 3 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 December 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer KC, the number of parts of the composition. ! 1 <= KC. ! ! Input/output, integer XC(KC), the current composition. ! Each entry of XC must be nonnegative. ! On return, XC has been replaced by the next composition in the ! grlex order. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer i integer im1 integer j integer t integer xc(kc) ! ! Ensure that 1 <= KC. ! if ( kc < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_NEXT_GRLEX - Fatal error!' write ( *, '(a)' ) ' KC < 1' stop 1 end if ! ! Ensure that 0 <= XC(I). ! do i = 1, kc if ( xc(i) < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_NEXT_GRLEX - Fatal error!' write ( *, '(a)' ) ' XC(I) < 0' stop 1 end if end do ! ! Find I, the index of the rightmost nonzero entry of X. ! i = 0 do j = kc, 1, -1 if ( 0 < xc(j) ) then i = j exit end if end do ! ! set T = X(I) ! set XC(I) to zero, ! increase XC(I-1) by 1, ! increment XC(KC) by T-1. ! if ( i == 0 ) then xc(kc) = 1 return else if ( i == 1 ) then t = xc(1) + 1 im1 = kc else if ( 1 < i ) then t = xc(i) im1 = i - 1 end if xc(i) = 0 xc(im1) = xc(im1) + 1 xc(kc) = xc(kc) + t - 1 return end subroutine comp_random ( n, k, a ) !*****************************************************************************80 ! !! comp_random() selects a random composition of the integer N into K parts. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 April 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Input: ! ! integer N, the integer to be decomposed. ! ! integer K, the number of parts in the composition. ! ! Output: ! ! integer A(K), the parts of the composition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer b(k-1) integer i integer l integer m integer n call ksub_random2 ( n + k - 1, k - 1, b ) a(1:k-1) = b(1:k-1) a(k) = n + k l = 0 do i = 1, k m = a(i) a(i) = a(i) - l - 1 l = m end do return end subroutine comp_random_grlex ( kc, rank1, rank2, xc, rank ) !*****************************************************************************80 ! !! comp_random_grlex(): random composition with degree less than or equal to NC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 September 2014 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer KC, the number of parts in the composition. ! ! Input, integer RANK1, RANK2, the minimum and maximum ranks, ! 1 <= RANK1 <= RANK2. ! ! Output, integer XC(KC), the random composition. ! ! Output, integer RANK, the rank of the composition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer i4_uniform_ab integer rank integer rank1 integer rank2 integer xc(kc) ! ! Ensure that 1 <= KC. ! if ( kc < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_RANDOM_GRLEX - Fatal error!' write ( *, '(a)' ) ' KC < 1' stop 1 end if ! ! Ensure that 1 <= RANK1. ! if ( rank1 < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_RANDOM_GRLEX - Fatal error!' write ( *, '(a)' ) ' RANK1 < 1' stop 1 end if ! ! Ensure that RANK1 <= RANK2. ! if ( rank2 < rank1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_RANDOM_GRLEX - Fatal error!' write ( *, '(a)' ) ' RANK2 < RANK1' stop 1 end if ! ! Select the rank. ! rank = i4_uniform_ab ( rank1, rank2 ) ! ! Recover the composition. ! call comp_unrank_grlex ( kc, rank, xc ) return end subroutine comp_rank_grlex ( kc, xc, rank ) !*****************************************************************************80 ! !! comp_rank_grlex() computes the graded lexicographic rank of a composition. ! ! Discussion: ! ! The graded lexicographic ordering is used, over all KC-compositions ! for NC = 0, 1, 2, ... ! ! For example, if KC = 3, the ranking begins: ! ! Rank Sum 1 2 3 ! ---- --- -- -- -- ! 1 0 0 0 0 ! ! 2 1 0 0 1 ! 3 1 0 1 0 ! 4 1 1 0 1 ! ! 5 2 0 0 2 ! 6 2 0 1 1 ! 7 2 0 2 0 ! 8 2 1 0 1 ! 9 2 1 1 0 ! 10 2 2 0 0 ! ! 11 3 0 0 3 ! 12 3 0 1 2 ! 13 3 0 2 1 ! 14 3 0 3 0 ! 15 3 1 0 2 ! 16 3 1 1 1 ! 17 3 1 2 0 ! 18 3 2 0 1 ! 19 3 2 1 0 ! 20 3 3 0 0 ! ! 21 4 0 0 4 ! .. .. .. .. .. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 December 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer KC, the number of parts in the composition. ! 1 <= KC. ! ! Input, integer XC(KC), the composition. ! For each 1 <= I <= KC, we have 0 <= XC(I). ! ! Output, integer RANK, the rank of the composition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer i integer i4_choose integer i4vec_sum integer j integer ks integer n integer nc integer ns integer rank integer tim1 integer xc(kc) integer xs(kc-1) ! ! Ensure that 1 <= KC. ! if ( kc < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_RANK_GRLEX - Fatal error!' write ( *, '(a)' ) ' KC < 1' stop 1 end if ! ! Ensure that 0 <= XC(I). ! do i = 1, kc if ( xc(i) < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_RANK_GRLEX - Fatal error!' write ( *, '(a)' ) ' XC(I) < 0' stop 1 end if end do ! ! NC = sum ( XC ) ! nc = i4vec_sum ( kc, xc ) ! ! Convert to KSUBSET format. ! ns = nc + kc - 1 ks = kc - 1 xs(1) = xc(1) + 1 do i = 2, kc - 1 xs(i) = xs(i-1) + xc(i) + 1 end do ! ! Compute the rank. ! rank = 1 do i = 1, ks if ( i == 1 ) then tim1 = 0 else tim1 = xs(i-1) end if if ( tim1 + 1 <= xs(i) - 1 ) then do j = tim1 + 1, xs(i) - 1 rank = rank + i4_choose ( ns - j, ks - i ) end do end if end do do n = 0, nc - 1 rank = rank + i4_choose ( n + kc - 1, n ) end do return end subroutine comp_to_ksub ( nc, kc, ac, ns, ks, as ) !*****************************************************************************80 ! !! comp_to_ksub() converts a composition to a K-subset. ! ! Discussion: ! ! There is a bijection between K subsets and compositions. ! ! Because we allow a composition to have entries that are 0, we need ! to implicitly add 1 to each entry before establishing the bijection. ! ! Let AC be a composition of NC into KC parts. ! ! Then let ! NS = NC + KC - 1 ! KS = KC - 1 ! and define ! AS(I) = sum ( AC(1:I) + 1 ), for I = 1 : KS. ! ! Then AS is a KS subset of the integers 1 through NS. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 December 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NC, the composition sum. ! ! Input, integer KC, the number of parts of the composition. ! ! Input, integer AC(KC), the parts of the composition. ! ! Output, integer NS, the size of the set. ! ! Output, integer KS, the size of the subset. ! ! Output, integer AS(KS), the entries of the K-subset, ! in increasing order. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer ks integer ac(kc) integer as(ks) integer i integer nc integer ns ns = nc + kc - 1 ks = kc - 1 as(1) = ac(1) + 1 do i = 2, kc - 1 as(i) = as(i-1) + ac(i) + 1 end do return end subroutine comp_unrank_grlex ( kc, rank, xc ) !*****************************************************************************80 ! !! comp_unrank_grlex() computes the composition of given grlex rank. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 December 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer KC, the number of parts of the composition. ! 1 <= KC. ! ! Input, integer RANK, the rank of the composition. ! 1 <= RANK. ! ! Output, integer XC(KC), the composition of the given rank. ! For each I, 0 <= XC(I) <= NC, and ! sum ( 1 <= I <= KC ) XC(I) = NC. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer i integer i4_choose integer j integer ks integer nc integer nksub integer ns integer r integer rank integer rank1 integer rank2 integer xc(kc) integer xs(kc-1) ! ! Ensure that 1 <= KC. ! if ( kc < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_UNRANK_GRLEX - Fatal error!' write ( *, '(a)' ) ' KC < 1' stop 1 end if ! ! Ensure that 1 <= RANK. ! if ( rank < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'COMP_UNRANK_GRLEX - Fatal error!' write ( *, '(a)' ) ' RANK < 1' stop 1 end if ! ! Determine the appropriate value of NC. ! Do this by adding up the number of compositions of sum 0, 1, 2, ! ..., without exceeding RANK. Moreover, RANK - this sum essentially ! gives you the rank of the composition within the set of compositions ! of sum NC. And that's the number you need in order to do the ! unranking. ! rank1 = 1 nc = -1 do nc = nc + 1 r = i4_choose ( nc + kc - 1, nc ) if ( rank < rank1 + r ) then exit end if rank1 = rank1 + r end do rank2 = rank - rank1 ! ! Convert to KSUBSET format. ! Apology: an unranking algorithm was available for KSUBSETS, ! but not immediately for compositions. One day we will come back ! and simplify all this. ! ks = kc - 1 ns = nc + kc - 1 nksub = i4_choose ( ns, ks ) j = 1 do i = 1, ks r = i4_choose ( ns - j, ks - i ) do while ( r <= rank2 .and. 0 < r ) rank2 = rank2 - r j = j + 1 r = i4_choose ( ns - j, ks - i ) end do xs(i) = j j = j + 1 end do ! ! Convert from KSUBSET format to COMP format. ! xc(1) = xs(1) - 1 do i = 2, kc - 1 xc(i) = xs(i) - xs(i-1) - 1 end do xc(kc) = ns - xs(ks) return end subroutine compnz_enum ( n, k, number ) !*****************************************************************************80 ! !! compnz_enum() returns the number of nonzero compositions of the N into K parts. ! ! Discussion: ! ! A composition of the integer N into K nonzero parts is an ordered sequence ! of K positive integers which sum to N. The compositions (1,2,1) ! and (1,1,2) are considered to be distinct. ! ! The 10 compositions of 6 into three nonzero parts are: ! ! 4 1 1 ! 3 2 1 ! 3 1 2 ! 2 3 1 ! 2 2 2 ! 2 1 3, ! 1 4 1 ! 1 3 2 ! 1 2 3 ! 1 1 4. ! ! The formula for the number of compositions of N into K nonzero ! parts is ! ! Number = ( N - 1 )! / ( ( N - K )! * ( K - 1 )! ) ! ! (Describe the composition using N-K '1's and K-1 dividing lines '|'. ! The number of distinct permutations of these symbols is the number ! of compositions into nonzero parts. This is equal to the number of ! permutations of N-1 things, with N-K identical of one kind ! and K-1 identical of another.) ! ! Thus, for the above example, we have: ! ! Number = ( 6 - 1 )! / ( ( 6 - 3 )! * ( 3 - 1 )! ) = 10 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer whose compositions are desired. ! ! Input, integer K, the number of parts in the composition. ! ! Output, integer NUMBER, the number of compositions of N into ! K nonzero parts. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i4_choose integer k integer n integer number number = i4_choose ( n - 1, n - k ) return end subroutine compnz_next ( n, k, a, more, h, t ) !*****************************************************************************80 ! !! compnz_next() computes the compositions of the integer N into K nonzero parts. ! ! Discussion: ! ! A composition of the integer N into K nonzero parts is an ordered sequence ! of K positive integers which sum to N. The compositions (1,2,1) ! and (1,1,2) are considered to be distinct. ! ! 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 4+1+1 but 5+1+0 is not allowed since it includes a zero part. ! ! On the first call to this routine, set MORE = FALSE. The routine ! will compute the first element in the sequence of compositions, and ! return it, as well as setting MORE = TRUE. If more compositions ! are desired, call again, and again. Each time, the routine will ! return with a new composition. ! ! However, when the LAST composition in the sequence is computed ! and returned, the routine will reset MORE to FALSE, signaling that ! the end of the sequence has been reached. ! ! The 10 compositions of 6 into three nonzero parts are: ! ! 4 1 1, 3 2 1, 3 1 2, 2 3 1, 2 2 2, 2 1 3, ! 1 4 1, 1 3 2, 1 2 3, 1 1 4. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer whose compositions are desired. ! ! Input, integer K, the number of parts in the composition. ! K must be less than or equal to N. ! ! Input/output, integer A(K), the parts of the composition. ! ! Input/output, logical MORE, set by the user to start the computation, ! and by the routine to terminate it. ! ! Input/output, integer H, T, two internal parameters needed ! for the computation. The user should allocate space for these in the ! calling program, include them in the calling sequence, but never alter ! them! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer h logical more integer n integer t ! ! We use the trick of computing ordinary compositions of (N-K) ! into K parts, and adding 1 to each part. ! if ( n < k ) then more = .false. a(1:k) = -1 return end if ! ! The first computation. ! if ( .not. more ) then t = n - k h = 0 a(1) = n - k a(2:k) = 0 ! ! The next computation. ! else a(1:k) = a(1:k) - 1 if ( 1 < t ) then h = 0 end if h = h + 1 t = a(h) a(h) = 0 a(1) = t - 1 a(h+1) = a(h+1) + 1 end if ! ! This is the last element of the sequence if all the ! items are in the last slot. ! more = ( a(k) /= ( n - k ) ) a(1:k) = a(1:k) + 1 return end subroutine compnz_random ( n, k, a ) !*****************************************************************************80 ! !! compnz_random() selects a random composition of N into K nonzero parts. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 December 2005 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer to be decomposed. ! ! Input, integer K, the number of parts in the composition. ! K must be no greater than N. ! ! Output, integer A(K), the parts of the composition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer i integer l integer m integer n if ( n < k ) then a(1:k) = -1 return end if if ( 1 < k ) then call ksub_random2 ( n - 1, k - 1, a ) end if a(k) = n l = 0 do i = 1, k m = a(i) a(i) = a(i) - l - 1 l = m end do a(1:k) = a(1:k) + 1 return end subroutine compnz_to_ksub ( nc, kc, ac, ns, ks, as ) !*****************************************************************************80 ! !! compnz_to_ksub() converts a nonzero composition to a K-subset. ! ! Discussion: ! ! There is a bijection between K subsets and nonzero compositions. ! ! Let AC be a composition of NC into KC parts. ! ! Then let ! NS = NC - 1 ! KS = KC - 1 ! and define ! AS(I) = sum ( AC(1:I) ), for I = 1 : KS. ! ! Then AS is a KS subset of the integers 1 through NS. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NC, the composition sum. ! ! Input, integer KC, the number of parts of the composition. ! ! Input, integer AC(KC), the parts of the composition. ! ! Output, integer NS, the size of the set. ! ! Output, integer KS, the size of the subset. ! ! Output, integer AS(KS), the entries of the K-subset, ! in increasing order. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer ks integer ac(kc) integer as(ks) integer i integer nc integer ns ns = nc - 1 ks = kc - 1 as(1) = ac(1) do i = 2, kc - 1 as(i) = as(i-1) + ac(i) end do return end subroutine congruence ( a, b, c, ierror, x ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 November 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998, page 446. ! ! 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 :: rk = kind ( 1.0D+00 ) 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 i4_gcd integer ierror integer k integer n integer q(nmax) logical swap integer x integer y integer z ! ! 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 = i4_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 = i4_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 ( b_mag <= a_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 ( nmax < n ) then ierror = 5 write ( *, '(a)' ) '' write ( *, '(a)' ) 'CONGRUENCE - Fatal error!' write ( *, '(a)' ) ' Exceeded number of iterations.' stop 1 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 z = x x = y y = z 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 ) ! ! Force positivity. ! if ( x < 0 ) then x = x + b end if return end subroutine count_pose_random ( blocks, goal ) !*****************************************************************************80 ! !! count_pose_random() 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 April 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Raymond Seroul, ! Programming for Mathematicians, ! Springer Verlag, 2000, pages 355-357. ! ! Parameters: ! ! Output, integer BLOCKS(6), the six numbers available for ! the formula. ! ! Output, integer GOAL, the goal number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer blocks(6) integer goal integer i4_uniform_ab integer ind(6) integer, dimension ( 14 ) :: stuff = & (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 25, 50, 75, 100 /) goal = i4_uniform_ab ( 100, 999 ) call ksub_random2 ( 14, 6, ind ) blocks(1:6) = stuff(ind(1:6)) return end subroutine debruijn ( m, n, string ) !*****************************************************************************80 ! !! debruijn() constructs a de Bruijn sequence. ! ! Discussion: ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 integer string(m**n) logical success 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 ( mantissa1, exponent1, mantissa2, exponent2, & dec_digit, mantissa, exponent ) !*****************************************************************************80 ! !! dec_add() adds two decimal quantities. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^EXPONENT. ! ! The routine computes ! ! MANTISSA * 10^EXPONENT = ! MANTISSA1 * 10^EXPONENT1 ! + MANTISSA2 * 10^EXPONENT2 ! ! while trying to avoid integer overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA1, EXPONENT1, the first number to ! be added. ! ! Input, integer MANTISSA2, EXPONENT2, the second number to ! be added. ! ! Input, integer DEC_DIGIT, the number of decimal digits. ! ! Output, integer MANTISSA, EXPONENT, the sum. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dec_digit integer exponent integer exponent1 integer exponent2 integer mantissa integer mantissa1 integer mantissa2 integer mantissa3 integer mantissa4 if ( mantissa1 == 0 ) then mantissa = mantissa2 exponent = exponent2 return else if ( mantissa2 == 0 ) then mantissa = mantissa1 exponent = exponent1 return else if ( exponent1 == exponent2 ) then mantissa = mantissa1 + mantissa2 exponent = exponent1 call dec_round ( mantissa, exponent, dec_digit, mantissa, exponent ) return end if ! ! Line up the exponents. ! mantissa3 = mantissa1 mantissa4 = mantissa2 if ( exponent1 < exponent2 ) then mantissa4 = mantissa4 * 10**( exponent2 - exponent1 ) else mantissa3 = mantissa3 * 10**( exponent1 - exponent2 ) end if ! ! Add the coefficients. ! mantissa = mantissa3 + mantissa4 exponent = min ( exponent1, exponent2 ) ! ! Clean up the result. ! call dec_round ( mantissa, exponent, dec_digit, mantissa, exponent ) return end subroutine dec_div ( mantissa1, exponent1, mantissa2, exponent2, & dec_digit, mantissa, exponent, ierror ) !*****************************************************************************80 ! !! dec_div() divides two decimal values. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! The routine computes ! ! MANTISSA * 10^EXPONENT ! = ( MANTISSA1 * 10^EXPONENT1 ) / ( MANTISSA2 * 10^EXPONENT2 ) ! = ( MANTISSA1 / MANTISSA2 ) * 10^( EXPONENT1 - EXPONENT2 ) ! ! while avoiding integer overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA1, EXPONENT1, the numerator. ! ! Input, integer MANTISSA2, EXPONENT2, the denominator. ! ! Input, integer DEC_DIGIT, the number of decimal digits. ! ! Output, integer MANTISSA, EXPONENT, the result. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dec_digit real ( kind = rk ) dval integer exponent integer exponent1 integer exponent2 integer exponent3 integer ierror integer mantissa integer mantissa1 integer mantissa2 integer mantissa3 ! ! First special case, top fraction is 0. ! if ( mantissa1 == 0 ) then mantissa = 0 exponent = 0 return end if ! ! First error, bottom of fraction is 0. ! if ( mantissa2 == 0 ) then ierror = 1 mantissa = 0 exponent = 0 return end if ! ! Second special case, result is 1. ! if ( mantissa1 == mantissa2 .and. exponent1 == exponent2 ) then mantissa = 1 exponent = 0 return end if ! ! Third special case, result is power of 10. ! if ( mantissa1 == mantissa2 ) then mantissa = 1 exponent = exponent1 - exponent2 return end if ! ! Fourth special case: MANTISSA1/MANTISSA2 is exact. ! if ( ( mantissa1 / mantissa2 ) * mantissa2 == mantissa1 ) then mantissa = mantissa1 / mantissa2 exponent = exponent1 - exponent2 return end if ! ! General case. ! dval = real ( mantissa1, kind = rk ) / real ( mantissa2, kind = rk ) call r8_to_dec ( dval, dec_digit, mantissa3, exponent3 ) mantissa = mantissa3 exponent = exponent3 + exponent1 - exponent2 return end subroutine dec_mul ( mantissa1, exponent1, mantissa2, exponent2, & dec_digit, mantissa, exponent ) !*****************************************************************************80 ! !! dec_mul() multiplies two decimals. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! The routine computes ! ! MANTISSA * 10^exponent ! = ( MANTISSA1 * 10^exponent1) * (MANTISSA2 * 10^exponent2) ! = ( MANTISSA1 * MANTISSA2 ) * 10**( EXPONENT1 + EXPONENT2 ) ! ! while avoiding integer overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA1, EXPONENT1, the first multiplier. ! ! Input, integer MANTISSA2, EXPONENT2, the second multiplier. ! ! Input, integer DEC_DIGIT, the number of decimal digits. ! ! Output, integer MANTISSA, EXPONENT, the product. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dec_digit real ( kind = rk ) dval integer exponent integer exponent1 integer exponent2 integer exponent3 integer i_max integer i4_huge integer mantissa integer mantissa1 integer mantissa2 integer mantissa3 real ( kind = rk ) temp i_max = i4_huge ( ) ! ! The result is zero if either MANTISSA1 or MANTISSA2 is zero. ! if ( mantissa1 == 0 .or. mantissa2 == 0 ) then mantissa = 0 exponent = 0 return end if ! ! The result is simple if either MANTISSA1 or MANTISSA2 is one. ! if ( abs ( mantissa1 ) == 1 .or. abs ( mantissa2 ) == 1 ) then mantissa = mantissa1 * mantissa2 exponent = exponent1 + exponent2 return end if temp = log ( real ( abs ( mantissa1 ), kind = rk ) ) & + log ( real ( abs ( mantissa2 ), kind = rk ) ) if ( temp < log ( real ( i_max, kind = rk ) ) ) then mantissa = mantissa1 * mantissa2 exponent = exponent1 + exponent2 else dval = real ( mantissa1, kind = rk ) * real ( mantissa2, kind = rk ) call r8_to_dec ( dval, dec_digit, mantissa3, exponent3 ) mantissa = mantissa3 exponent = exponent3 + ( exponent1 + exponent2 ) end if call dec_round ( mantissa, exponent, dec_digit, mantissa, exponent ) return end subroutine dec_round ( mantissa1, exponent1, dec_digit, mantissa2, exponent2 ) !*****************************************************************************80 ! !! dec_round() rounds a decimal fraction to a given number of digits. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! The routine takes an arbitrary decimal fraction makes sure that ! MANTISSA has no more than DEC_DIGIT digits. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA1, EXPONENT1, the coefficient and ! exponent of a decimal fraction to be rounded. ! ! Input, integer DEC_DIGIT, the number of decimal digits. ! ! Output, integer MANTISSA2, EXPONENT2, the rounded coefficient ! and exponent of a decimal fraction. MANTISSA2 has no more than ! DEC_DIGIT decimal digits. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dec_digit integer exponent1 integer exponent2 integer mantissa1 integer mantissa2 mantissa2 = mantissa1 exponent2 = exponent1 if ( mantissa2 == 0 ) then exponent2 = 0 return end if do while ( 10 ** dec_digit <= abs ( mantissa2 ) ) mantissa2 = nint ( real ( mantissa2, kind = rk ) / 10.0D+00 ) exponent2 = exponent2 + 1 end do ! ! Absorb trailing 0's into the exponent. ! do while ( ( mantissa2 / 10 ) * 10 == mantissa2 ) mantissa2 = mantissa2 / 10 exponent2 = exponent2 + 1 end do return end subroutine dec_to_r8 ( mantissa, exponent, r ) !*****************************************************************************80 ! !! dec_to_r8() converts a decimal to an R8. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA, EXPONENT, the coefficient and ! exponent of the decimal value. ! ! Output, real ( kind = rk ) R, the equivalent real value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer exponent integer mantissa real ( kind = rk ) r r = mantissa * 10.0D+00**exponent return end subroutine dec_to_rat ( mantissa, exponent, rat_top, rat_bot ) !*****************************************************************************80 ! !! dec_to_rat() converts a decimal to a rational representation. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! A rational value is represented by RAT_TOP / RAT_BOT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA, EXPONENT, the decimal number. ! ! Output, integer RAT_TOP, RAT_BOT, the rational value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer gcd integer exponent integer i4_gcd integer mantissa integer rat_bot integer rat_top if ( exponent == 0 ) then rat_top = mantissa rat_bot = 1 else if ( 0 < exponent ) then rat_top = mantissa * 10 ** exponent rat_bot = 1 else rat_top = mantissa rat_bot = 10**( - exponent ) gcd = i4_gcd ( rat_top, rat_bot ) rat_top = rat_top / gcd rat_bot = rat_bot / gcd end if return end subroutine dec_to_s ( mantissa, exponent, s ) !*****************************************************************************80 ! !! dec_to_s() returns a string representation of a decimal. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! Example: ! ! MANTISSA EXPONENT 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 September 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA, EXPONENT, 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 integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 22 ) chrrep integer exponent integer i integer iget1 integer iget2 integer iput1 integer iput2 integer mantissa integer maxdigit integer ndigit integer nleft character ( len = * ) s s = '' if ( mantissa == 0 ) then s = '0' return end if maxdigit = len ( s ) ! ! Store a representation of MANTISSA in CHRREP. ! write ( chrrep, '(i22)' ) mantissa call s_blank_delete ( chrrep ) ndigit = len_trim ( chrrep ) ! ! Overflow if EXPONENT is positive, and MAXDIGIT < NDIGIT + EXPONENT. ! if ( 0 < exponent ) then if ( maxdigit < ndigit + exponent ) then s = 'Inf' return end if end if ! ! Underflow if EXPONENT is negative, and MAXDIGIT < 3 + NDIGIT - EXPONENT. ! if ( exponent < 0 ) then if ( 0 < mantissa ) then if ( maxdigit < 3 - ndigit - exponent ) then s = '0.0' return end if else if ( maxdigit < 5 - ndigit - exponent ) then s = '0.0' return end if end if end if ! ! If EXPONENT is nonnegative, insert trailing zeros. ! if ( 0 <= exponent ) then s(1:ndigit) = chrrep(1:ndigit) do i = ndigit + 1, ndigit + exponent s(i:i) = '0' end do else if ( exponent < 0 ) then iput2 = 0 iget2 = 0 ! ! Sign. ! if ( mantissa < 0 ) then iput1 = 1 iput2 = 1 iget2 = 1 s(iput1:iput2) = '-' ndigit = ndigit - 1 end if ! ! Digits of the integral part. ! if ( 0 < ndigit + exponent ) then iput1 = iput2 + 1 iput2 = iput1 + ndigit + exponent -1 iget1 = iget2 + 1 iget2 = iget1 + ndigit + exponent - 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, - exponent - ndigit iput1 = iput2 + 1 iput2 = iput1 s(iput1:iput2) = '0' end do nleft = min ( -exponent, 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 function dec_width ( mantissa, exponent ) !*****************************************************************************80 ! !! dec_width() returns the "width" of a decimal number. ! ! Discussion: ! ! A decimal value is represented by MANTISSA * 10^exponent. ! ! The "width" of a decimal number is the number of characters ! required to print it. ! ! Example: ! ! Mantissa Exponent Width Representation: ! ! 523 -1 4 5.23 ! 134 2 5 13400 ! 0 10 1 0 ! 123456 -10 12 0.0000123456 ! 123456 -3 7 123.456 ! 123456 0 6 123456 ! 123456 3 9 123456000 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 June 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer MANTISSA, EXPONENT, the decimal number. ! ! Output, integer DEC_WIDTH, the "width" of the decimal number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dec_width integer exponent integer mantissa integer mantissa_abs integer ten_pow integer value value = 1 ten_pow = 10 if ( mantissa == 0 ) then dec_width = value return end if mantissa_abs = abs ( mantissa ) do while ( ten_pow <= mantissa_abs ) value = value + 1 ten_pow = ten_pow * 10 end do if ( 0 < exponent ) then value = value + exponent else if ( exponent < 0 ) then value = max ( value, 1-exponent ) ! ! An internal decimal point adds one position. ! if ( 0 < value ) then value = value + 1 ! ! A leading "0." adds two positions. ! else value = 2 - value end if end if if ( mantissa < 0 ) then value = value + 1 end if dec_width = value return end subroutine decmat_det ( n, atop, abot, dec_digit, dtop, dbot, ierror ) !*****************************************************************************80 ! !! decmat_det() finds the determinant of an N by N matrix of decimal entries. ! ! Discussion: ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of rows and columns of A. ! ! Input, integer ATOP(N,N), ABOT(N,N), the decimal ! representation of the matrix. ! ! Output, integer DTOP, DBOT, the decimal determinant of ! the matrix. ! ! Output, integer IERROR. ! 0, no error occurred. ! 1, an error occurred (probably overflow). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer dec_digit logical even integer i integer abot(n,n) integer atop(n,n) integer iarray(n) integer ibot integer ibot1 integer ibot2 integer dbot integer dtop integer ierror integer itop integer itop1 integer itop2 logical more ierror = 0 more = .false. dtop = 0 dbot = 1 ! ! Compute the next permutation. ! do call perm1_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 = atop(i,iarray(i)) ibot2 = abot(i,iarray(i)) call dec_mul ( itop1, ibot1, itop2, ibot2, dec_digit, itop, ibot ) end do ! ! Add this term to the total. ! itop1 = itop ibot1 = ibot call dec_add ( itop1, ibot1, dtop, dbot, dec_digit, itop, ibot ) dtop = itop dbot = ibot if ( .not. more ) then exit end if end do return end subroutine decmat_print ( m, n, a, b, title ) !*****************************************************************************80 ! !! decmat_print() prints out decimal vectors and matrices. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer a(m,n) integer b(m,n) character ( len = 22 ) chrtmp character ( len = 10 ) chrtmp2 character ( len = 10 ) chrtmp3 character ( len = 40 ) format2 integer i integer imax integer j integer jmax integer jmin integer khi integer klo integer kmax integer lenc integer, parameter :: ncolum = 80 integer npline character ( len = 255 ) 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 ( 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 i4_to_s_left ( npline, chrtmp2 ) call i4_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 ( 1 < jmin .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 ( 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 function derange_enum ( n ) !*****************************************************************************80 ! !! derange_enum() returns the number of derangements of N objects. ! ! Discussion: ! ! A derangement of N objects is a permutation which leaves no object ! unchanged. ! ! 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. ! ! The number of derangements of N objects is sometimes called ! the subfactorial function, or the derangement number D(N). ! ! 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). ! ! 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. ! ! D(N) = nint ( N! / E ) ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! derange_enum2() returns the number of derangements of 0 through N objects. ! ! Discussion: ! ! A derangement of N objects is a permutation which leaves no object ! unchanged. ! ! 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. ! ! The number of derangements of N objects is sometimes called ! the subfactorial function, or the derangement number D(N). ! ! 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). ! ! 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. ! ! D(N) = nint ( N! / E ) ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 function derange_enum3 ( n ) !*****************************************************************************80 ! !! derange_enum3() returns the number of derangements of 0 through N objects. ! ! Discussion: ! ! A derangement of N objects is a permutation which leaves no object ! unchanged. ! ! 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. ! ! The number of derangements of N objects is sometimes called ! the subfactorial function, or the derangement number D(N). ! ! 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). ! ! 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. ! ! D(N) = nint ( N! / E ) ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 August 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the maximum number of objects to be ! permuted. ! ! Output, integer DERANGE_ENUM3, the number of derangements ! of N objects. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer derange_enum3 real ( kind = rk ), parameter :: e = 2.718281828459045D+00 integer n real ( kind = rk ) r8_factorial if ( n < 0 ) then derange_enum3 = -1 else if ( n == 0 ) then derange_enum3 = 1 else if ( n == 1 ) then derange_enum3 = 0 else derange_enum3 = nint ( r8_factorial ( n ) / e ) end if return end subroutine derange1_back_candidate ( n, maxstack, a, k, nstack, stack, ncan ) !*****************************************************************************80 ! !! derange1_back_candidate() finds values for the K-th entry of a derangement. ! ! Discussion: ! ! A derangement of N objects is a permutation of (1,...,N) which leaves ! no object unchanged. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the derangement. ! ! Input, integer MAXSTACK, the maximum stack length. ! ! Input, integer A(N). The first K-1 entries of A ! 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(MAXSTACK). 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, parameter :: rk = kind ( 1.0D+00 ) integer maxstack integer n integer a(n) integer ican integer ifree(n) integer k integer ncan(n) integer nfree integer nstack integer stack(maxstack) ! ! Consider all the integers from 1 through N that have not been used yet. ! nfree = n - k + 1 call perm1_free ( k - 1, a, nfree, ifree ) ! ! 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 if ( maxstack < nstack ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'DERANGE1_BACK_CANDIDATE - Fatal error!' write ( *, '(a,i8)' ) ' Exceeding stacksize limit of ', maxstack stop 1 end if stack(nstack) = ifree(ican) end if end do return end subroutine derange1_back_next ( n, a, more ) !*****************************************************************************80 ! !! derange1_back_next() returns the next derangement of N items. ! ! Discussion: ! ! A derangement of N objects is a permutation of (1,...,N) which leaves ! no object unchanged. ! ! This routine uses backtracking. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items to be deranged. ! N should be at least 2. ! ! Input/output, integer A(N). ! On the first call, the input value of A is not important. ! On return with MORE = TRUE, A contains the next derangement. ! On subsequent input, A 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 is being treturned in A, ! and FALSE if no more can be found. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(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 if ( n < 2 ) then more = .false. return end if indx = 0 k = 0 maxstack = ( n * ( n + 1 ) ) / 2 nstack = 0 if ( allocated ( stack ) ) then deallocate ( stack ) end if allocate ( stack(1:maxstack) ) 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 i4vec_backtrack ( n, maxstack, a, indx, k, nstack, stack, ncan ) if ( indx == 1 ) then exit else if ( indx == 2 ) then call derange1_back_candidate ( n, maxstack, a, k, nstack, stack, ncan ) else more = .false. exit end if end do return end subroutine derange1_check ( n, a, check ) !*****************************************************************************80 ! !! derange1_check() checks if a permutation is a derangement of (1,...,N). ! ! Discussion: ! ! A derangement of N objects is a permutation which leaves no object ! unchanged. ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects permuted. ! ! Input, integer A(N), a permutation of the integers 1 ! through N. ! ! Output, logical CHECK, is TRUE if A is a derangement, and ! FALSE otherwise. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) logical check integer i integer j ! ! Values must be between 1 and N. ! do i = 1, n if ( a(i) < 1 .or. n < a(i) ) then check = .false. return end if end do ! ! Every value must be represented. ! do j = 1, n check = .false. do i = 1, n if ( a(i) .eq. j ) then check = .true. exit end if end do if ( .not. check ) then return end if end do ! ! Values must be deranged. ! do i = 1, n if ( a(i) == i ) then check = .false. return end if end do check = .true. return end subroutine derange1_weed_next ( n, a, more, maxder, numder ) !*****************************************************************************80 ! !! derange1_weed_next() computes derangements of (1,...,N). ! ! Discussion: ! ! A derangement of N objects is a permutation which leaves no object ! unchanged. ! ! 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. ! ! The number of derangements of N objects is sometimes called ! the subfactorial function, or the derangement number D(N). ! ! This routine simply generates all permutations, one at a time, ! and weeds out those that are not derangements. ! ! Example: ! ! Here are the derangements when N = 4: ! ! 2143 ! 2341 ! 2413 ! 3142 ! 3412 ! 3421 ! 4123 ! 4312 ! 4321 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input/output, integer A(N). ! On first call, the input contents of A are unimportant. But ! on the second and later calls, the input value of A should be ! the output value returned on the previous call. ! On output, A 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. ! ! Input/output, integer MAXDER, NUMDER, two parameters ! used by the program for bookkeeping. The user should declare these ! variables, and pass the output values from one call to the next, ! but should not alter them. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) logical deranged integer derange_enum integer maxder logical more integer numder ! ! 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 perm1_lex_next ( n, a, more ) ! ! See if it is a derangment. ! call derange1_check ( n, a, deranged ) if ( deranged ) then exit end if end do numder = numder + 1 if ( maxder <= numder ) then more = .false. end if return end subroutine digit_to_ch ( digit, c ) !*****************************************************************************80 ! !! digit_to_ch() returns the character representation of a decimal digit. ! ! Example: ! ! DIGIT C ! ----- --- ! 0 '0' ! 1 '1' ! ... ... ! 9 '9' ! 17 '*' ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 integer, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! digraph_arc_euler() returns an Euler circuit in a digraph. ! ! Discussion: ! ! 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. ! ! ! 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 halt. ! ! 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 ). ! ! The digraph is assumed to be connected. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 July 2000 ! ! Author: ! ! Original FORTRAN77 version by Hang Tong Lau. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Hang Tong Lau, ! Algorithms on Graphs, ! Tab Books, 1989. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 i4vec_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 i4vec_reverse ( nedge, trail ) return end subroutine digraph_arc_print ( nedge, inode, jnode, title ) !*****************************************************************************80 ! !! digraph_arc_print() prints out a digraph from an edge list. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer nedge integer i integer inode(nedge) integer jnode(nedge) character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' do i = 1, nedge write ( *, '(i8,4x,2i8)' ) i, inode(i), jnode(i) end do return end subroutine diophantine ( a, b, c, ierror, x, y ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 October 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998, page 446. ! ! 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 :: rk = kind ( 1.0D+00 ) 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 i4_gcd integer ierror integer k integer n integer q(nmax) logical swap integer x integer y ! ! 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 = i4_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 = i4_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 ( b_mag <= a_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 ( nmax < n ) then ierror = 5 write ( *, '(a)' ) '' write ( *, '(a)' ) 'DIOPHANTINE - Fatal error!' write ( *, '(a)' ) ' Exceeded number of iterations.' stop 1 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 i4_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 ) !*****************************************************************************80 ! !! diophantine_solution_minimize(): 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 October 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Eric Weisstein, editor, ! CRC Concise Encylopedia of Mathematics, ! CRC Press, 1998, page 446. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer a integer b real ( kind = rk ) norm real ( kind = rk ) norm_new real ( kind = rk ) t integer x integer xnew integer y integer ynew ! ! Compute the minimum for T real, and then look nearby. ! t = ( - real ( b, kind = rk ) * real ( x, kind = rk ) & + real ( a, kind = rk ) * real ( y, kind = rk ) ) & / ( real ( a, kind = rk )**2 + real ( b, kind = rk )**2 ) x = x + nint ( t ) * b y = y - nint ( t ) * a ! ! Now look nearby. ! norm = ( real ( x, kind = rk ) )**2 + ( real ( y, kind = rk ) )**2 do xnew = x + b ynew = y - a norm_new = ( real ( xnew, kind = rk ) )**2 + ( real ( ynew, kind = rk ) )**2 if ( norm <= norm_new ) then exit end if x = xnew y = ynew norm = norm_new end do do xnew = x - b ynew = y + a norm_new = ( real ( xnew, kind = rk ) )**2 + ( real ( ynew, kind = rk ) )**2 if ( norm <= norm_new ) then exit end if x = xnew y = ynew norm = norm_new end do return end subroutine dvec_add ( n, dvec1, dvec2, dvec3 ) !*****************************************************************************80 ! !! dvec_add() adds two (signed) DVEC's. ! ! Discussion: ! ! A DVEC is an integer vector of decimal digits, intended to ! represent an integer. DVEC(1) is the units digit, DVEC(N-1) ! is the coefficient of 10^(N-2), and DVEC(N) contains sign ! information. It is 0 if the number is positive, and 9 if ! the number is negative. ! ! Example: ! ! N = 4 ! ! DVEC1 + DVEC2 = DVEC3 ! ! ( 0 0 1 7 ) + ( 0 1 0 4 ) = ( 0 0 1 2 1 ) ! ! 17 + 104 = 121 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 November 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer DVEC1(N), DVEC2(N), the vectors to be added. ! ! Output, integer DVEC3(N), the sum of the two input vectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 10 integer dvec1(n) integer dvec2(n) integer dvec3(n) integer i logical overflow overflow = .false. dvec3(1:n) = dvec1(1:n) + dvec2(1:n) do i = 1, n do while ( base <= dvec3(i) ) dvec3(i) = dvec3(i) - base if ( i < n ) then dvec3(i+1) = dvec3(i+1) + 1 else overflow = .true. end if end do end do return end subroutine dvec_complementx ( n, dvec1, dvec2 ) !*****************************************************************************80 ! !! dvec_complementx() computes the ten's complement of a DVEC. ! ! Discussion: ! ! A DVEC is an integer vector of decimal digits, intended to ! represent an integer. DVEC(1) is the units digit, DVEC(N-1) ! is the coefficient of 10^(N-2), and DVEC(N) contains sign ! information. It is 0 if the number is positive, and 9 if ! the number is negative. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 November 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer DVEC1(N), the vector to be complemented. ! ! Output, integer DVEC2(N), the complemented vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 10 integer dvec1(n) integer dvec2(n) integer dvec3(n) integer dvec4(n) dvec3(1:n) = ( base - 1 ) - dvec1(1:n) dvec4(1) = 1 dvec4(2:n) = 0 call dvec_add ( n, dvec3, dvec4, dvec2 ) return end subroutine dvec_mul ( n, dvec1, dvec2, dvec3 ) !*****************************************************************************80 ! !! dvec_mul() computes the product of two DVEC's. ! ! Discussion: ! ! A DVEC is an integer vector of decimal digits, intended to ! represent an integer. DVEC(1) is the units digit, DVEC(N-1) ! is the coefficient of 10^(N-2), and DVEC(N) contains sign ! information. It is 0 if the number is positive, and 9 if ! the number is negative. ! ! Since the user may want to make calls like ! ! call dvec_mul ( n, dvec1, dvec1, dvec3 ) ! or even ! call dvec_mul ( n, dvec1, dvec1, dvec1 ) ! ! we need to copy the arguments, work on them, and then copy out the result. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 December 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer DVEC1(N), DVEC2(N), the vectors to be ! multiplied. ! ! Output, integer DVEC3(N), the product of the two input ! vectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 10 integer carry integer dvec1(n) integer dvec2(n) integer dvec3(n) integer dveca(n) integer dvecb(n) integer dvecc(n) integer i integer product_sign ! ! Copy the input. ! dveca(1:n) = dvec1(1:n) dvecb(1:n) = dvec2(1:n) ! ! Record the sign of the product. ! Make the factors positive. ! product_sign = 1 if ( dveca(n) /= 0 ) then product_sign = - product_sign call dvec_complementx ( n, dveca, dveca ) end if if ( dvecb(n) /= 0 ) then product_sign = - product_sign call dvec_complementx ( n, dvecb, dvecb ) end if dvecc(1:n) = 0 ! ! Multiply. ! do i = 1, n - 1 dvecc(i:n-1) = dvecc(i:n-1) + dveca(i) * dvecb(1:n-i) end do ! ! Take care of carries. ! Unlike the DVEC_ADD routine, we do NOT allow carries into the ! N-th position. ! do i = 1, n - 1 carry = dvecc(i) / base dvecc(i) = dvecc(i) - carry * base if ( i < n - 1 ) then dvecc(i+1) = dvecc(i+1) + carry end if end do ! ! Take care of the sign of the product. ! if ( product_sign < 0 ) then call dvec_complementx ( n, dvecc, dvecc ) end if ! ! Copy the output. ! dvec3(1:n) = dvecc(1:n) return end subroutine dvec_print ( n, dvec, title ) !*****************************************************************************80 ! !! dvec_print() prints a DVEC, with an optional title. ! ! Discussion: ! ! A DVEC is an integer vector of decimal digits, intended to ! represent an integer. DVEC(1) is the units digit, DVEC(N-1) ! is the coefficient of 10^(N-2), and DVEC(N) contains sign ! information. It is 0 if the number is positive, and 9 if ! the number is negative. ! ! The vector is printed "backwards", that is, the first entry ! printed is DVEC(N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 May 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer DVEC(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer dvec(n) integer ihi integer ilo character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' do ihi = n, 1, -80 ilo = max ( ihi - 79, 1 ) if ( ihi == n ) then if ( dvec(n) == 9 ) then write ( *, '(2x,a1,79i1)' ) '-', dvec(ihi-1:ilo:-1) else write ( *, '(2x,a1,79i1)' ) '+', dvec(ihi-1:ilo:-1) end if else write ( *, '(2x,80i1)' ) dvec(ihi:ilo:-1) end if end do return end subroutine dvec_sub ( n, dvec1, dvec2, dvec3 ) !*****************************************************************************80 ! !! dvec_sub() subtracts two DVEC's. ! ! Discussion: ! ! A DVEC is an integer vector of decimal digits, intended to ! represent an integer. DVEC(1) is the units digit, DVEC(N-1) ! is the coefficient of 10^(N-2), and DVEC(N) contains sign ! information. It is 0 if the number is positive, and 9 if ! the number is negative. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 November 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer DVEC1(N), DVEC2(N), the vectors to be ! subtracted. ! ! Output, integer DVEC3(N), the value of DVEC1 - DVEC2. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer dvec1(n) integer dvec2(n) integer dvec3(n) dvec3(1:n) = dvec2(1:n) call dvec_complementx ( n, dvec3, dvec3 ) call dvec_add ( n, dvec1, dvec3, dvec3 ) return end subroutine dvec_to_i4 ( n, dvec, i4 ) !*****************************************************************************80 ! !! dvec_to_i4() makes an integer from a (signed) DVEC. ! ! Discussion: ! ! A DVEC is an integer vector of decimal digits, intended to ! represent an integer. DVEC(1) is the units digit, DVEC(N-1) ! is the coefficient of 10^(N-2), and DVEC(N) contains sign ! information. It is 0 if the number is positive, and 9 if ! the number is negative. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 November 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of the vector. ! ! Input, integer DVEC(N), the decimal vector. ! ! Output, integer I4, the integer. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 10 integer dvec(n) integer dvec2(n) integer i integer i_sign integer i4 dvec2(1:n) = dvec(1:n) i_sign = 1 if ( dvec2(n) == base - 1 ) then i_sign = -1 call dvec_complementx ( n - 1, dvec2, dvec2 ) end if i4 = 0 do i = n - 1, 1, -1 i4 = base * i4 + dvec2(i) end do i4 = i_sign * i4 return end subroutine equiv_next ( n, npart, jarray, iarray, more ) !*****************************************************************************80 ! !! equiv_next() computes the partitions of a set one at a time. ! ! Discussion: ! ! A partition of a set assigns each element to exactly one subset. ! ! The number of partitions of a set of size N is the Bell number B(N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 July 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of elements in the set to ! be partitioned. ! ! Input/output, integer NPART, the number of subsets in ! the partition. ! ! Input/output, integer JARRAY(N), the number of elements ! in each subset of the partition. ! ! Input/output, integer IARRAY(N), the subset to which ! each element 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, parameter :: rk = kind ( 1.0D+00 ) integer n 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 ( n, a, done ) !*****************************************************************************80 ! !! equiv_next2() computes, one at a time, the partitions of a set. ! ! Discussion: ! ! A partition of a set assigns each element to exactly one subset. ! ! The number of partitions of a set of size N is the Bell number B(N). ! ! The entries of A 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 A will be a ! number between 1 and NPART. Every number from 1 to NPART will ! occur somewhere in the list. If the entries of A 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! FORTRAN90 version by John Burkardt. ! ! Parameters: ! ! Input, integer N, the number of elements in the set. ! ! Input/output, integer A(N), contains the information ! defining the current partition. The user should not alter ! A between calls. Except for the very first ! call, the routine uses the previous output value of A to compute ! the next value. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) logical done integer imax integer j integer jmax if ( done ) then done = .false. a(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 = a(1) imax = 1 do j = 2, n if ( jmax < a(j) ) then jmax = a(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. a(imax) = a(imax) + 1 a(imax+1:n) = 1 end if return end subroutine equiv_print ( n, a, title ) !*****************************************************************************80 ! !! equiv_print() prints a partition of a set. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 July 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, number of elements in set to be partitioned. ! ! Input, integer A(N), defines the partition or set of ! equivalence classes. Element I belongs to subset A(I). ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer karray(n) integer j integer k integer s integer s_max integer s_min character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' write ( *, '(a)' ) ' Set Size' s_min = minval ( a(1:n) ) s_max = maxval ( a(1:n) ) do s = s_min, s_max k = 0 do j = 1, n if ( a(j) == s ) then k = k + 1 karray(k) = j end if end do if ( 0 < k ) then write ( *, '(i8,i8,a,(10i4))' ) s, k, ' :: ', karray(1:k) end if end do return end subroutine equiv_print2 ( n, s, title ) !*****************************************************************************80 ! !! equiv_print2() prints a partition of a set. ! ! Discussion: ! ! The partition is printed using the parenthesis format. ! ! For example, here are the partitions of a set of 4 elements: ! ! (1,2,3,4) ! (1,2,3)(4) ! (1,2,4)(3) ! (1,2)(3,4) ! (1,2)(3)(4) ! (1,3,4)(2) ! (1,3)(2,4) ! (1,3)(2)(4) ! (1,4)(2,3) ! (1)(2,3,4) ! (1)(2,3)(4) ! (1,4)(2)(3) ! (1)(2,4)(3) ! (1)(2)(3,4) ! (1)(2)(3)(4) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements in the set. ! ! Input, integer S(N), defines the partition. ! Element I belongs to subset S(I). ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer j integer s(n) integer s_max integer s_min integer size character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' s_min = minval ( s(1:n) ) s_max = maxval ( s(1:n) ) do j = 1, s_max write ( *, '(a)', ADVANCE = 'NO' ) '(' size = 0 do i = 1, n if ( s(i) == j ) then if ( 0 < size ) then write ( *, '(a)', ADVANCE = 'NO' ) ',' end if write ( *, '(i2)', ADVANCE = 'NO' ) i size = size + 1 end if end do write ( *, '(a)', ADVANCE = 'NO' ) ')' end do write ( *, '(a)', ADVANCE = 'YES' ) return end subroutine equiv_random ( n, npart, a ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 May 2002 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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 A(N), indicates the class to which each ! element is assigned. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) real ( kind = rk ) b(n) integer i integer i4_uniform_ab integer j integer k integer l integer m integer npart real ( kind = rk ) sum1 integer t real ( kind = rk ) z b(1) = 1.0D+00 do l = 1, n - 1 sum1 = 1.0D+00 / real ( l, kind = rk ) do k = 1, l - 1 sum1 = ( sum1 + b(k) ) / real ( l - k, kind = rk ) end do b(l+1) = ( sum1 + b(l) ) / real ( l + 1, kind = rk ) end do m = n npart = 0 do call random_number ( harvest = z ) z = real ( m, kind = rk ) * b(m) * z k = 0 npart = npart + 1 do while ( 0.0D+00 <= z ) a(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. ! do i = 1, n - 1 j = i4_uniform_ab ( i, n ) t = a(i) a(i) = a(j) a(j) = t end do return end subroutine euler_row ( n, ieuler ) !*****************************************************************************80 ! !! euler_row() returns the N-th row of Euler's triangle. ! ! Discussion: ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 June 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the row of Euler's triangle desired. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer ieuler(0:n) integer irow integer k ieuler(0) = 1 if ( 0 < n ) 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 frobenius_number_order2 ( c1, c2 ) !*****************************************************************************80 ! !! frobenius_number_order2() returns the Frobenius number for order 2. ! ! Discussion: ! ! The Frobenius number of order N is the solution of the Frobenius ! coin sum problem for N coin denominations. ! ! The Frobenius coin sum problem assumes the existence of ! N coin denominations, and asks for the largest value that cannot ! be formed by any combination of coins of these denominations. ! ! The coin denominations are assumed to be distinct positive integers. ! ! For general N, this problem is fairly difficult to handle. ! ! For N = 2, it is known that: ! ! * if C1 and C2 are not relatively prime, then ! there are infinitely large values that cannot be formed. ! ! * otherwise, the largest value that cannot be formed is ! C1 * C2 - C1 - C2, and that exactly half the values between ! 1 and C1 * C2 - C1 - C2 + 1 cannot be represented. ! ! As a simple example, if C1 = 2 and C2 = 7, then the largest ! unrepresentable value is 5, and there are (5+1)/2 = 3 ! unrepresentable values, namely 1, 3, and 5. ! ! For a general N, and a set of coin denominations C1, C2, ..., CN, ! the Frobenius number F(N, C(1:N) ) is defined as the largest value ! B for which the equation ! ! C1*X1 + C2*X2 + ... + CN*XN = B ! ! has no nonnegative integer solution X(1:N). ! ! In the Mathematica Package "NumberTheory", the Frobenius number ! can be determined by ! ! < .0 = 0.0 ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 December 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Halton, ! On the efficiency of certain quasi-random sequences of points ! in evaluating multi-dimensional integrals, ! Numerische Mathematik, ! Volume 2, pages 84-90, 1960. ! ! John Hammersley, ! Monte Carlo methods for solving multivariable problems, ! Proceedings of the New York Academy of Science, ! Volume 86, pages 844-874, 1960. ! ! Johannes van der Corput, ! Verteilungsfunktionen I & II, ! Proceedings of the Koninklijke Nederlandsche Akademie ! van Wetenschappen, ! Volume 38, 1935, pages 813-820, pages 1058-1066. ! ! Parameters: ! ! Input, integer SEED, the seed or index of the desired element. ! SEED should be nonnegative. ! SEED = 0 is allowed, and returns R = 0. ! ! Input, integer BASE, the van der Corput base, which is ! typically a prime number. BASE must be greater than 1. ! ! Output, real ( kind = rk ) R, the SEED-th element of the van der ! Corput sequence for base BASE. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer base real ( kind = rk ) base_inv integer digit real ( kind = rk ) r integer seed integer seed2 if ( base <= 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4_TO_VAN_DER_CORPUT - Fatal error!' write ( *, '(a)' ) ' The input base BASE is <= 1!' write ( *, '(a,i8)' ) ' BASE = ', base stop 1 end if if ( seed < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4_TO_VAN_DER_CORPUT - Fatal error!' write ( *, '(a)' ) ' The input base SEED is < 0!' write ( *, '(a,i8)' ) ' SEED = ', seed stop 1 end if seed2 = seed r = 0.0D+00 base_inv = 1.0D+00 / real ( base, kind = rk ) do while ( seed2 /= 0 ) digit = mod ( seed2, base ) r = r + real ( digit, kind = rk ) * base_inv base_inv = base_inv / real ( base, kind = rk ) seed2 = seed2 / base end do return end function i4_uniform_ab ( a, b ) !*****************************************************************************80 ! !! i4_uniform_ab() returns a scaled pseudorandom I4 between A and B. ! ! Discussion: ! ! An I4 is an integer value. ! ! The pseudorandom number will be scaled to be uniformly distributed ! between A and B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 October 2012 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Second Edition, ! Springer, 1987, ! ISBN: 0387964673, ! LC: QA76.9.C65.B73. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, December 1986, pages 362-376. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley, 1998, ! ISBN: 0471134031, ! LC: T57.62.H37. ! ! Peter Lewis, Allen Goodman, James Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, Number 2, 1969, pages 136-143. ! ! Parameters: ! ! Input, integer A, B, the limits of the interval. ! ! Output, integer I4_UNIFORM_AB, a number between A and B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer b integer, parameter :: i4_huge = 2147483647 integer i4_uniform_ab real r integer value call random_number ( harvest = r ) ! ! Scale R to lie between A-0.5 and B+0.5. ! r = ( 1.0E+00 - r ) * ( real ( min ( a, b ) ) - 0.5E+00 ) & + r * ( real ( max ( a, b ) ) + 0.5E+00 ) ! ! Use rounding to convert R to an integer between A and B. ! value = nint ( r ) value = max ( value, min ( a, b ) ) value = min ( value, max ( a, b ) ) i4_uniform_ab = value return end subroutine i4mat_01_rowcolsum ( m, n, r, c, a, ierror ) !*****************************************************************************80 ! !! i4mat_01_rowcolsum() creates a 0/1 I4MAT 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Jack vanLint, Richard Wilson, ! A Course in Combinatorics, ! Cambridge, 1992, ! ISBN: 0-521-42260-4. ! ! 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. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer a(m,n) integer c(n) integer c_sum integer i integer ierror logical i4vec_descends integer i4vec_maxloc_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. i4vec_descends ( m, r ) ) then ierror = 2 return end if if ( n < r(1) .or. r(m) < 0 ) then ierror = 2 return end if if ( .not. i4vec_descends ( n, c ) ) then ierror = 3 return end if if ( m < c(1) .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 ( r_sum < c_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 = i4vec_maxloc_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 ( 1 < i ) then i = i - 1 else i = i4vec_maxloc_last ( m, r2 ) if ( i == 1 .and. k < c(j) ) then i = 1 + i4vec_maxloc_last ( m-1, r2(2:m) ) end if end if end do end do return end subroutine i4mat_01_rowcolsum2 ( m, n, r, c, a, ierror ) !*****************************************************************************80 ! !! i4mat_01_rowcolsum2() creates a 0/1 I4MAT 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Jack van Lint, Richard 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. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer a(m,n) integer c(n) integer capflo(2,2*(m+m*n+n)) integer cut(m+n+2) integer i integer iendpt(2,2*(m+m*n+n)) integer ierror integer j integer k integer nedge integer nnode integer node_flow(m+n+2) integer r(m) integer sink integer source ierror = 0 ! ! There are M + N + 2 nodes. The last two are the special source and sink. ! source = m + n + 1 sink = 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) = source iendpt(2,k) = i capflo(1,k) = r(i) capflo(2,k) = 0 k = k + 1 iendpt(1,k) = i iendpt(2,k) = source 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) = sink capflo(1,k) = c(j) capflo(2,k) = 0 k = k + 1 iendpt(1,k) = sink 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, source, sink, & cut, 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) == source ) then if ( capflo(1,k) /= capflo(2,k) ) then ierror = 1 end if end if if ( iendpt(2,k) == sink ) 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 i4mat_perm1 ( n, a, p ) !*****************************************************************************80 ! !! i4mat_perm1() permutes the rows and columns of a square I4MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 July 2000 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 perm1_cycle ( n, 1, p, is, nc ) do i = 1, n i1 = -p(i) if ( 0 < i1 ) 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 i4_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 i4mat_2perm1 ( m, n, a, p, q ) !*****************************************************************************80 ! !! i4mat_2perm1() permutes the rows and columns of a rectangular I4MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 1999 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer M, the number of rows in the matrix. ! ! Input, integer N, the 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, parameter :: rk = kind ( 1.0D+00 ) 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 perm1_cycle ( m, 1, p, is, nc ) if ( 0 < q(1) ) then call perm1_cycle ( n, 1, q, is, nc ) end if do i = 1, m i1 = -p(i) if ( 0 < i1 ) 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 i4_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 i4mat_print ( m, n, a, title ) !*****************************************************************************80 ! !! i4mat_print() prints an I4MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2004 ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer a(m,n) character ( len = * ) title call i4mat_print_some ( m, n, a, 1, 1, m, n, title ) return end subroutine i4mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title ) !*****************************************************************************80 ! !! i4mat_print_some() prints some of an I4MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns. ! ! Input, integer A(M,N), an M by N matrix to be printed. ! ! Input, integer ILO, JLO, the first row and column to print. ! ! Input, integer IHI, JHI, the last row and column to print. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: incx = 10 integer m integer n integer a(m,n) character ( len = 7 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx j2hi = j2lo + incx - 1 j2hi = min ( j2hi, n ) j2hi = min ( j2hi, jhi ) inc = j2hi + 1 - j2lo write ( *, '(a)' ) '' do j = j2lo, j2hi j2 = j + 1 - j2lo write ( ctemp(j2), '(i7)') j end do write ( *, '('' Col '',10a7)' ) ctemp(1:inc) write ( *, '(a)' ) ' Row' write ( *, '(a)' ) '' i2lo = max ( ilo, 1 ) i2hi = min ( ihi, m ) do i = i2lo, i2hi do j2 = 1, inc j = j2lo - 1 + j2 write ( ctemp(j2), '(i7)' ) a(i,j) end do write ( *, '(i8,2x,10a7)' ) i, ( ctemp(j), j = 1, inc ) end do end do return end subroutine i4mat_u1_inverse ( n, a, b ) !*****************************************************************************80 ! !! i4mat_u1_inverse() inverts a unit upper triangular I4MAT. ! ! 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 i4mat_u1_inverse ( n, a, a ) ! ! will result in A being overwritten by its inverse, which can ! reduce storage if the original value of A is not needed later. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 March 1999 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of rows and columns in ! the matrix. ! ! Input, integer A(N,N), the unit upper triangular matrix ! to be inverted. ! ! Output, integer B(N,N), the inverse matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 i4poly ( n, a, x0, iopt, value ) !*****************************************************************************80 ! !! i4poly() performs operations on I4POLY's 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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 VALUE, for IOPT = -1 or 0, the value of the ! polynomial at the point X0. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer eps integer i integer iopt integer m integer n1 integer value 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 ( -2 < iopt ) then w = w + x0 end if do m = 1, n1 value = 0 z = w do i = m, n z = z + eps value = a(n+m-i) + z * value if ( iopt /= 0 .and. iopt /= -1 ) then a(n+m-i) = value end if end do if ( iopt < 0 ) then w = w + 1 end if end do return end subroutine i4poly_add ( na, a, nb, b, c ) !*****************************************************************************80 ! !! i4poly_add() adds two I4POLY's. ! ! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 November 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the degree of polynomial A. ! ! Input, integer A(0:NA), the coefficients of the first ! polynomial factor. ! ! Input, integer NB, the degree of polynomial B. ! ! Input, integer B(0:NB), the coefficients of the ! second polynomial factor. ! ! Output, integer C(0:max(NA,NB)), the coefficients of A + B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer na integer nb integer a(0:na) integer b(0:nb) integer c(0:max(na,nb)) integer d(0:max(na,nb)) if ( nb == na ) then d(0:na) = a(0:na) + b(0:na) else if ( nb < na ) then d(0:nb) = a(0:nb) + b(0:nb) d(nb+1:na) = a(nb+1:na) else if ( na < nb ) then d(0:na) = a(0:na) + b(0:na) d(na+1:nb) = b(na+1:nb) end if c(0:max(na,nb)) = d(0:max(na,nb)) return end subroutine i4poly_cyclo ( n, phi ) !*****************************************************************************80 ! !! i4poly_cyclo() computes a cyclotomic polynomial. ! ! Discussion: ! ! For 1 <= N, 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Raymond Seroul, ! Programming for Mathematicians, ! Springer, 2000, ! ISBN: 3-540-66422-X. ! ! Parameters: ! ! Input, integer N, the index of the cyclotomic polynomial ! desired. ! ! Output, integer PHI(0:N), the N-th cyclotomic polynomial. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 i4_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 ( max_poly < num_n + d ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4POLY_CYCLO - Fatal error!' write ( *, '(a)' ) ' Numerator polynomial degree too high.' stop 1 end if call i4poly_mul ( num_n, num, d, factor, num ) num_n = num_n + d else if ( mu == -1 ) then if ( max_poly < den_n + d ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4POLY_CYCLO - Fatal error!' write ( *, '(a)' ) ' Denominator polynomial degree too high.' stop 1 end if call i4poly_mul ( den_n, den, d, factor, den ) den_n = den_n + d end if end if end do ! ! PHI = NUM / DEN ! call i4poly_div ( num_n, num, den_n, den, nq, phi, nr, rem ) return end subroutine i4poly_degree ( na, a, degree ) !*****************************************************************************80 ! !! i4poly_degree() returns the degree of an I4POLY. ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer na integer a(0:na) integer degree degree = na do while ( 0 < degree ) if ( a(degree) /= 0 ) then return end if degree = degree - 1 end do return end subroutine i4poly_dif ( na, a, d, b ) !*****************************************************************************80 ! !! i4poly_dif() differentiates an I4POLY. ! ! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 November 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the degree of polynomial A. ! ! Input, integer A(0:NA), the coefficients of a polynomial. ! ! Input, integer D, the number of times the polynomial ! is to be differentiated. ! ! Output, integer B(0:NA-D), the coefficients of the ! differentiated polynomial. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer na integer d integer a(0:na) integer b(0:na-d) integer i integer i4_fall if ( na < d ) then b(0) = 0 return end if do i = 0, na - d b(i) = a(i+d) * i4_fall ( i + d, d ) end do return end subroutine i4poly_div ( na, a, nb, b, nq, q, nr, r ) !*****************************************************************************80 ! !! i4poly_div() computes the quotient and remainder of two I4POLY's. ! ! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the degree of polynomial A. ! ! Input, integer A(0:NA), the coefficients of the polynomial ! to be divided. ! ! Input, integer NB, the degree of polynomial B. ! ! Input, integer B(0:NB), the coefficients of the divisor ! polynomial. ! ! Output, integer NQ, the degree of polynomial 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 polynomial 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, parameter :: rk = kind ( 1.0D+00 ) 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 i4poly_degree ( na, a, na2 ) call i4poly_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 i4poly_mul ( na, a, nb, b, c ) !*****************************************************************************80 ! !! i4poly_mul() computes the product of two I4POLY's. ! ! 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NA, the degree of polynomial A. ! ! Input, integer A(0:NA), the coefficients of the first ! polynomial factor. ! ! Input, integer NB, the degree of polynomial 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, parameter :: rk = kind ( 1.0D+00 ) integer na integer nb integer a(0:na) integer b(0:nb) integer c(0:na+nb) integer d(0:na+nb) integer i 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 i4poly_print ( n, a, title ) !*****************************************************************************80 ! !! i4poly_print() prints an I4POLY. ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x^(n-1) + a(n)*x^(n) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the degree of the polynomial 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, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(0:n) integer i integer mag integer n2 character plus_minus character ( len = * ) title write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) '' call i4poly_degree ( n, a, n2 ) if ( a(n2) < 0 ) then plus_minus = '-' else plus_minus = '' end if mag = abs ( a(n2) ) if ( 2 <= n2 ) then write ( *, '( '' p(x) = '', a1, i8, '' * x ^ '', i3 )' ) & plus_minus, mag, n2 else if ( n2 == 1 ) then write ( *, '( '' p(x) = '', a1, i8, '' * x'' )' ) plus_minus, mag else if ( n2 == 0 ) then write ( *, '( '' p(x) = '', a1, i8 )' ) plus_minus, mag end if do i = n2 - 1, 0, -1 if ( a(i) < 0.0D+00 ) then plus_minus = '-' else plus_minus = '+' end if mag = abs ( a(i) ) if ( mag /= 0 ) then if ( 2 <= i ) then write ( *, ' ( '' '', a1, i8, '' * x ^ '', i3 )' ) & plus_minus, mag, i else if ( i == 1 ) then write ( *, ' ( '' '', a1, i8, '' * x'' )' ) plus_minus, mag else if ( i == 0 ) then write ( *, ' ( '' '', a1, i8 )' ) plus_minus, mag end if end if end do return end subroutine i4poly_to_i4 ( n, a, x, value ) !*****************************************************************************80 ! !! i4poly_to_i4() evaluates an I4POLY. ! ! Discussion: ! ! The power sum form is: ! ! p(x) = a(0) + a(1)*x + ... + a(n-1)*x^(n-1) + a(n)*x^(n) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the degree of the polynomial. ! ! Input, integer A(0:N), the polynomial coefficients. ! A(0) is the constant term and ! A(N) is the coefficient of X^N. ! ! Input, integer X, the point at which the polynomial is ! to be evaluated. ! ! Output, integer VALUE, the value of the polynomial. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(0:n) integer i integer value integer x value = 0 do i = n, 0, -1 value = value * x + a(i) end do return end function i4vec_ascends ( n, x ) !*****************************************************************************80 ! !! i4vec_ascends() determines if an I4VEC is (weakly) ascending. ! ! Discussion: ! ! The sequence is not required to be strictly ascending. ! ! Example: ! ! X = ( -8, 1, 2, 3, 7, 7, 9 ) ! ! I4VEC_ASCENDS = TRUE ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the array. ! ! Input, integer X(N), the array to be examined. ! ! Output, logical I4VEC_ASCENDS, is TRUE if the entries of X ascend. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i logical i4vec_ascends integer x(n) i4vec_ascends = .false. do i = 1, n - 1 if ( x(i+1) < x(i) ) then return end if end do i4vec_ascends = .true. return end subroutine i4vec_backtrack ( n, maxstack, x, indx, k, nstack, stack, ncan ) !*****************************************************************************80 ! !! i4vec_backtrack() supervises a backtrack search for an I4VEC. ! ! 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; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 June 2015 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of positions to be filled in ! the vector. ! ! Input, integer MAXSTACK, the maximum length of the stack. ! ! Input/output, integer X(N), the partially filled in ! candidate vector. ! ! Input/output, integer INDX, a communication flag. ! On input, ! 0, to begin a backtracking search. ! 2, the requested candidates for position K have been added to ! STACK, and NCAN(K) was updated. ! 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. ! ! Input/output, integer K, the index in X that we are trying ! to fill. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input/output, integer STACK(MAXSTACK), a list of all current ! candidates for all positions 1 through K. ! ! Input/output, integer NCAN(N), lists the current number ! of candidates for all positions 1 through K. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ( 0 < ncan(k) ) 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 function i4vec_descends ( n, x ) !*****************************************************************************80 ! !! i4vec_descends() determines if an I4VEC is decreasing. ! ! Example: ! ! X = ( 9, 7, 7, 3, 2, 1, -8 ) ! ! I4VEC_DESCENDS = TRUE ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 I4VEC_DESCEND, is TRUE if the entries of X descend. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i logical i4vec_descends integer x(n) i4vec_descends = .false. do i = 1, n - 1 if ( x(i) < x(i+1) ) then return end if end do i4vec_descends = .true. return end subroutine i4vec_frac ( n, a, k, afrac ) !*****************************************************************************80 ! !! i4vec_frac() searches for the K-th smallest element in an I4VEC. ! ! Discussion: ! ! Hoare's algorithm is used. ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! John Burkardt ! ! 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 AFRAC, the value of the K-th fractile of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer a(n) integer afrac integer iryt integer ix integer j integer k integer left if ( n <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4VEC_FRAC - Fatal error!' write ( *, '(a,i8)' ) ' Illegal nonpositive value of N = ', n stop 1 end if if ( k <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4VEC_FRAC - Fatal error!' write ( *, '(a,i8)' ) ' Illegal nonpositive value of K = ', k stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'I4VEC_FRAC - Fatal error!' write ( *, '(a,i8)' ) ' Illegal N < K, K = ', k stop 1 end if left = 1 iryt = n do if ( iryt <= left ) then afrac = a(k) exit end if ix = a(k) i = left j = iryt do if ( j < i ) 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 i4_swap ( a(i), a(j) ) i = i + 1 j = j - 1 end if end do end do return end subroutine i4vec_heap_d ( n, a ) !*****************************************************************************80 ! !! i4vec_heap_d() reorders an I4VEC into an descending heap. ! ! Discussion: ! ! An I4VEC is a vector of integer values. ! ! A descending heap is an array A with the property that, for every index J, ! A(J) >= A(2*J) and A(J) >= A(2*J+1), (as long as the indices ! 2*J and 2*J+1 are legal). ! ! A(1) ! / \ ! A(2) A(3) ! / \ / \ ! A(4) A(5) A(6) A(7) ! / \ / \ ! A(8) A(9) A(10) A(11) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Parameters: ! ! Input, integer N, the size of the input array. ! ! Input/output, integer A(N). ! On input, an unsorted array. ! On output, the array has been reordered into a heap. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer ifree integer key integer m ! ! Only nodes N/2 down to 1 can be "parent" nodes. ! do i = n / 2, 1, -1 ! ! Copy the value out of the parent node. ! Position IFREE is now "open". ! key = a(i) ifree = i do ! ! Positions 2*IFREE and 2*IFREE + 1 are the descendants of position ! IFREE. (One or both may not exist because they exceed N.) ! m = 2 * ifree ! ! Does the first position exist? ! if ( n < m ) then exit end if ! ! Does the second position exist? ! if ( m + 1 <= n ) then ! ! If both positions exist, take the larger of the two values, ! and update M if necessary. ! if ( a(m) < a(m+1) ) then m = m + 1 end if end if ! ! If the large descendant is larger than KEY, move it up, ! and update IFREE, the location of the free position, and ! consider the descendants of THIS position. ! if ( a(m) <= key ) then exit end if a(ifree) = a(m) ifree = m end do ! ! Once there is no more shifting to do, KEY moves into the free spot IFREE. ! a(ifree) = key end do return end subroutine i4vec_indicator1 ( n, a ) !*****************************************************************************80 ! !! i4vec_indicator1() sets an I4VEC to the indicator vector (1,...,N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i do i = 1, n a(i) = i end do return end function i4vec_index ( n, a, aval ) !*****************************************************************************80 ! !! i4vec_index() returns the location of the first occurrence of a given value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 I4VEC_INDEX, the first location in A ! which has the value AVAL, or -1 if no such index exists. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer aval integer i integer i4vec_index do i = 1, n if ( a(i) == aval ) then i4vec_index = i return end if end do i4vec_index = -1 return end function i4vec_maxloc_last ( n, x ) !*****************************************************************************80 ! !! i4vec_maxloc_last() returns the index of the last maximal I4VEC entry. ! ! Example: ! ! X = ( 5, 1, 2, 5, 0, 5, 3 ) ! ! I4VEC_MAXLOC_LAST = 6 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 I4VEC_MAXLOC_LAST, the index of the ! last element of X of maximal value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i4vec_maxloc_last integer i4vec_maxval_last integer x(n) i4vec_maxloc_last = 0 do i = 1, n if ( i == 1 ) then i4vec_maxloc_last = 1 i4vec_maxval_last = x(1) else if ( i4vec_maxval_last <= x(i) ) then i4vec_maxloc_last = i i4vec_maxval_last = x(i) end if end do return end function i4vec_pairwise_prime ( n, a ) !*****************************************************************************80 ! !! i4vec_pairwise_prime() checks whether an I4VEC is pairwise prime. ! ! Discussion: ! ! Two positive integers I and J are pairwise prime if they have no common ! factor greater than 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 I4VEC_PAIRWISE_PRIME, is TRUE if the vector of integers ! is pairwise prime. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_gcd logical i4vec_pairwise_prime integer j i4vec_pairwise_prime = .false. do i = 1, n do j = i + 1, n if ( i4_gcd ( a(i), a(j) ) /= 1 ) then return end if end do end do i4vec_pairwise_prime = .true. return end subroutine i4vec_print ( n, a, title ) !*****************************************************************************80 ! !! i4vec_print() prints an I4VEC, with an optional title. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' do i = 1, n write ( *, '(i8,i10)' ) i, a(i) end do return end subroutine i4vec_reverse ( n, a ) !*****************************************************************************80 ! !! i4vec_reverse() reverses the elements of an I4VEC. ! ! Example: ! ! Input: ! ! N = 5, ! A = ( 11, 12, 13, 14, 15 ). ! ! Output: ! ! A = ( 15, 14, 13, 12, 11 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i do i = 1, n / 2 call i4_swap ( a(i), a(n+1-i) ) end do return end subroutine i4vec_sort_bubble_a ( n, a ) !*****************************************************************************80 ! !! i4vec_sort_bubble_a() ascending sorts an I4VEC using bubble sort. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer A(N). ! On input, the array to be sorted; ! On output, the array has been sorted. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer j do i = 1, n - 1 do j = i + 1, n if ( a(j) < a(i) ) then call i4_swap ( a(i), a(j) ) end if end do end do return end subroutine i4vec_sort_heap_a ( n, a ) !*****************************************************************************80 ! !! i4vec_sort_heap_a() ascending sorts an I4VEC using heap sort. ! ! Discussion: ! ! An I4VEC is a vector of integer values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms, ! Academic Press, 1978, second edition, ! ISBN 0-12-519260-6. ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, integer A(N). ! On input, the array to be sorted; ! On output, the array has been sorted. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer n1 integer t if ( n <= 1 ) then return end if ! ! 1: Put A into descending heap form. ! call i4vec_heap_d ( n, a ) ! ! 2: Sort A. ! ! The largest object in the heap is in A(1). ! Move it to position A(N). ! t = a(1) a(1) = a(n) a(n) = t ! ! Consider the diminished heap of size N1. ! do n1 = n - 1, 2, -1 ! ! Restore the heap structure of A(1) through A(N1). ! call i4vec_heap_d ( n1, a ) ! ! Take the largest object from A(1) and move it to A(N1). ! t = a(1) a(1) = a(n1) a(n1) = t end do return end subroutine i4vec_sort_heap_index_d ( n, a, indx ) !*****************************************************************************80 ! !! i4vec_sort_heap_index_d() does an indexed heap descending sort of an I4VEC. ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 January 2007 ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer aval integer i integer indx(n) integer indxt integer ir integer j integer l call i4vec_indicator1 ( n, indx ) l = n / 2 + 1 ir = n do if ( 1 < l ) 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 exit end if end if i = l j = l + l do while ( j <= ir ) if ( j < ir ) then if ( a(indx(j+1)) < a(indx(j)) ) then j = j + 1 end if end if if ( a(indx(j)) < aval ) 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 function i4vec_sum ( n, a ) !*****************************************************************************80 ! !! i4vec_sum() returns the sum of the entries of an I4VEC. ! ! Discussion: ! ! An I4VEC is a vector of I4's. ! ! In FORTRAN90, this facility is offered by the built in ! SUM function: ! ! I4VEC_SUM ( N, A ) = SUM ( A(1:N) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 September 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input, integer A(N), the array. ! ! Output, integer I4VEC_SUM, the sum of the entries. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i4vec_sum i4vec_sum = sum ( a(1:n) ) return end subroutine i4vec_transpose_print ( n, a, title ) !*****************************************************************************80 ! !! i4vec_transpose_print() prints an I4VEC "transposed". ! ! Discussion: ! ! An I4VEC is a vector of I4's. ! ! Example: ! ! A = (/ 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11 /) ! TITLE = 'My vector: ' ! ! My vector: ! 1 2 3 4 5 ! 6 7 8 9 10 ! 11 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2015 ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer ihi integer ilo character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if if ( 0 < n ) then do ilo = 1, n, 5 ihi = min ( ilo + 5 - 1, n ) write ( *, '(5i12)' ) a(ilo:ihi) end do else write ( *, '(a)' ) ' (empty vector)' end if return end subroutine i4vec_uniform_ab ( n, a, b, x ) !*****************************************************************************80 ! !! i4vec_uniform_ab() returns a scaled pseudorandom I4VEC. ! ! Discussion: ! ! An I4VEC is a vector of I4's. ! ! The pseudorandom numbers should be scaled to be uniformly distributed ! between A and B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Second Edition, ! Springer, 1987, ! ISBN: 0387964673, ! LC: QA76.9.C65.B73. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, December 1986, pages 362-376. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley, 1998, ! ISBN: 0471134031, ! LC: T57.62.H37. ! ! Peter Lewis, Allen Goodman, James Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, Number 2, 1969, pages 136-143. ! ! Parameters: ! ! Input, integer N, the dimension of the vector. ! ! Input, integer A, B, the limits of the interval. ! ! Output, integer X(N), a vector of numbers between A and B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a integer b integer i integer, parameter :: i4_huge = 2147483647 real r integer value integer x(n) do i = 1, n call random_number ( harvest = r ) ! ! Scale R to lie between A-0.5 and B+0.5. ! r = ( 1.0E+00 - r ) * ( real ( min ( a, b ) ) - 0.5E+00 ) & + r * ( real ( max ( a, b ) ) + 0.5E+00 ) ! ! Use rounding to convert R to an integer between A and B. ! value = nint ( r ) value = max ( value, min ( a, b ) ) value = min ( value, max ( a, b ) ) x(i) = value end do return end subroutine index_box2_next_2d ( n1, n2, ic, jc, i, j, more ) !*****************************************************************************80 ! !! index_box2_next_2d() produces index vectors 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 index vectors 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ( jc + n2 < j ) 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 ) !*****************************************************************************80 ! !! index_box2_next_3d() produces index vectors 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 index vectors 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ( kc + n3 < k ) 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 ( jc + n2 < j ) 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 ) !*****************************************************************************80 ! !! index_box_next_2d() produces index vectors on the surface of a box in 2D. ! ! Discussion: ! ! The index vectors 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ( n2 < j ) 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 ) !*****************************************************************************80 ! !! index_box_next_3d() produces index vectors on the surface of a box in 3D. ! ! Discussion: ! ! The index vectors 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ( n3 < k ) 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 ( n2 < j ) 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, a, more ) !*****************************************************************************80 ! !! index_next0() generates all index vectors within given upper limits. ! ! Discussion: ! ! The index vectors 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 A(N). ! On startup calls, with MORE = FALSE, the input value of A ! doesn't matter, because the routine initializes it. ! On calls with MORE = TRUE, the input value of A must be ! the output value of A from the previous call. (In other words, ! just leave it alone!). ! On output, A 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 to FALSE and you should stop calling the program. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi integer i integer inc logical more if ( .not. more ) then a(1:n) = 1 if ( hi < 1 ) then more = .false. write ( *, '(a)' ) '' write ( *, '(a)' ) 'INDEX_NEXT0 - Fatal error!' write ( *, '(a,i8)' ) ' HI is ', hi write ( *, '(a)' ) ' but HI must be at least 1.' stop 1 end if else inc = 1 do while ( hi <= a(inc) ) a(inc) = 1 inc = inc + 1 end do a(inc) = a(inc) + 1 end if ! ! See if there are more entries to compute. ! more = .false. do i = 1, n if ( a(i) < hi ) then more = .true. end if end do return end subroutine index_next1 ( n, hi, a, more ) !*****************************************************************************80 ! !! index_next1() generates all index vectors within given upper limits. ! ! Discussion: ! ! The index vectors 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 June 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 A(N). ! On startup calls, with MORE = FALSE, the input value of A ! doesn't matter, because the routine initializes it. ! On calls with MORE = TRUE, the input value of A must be ! the output value of A from the previous call. (In other words, ! just leave it alone!). ! On output, A 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi(n) integer i integer inc logical more if ( .not. more ) then a(1:n) = 1 do i = 1, n if ( hi(i) < 1 ) then more = .false. write ( *, '(a)' ) '' write ( *, '(a)' ) 'INDEX_NEXT1 - Fatal error!' write ( *, '(a,i8,a,i8)' ) ' Entry ', i, ' of HI is ', hi(i) write ( *, '(a)' ) ' but all entries must be at least 1.' stop 1 end if end do else inc = 1 do while ( hi(inc) <= a(inc) ) a(inc) = 1 inc = inc + 1 end do a(inc) = a(inc) + 1 end if ! ! See if there are more entries to compute. ! more = .false. do i = 1, n if ( a(i) < hi(i) ) then more = .true. end if end do return end subroutine index_next2 ( n, lo, hi, a, more ) !*****************************************************************************80 ! !! index_next2() generates all index vectors 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. 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 A(N). ! On startup calls, with MORE = FALSE, the input value of A ! doesn't matter, because the routine initializes it. ! On calls with MORE = TRUE, the input value of A must be ! the output value of A from the previous call. (In other words, ! just leave it alone!). ! On output, A 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi(n) integer i integer inc integer lo(n) logical more if ( .not. more ) then a(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,i8,a,i8)' ) ' Entry ', i, ' of HI is ', hi(i) write ( *, '(a,i8,a,i8)' ) ' Entry ', i, ' of LO is ', lo(i) write ( *, '(a)' ) ' but LO(I) <= HI(I) is required.' stop 1 end if end do else inc = 1 do while ( hi(inc) <= a(inc) ) a(inc) = lo(inc) inc = inc + 1 end do a(inc) = a(inc) + 1 end if ! ! See if there are more entries to compute. ! more = .false. do i = 1, n if ( a(i) < hi(i) ) then more = .true. end if end do return end subroutine index_rank0 ( n, hi, a, rank ) !*****************************************************************************80 ! !! index_rank0() ranks an index vector within given upper limits. ! ! Example: ! ! N = 3, ! HI = 3 ! A = ( 3, 1, 2 ) ! ! RANK = 12 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 A(N), the index vector to be ranked. ! ! Output, integer RANK, the rank of the index vector, or -1 if A ! is not a legal index. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi integer i integer range integer rank rank = -1 do i = 1, n if ( a(i) < 1 .or. hi < a(i) ) then return end if end do rank = 0 do i = n, 1, -1 rank = hi * rank + a(i) end do rank = 1 range = 1 do i = 1, n rank = rank + ( a(i) - 1 ) * range range = range * hi end do return end subroutine index_rank1 ( n, hi, a, rank ) !*****************************************************************************80 ! !! index_rank1() ranks an index vector within given upper limits. ! ! Example: ! ! N = 3, ! HI(1) = 4, HI(2) = 2, HI(3) = 3 ! A = ( 4, 1, 2 ) ! ! RANK = 12 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 A(N), the index to be ranked. ! ! Output, integer RANK, the rank of the index vector, or -1 if A ! is not a legal index. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi(n) integer i integer range integer rank rank = -1 do i = 1, n if ( a(i) < 1 .or. hi(i) < a(i) ) then return end if end do rank = 0 do i = n, 1, -1 rank = hi(i) * rank + a(i) end do rank = 1 range = 1 do i = 1, n rank = rank + ( a(i) - 1 ) * range range = range * hi(i) end do return end subroutine index_rank2 ( n, lo, hi, a, rank ) !*****************************************************************************80 ! !! index_rank2() ranks an index vector 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 ! A = ( 1, 11, 5 ) ! ! RANK = 7 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 A(N), the index vector to be ranked. ! ! Output, integer RANK, the rank of the index vector, ! or -1 if A is not a legal index vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi(n) integer i integer lo(n) integer range integer rank do i = 1, n if ( a(i) < lo(i) .or. hi(i) < a(i) ) then rank = -1 return end if end do rank = 1 range = 1 do i = 1, n rank = rank + ( a(i) - lo(i) ) * range range = range * ( hi(i) + 1 - lo(i) ) end do return end subroutine index_unrank0 ( n, hi, rank, a ) !*****************************************************************************80 ! !! index_unrank0 unranks an index vector within given upper limits. ! ! Example: ! ! N = 3, ! HI = 3 ! RANK = 12 ! ! A = ( 3, 1, 2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 vector. ! ! Output, integer A(N), the index vector of the given rank. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi integer i integer j integer k integer range integer rank a(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 ( range < rank ) then return end if k = rank - 1 do i = n, 1, -1 range = range / hi j = k / range a(i) = j + 1 k = k - j * range end do return end subroutine index_unrank1 ( n, hi, rank, a ) !*****************************************************************************80 ! !! index_unrank1 unranks an index vector within given upper limits. ! ! Example: ! ! N = 3, ! HI(1) = 4, HI(2) = 2, HI(3) = 3 ! RANK = 11 ! ! A = ( 3, 1, 2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 vector. ! ! Output, integer A(N), the index vector of the given rank. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi(n) integer i integer j integer k integer range integer rank a(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 ( range < rank ) then return end if k = rank - 1 do i = n, 1, -1 range = range / hi(i) j = k / range a(i) = j + 1 k = k - j * range end do return end subroutine index_unrank2 ( n, lo, hi, rank, a ) !*****************************************************************************80 ! !! index_unrank2 unranks an index vector 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 ! ! A = ( 1, 11, 5 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 July 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in A. ! ! 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 A(N), the index vector of the given rank. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer hi(n) integer i integer j integer k integer lo(n) integer range integer rank a(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 ( range < rank ) then return end if k = rank - 1 do i = n, 1, -1 range = range / ( hi(i) + 1 - lo(i) ) j = k / range a(i) = j + lo(i) k = k - j * range end do return end subroutine inverse_mod_n ( b, n, y ) !*****************************************************************************80 ! !! inverse_mod_n() computes the inverse of B mod N. ! ! Discussion: ! ! If ! ! Y = inverse_mod_n ( B, N ) ! ! then ! ! mod ( B * Y, N ) = 1 ! ! The value Y will exist if and only if B and N are relatively prime. ! ! Examples: ! ! B N Y ! ! 1 2 1 ! ! 1 3 1 ! 2 3 2 ! ! 1 4 1 ! 2 4 0 ! 3 4 3 ! ! 1 5 1 ! 2 5 3 ! 3 5 2 ! 4 5 4 ! ! 1 6 1 ! 2 6 0 ! 3 6 0 ! 4 6 0 ! 5 6 5 ! ! 1 7 1 ! 2 7 4 ! 3 7 5 ! 4 7 2 ! 5 7 3 ! 6 7 6 ! ! 1 8 1 ! 2 8 0 ! 3 8 3 ! 4 8 0 ! 5 8 5 ! 6 8 0 ! 7 8 7 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 November 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer B, the number whose inverse mod N is desired. ! B should be positive. Normally, B < N, but this is not required. ! ! Input, integer N, the number with respect to which the ! modulus is computed. N should be positive. ! ! Output, integer Y, the inverse of B mod N, or 0 if there ! is not inverse for B mode N. 1 <= Y < N if the inverse exists. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer b integer b0 integer n integer n0 integer q integer r integer t integer t0 integer temp integer y n0 = n b0 = b t0 = 0 t = 1 q = n / b r = n - q * b do while ( 0 < r ) temp = t0 - q * t if ( 0 <= temp ) then temp = mod ( temp, n ) end if if ( temp < 0 ) then temp = n - mod ( - temp, n ) end if t0 = t t = temp n0 = b0 b0 = r q = n0 / b0 r = n0 - q * b0 end do if ( b0 /= 1 ) then y = 0 return end if y = mod ( t, n ) return end subroutine inversion_to_perm1 ( n, ins, p ) !*****************************************************************************80 ! !! inversion_to_perm1(): inversion sequence to permutation of (1,...,N). ! ! Discussion: ! ! 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(I) < P(J). ! ! Example: ! ! Input: ! ! ( 0, 0, 2, 1, 3 ) ! ! Output: ! ! ( 3, 5, 1, 4, 2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 July 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ins(n) integer itemp integer j integer p(n) call i4vec_indicator1 ( 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 involute_enum ( n, s ) !*****************************************************************************80 ! !! involute_enum() enumerates the involutions of N objects. ! ! Discussion: ! ! An involution is a permutation consisting only of fixed points and ! pairwise transpositions. ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 May 2003 ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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) + ( i - 1 ) * s(i-2) end do return end subroutine jfrac_to_rfrac ( m, r, s, p, q ) !*****************************************************************************80 ! !! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 April 2000 ! ! Author: ! ! Original FORTRAN77 version by John Hart, Ward Cheney, Charles Lawson, ! Hans Maehly, Charles Mesztenyi, John Rice, Henry Thatcher, ! Christoph Witzgall, ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, Charles Mesztenyi, ! John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! 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 ( kind = rk ) R(M), S(M), the coefficients defining ! the J-fraction. ! ! Output, real ( kind = rk ) 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, parameter :: rk = kind ( 1.0D+00 ) integer m real ( kind = rk ) a(m,m) real ( kind = rk ) b(m,m) integer i integer k real ( kind = rk ) p(m) real ( kind = rk ) q(m+1) real ( kind = rk ) r(m) real ( kind = rk ) s(m) a(1,1) = r(1) b(1,1) = s(1) if ( 1 < m ) 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.0D+00 return end subroutine josephus ( n, m, k, x ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 April 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! WW 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, ! ISBN: 0201896850, ! LC: QA76.6.K64. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer i4_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 1 end if if ( m == 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'JOSEPHUS - Fatal error!' write ( *, '(a)' ) ' M = 0.' stop 1 end if if ( k <= 0 .or. n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'JOSEPHUS - Fatal error!' write ( *, '(a)' ) ' J <= 0 or N < K.' stop 1 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 = i4_modp ( m, n ) x = k * m2 do while ( n < x ) x = ( m2 * ( x - n ) - 1 ) / ( m2 - 1 ) end do return end subroutine ksub_next ( n, k, a, more, m, m2 ) !*****************************************************************************80 ! !! ksub_next() generates the subsets of size K from a set of size N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 May 2015 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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. ! ! Input/output, integer A(K). A(I) is the I-th element of the ! subset. Thus A(I) will be an integer between 1 and N. ! Note that the routine will return the values in A ! in sorted order: 1 <= A(1) < A(2) < ... < A(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. ! ! Input/output, integer M, M2, two variables used by this ! procedure for bookkeeping. The user must declare these variables, ! and the output values from one call must be used as the input values ! on the next. The user should not change these values. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer j integer m integer m2 logical more integer n if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT - Fatal error!' write ( *, '(a,i8)' ) 'K = ', k write ( *, '(a)' ) 'but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT - Fatal error!' write ( *, '(a,i8)' ) 'N = ', n write ( *, '(a,i8)' ) 'K = ', k write ( *, '(a)' ) 'but K <= N is required!' stop 1 end if if ( .not. more ) then m2 = 0 m = k else if ( m2 < n - m ) then m = 0 end if m = m + 1 m2 = a(k+1-m) end if do j = 1, m a(k+j-m) = m2 + j end do more = ( a(1) /= ( n - k + 1 ) ) return end subroutine ksub_next2 ( n, k, a, in, iout ) !*****************************************************************************80 ! !! ksub_next2() generates the subsets of size K from a set of size N. ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2001 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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 A(K). On input, the user must ! supply a subset of size K in A. That is, A must ! contain K unique numbers, in order, between 1 and N. On ! output, A(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, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(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,i8)' ) ' N = ', n write ( *, '(a)' ) ' but 0 < N is required!' stop 1 end if if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT2 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT2 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if j = 0 do if ( 0 < j .or. mod ( k, 2 ) == 0 ) then j = j + 1 if ( k < j ) then a(k) = k in = k iout = n return end if if ( a(j) /= j ) then iout = a(j) in = iout - 1 a(j) = in if ( j /= 1 ) then in = j - 1 a(j-1) = in end if return end if end if j = j + 1 m = n if ( j < k ) then m = a(j+1) - 1 end if if ( m /= a(j) ) then exit end if end do in = a(j) + 1 a(j) = in iout = in - 1 if ( j /= 1 ) then a(j-1) = iout iout = j - 1 end if return end subroutine ksub_next3 ( n, k, a, more, in, iout ) !*****************************************************************************80 ! !! ksub_next3() generates the subsets of size K from a set of size N. ! ! Discussion: ! ! The routine uses the revolving door method. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 March 2001 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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. ! ! Input/output, integer A(K). A(I) is the I-th element of the ! output subset. The elements of A 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, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(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,i8)' ) ' N = ', n write ( *, '(a)' ) ' but 0 < N is required!' stop 1 end if if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT3 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT3 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if if ( .not. more ) then in = 0 iout = 0 call i4vec_indicator1 ( k, a ) more = ( k /= n ) return end if j = 0 do if ( 0 < j .or. mod ( k, 2 ) == 0 ) then j = j + 1 if ( a(j) /= j ) then iout = a(j) in = iout - 1 a(j) = in if ( j /= 1 ) then in = j - 1 a(j-1) = in end if if ( k /= 1 ) then more = ( a(k-1) == k - 1 ) end if more = ( .not. more ) .or. ( a(k) /= n ) return end if end if j = j + 1 m = n if ( j < k ) then m = a(j+1) - 1 end if if ( m /= a(j) ) then exit end if end do in = a(j) + 1 a(j) = in iout = in - 1 if ( j /= 1 ) then a(j-1) = iout iout = j - 1 end if if ( k /= 1 ) then more = ( a(k-1) == k - 1 ) end if more = ( .not. more ) .or. ( a(k) /= n ) return end subroutine ksub_next4 ( n, k, a, done ) !*****************************************************************************80 ! !! ksub_next4() generates the subsets of size K from a set of size N. ! ! 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 ! A 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 May 2018 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the entire set. ! 0 <= N. ! ! Input, integer K, the size of the desired subset. ! 0 <= K <= N. ! ! Input/output, integer A(K), contains information about ! the subsets. On the first call with DONE = TRUE, the input contents ! of A don't matter. Thereafter, the input value of A ! 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, A contains ! information defining a subset of K elements of a set of N elements. ! In other words, A will contain K distinct numbers (in order) ! between 1 and N. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) logical done integer j integer jsave integer n if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT4 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_NEXT4 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if ! ! First call: ! if ( done ) then call i4vec_indicator1 ( k, a ) done = .false. ! ! Empty set returned on previous call. ! else if ( n == 0 .or. k == 0 ) then done = .true. ! ! Next call. ! else if ( a(1) < n - k + 1 ) then jsave = k do j = 1, k - 1 if ( a(j) + 1 < a(j+1) ) then jsave = j exit end if end do call i4vec_indicator1 ( jsave - 1, a ) a(jsave) = a(jsave) + 1 done = .false. else done = .true. end if return end subroutine ksub_random ( n, k, a ) !*****************************************************************************80 ! !! ksub_random() selects a random subset of size K from a set of size N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 April 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets ! are drawn. ! ! Input, integer K, number of elements in desired subsets. ! 0 <= K <= N. ! ! Output, integer A(K). A(I) is the I-th element of the ! output set. The elements of A are in order. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer i integer i4_uniform_ab integer ids integer ihi integer ip integer ir integer is integer ix integer l integer ll integer m integer m0 integer n if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' K <= N is required!' stop 1 end if if ( k == 0 ) then return end if do i = 1, k a(i) = ( ( i - 1 ) * n ) / k end do do i = 1, k do ix = i4_uniform_ab ( 1, n ) l = 1 + ( ix * k - 1 ) / n if ( a(l) < ix ) then exit end if end do a(l) = a(l) + 1 end do ip = 0 is = k do i = 1, k m = a(i) a(i) = 0 if ( m /= ( ( i - 1 ) * n ) / k ) then ip = ip + 1 a(ip) = m end if end do ihi = ip do i = 1, ihi ip = ihi + 1 - i l = 1 + ( a(ip) * k - 1 ) / n ids = a(ip) - ( ( l - 1 ) * n ) / k a(ip) = 0 a(is) = l is = is - ids end do do ll = 1, k l = k + 1 - ll if ( a(l) /= 0 ) then ir = l m0 = 1 + ( ( a(l) - 1 ) * n ) / k m = ( a(l) * n ) / k - m0 + 1 end if ! ! There is something wrong with this algorithm! ! If A[L-1] is zero, then the values of IR, M0, and M are not defined ! on this loop iteration, and hence are either STALE values from the ! previous iteration, or UNDEFINED if this is the first pass. ! JVB, 21 December 2014. ! ix = i4_uniform_ab ( m0, m0 + m - 1 ) i = l + 1 do while ( i <= ir ) if ( ix < a(i) ) then exit end if ix = ix + 1 a(i-1) = a(i) i = i + 1 end do a(i-1) = ix m = m - 1 end do return end subroutine ksub_random2 ( n, k, a ) !*****************************************************************************80 ! !! ksub_random2() selects a random subset of size K from a set of size N. ! ! Discussion: ! ! This algorithm is designated Algorithm RKS2 in the reference. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2015 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! A Bebbington, ! A simple method of drawing a sample without replacement, ! Journal of Applied Statistics, ! Volume 24, 1975, page 136. ! ! Parameters: ! ! Input, integer N, the size of the set. ! ! Input, integer K, the size of the subset. ! ! Output, integer A(K), the indices of the selected elements. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer c1 integer c2 integer i integer k0 integer n real ( kind = rk ) r if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM2 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM2 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if if ( k == 0 ) then return end if c1 = k c2 = n k0 = 0 i = 0 do i = i + 1 call random_number ( harvest = r ) if ( real ( c2, kind = rk ) * r <= real ( c1, kind = rk ) ) then c1 = c1 - 1 k0 = k0 + 1 a(k0) = i if ( c1 <= 0 ) then exit end if end if c2 = c2 - 1 end do return end subroutine ksub_random3 ( n, k, a ) !*****************************************************************************80 ! !! ksub_random3() selects a random subset of size K from a set of size N. ! ! Discussion: ! ! This routine uses Floyd's algorithm. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! 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 A(N). I is an element of the subset ! if A(I) = 1, and I is not an element if A(I)=0. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_uniform_ab integer j integer k if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM3 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM3 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if a(1:n) = 0 if ( k == 0 ) then return end if do i = n - k + 1, n j = i4_uniform_ab ( 1, i ) if ( a(j) == 0 ) then a(j) = 1 else a(i) = 1 end if end do return end subroutine ksub_random4 ( n, k, a ) !*****************************************************************************80 ! !! ksub_random4() selects a random subset of size K from a set of size N. ! ! Discussion: ! ! This routine is somewhat impractical for the given problem, but ! it is included for comparison, because it is an interesting ! approach that is superior for certain applications. ! ! The approach is mainly interesting because it is "incremental"; ! it proceeds by considering every element of the set, and does not ! need to know how many elements there are. ! ! This makes this approach ideal for certain cases, such as the ! need to pick 5 lines at random from a text file of unknown length, ! or to choose 6 people who call a certain telephone number on a ! given day. Using this technique, it is possible to make the ! selection so that, whenever the input stops, a valid uniformly ! random subset has been chosen. ! ! Obviously, if the number of items is known in advance, and ! it is easy to extract K items directly, there is no need for ! this approach, and it is less efficient since, among other costs, ! it has to generate a random number for each item, and make an ! acceptance/rejection test. ! ! This routine is based on "8.6: Picking a Random Line from a File", ! in the Perl Cookbook. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 July 2016 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Tom Christiansen, Nathan Torkington, ! Perl Cookbook, ! OReilly, 1999. ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets ! are drawn. ! ! Input, integer K, number of elements in desired subsets. ! 0 <= K <= N. ! ! Output, integer A(K), contains the indices of the ! selected items. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_uniform_ab integer k integer next real ( kind = rk ) r if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM4 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM4 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if next = 0 ! ! Here, we use a DO WHILE to suggest that the algorithm ! proceeds to the next item, without knowing how many items ! there are in total. ! ! Note that this is really the only place where N occurs, ! so other termination criteria could be used, and we really ! don't need to know the value of N! ! do while ( next < n ) next = next + 1 if ( next <= k ) then i = next a(i) = next else call random_number ( harvest = r ) if ( r * real ( next, kind = rk ) <= real ( k, kind = rk ) ) then i = i4_uniform_ab ( 1, k ) ! ! If we slide the current values down, and add the new item at the end, ! our subset will be ordered. ! a(i:k-1) = a(i+1:k) a(k) = next ! a(i) = next end if end if end do ! ! Put the elements in ascending order. ! call i4vec_sort_heap_a ( k, a ) return end subroutine ksub_random5 ( n, k, a ) !*****************************************************************************80 ! !! ksub_random5() selects a random subset of size K from a set of size N. ! ! Discussion: ! ! Consider the set A(1:N) = 1, 2, 3, ... N. ! Choose a random index I1 between 1 and N, and swap items A(1) and A(I1). ! Choose a random index I2 between 2 and N, and swap items A(2) and A(I2). ! repeat K times. ! A(1:K) is your random K-subset. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 June 2011 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the set from which subsets ! are drawn. ! ! Input, integer K, number of elements in desired subsets. ! 1 <= K <= N. ! ! Output, integer A(K), the indices of the randomly ! chosen elements. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer n integer a(k) integer b(n) integer i integer i4_uniform_ab integer j integer t if ( k < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM5 - Fatal error!' write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but 0 <= K is required!' stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'KSUB_RANDOM5 - Fatal error!' write ( *, '(a,i8)' ) ' N = ', n write ( *, '(a,i8)' ) ' K = ', k write ( *, '(a)' ) ' but K <= N is required!' stop 1 end if ! ! Let B index the set. ! do i = 1, n b(i) = i end do ! ! Choose item 1 from N things, ! choose item 2 from N-1 things, ! choose item K from N-K+1 things. ! do i = 1, k j = i4_uniform_ab ( i, n ) t = b(i) b(i) = b(j) b(j) = t end do ! ! Copy the first K elements. ! a(1:k) = b(1:k) ! ! Put the elements in ascending order. ! call i4vec_sort_heap_a ( k, a ) return end subroutine ksub_rank ( k, a, rank ) !*****************************************************************************80 ! !! ksub_rank() computes the rank of a K 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. ! ! It uses the same ranking that KSUB_NEXT2 uses to generate all the subsets ! one at a time. ! ! Note the value of N is not input, and is not, in fact, ! needed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 May 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer K, the number of elements in the subset. ! ! Input, integer A(K), contains K distinct numbers between ! 1 and N, in order. ! ! Output, integer RANK, the rank of this subset. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer i integer iprod integer j integer rank rank = 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 rank = rank + iprod end do rank = rank + 1 return end subroutine ksub_to_comp ( ns, ks, as, nc, kc, ac ) !*****************************************************************************80 ! !! ksub_to_comp() converts a K-subset to a composition. ! ! Discussion: ! ! There is a bijection between K subsets and compositions. ! ! Because we allow a composition to have entries that are 0, we need ! to implicitly add 1 to each entry before establishing the bijection. ! ! Let AS be a KS subset of a set of the integers 1 through NS. ! ! Then let ! NC = NS - KS, ! KC = KS + 1, ! and define ! AC(1) = AS(1) - 1; ! AC(2:KC-1) = AS(2:KC-1) - AS(1:KC-2) - 1; ! AC(KC) = NS - AS(KS). ! ! Then AC is a composition of NC into KC parts. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 December 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NS, the size of the set. ! ! Input, integer KS, the size of the subset. ! ! Input, integer AS(KS), the entries of the K-subset, ! in increasing order. ! ! Output, integer NC, the composition sum. ! ! Output, integer KC, the number of parts of the composition. ! ! Output, integer AC(KC), the parts of the composition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer ks integer ac(kc) integer as(ks) integer i integer nc integer ns nc = ns - ks kc = ks + 1 ac(1) = as(1) - 1 do i = 2, kc - 1; ac(i) = as(i) - as(i-1) - 1 end do ac(kc) = ns - as(ks) return end subroutine ksub_to_compnz ( ns, ks, as, nc, kc, ac ) !*****************************************************************************80 ! !! ksub_to_compnz() converts a K-subset to a nonzero composition. ! ! Discussion: ! ! There is a bijection between K subsets and nonzero compositions. ! ! Let AS be a KS subset of a set of the integers 1 through NS. ! ! Then let ! NC = NS + 1 ! KC = KS + 1, ! and define ! AC(1) = AS(1); ! AC(2:KC-1) = AS(2:KC-1) - AS(1:KC-2); ! AC(KC) = NC - AS(KS). ! ! Then AC is a composition of NC into KC parts. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NS, the size of the set. ! ! Input, integer KS, the size of the subset. ! ! Input, integer AS(KS), the entries of the K-subset, ! in increasing order. ! ! Output, integer NC, the composition sum. ! ! Output, integer KC, the number of parts of the composition. ! ! Output, integer AC(KC), the parts of the composition. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kc integer ks integer ac(kc) integer as(ks) integer i integer nc integer ns nc = ns + 1 kc = ks + 1 ac(1) = as(1) do i = 2, kc - 1; ac(i) = as(i) - as(i-1) end do ac(kc) = nc - as(ks) return end subroutine ksub_unrank ( k, rank, a ) !*****************************************************************************80 ! !! ksub_unrank() returns the subset of a given rank. ! ! Discussion: ! ! The routine is given a rank and returns the corresponding subset of K ! elements of a set of N elements. ! ! It uses the same ranking that KSUB_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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 June 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer K, the number of elements in the subset. ! ! Input, integer RANK, the rank of the desired subset. ! There are ( N*(N-1)*...*(N+K-1)) / ( K*(K-1)*...*2*1) such ! subsets, so RANK must be between 1 and that value. ! ! Output, integer A(K), K distinct integers in order between ! 1 and N, which define the subset. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer i integer ip integer iprod integer jrank integer rank jrank = rank - 1 do i = k, 1, -1 ip = i - 1 iprod = 1 do ip = ip + 1 if ( ip /= i ) then iprod = ( ip * iprod ) / ( ip - i ) end if if ( jrank < iprod ) 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 l4vec_next ( n, l4vec ) !*****************************************************************************80 ! !! l4vec_next() generates the next logical vector. ! ! Discussion: ! ! In the following discussion, we will let '0' stand for FALSE and ! '1' for TRUE. ! ! The logical vectors have the order ! ! (0,0,...,0), ! (0,0,...,1), ! ... ! (1,1,...,1) ! ! and the "next" vector after (1,1,...,1) is (0,0,...,0). That is, ! we allow wrap around. ! ! Example: ! ! N = 3 ! ! Input Output ! ----- ------ ! 0 0 0 => 0 0 1 ! 0 0 1 => 0 1 0 ! 0 1 0 => 0 1 1 ! 0 1 1 => 1 0 0 ! 1 0 0 => 1 0 1 ! 1 0 1 => 1 1 0 ! 1 1 0 => 1 1 1 ! 1 1 1 => 0 0 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2008 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of the vectors. ! ! Input/output, logical L4VEC(N), on output, the successor to the ! input vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i logical l4vec(n) do i = n, 1, -1 if ( .not. l4vec(i) ) then l4vec(i) = .true. return end if l4vec(i) = .false. end do return end subroutine matrix_product_opt ( n, rank, cost, order ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 April 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Sedgewick, ! Algorithms in C, ! Addison-Wesley, 1990, ! ISBN: 0-201-51425-7, ! LC: QA76.73.C15S43. ! ! 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 :: rk = kind ( 1.0D+00 ) integer, parameter :: stack_max = 100 integer n integer best(n,n) integer cost integer cost2(n,n) integer cost3 integer i integer i1 integer i2 integer i3 integer i4_huge 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) = i4_huge ( ) 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 ( 0 < stack_num ) 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 ) !*****************************************************************************80 ! !! moebius_matrix() finds the Moebius matrix from a covering relation. ! ! Discussion: ! ! This routine can be called with A and MU being the same matrix. ! The routine will correctly compute the Moebius matrix, which ! will, in this case, overwrite the input matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n,n) integer i integer j integer mu(n,n) integer p(n) integer q(n) ! ! Compute a reordering P of the elements of the partially ordered matrix. ! call triang ( n, a, p ) ! ! Copy the matrix. ! mu(1:n,1:n) = a(1:n,1:n) ! ! Apply the reordering to MU. ! call i4mat_2perm1 ( n, n, mu, p, p ) ! ! 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 i4mat_u1_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 i4mat_u1_inverse ( n, mu, mu ) ! ! Compute the inverse permutation. ! do i = 1, n q(p(i)) = i end do ! ! Unpermute the rows and columns of MU. ! call i4mat_2perm1 ( n, n, mu, q, q ) return end subroutine moebius_values ( n_data, n, c ) !*****************************************************************************80 ! !! moebius_values() returns some values of the Moebius function. ! ! Discussion: ! ! 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. ! ! In Mathematica, the function can be evaluated by: ! ! MoebiusMu[n] ! ! 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 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 February 2003 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Cambridge University Press, 1999, ! ISBN: 0-521-64314-7, ! LC: QA76.95.W65. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer N, the argument of the Moebius function. ! ! Output, integer C, the value of the Moebius function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 20 integer c integer, save, dimension ( n_max ) :: c_vec = (/ & 1, -1, -1, 0, -1, 1, -1, 0, 0, 1, & -1, 0, -1, 1, 1, 0, -1, 0, -1, 0 /) integer n integer n_data integer, save, dimension ( n_max ) :: n_vec = (/ & 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, & 11, 12, 13, 14, 15, 16, 17, 18, 19, 20 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 n = 0 c = 0 else n = n_vec(n_data) c = c_vec(n_data) end if return end subroutine monomial_count ( degree_max, dim, total ) !*****************************************************************************80 ! !! monomial_count() counts the number of monomials up to a given degree. ! ! Discussion: ! ! In 3D, there are 10 monomials of degree 3 or less: ! ! Degree Count List ! ------ ----- ---- ! 0 1 1 ! 1 3 x y z ! 2 6 xx xy xz yy yz zz ! 3 10 xxx xxy xxz xyy xyz xzz yyy yyz yzz zzz ! ! Total 20 ! ! The formula is ! ! COUNTS(DEGREE,DIM) = (DIM-1+DEGREE)! / (DIM-1)! / DEGREE! ! ! TOTAL = (DIM +DEGREE)! / (DIM)! / DEGREE! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 October 2008 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DEGREE_MAX, the maximum degree. ! ! Input, integer DIM, the spatial dimension. ! ! Output, integer TOTAL, the total number of monomials ! of degrees 0 through DEGREE_MAX. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer bot integer degree_max integer dim integer top integer total total = 1 if ( degree_max < dim ) then top = dim + 1 do bot = 1, degree_max total = ( total * top ) / bot top = top + 1 end do else top = degree_max + 1 do bot = 1, dim total = ( total * top ) / bot top = top + 1 end do end if return end subroutine monomial_counts ( degree_max, dim, counts ) !*****************************************************************************80 ! !! monomial_counts() counts the number of monomials up to a given degree. ! ! Discussion: ! ! In 3D, there are 10 monomials of degree 3 or less: ! ! Degree Count List ! ------ ----- ---- ! 0 1 1 ! 1 3 x y z ! 2 6 xx xy xz yy yz zz ! 3 10 xxx xxy xxz xyy xyz xzz yyy yyz yzz zzz ! ! Total 20 ! ! The formula is ! ! COUNTS(DEGREE,DIM) = (DIM-1+DEGREE)! / (DIM-1)! / DEGREE! ! ! TOTAL = (DIM +DEGREE)! / (DIM)! / DEGREE! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 October 2008 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DEGREE_MAX, the maximum degree. ! ! Input, integer DIM, the spatial dimension. ! ! Output, integer COUNTS(0:DEGREE_MAX), the number of ! monomials of each degree. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer degree_max integer counts(0:degree_max) integer degree integer dim degree = 0 counts(degree) = 1 do degree = 1, degree_max counts(degree) = ( counts(degree-1) * ( dim - 1 + degree ) ) / degree end do return end subroutine morse_thue ( i, s ) !*****************************************************************************80 ! !! morse_thue() generates a Morse_Thue number. ! ! Discussion: ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 :: rk = kind ( 1.0D+00 ) integer, parameter :: nbits = 32 integer b(nbits) integer i integer i_copy integer s i_copy = abs ( i ) ! ! Expand I into binary form. ! call ui4_to_ubvec ( 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 ) !*****************************************************************************80 ! !! multinomial_coef1() computes a multinomial coefficient. ! ! Discussion: ! ! 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). ! ! NCOMB = N! / ( FACTOR(1)! FACTOR(2)! ... FACTOR(NFACTOR)! ) ! ! The logarithm of the Gamma function is used, to avoid overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer nfactor real ( kind = rk ) arg real ( kind = rk ) fack real ( kind = rk ) facn integer factor(nfactor) 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,i8,a,i8)' ) ' Factor ', i, ' = ', factor(i) write ( *, '(a)' ) ' But this value must be nonnegative.' stop 1 end if end do ! ! The factors sum to N. ! n = sum ( factor(1:nfactor) ) arg = real ( n + 1, kind = rk ) facn = lgamma ( arg ) do i = 1, nfactor arg = real ( factor(i) + 1, kind = rk ) fack = lgamma ( arg ) facn = facn - fack end do ncomb = nint ( exp ( facn ) ) return end subroutine multinomial_coef2 ( nfactor, factor, ncomb ) !*****************************************************************************80 ! !! multinomial_coef2() computes a multinomial coefficient. ! ! Discussion: ! ! 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). ! ! NCOMB = N! / ( FACTOR(1)! FACTOR(2)! ... FACTOR(NFACTOR)! ) ! ! A direct method is used, which should be exact. However, there ! is a possibility of intermediate overflow of the result. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 multinomial coefficient. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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,i8,a,i8)' ) ' Factor ', i, ' = ', factor(i) write ( *, '(a)' ) ' But this value must be nonnegative.' stop 1 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 multiperm_enum ( n, k, counts, number ) !*****************************************************************************80 ! !! multiperm_enum() enumerates multipermutations. ! ! Discussion: ! ! A multipermutation is a permutation of objects, some of which are ! identical. ! ! While there are 6 permutations of the distinct objects A,B,C, there ! are only 3 multipermutations of the objects A,B,B. ! ! In general, there are N! permutations of N distinct objects, but ! there are N! / ( ( M1! ) ( M2! ) ... ( MK! ) ) multipermutations ! of N objects, in the case where the N objects consist of K ! types, with M1 examples of type 1, M2 examples of type 2 and so on, ! and for which objects of the same type are indistinguishable. ! ! Example: ! ! Input: ! ! N = 5, K = 3, COUNTS = (/ 1, 2, 2 /) ! ! Output: ! ! Number = 30 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 July 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items in the multipermutation. ! ! Input, integer K, the number of types of items. ! 1 <= K. Ordinarily, K <= N, but we allow any positive K, because ! we also allow entries in COUNTS to be 0. ! ! Input, integer COUNTS(K), the number of items of each type. ! 0 <= COUNTS(1:K) <= N and sum ( COUNTS(1:K) ) = N. ! ! Output, integer NUMBER, the number of multipermutations. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer counts(k) integer i integer j integer n integer number integer top if ( n < 0 ) then number = -1 return end if if ( n == 0 ) then number = 1 return end if if ( k < 1 ) then number = -1 return end if if ( any ( counts(1:k) < 0 ) ) then number = -1 return end if if ( sum ( counts(1:k) ) /= n ) then number = -1 return end if ! ! Ready for computation. ! By design, the integer division should never have a remainder. ! top = 0 number = 1 do i = 1, k do j = 1, counts ( i ) top = top + 1 number = ( number * top ) / j end do end do return end subroutine multiperm_next ( n, a, more ) !*****************************************************************************80 ! !! multiperm_next() returns the next multipermutation. ! ! Discussion: ! ! A multipermutation is a permutation of objects, some of which are ! identical. ! ! While there are 6 permutations of the distinct objects A,B,C, there ! are only 3 multipermutations of the objects A,B,B. ! ! In general, there are N! permutations of N distinct objects, but ! there are N! / ( ( M1! ) ( M2! ) ... ( MK! ) ) multipermutations ! of N objects, in the case where the N objects consist of K ! types, with M1 examples of type 1, M2 examples of type 2 and so on, ! and for which objects of the same type are indistinguishable. ! ! To begin the computation, the user must set up the first multipermutation. ! To compute ALL possible multipermutations, this first permutation should ! list the values in ascending order. ! ! The routine will compute, one by one, the next multipermutation, ! in lexicographical order. On the call after computing the last ! multipermutation, the routine will return MORE = FALSE (and will ! reset the multipermutation to the FIRST one again.) ! ! Example: ! ! 1 1 2 2 3 3 ! 2 1 2 3 2 3 ! 3 1 2 3 3 2 ! 4 1 3 2 2 3 ! 5 1 3 2 3 2 ! 6 1 3 3 2 2 ! 7 2 1 2 3 3 ! 8 2 1 3 2 3 ! ... ! 30 3 3 2 2 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 March 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items in the multipermutation. ! ! Input/output, integer A(N); on input, the current ! multipermutation. On output, the next multipermutation. ! ! Output, logical MORE, is TRUE if the next multipermutation ! was computed, or FALSE if no further multipermutations could ! be computed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer m logical more integer temp ! ! Step 1: ! Find M, the last location in A for which A(M) < A(M+1). ! m = 0 do i = 1, n - 1 if ( a(i) < a(i+1) ) then m = i end if end do ! ! Step 2: ! If no M was found, we've run out of multipermutations. ! if ( m == 0 ) then more = .false. call i4vec_sort_heap_a ( n, a ) return else more = .true. end if ! ! Step 3: ! Ascending sort A(M+1:N). ! if ( m + 1 < n ) then call i4vec_sort_heap_a ( n-m, a(m+1:n) ) end if ! ! Step 4: ! Locate the first larger value after A(M). ! i = 1 do while ( a(m+i) <= a(m) ) i = i + 1 end do ! ! Step 5: ! Interchange A(M) and the next larger value. ! temp = a(m) a(m) = a(m+i) a(m+i) = temp return end subroutine network_flow_max ( nnode, nedge, iendpt, icpflo, source, sink, & cut, node_flow ) !*****************************************************************************80 ! !! network_flow_max() finds the maximal flow and a minimal cut in a network. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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). ! 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 SOURCE, the designated source node. ! ! Input, integer SINK, the designated sink node. ! ! Output, integer CUT(NNODE). CUT(I) = 1 if node I is in the ! minimal cut set, otherwise 0. ! ! Output, integer NODE_FLOW(NNODE), the flow through each node. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer nedge integer nnode integer cut(nnode) integer del integer i integer i1 integer iarray(nnode) integer icpflo(2,nedge) integer :: ien1 = 0 integer :: ien2 = 0 integer iendpt(2,nedge) integer indx integer ip integer iparm integer iq integer ir integer iread integer irite integer is integer isort integer it integer j integer j1 integer k0 integer k1 integer kz integer lst integer m integer n1 integer node_flow(nnode) integer sink integer source integer work1(nnode) integer work2(nnode) ! ! Initialization. ! iarray(1:nnode) = 0 del = 0 icpflo(2,1:nedge) = 0 do i = 1, nedge ip = iendpt(1,i) if ( ip == source ) then del = del + icpflo(1,i) end if iarray(ip) = iarray(ip) + 1 end do node_flow(source) = del is = 1 do i = 1, nnode it = iarray(i) iarray(i) = is work1(i) = is is = is + it end do isort = 0 ! ! Sorting. ! 10 continue indx = 0 50 continue do call sort_heap_external ( nedge, indx, ien1, ien2, is, i1, j1, k0, k1, n1 ) 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 ( 0 < indx ) then do ir = 1, 2 call i4_swap ( iendpt(ir,ien1), iendpt(ir,ien2) ) call i4_swap ( icpflo(ir,ien1), icpflo(ir,ien2) ) end do else if ( 0 < isort ) then return end if do i = 1, nedge iq = iendpt(2,i) iendpt(1,i) = work1(iq) work1(iq) = work1(iq) + 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 i4_swap ( iendpt(ir,ien1), iendpt(ir,ien2) ) call i4_swap ( icpflo(ir,ien1), icpflo(ir,ien2) ) end do if ( indx < 0 ) then work2(iq) = ien2 go to 280 end if if ( indx == 0 ) then go to 170 end if go to 50 100 continue indx = 0 do i = 1, nnode if ( i /= source ) then node_flow(i) = 0 end if work2(i) = nedge + 1 if ( i < nnode ) then work2(i) = iarray(i+1) end if cut(i) = 0 end do iread = 0 irite = 1 work1(1) = source cut(source) = -1 120 continue iread = iread + 1 if ( iread <= irite ) then ip = work1(iread) lst = work2(ip) - 1 i = iarray(ip) - 1 do i = i + 1 if ( lst < i ) then go to 120 end if iq = iendpt(2,i) del = icpflo(1,i) - icpflo(2,i) if ( cut(iq) == 0 .and. del /= 0 ) then if ( iq /= sink ) then irite = irite + 1 work1(irite) = iq end if cut(iq) = -1 end if end do end if if ( cut(sink) == 0 ) then cut(1:nnode) = -cut(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(source) = node_flow(sink) isort = 1 go to 10 end if cut(sink) = 1 160 continue iread = iread - 1 if ( iread == 0 ) then go to 180 end if ip = work1(iread) ien1 = iarray(ip) - 1 ien2 = work2(ip) - 1 170 continue if ( ien1 /= ien2 ) then iq = iendpt(2,ien2) if ( cut(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 ( iarray(ip) <= ien1 ) then cut(ip) = ien1 end if go to 160 180 continue kz = 0 do ir = 1, irite if ( 0 < cut(work1(ir)) ) then kz = kz + 1 work1(kz) = work1(ir) end if end do indx = -1 m = 1 200 continue ip = work1(m) if ( 0 < node_flow(ip) ) 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 ( 0 <= iq ) then iendpt(2,i) = iq j = iendpt(1,i) icpflo(1,i) = icpflo(1,i) - icpflo(2,j) del = icpflo(2,i) - icpflo(2,j) icpflo(2,i) = del icpflo(2,j) = -del end if end do go to 100 end if ip = work1(m) 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 = work2(ip) work2(ip) = lst do if ( i == lst ) then go to 220 end if j = iendpt(1,i) del = icpflo(2,j) icpflo(2,j) = 0 icpflo(1,j) = icpflo(1,j) - del icpflo(2,i) = icpflo(2,i) - del i = i + 1 end do end if if ( cut(ip) < iarray(ip) ) then go to 300 end if 250 continue i = cut(ip) + 1 260 continue do i = i - 1 if ( i < iarray(ip) ) then go to 290 end if iq = -iendpt(2,i) if ( 0 <= node_flow(iq) ) then exit end if end do del = min ( icpflo(1,i) - icpflo(2,i), node_flow(ip) ) icpflo(2,i) = icpflo(2,i) + del node_flow(ip) = node_flow(ip) - del node_flow(iq) = node_flow(iq) + del iparm = 1 ien1 = iendpt(1,i) ien2 = work2(iq) - 1 if ( ien1 < ien2 ) then go to 80 end if if ( ien1 == ien2 ) then work2(iq) = ien2 end if 280 continue if ( 0 < node_flow(ip) ) then go to 260 end if if ( icpflo(1,i) == icpflo(2,i) ) then i = i - 1 end if 290 continue cut(ip) = i if ( iparm /= 0 ) then go to 210 end if 300 continue i = work2(ip) do j = iendpt(1,i) del = min ( icpflo(2,j), node_flow(ip) ) icpflo(2,j) = icpflo(2,j) - del node_flow(ip) = node_flow(ip) - del iq = iendpt(2,i) node_flow(iq) = node_flow(iq) + del i = i + 1 if ( node_flow(ip) <= 0 ) then exit end if end do node_flow(ip) = -1 go to 220 end subroutine nim_sum ( i, j, k ) !*****************************************************************************80 ! !! 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 base 2 J base 2 K base 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer I, J, the integers to be Nim-summed. ! ! Output, integer K, the Nim sum of I and J. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: nbits = 32 integer i integer ivec(nbits) integer j integer jvec(nbits) integer k integer kvec(nbits) call ui4_to_ubvec ( i, nbits, ivec ) call ui4_to_ubvec ( j, nbits, jvec ) call ubvec_xor ( nbits, ivec, jvec, kvec ) call ubvec_to_ui4 ( nbits, kvec, k ) return end subroutine padovan ( n, p ) !*****************************************************************************80 ! !! padovan() returns the first N values of the Padovan sequence. ! ! Discussion: ! ! The Padovan sequence has the initial values: ! ! P(0) = 1 ! P(1) = 1 ! P(2) = 1 ! ! and subsequent entries are generated by the recurrence ! ! P(I+1) = P(I-1) + P(I-2) ! ! Example: ! ! 0 1 ! 1 1 ! 2 1 ! 3 2 ! 4 2 ! 5 3 ! 6 4 ! 7 5 ! 8 7 ! 9 9 ! 10 12 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Ian Stewart, ! "A Neglected Number", ! Scientific American, ! Volume 274, pages 102-102, June 1996. ! ! Ian Stewart, ! Math Hysteria, ! Oxford, 2004, ! ISBN: 0198613369. ! ! Parameters: ! ! Input, integer N, the number of terms. ! ! Output, integer P(N), terms 0 though N-1 of the sequence. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer p(n) if ( n < 1 ) then return end if p(1) = 1 if ( n < 2 ) then return end if p(2) = 1 if ( n < 3 ) then return end if p(3) = 1 do i = 4, n p(i) = p(i-2) + p(i-3) end do return end subroutine pell_basic ( d, x0, y0 ) !*****************************************************************************80 ! !! pell_basic() returns the fundamental solution for Pell's basic equation. ! ! Discussion: ! ! Pell's equation has the form: ! ! X*X - D * Y*Y = 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 May 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Mark Herkommer, ! Number Theory, A Programmer's Guide, ! McGraw Hill, 1999, ! ISBN: 0-07-913074-7. ! ! 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 :: rk = kind ( 1.0D+00 ) 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.' stop 1 end if call i4_sqrt ( d, q, r ) if ( r == 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PELL_BASIC - Fatal error!' write ( *, '(a)' ) ' Pell coefficient is a perfect square.' stop 1 end if ! ! Find the continued fraction representation of sqrt ( D ). ! call i4_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 ) !*****************************************************************************80 ! !! pell_next() returns the next solution of Pell's equation. ! ! Discussion: ! ! Pell's equation has the form: ! ! X*X - D * Y*Y = 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 May 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Mark Herkommer, ! Number Theory, A Programmer's Guide, ! McGraw Hill, 1999, ! ISBN: 0-07-913074-7. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! pent_enum() computes the N-th pentagonal number. ! ! Discussion: ! ! 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. ! ! The pentagonal numbers are also useful in determining the ! number of partitions of an integer. ! ! P(N) = ( N * ( 3 * N - 1 ) ) / 2 ! ! 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 ! 6 51 ! 7 70 ! 8 92 ! 9 117 ! 10 145 ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer p p = ( n * ( 3 * n - 1 ) ) / 2 return end subroutine perm_ascend ( n, a, length, sub ) !*****************************************************************************80 ! !! perm_ascend() computes the longest ascending subsequence of a permutation. ! ! Discussion: ! ! Although this routine is intended to be applied to a permutation, ! it will work just as well for an arbitrary vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) 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 ( 1 < k ) 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_fixed_enum ( n, m, fnm ) !*****************************************************************************80 ! !! perm_fixed_enum() enumerates the permutations of N objects with M fixed. ! ! Discussion: ! ! 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. ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2007 ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer derange_enum integer fnm integer i4_choose integer m integer n if ( n <= 0 ) then fnm = 1 else if ( m < 0 ) then fnm = 0 else if ( n < m ) 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 fnm = i4_choose ( n, m ) * derange_enum ( n - m ) end if return end function perm0_check ( n, p ) !*****************************************************************************80 ! !! perm0_check() checks a 0-based permutation. ! ! Discussion: ! ! The routine verifies that each of the integers from 0 to ! to N-1 occurs among the N entries of the permutation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries. ! ! Input, integer P(N), the array to check. ! ! Output, integer PERM0_CHECK: ! 0, no error. ! 1, P is not a 0-based permutation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer ierror integer location integer p(n) integer perm0_check integer value ierror = 0 do value = 0, n - 1 ierror = 1 do location = 1, n if ( p(location) == value ) then ierror = 0 exit end if end do if ( ierror /= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM0_CHECK - Fatal error!' write ( *, '(a,i4)' ) ' Permutation is missing value ', value exit end if end do perm0_check = ierror return end subroutine perm0_print ( n, p, title ) !*****************************************************************************80 ! !! perm0_print() prints a permutation of (0,...,N-1). ! ! Example: ! ! Input: ! ! P = 6 1 3 0 4 2 5 ! ! Printed output: ! ! "This is the permutation:" ! ! 0 1 2 3 4 5 6 ! 6 1 3 0 4 2 5 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 June 2015 ! ! 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, a title. ! If no title is supplied, then only the permutation is printed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ( *, '(2x,20i4)' ) ( i - 1, i = ilo, ihi ) write ( *, '(2x,20i4)' ) p(ilo:ihi) end do else do ilo = 1, n, inc ihi = min ( n, ilo + inc - 1 ) write ( *, '(2x,20i4)' ) p(ilo:ihi) end do end if return end subroutine perm1_break_count ( n, p, break_count ) !*****************************************************************************80 ! !! perm1_break_count() counts breaks in a permutation of (1,...,N). ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2015 ! ! Author: ! ! John Burkardt ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer break_count integer i integer ierror integer p(n) integer perm1_check ! ! Make sure the permutation is legal. ! ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'perm1_break_count(): Fatal error!' write ( *, '(a)' ) ' perm1_check() returned error.' stop 1 end if break_count = 0 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 perm1_canon_to_cycle ( n, p1, p2 ) !*****************************************************************************80 ! !! perm1_canon_to_cycle(): permutation of (1,...,N) 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 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, page 176. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 function perm1_check ( n, p ) !*****************************************************************************80 ! !! perm1_check() checks a 1-based permutation. ! ! Discussion: ! ! The routine verifies that each of the integers from 1 to ! to N occurs among the N entries of the permutation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 May 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries. ! ! Input, integer P(N), the array to check. ! ! Output, integer PERM1_CHECK: ! 0, P is a 1-based permutation. ! 1, P is not a 1-based permutation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer ierror integer location integer p(n) integer perm1_check integer value ierror = 0 do value = 1, n ierror = 1 do location = 1, n if ( p(location) == value ) then ierror = 0 exit end if end do if ( ierror /= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'perm1_check(): Fatal error!' write ( *, '(a,i4)' ) ' Permutation is missing value ', value exit end if end do perm1_check = ierror return end subroutine perm1_cycle ( n, iopt, p, isgn, ncycle ) !*****************************************************************************80 ! !! perm1_cycle() analyzes a permutation of (1,...,N). ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! This version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer IOPT, requests tagging. ! 0, the permutation will not be tagged. ! 1, the permutation will be tagged. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i1 integer i2 integer ierror integer iopt integer is integer isgn integer ncycle integer p(n) integer perm1_check ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'perm1_cycle(): Fatal error!' write ( *, '(a)' ) ' perm1_check() returned error.' stop 1 end if is = 1 ncycle = n do i = 1, n i1 = p(i) do while ( i < i1 ) 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 perm1_cycle_max ( n, p, cycle_max ) !*****************************************************************************80 ! !! perm1_cycle_max() returns the length of a longest cycle in a permutation. ! ! Discussion: ! ! The permutation is assumed to be over the integers 1 through N. ! ! Example: ! ! N = 9 ! P = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! Cycles: ( 1, 2, 3, 9 ), ( 4, 6, 8 ), ( 5, 7 ) ! cycle_max = 4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 November 2022 ! ! Author: ! ! John Burkardt. ! ! Input: ! ! integer N: the number of objects being permuted. ! ! integer P(N): describes a of 1 through N. ! ! Output: ! ! integer cycle_max: the maximum cycle length in the permutation. ! implicit none integer n integer cycle_length integer cycle_max integer i integer j integer p(n) cycle_max = 0; do i = 1, n j = p(i) cycle_length = 1 do while ( j /= i ) j = p(j) cycle_length = cycle_length + 1 end do cycle_max = max ( cycle_max, cycle_length ) end do return end subroutine perm1_cycle_stats ( n, p, cycle_stats ) !*****************************************************************************80 ! !! perm1_cycle_stats() returns permutation cycle length statistics. ! ! Discussion: ! ! The permutation is assumed to be over the integers 1 through N. ! ! Example: ! ! P = 2, 3, 9, 6, 7, 8, 5, 4, 1 ! ! Cycles: ( 1, 2, 3, 9 ), ( 4, 6, 8 ), ( 5, 7 ) ! ! cycle_max = 4 ! 1, 2, 3, 4, 5, 6, 7, 8, 9 ! cycle_stats = ( 0, 1, 1, 1, 0, 0, 0, 0, 0 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 November 2022 ! ! Author: ! ! John Burkardt. ! ! Input: ! ! integer n: the length of the permutation. ! ! integer p(n): the permutation to be analyzed. ! ! Output: ! ! integer cycle_stats(n): the number of cycles of each length. ! implicit none integer n integer cycle_length integer cycle_stats(n) integer i integer j integer p(n) cycle_stats(1:n) = 0 do i = 1, n j = p(i) cycle_length = 1 do while ( j /= i ) j = p(j) cycle_length = cycle_length + 1 end do cycle_stats(cycle_length) = cycle_stats(cycle_length) + 1 end do do i = 1, n cycle_stats(i) = cycle_stats(i) / i end do return end subroutine perm1_cycle_to_canon ( n, p1, p2 ) !*****************************************************************************80 ! !! perm1_cycle_to_canon(): permutation of (1,...,N) from cycle to canonical form. ! ! 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 ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, pages 176. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 i4vec_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 perm1_cycle_to_index ( n, p1, p2 ) !*****************************************************************************80 ! !! perm1_cycle_to_index(): permutation of (1,...,N) from cycle to 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 perm1_distance ( n, a, b, k ) !*****************************************************************************80 ! !! perm1_distance() computes distance between permutations of (1,...,N). ! ! Discussion: ! ! The distance is known as the Ulam metric. ! ! 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 ) ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the permutation. ! ! Input, integer A(N), B(N), the permutations. ! ! Output, integer K, the Ulam metric distance between A and B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer b(n) integer binv(n) integer c(n) integer k integer length integer sub(n) call perm1_inverse ( n, b, binv ) call perm1_mul ( n, a, binv, c ) call perm_ascend ( n, c, length, sub ) k = n - length return end subroutine perm1_free ( npart, ipart, nfree, ifree ) !*****************************************************************************80 ! !! perm1_free() reports unused items in a partial permutation of (1,...,N). ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer NPART, the number of entries in IPART. ! NPART may be 0. ! ! Input, integer IPART(NPART), the partial permutation, which ! should contain, at most once, some of the integers between 1 and ! NPART+NFREE. ! ! Input, integer NFREE, the number of integers that have not ! been used in IPART. This is simply N - NPART. NFREE may be zero. ! ! Output, integer IFREE(NFREE), the integers between 1 and ! NPART+NFREE that were not used in IPART. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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)' ) 'PERM1_FREE - Fatal error!' write ( *, '(a)' ) ' NPART < 0.' write ( *, '(a,i8)' ) ' NPART = ', npart stop 1 else if ( npart == 0 ) then call i4vec_indicator1 ( n, ifree ) else if ( nfree < 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_FREE - Fatal error!' write ( *, '(a)' ) ' NFREE < 0.' write ( *, '(a,i8)' ) ' NFREE = ', nfree stop 1 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 ( nfree < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_FREE - Fatal error!' write ( *, '(a)' ) ' The partial permutation is illegal.' write ( *, '(a)' ) ' It should contain, at most once, some of' write ( *, '(a,i8)' ) ' the integers between 1 and ', n write ( *, '(a)' ) '' write ( *, '(a)' ) ' Our error is that NFREE < K,' write ( *, '(a)' ) ' We have TOO MANY missing values.' write ( *, '(a,i8)' ) ' Value of NFREE = ', nfree write ( *, '(a,i8)' ) ' Value of K = ', k call i4vec_print ( npart, ipart, ' Partial permutation:' ) stop 1 end if ifree(k) = i end if end do end if return end subroutine perm1_index_to_cycle ( n, p1, p2 ) !*****************************************************************************80 ! !! perm1_index_to_cycle(): permutation of (1,...,N) from 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 July 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 perm1_inverse ( n, p1, p2 ) !*****************************************************************************80 ! !! perm1_inverse() inverts a permutation of (1,...,N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 July 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of objects being permuted. ! ! Input, integer P1(N), the permutation. ! ! Output, integer P2(N), the inverse permutation. ! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i0 integer i1 integer i2 integer ierror integer is integer p1(n) integer p2(n) integer perm1_check if ( n <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_INVERSE - Fatal error!' write ( *, '(a,i8)' ) ' Input value of N = ', n stop 1 end if ierror = perm1_check ( n, p1 ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_INVERSE - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if p2(1:n) = p1(1:n) is = 1 do i = 1, n i1 = p2(i) do while ( i < i1 ) i2 = p2(i1) p2(i1) = - i2 i1 = i2 end do is = - sign ( 1, p2(i) ) p2(i) = sign ( p2(i), is ) end do do i = 1, n i1 = - p2(i) if ( 0 <= i1 ) then i0 = i do i2 = p2(i1) p2(i1) = i0 if ( i2 < 0 ) then exit end if i0 = i1 i1 = i2 end do end if end do return end subroutine perm1_inverse2 ( n, p ) !*****************************************************************************80 ! !! perm1_inverse2() inverts a permutation of (1,...,N). ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2015 ! ! Author: ! ! John Burkardt ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ierror integer j integer k integer m integer p(n) integer perm1_check ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_INVERSE2 - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if do m = n, 1, -1 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 perm1_inverse3 ( n, p, p_inv ) !*****************************************************************************80 ! !! perm1_inverse3() produces the inverse of a permutation of (1,...,N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of items permuted. ! ! Input, integer P(N), a permutation. ! ! Output, integer P_INV(N), the inverse permutation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ierror integer p(n) integer p_inv(n) integer perm1_check ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_INVERSE3 - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if do i = 1, n p_inv(p(i)) = i end do return end subroutine perm1_lex_next ( n, p, more ) !*****************************************************************************80 ! !! perm1_lex_next() generates permutations of (1,...,N) in lexical order. ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 September 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Mok-Kong Shen, ! Algorithm 202: Generation of Permutations in Lexicographical Order, ! Communications of the ACM, ! Volume 6, September 1963, page 517. ! ! Parameters: ! ! Input, integer N, the number of elements being permuted. ! ! Input/output, integer P(N); on first call with MORE = FALSE, ! this value is not used. Otherwise, the input value is the previous ! permutation. The output value is the next permutation. ! ! Input/output, logical MORE. ! On the first call, set MORE = FALSE, to request initialization. ! On return, if MORE is TRUE, another permutation has been ! computed and returned, while if MORE is FALSE, there are no more ! permutations. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer j integer k logical more integer p(n) integer t integer u integer w ! ! Initialization. ! if ( .not. more ) then call i4vec_indicator1 ( 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 ( u < p(j) ) then p(w-1) = p(j) p(j) = u do k = 0, ( n - w - 1 ) / 2 t = p(n-k) p(n-k) = p(w+k) p(w+k) = t end do return end if end do end if return end subroutine perm1_mul ( n, p1, p2, p3 ) !*****************************************************************************80 ! !! perm1_mul() "multiplies" two permutations of (1,...,N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the permutations. ! ! Input, integer P1(N), P2(N), the permutations. ! ! Output, integer P3(N), the product permutation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer ierror integer p1(n) integer p2(n) integer p3(n) integer perm1_check ierror = perm1_check ( n, p1 ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_MUL - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if ierror = perm1_check ( n, p2 ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_MUL - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if p3(1:n) = p2(p1(1:n)) return end subroutine perm1_next ( n, p, more, even ) !*****************************************************************************80 ! !! perm1_next() computes permutations of (1,...,N), 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 March 2001 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 i4vec_indicator1 ( 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 ( ia < p(j) ) 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 perm1_next2 ( n, p, done, invers ) !*****************************************************************************80 ! !! perm1_next2() generates permutations of (1,...,N). ! ! 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 PERM1_RANK and PERM1_UNRANK. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 July 2004 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! 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. ! ! Output, integer INVERS(N), the inverse permutation of P. ! ! Local Parameters: ! ! Local, integer ACTIVE(N), DIR(N). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, save, allocatable, dimension ( : ) :: active integer, save, allocatable, dimension ( : ) :: dir logical done integer i integer invers(n) integer j integer nactiv integer p(n) ! ! An input value of TRUE for DONE is assumed to mean a new ! computation is beginning. ! if ( done ) then call i4vec_indicator1 ( n, p ) invers(1:n) = p(1:n) if ( allocated ( active ) ) then deallocate ( active ) end if if ( allocated ( dir ) ) then deallocate ( dir ) end if allocate ( active(1:n) ) allocate ( dir(1:n) ) dir(1:n) = -1 active(1) = 0 active(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 ( 1 < n ) then done = .false. else done = .true. end if ! ! Otherwise, assume we are in a continuing computation. ! else nactiv = 0 do i = 1, n if ( active(i) /= 0 ) then nactiv = i end if end do if ( nactiv <= 0 ) then done = .true. else j = invers(nactiv) p(j) = p(j+dir(nactiv)) p(j+dir(nactiv)) = nactiv invers(nactiv) = invers(nactiv) + dir(nactiv) invers(p(j)) = j if ( j + 2 * dir(nactiv) < 1 .or. n < j + 2 * dir(nactiv) ) then dir(nactiv) = -dir(nactiv) active(nactiv) = 0 else if ( nactiv < p(j+2*dir(nactiv)) ) then dir(nactiv) = -dir(nactiv) active(nactiv) = 0 end if active(nactiv+1:n) = 1 end if end if if ( done ) then deallocate ( active ) deallocate ( dir ) end if return end subroutine perm1_next3 ( n, p, more, rank ) !*****************************************************************************80 ! !! perm1_next3() computes permutations of (1,...,N). ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 November 2018 ! ! Author: ! ! Original FORTRAN77 version by Hale Trotter, ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Hale Trotter, ! Algorithm 115: ! PERM, ! Communications of the Association for Computing Machinery, ! Volume 5, 1962, pages 434-435. ! ! 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. ! ! Input/output, integer RANK, the rank of the current permutation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer m2 logical more integer n2 integer p(n) integer q integer rank integer s integer t if ( .not. more ) then do i = 1, n p(i) = i end do more = .true. rank = 1 else n2 = n m2 = rank 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 if ( n2 == 0 ) then do i = 1, n p(i) = i end do more = .false. rank = 1 exit end if end do if ( n2 /= 0 ) then if ( q == t ) then s = s - q else s = s + q - n2 end if ! ! Swap. ! t = p(s) p(s) = p(s+1) p(s+1) = t rank = rank + 1 end if end if return end subroutine perm1_print ( n, p, title ) !*****************************************************************************80 ! !! perm1_print() prints a permutation of (1,...,N). ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 June 2015 ! ! 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, a title. ! If no title is supplied, then only the permutation is printed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ( *, '(2x,20i4)' ) ( i, i = ilo, ihi ) write ( *, '(2x,20i4)' ) p(ilo:ihi) end do else do ilo = 1, n, inc ihi = min ( n, ilo + inc - 1 ) write ( *, '(2x,20i4)' ) p(ilo:ihi) end do end if return end subroutine perm1_random ( n, p ) !*****************************************************************************80 ! !! perm1_random() selects a random permutation of (1,...,N). ! ! Discussion: ! ! The algorithm is known as the Fisher-Yates or Knuth shuffle. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 May 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i4_uniform_ab integer j integer p(n) integer t do i = 1, n p(i) = i end do do i = 1, n - 1 j = i4_uniform_ab ( i, n ) t = p(i) p(i) = p(j) p(j) = t end do return end subroutine perm1_random2 ( n, p ) !*****************************************************************************80 ! !! perm1_random2() selects a random permutation of (1,...,N). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by James Filliben. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Karla Hoffman, Douglas 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. ! ! Parameters: ! ! Input, integer N, the number of elements of the array. ! ! Output, integer P(N), a permutation, in standard index form. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i4_uniform_ab integer iadd integer j integer p(n) integer t if ( n < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_RANDOM2 - Fatal error!' write ( *, '(a,i8)' ) ' Illegal input value of N = ', n write ( *, '(a)' ) ' N must be at least 1!' stop 1 end if if ( n == 1 ) then p(1) = 1 return end if do i = 1, n p(i) = i end do do i = 1, n iadd = i4_uniform_ab ( 1, n ) j = i + iadd if ( n < j ) then j = j - n end if if ( i /= j ) then t = p(i) p(i) = p(j) p(j) = t end if end do return end subroutine perm1_rank ( n, p, rank ) !*****************************************************************************80 ! !! perm1_rank() ranks a permutation of (1,...,N). ! ! Discussion: ! ! This is the same as asking for the step at which PERM1_NEXT2 ! would compute the permutation. The value of the rank will be ! between 1 and N!. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by Dennis Stanton, Dennis White. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! 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 RANK, 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer count integer i integer ierror integer invers(n) integer j integer p(n) integer perm1_check integer rank integer rem ! ! Make sure the permutation is legal. ! ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_RANK - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if ! ! Compute the inverse permutation. ! invers(1:n) = p(1:n) call perm1_inverse2 ( n, invers ) rank = 0 do i = 1, n count = 0 do j = 1, invers(i) if ( p(j) < i ) then count = count + 1 end if end do if ( mod ( rank, 2 ) == 1 ) then rem = count else rem = i - 1 - count end if rank = i * rank + rem end do rank = rank + 1 return end subroutine perm1_sign ( n, p, p_sign ) !*****************************************************************************80 ! !! perm1_sign() returns the sign of a permutation of (1,...,N). ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 February 2000 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer i4vec_index integer ierror integer j integer p(n) integer p_sign integer perm1_check integer q(n) ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_SIGN - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 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 = i4vec_index ( n, q, i ) if ( j /= i ) then call i4_swap ( q(i), q(j) ) p_sign = -p_sign end if end do return end subroutine perm1_to_equiv ( n, p, npart, jarray, iarray ) !*****************************************************************************80 ! !! perm1_to_equiv() computes the partition induced by a permutation of (1,...,N). ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer iarray(n) integer ierror integer j integer jarray(n) integer k integer npart integer p(n) integer perm1_check ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_TO_EQUIV - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if ! ! Initialize. ! iarray(1:n) = -1 jarray(1:n) = -1 npart = 0 ! ! Search for the next item J which has not been assigned a subset/orbit. ! do j = 1, n if ( iarray(j) /= -1 ) 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) /= -1 ) then exit end if end do end do return end subroutine perm1_to_inversion ( n, p, ins ) !*****************************************************************************80 ! !! perm1_to_inversion(): permutation of (1,...,N) to inversion sequence. ! ! Discussion: ! ! 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(I) < P(J). ! ! The original permutation can be recovered from the inversion sequence. ! ! Example: ! ! Input: ! ! ( 3, 5, 1, 4, 2 ) ! ! Output: ! ! ( 0, 0, 2, 1, 3 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ierror integer ins(n) integer j integer p(n) integer perm1_check ierror = perm1_check ( n, p ) if ( ierror .ne. 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_TO_INVERSION - Fatal error!' write ( *, '(a)' ) ' PERM1_CHECK returned error.' stop 1 end if ins(1:n) = 0 do i = 1, n do j = 1, i - 1 if ( p(i) < p(j) ) then ins(i) = ins(i) + 1 end if end do end do return end subroutine perm1_to_ytb ( n, p, lambda, a ) !*****************************************************************************80 ! !! perm1_to_ytb() converts a permutation of (1,...,N) to a Young table. ! ! Discussion: ! ! The mapping is not invertible. In most cases, several permutations ! correspond to the same table. ! ! 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 ! ! A = 1 1 1 2 2 1 3 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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 A(N). A(I) is the row containing I. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) logical another integer compare integer lambda(n) integer p(n) integer put_index integer put_row integer put_value ! ! Initialize. ! lambda(1:n) = 0 a(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 ( a(compare) == put_row ) then another = .true. a(put_value) = put_row a(compare) = 0 put_value = compare put_row = put_row + 1 exit end if end do if ( .not. another ) then exit end if end do a(put_value) = put_row lambda(put_row) = lambda(put_row) + 1 end do return end subroutine perm1_unrank ( n, rank, p ) !*****************************************************************************80 ! !! perm1_unrank() "unranks" a permutation of (1,...,N). ! ! Discussion: ! ! That is, given a rank, it computes the corresponding permutation. ! This is the same as asking for the permutation which PERM1_NEXT2 ! would compute at the RANK-th step. ! ! The value of the rank should be between 1 and N!. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 July 2004 ! ! Author: ! ! Original FORTRAN77 version by Dennis Stanton, Dennis White. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! Parameters: ! ! Input, integer N, the number of elements in the set. ! ! Input, integer RANK, 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 ordering of PERM1_NEXT2. ! ! Output, integer P(N), the permutation, in standard index form. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer icount integer iprev integer irem integer j integer jdir integer jrank integer nfact integer p(n) integer rank p(1:n) = 0 nfact = 1 do i = 1, n nfact = nfact * i end do if ( rank < 1 .or. nfact < rank ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PERM1_UNRANK - Fatal error!' write ( *, '(a)' ) ' Illegal input value for RANK.' write ( *, '(a,i8)' ) ' RANK must be between 1 and ', nfact write ( *, '(a,i8)' ) ' but the input value is ', rank stop 1 end if jrank = rank - 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 ( irem < icount ) then exit end if end do p(j) = iprev end do return end subroutine perrin ( n, p ) !*****************************************************************************80 ! !! perrin() returns the first N values of the Perrin sequence. ! ! Discussion: ! ! The Perrin sequence has the initial values: ! ! P(0) = 3 ! P(1) = 0 ! P(2) = 2 ! ! and subsequent entries are generated by the recurrence ! ! P(I+1) = P(I-1) + P(I-2) ! ! Note that if N is a prime, then N must evenly divide P(N). ! ! Example: ! ! 0 3 ! 1 0 ! 2 2 ! 3 3 ! 4 2 ! 5 5 ! 6 5 ! 7 7 ! 8 10 ! 9 12 ! 10 17 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Ian Stewart, ! "A Neglected Number", ! Scientific American, Volume 274, pages 102-102, June 1996. ! ! Ian Stewart, ! Math Hysteria, ! Oxford, 2004. ! ! Eric Weisstein, ! CRC Concise Encyclopedia of Mathematics, ! CRC Press, 2002, ! Second edition, ! ISBN: 1584883472, ! LC: QA5.W45. ! ! Parameters: ! ! Input, integer N, the number of terms. ! ! Output, integer P(N), the terms 0 through N-1 of the sequence. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer p(n) if ( n < 1 ) then return end if p(1) = 3 if ( n < 2 ) then return end if p(2) = 0 if ( n < 3 ) then return end if p(3) = 2 do i = 4, n p(i) = p(i-2) + p(i-3) end do return end subroutine pord_check ( n, a, ierror ) !*****************************************************************************80 ! !! pord_check() checks a matrix representing a partial ordering. ! ! Discussion: ! ! The array A is supposed to represent a partial ordering of ! the elements of a set of N objects. ! ! For distinct indices I and J, the value of A(I,J) is: ! ! 1, if I << J ! 0, otherwise ( I and J may be unrelated, or perhaps J << I). ! ! Diagonal elements of A are ignored. ! ! This routine checks that the values of A do represent ! a partial ordering. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements in the set. ! ! Input, integer A(N,N), the partial ordering. ! 1 if I is less than J in the partial ordering, ! 0 otherwise. ! ! Output, integer IERROR, error flag. ! 0, no errors detected. A is a partial ordering. ! 1, N <= 0. ! 2, 0 < A(I,J) and 0 < A(J,I) for some I and J. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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,i8)' ) ' N must be positive, but N = ', n ierror = 1 stop 1 end if do i = 1, n do j = i + 1, n if ( 0 < a(i,j) ) then if ( 0 < a(j,i) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'PORD_CHECK - Fatal error!' write ( *, '(a,i8)' ) ' For indices I = ', i write ( *, '(a,i8)' ) ' and J = ', j write ( *, '(a,i8)' ) ' A(I,J) = ', a(i,j) write ( *, '(a,i8)' ) ' A(J,I) = ', a(j,i) ierror = 2 stop 1 end if end if end do end do return end subroutine power_mod ( a, n, m, x ) !*****************************************************************************80 ! !! power_mod() computes mod ( A^N, M ). ! ! Discussion: ! ! Some programming tricks are used to speed up the computation, and to ! allow computations in which the value A^N is much too large to ! store in an integer word. ! ! First, for efficiency, the power A^GN 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. ! ! Example: ! ! A N M X ! ! 13 0 31 1 ! 13 1 31 13 ! 13 2 31 14 ! 13 3 31 27 ! 13 4 31 10 ! 13 5 31 6 ! 13 6 31 16 ! 13 7 31 22 ! 13 8 31 7 ! 13 9 31 29 ! 13 10 31 5 ! 13 11 31 3 ! 13 12 31 8 ! 13 13 31 11 ! 13 14 31 19 ! 13 15 31 30 ! 13 16 31 18 ! 13 17 31 17 ! 13 18 31 4 ! 13 19 31 21 ! 13 20 31 25 ! 13 21 31 15 ! 13 22 31 9 ! 13 23 31 24 ! 13 24 31 2 ! 13 25 31 26 ! 13 26 31 28 ! 13 27 31 23 ! 13 28 31 20 ! 13 29 31 12 ! 13 30 31 1 ! 13 31 31 13 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 November 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, the base of the expression to be tested. ! 0 <= A is required. ! ! Input, integer N, the power to which the base is raised. ! 0 <= N is required. ! ! Input, integer M, the divisor against which the expression ! is tested. 0 < M is required. ! ! Output, integer X, the remainder when A^N is divided by M. ! If any input quantity is unacceptable, then the nonsensical value ! X = -1 is returned. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer ( kind = rk ) a_square2 integer d integer m integer ( kind = rk ) m2 integer n integer ncopy integer x integer ( kind = rk ) x2 if ( a < 0 ) then x = -1 return end if if ( m <= 0 ) then x = -1 return end if if ( n < 0 ) then x = -1 return end if ! ! A_SQUARE2 contains the successive squares of A. ! a_square2 = int ( a, kind = rk ) m2 = int ( m, kind = rk ) x2 = int ( 1, kind = rk ) ncopy = n do while ( 0 < ncopy ) d = mod ( ncopy, 2 ) if ( d == 1 ) then x2 = mod ( x2 * a_square2, m2 ) end if a_square2 = mod ( a_square2 * a_square2, m2 ) ncopy = ( ncopy - d ) / 2 end do ! ! Ensure that X is nonnegative. ! do while ( x2 < 0 ) x2 = x2 + m end do x = int ( x2 ) return end subroutine power_series1 ( n, alpha, a, b ) !*****************************************************************************80 ! !! power_series1() computes the power series for G(Z) = (1+F(Z))^ALPHA. ! ! Discussion: ! ! The power series for F(Z) is given. ! ! The form of the power series are: ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of terms in the power series. ! ! Input, real ( kind = rk ) ALPHA, the exponent of 1+F(Z) in the ! definition of G(Z). ! ! Input, real ( kind = rk ) A(N), the power series coefficients for F(Z). ! ! Output, real ( kind = rk ) B(N), the power series coefficients for G(Z). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) alpha real ( kind = rk ) b(n) integer i integer j real ( kind = rk ) v do j = 1, n v = 0.0D+00 do i = 1, j - 1 v = v + b(i) * a(j-i) * ( alpha * ( j - i ) - i ) end do b(j) = ( alpha * a(j) + v / real ( j, kind = rk ) ) end do return end subroutine power_series2 ( n, a, b ) !*****************************************************************************80 ! !! power_series2() computes the power series for G(Z) = exp(F(Z)) - 1. ! ! Discussion: ! ! The power series for F(Z) is given. ! ! The power series have the form: ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of terms in the power series. ! ! Input, real ( kind = rk ) A(N), the power series coefficients for F(Z). ! ! Output, real ( kind = rk ) B(N), the power series coefficients for G(Z). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) b(n) integer i integer j real ( kind = rk ) v do j = 1, n v = 0.0D+00 do i = 1, j - 1 v = v + b(i) * a(j-i) * real ( j - i, kind = rk ) end do b(j) = a(j) + v / real ( j, kind = rk ) end do return end subroutine power_series3 ( n, a, b, c ) !*****************************************************************************80 ! !! power_series3() computes the power series for H(Z) = G(F(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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of terms in the power series. ! ! Input, real ( kind = rk ) A(N), the power series for F. ! ! Input, real ( kind = rk ) B(N), the power series for G. ! ! Output, real ( kind = rk ) C(N), the power series for H. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) b(n) real ( kind = rk ) c(n) integer i integer iq integer j integer m real ( kind = rk ) r real ( kind = rk ) v real ( kind = rk ) work(n) work(1:n) = b(1) * a(1:n) ! ! Search for IQ, the index of the first nonzero entry in A. ! iq = 0 do i = 1, n if ( a(i) /= 0.0D+00 ) then iq = i exit end if end do if ( iq /= 0 ) then m = 1 do m = m + 1 if ( n < m * iq ) then exit end if if ( b(m) == 0.0D+00 ) then cycle end if r = b(m) * a(iq) ** m work(m*iq) = work(m*iq) + r do j = 1, n - m * iq v = 0.0D+00 do i = 1, j - 1 v = v + c(i) * a(j-i+iq) * real ( m * ( j - i ) - i, kind = rk ) end do c(j) = ( real ( m, kind = rk ) * a(j) + v & / real ( j, kind = rk ) ) / a(iq) end do do i = 1, n - m * iq work(i+m*iq) = work(i+m*iq) + c(i) * r end do end do end if c(1:n) = work(1:n) return end subroutine power_series4 ( n, a, b, c ) !*****************************************************************************80 ! !! power_series4() computes the power series for H(Z) = G ( 1/F(Z) ). ! ! Discussion: ! ! The routine is given the power series for the functions F and G. ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 June 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of terms in the power series. ! ! Input, real ( kind = rk ) A(N), the power series for F. ! A(1) may not be 0.0. ! ! Input, real ( kind = rk ) B(N), the power series for G. ! ! Output, real ( kind = rk ) C(N), the power series for H. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) b(n) real ( kind = rk ) c(n) integer i integer j integer k real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ) work(n) if ( a(1) == 0.0D+00 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'POWER_SERIES4 - Fatal error!' write ( *, '(a)' ) ' A(1) is zero.' stop 1 end if t = 1.0D+00 do i = 1, n t = t / a(1) c(i) = b(i) * t work(i) = a(i) * t end do do k = 2, n s = -work(k) do i = k, n do j = i, n c(j) = c(j) + s * c(j+1-k) work(j) = work(j) + s * work(j+1-k) end do end do end do return end function prime ( n ) !*****************************************************************************80 ! !! prime() returns any of the first PRIME_MAX prime numbers. ! ! Discussion: ! ! PRIME_MAX is 1600, and the largest prime stored is 13499. ! ! Thanks to Bart Vandewoestyne for pointing out a typo, 18 February 2005. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 February 2005 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! 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. ! In general, is should be true that 0 <= N <= PRIME_MAX. ! N = -1 returns PRIME_MAX, the index of the largest prime available. ! N = 0 is legal, returning PRIME = 1. ! ! Output, integer PRIME, the N-th prime. If N is out of range, ! PRIME is returned as -1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: prime_max = 1600 integer, save :: call = 0 integer n integer, save, dimension ( prime_max ) :: npvec integer prime if ( call == 0 ) then call = 1 npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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 /) npvec(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,10937,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 /) npvec(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 /) npvec(1501:1600) = (/ & 12569,12577,12583,12589,12601,12611,12613,12619,12637,12641, & 12647,12653,12659,12671,12689,12697,12703,12713,12721,12739, & 12743,12757,12763,12781,12791,12799,12809,12821,12823,12829, & 12841,12853,12889,12893,12899,12907,12911,12917,12919,12923, & 12941,12953,12959,12967,12973,12979,12983,13001,13003,13007, & 13009,13033,13037,13043,13049,13063,13093,13099,13103,13109, & 13121,13127,13147,13151,13159,13163,13171,13177,13183,13187, & 13217,13219,13229,13241,13249,13259,13267,13291,13297,13309, & 13313,13327,13331,13337,13339,13367,13381,13397,13399,13411, & 13417,13421,13441,13451,13457,13463,13469,13477,13487,13499 /) end if if ( n == -1 ) then prime = prime_max else if ( n == 0 ) then prime = 1 else if ( n <= prime_max ) then prime = npvec(n) else prime = -1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'PRIME - Fatal error!' write ( *, '(a,i8)' ) ' Illegal prime index N = ', n write ( *, '(a,i8)' ) ' N should be between 1 and PRIME_MAX =', prime_max stop 1 end if return end subroutine pythag_triple_next ( i, j, a, b, c ) !*****************************************************************************80 ! !! pythag_triple_next() computes the next Pythagorean triple. ! ! Example: ! ! I J A B C A^2+B^2 = C^2 ! ! 2 1 3 4 5 25 ! 3 2 5 12 13 169 ! 4 1 15 8 17 289 ! 4 3 7 24 25 625 ! 5 2 21 20 29 841 ! 5 4 9 40 41 1681 ! 6 1 35 12 37 1369 ! 6 3 27 36 45 2025 ! 6 5 11 60 61 3721 ! 7 2 45 28 53 2809 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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*A + B*B = C*C. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer b integer c integer i integer j ! ! I starts at 2, and when it increases, increases by 1 and resets J; ! ! When I is reset, J starts out at 2 if I is odd, or 1 if I is even; ! Then I is held fixed and J increases by 2, as long as it remains 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 * i - j * j b = 2 * i * j c = i * i + j * j return end function r8_agm ( a, b ) !*****************************************************************************80 ! !! r8_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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) A, B, the numbers whose AGM is desired. ! A and B should both be non-negative. ! ! Output, real ( kind = rk ) R8_AGM, the AGM of the two numbers. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) a1 real ( kind = rk ) a2 real ( kind = rk ) b real ( kind = rk ) b1 real ( kind = rk ) b2 real ( kind = rk ) r8_agm real ( kind = rk ) tol if ( a < 0.0D+00 ) then r8_agm = -1.0D+00 return end if if ( b < 0.0D+00 ) then r8_agm = -1.0D+00 return end if if ( a == 0.0D+00 .or. b == 0.0D+00 ) then r8_agm = 0.0D+00 return end if if ( a == b ) then r8_agm = a return end if tol = epsilon ( tol ) * ( a + b + 1.0D+00 ) a1 = a b1 = b do a2 = ( a1 + b1 ) / 2.0D+00 b2 = sqrt ( a1 * b1 ) if ( abs ( a2 - b2 ) < tol ) then r8_agm = ( a2 + b2 ) / 2.0D+00 exit end if a1 = a2 b1 = b2 end do return end function r8_choose ( n, k ) !*****************************************************************************80 ! !! r8_choose() computes the combinatorial coefficient C(N,K). ! ! Discussion: ! ! Real arithmetic is used, and C(N,K) is computed directly, via ! Gamma functions, rather than recursively. ! ! 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. ! ! Example: ! ! 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! ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 June 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the value of N. ! ! Input, integer K, the value of K. ! ! Output, real ( kind = rk ) R8_CHOOSE, the value of C(N,K) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) arg real ( kind = rk ) fack real ( kind = rk ) facn real ( kind = rk ) facnmk integer k integer n real ( kind = rk ) r8_choose real ( kind = rk ) value if ( n < 0 ) then value = 0.0D+00 else if ( k == 0 ) then value = 1.0D+00 else if ( k == 1 ) then value = real ( n, kind = rk ) else if ( 1 < k .and. k < n-1 ) then arg = real ( n + 1, kind = rk ) facn = lgamma ( arg ) arg = real ( k + 1, kind = rk ) fack = lgamma ( arg ) arg = real ( n - k + 1, kind = rk ) facnmk = lgamma ( arg ) value = anint ( exp ( facn - fack - facnmk ) ) else if ( k == n-1 ) then value = real ( n, kind = rk ) else if ( k == n ) then value = 1.0D+00 else value = 0.0D+00 end if r8_choose = value return end function r8_factorial ( n ) !*****************************************************************************80 ! !! r8_factorial() computes the factorial of N. ! ! Discussion: ! ! factorial ( N ) = product ( 1 <= I <= N ) I ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 January 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the argument of the factorial function. ! If N is less than 1, the function value is returned as 1. ! ! Output, real ( kind = rk ) R8_FACTORIAL, the factorial of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_factorial integer i integer n r8_factorial = 1.0D+00 do i = 1, n r8_factorial = r8_factorial * real ( i, kind = rk ) end do return end function r8_fall ( x, n ) !*****************************************************************************80 ! !! r8_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. ! ! The formula used is: ! ! [X]_N = X * ( X - 1 ) * ( X - 2 ) * ... * ( X - N + 1 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) 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 ( kind = rk ) R8_FALL, the value of the falling ! factorial function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) arg integer i integer n real ( kind = rk ) r8_fall real ( kind = rk ) value real ( kind = rk ) x value = 1.0D+00 arg = x if ( 0 < n ) then do i = 1, n value = value * arg arg = arg - 1.0D+00 end do else if ( n < 0 ) then do i = -1, n, -1 value = value * arg arg = arg + 1.0D+00 end do end if r8_fall = value return end subroutine r8_fall_values ( n_data, x, n, f ) !*****************************************************************************80 ! !! r8_fall_values() returns some values of the falling factorial function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! FactorialPower[X,Y] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 December 2014 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Cambridge University Press, 1999, ! ISBN: 0-521-64314-7, ! LC: QA76.95.W65. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, integer N, the arguments. ! ! Output, real ( kind = rk ) F, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 15 real ( kind = rk ), save, dimension ( n_max ) :: f_vec = (/ & 120.0000000000000D+00, & 163.1601562500000D+00, & 216.5625000000000D+00, & 281.6601562500000D+00, & 360.0000000000000D+00, & 1.000000000000000D+00, & 7.500000000000000D+00, & 48.75000000000000D+00, & 268.1250000000000D+00, & 1206.562500000000D+00, & 4222.968750000000D+00, & 10557.42187500000D+00, & 15836.13281250000D+00, & 7918.066406250000D+00, & -3959.03320312500D+00 /) real ( kind = rk ) f integer n integer n_data integer, save, dimension ( n_max ) :: n_vec = (/ & 4, & 4, & 4, & 4, & 4, & 0, & 1, & 2, & 3, & 4, & 5, & 6, & 7, & 8, & 9 /) real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 5.00D+00, & 5.25D+00, & 5.50D+00, & 5.75D+00, & 6.00D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 n = 0 f = 0.0D+00 else x = x_vec(n_data) n = n_vec(n_data) f = f_vec(n_data) end if return end function r8_is_int ( r ) !*****************************************************************************80 ! !! r8_is_int() determines if a real number represents an integer value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) R, the number to be checked. ! ! Output, logical R8_IS_INT, is TRUE if R is an integer value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i4_huge real ( kind = rk ) r logical r8_is_int if ( real ( i4_huge ( ), kind = rk ) < r ) then r8_is_int = .false. else if ( r < - real ( i4_huge ( ), kind = rk ) ) then r8_is_int = .false. else if ( r == real ( int ( r ), kind = rk ) ) then r8_is_int = .true. else r8_is_int = .false. end if return end function r8_pi ( ) !*****************************************************************************80 ! !! r8_pi() returns the value of pi. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 December 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real ( kind = rk ) R8_PI, the value of pi. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_pi r8_pi = 3.141592653589793D+00 return end function r8_rise ( x, n ) !*****************************************************************************80 ! !! r8_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 of the objects 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) 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 ( kind = rk ) R8_RISE, the value of the rising factorial ! function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) arg integer i integer n real ( kind = rk ) r8_rise real ( kind = rk ) value real ( kind = rk ) x value = 1.0D+00 arg = x if ( 0 < n ) then do i = 1, n value = value * arg arg = arg + 1.0D+00 end do else if ( n < 0 ) then do i = -1, n, -1 value = value * arg arg = arg - 1.0D+00 end do end if r8_rise = value return end subroutine r8_rise_values ( n_data, x, n, f ) !*****************************************************************************80 ! !! r8_rise_values() returns some values of the rising factorial function. ! ! Discussion: ! ! Pochhammer(X,Y) = Gamma(X+Y) / Gamma(X) ! ! For integer arguments, Pochhammer(M,N) = ( M + N - 1 )! / ( N - 1 )! ! ! In Mathematica, the function can be evaluated by: ! ! Pochhammer[X,Y] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 December 2014 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! ISBN: 0-486-61272-4, ! LC: QA47.A34. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Cambridge University Press, 1999, ! ISBN: 0-521-64314-7, ! LC: QA76.95.W65. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, integer N, the arguments. ! ! Output, real ( kind = rk ) F, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 15 real ( kind = rk ), save, dimension ( n_max ) :: f_vec = (/ & 1680.000000000000D+00, & 1962.597656250000D+00, & 2279.062500000000D+00, & 2631.972656250000D+00, & 3024.000000000000D+00, & 1.000000000000000D+00, & 7.500000000000000D+00, & 63.75000000000000D+00, & 605.6250000000000D+00, & 6359.062500000000D+00, & 73129.21875000000D+00, & 914115.2343750000D+00, & 1.234055566406250D+07, & 1.789380571289063D+08, & 2.773539885498047D+09 /) real ( kind = rk ) f integer n integer n_data integer, save, dimension ( n_max ) :: n_vec = (/ & 4, & 4, & 4, & 4, & 4, & 0, & 1, & 2, & 3, & 4, & 5, & 6, & 7, & 8, & 9 /) real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 5.00D+00, & 5.25D+00, & 5.50D+00, & 5.75D+00, & 6.00D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00, & 7.50D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 n = 0 f = 0.0D+00 else x = x_vec(n_data) n = n_vec(n_data) f = f_vec(n_data) end if return end subroutine r8_swap ( x, y ) !*****************************************************************************80 ! !! r8_swap() switches two real values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = rk ) X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z z = x x = y y = z return end subroutine r8_to_cfrac ( r, n, a, p, q ) !*****************************************************************************80 ! !! r8_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). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 June 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Norman Richert, ! Strang's Strange Figures, ! American Mathematical Monthly, ! Volume 99, Number 2, February 1992, pages 101-107. ! ! Parameters: ! ! Input, real ( kind = rk ) 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(0:n) integer i integer p(-1:n) integer q(-1:n) real ( kind = rk ) r real ( kind = rk ) r_copy real ( kind = rk ) 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.0D+00 / ( x(i-1) - real ( a(i-1), kind = rk ) ) 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 r8_to_dec ( dval, dec_digit, mantissa, exponent ) !*****************************************************************************80 ! !! r8_to_dec() converts a real quantity to a decimal representation. ! ! Discussion: ! ! Given the real ( kind = rk ) value DVAL, the routine computes integers ! MANTISSA and EXPONENT so that it is approximately true that: ! ! DVAL = MANTISSA * 10 ^ EXPONENT ! ! In particular, only DEC_DIGIT digits of DVAL are used in constructing the ! representation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 July 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) DVAL, the value whose decimal representation ! is desired. ! ! Input, integer DEC_DIGIT, the number of decimal digits to use. ! ! Output, integer MANTISSA, EXPONENT, the approximate decimal ! representation of DVAL. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dec_digit real ( kind = rk ) dval integer exponent integer mantissa real ( kind = rk ) mantissa_double real ( kind = rk ) ten1 real ( kind = rk ) ten2 ! ! Special cases. ! if ( dval == 0.0D+00 ) then mantissa = 0 exponent = 0 return end if ! ! Factor DVAL = MANTISSA_DOUBLE * 10^exponent ! mantissa_double = dval exponent = 0 ! ! Now normalize so that ! 10**(DEC_DIGIT-1) <= ABS(MANTISSA_DOUBLE) < 10**(DEC_DIGIT) ! ten1 = 10.0D+00**( dec_digit - 1 ) ten2 = 10.0D+00**dec_digit do while ( abs ( mantissa_double ) < ten1 ) mantissa_double = mantissa_double * 10.0D+00 exponent = exponent - 1 end do do while ( ten2 <= abs ( mantissa_double ) ) mantissa_double = mantissa_double / 10.0D+00 exponent = exponent + 1 end do ! ! MANTISSA is the integer part of MANTISSA_DOUBLE, rounded. ! mantissa = nint ( mantissa_double ) ! ! Now divide out any factors of ten from MANTISSA. ! if ( mantissa /= 0 ) then do while ( 10 * ( mantissa / 10 ) == mantissa ) mantissa = mantissa / 10 exponent = exponent + 1 end do end if return end subroutine r8_to_rat ( r, ndig, iatop, iabot ) !*****************************************************************************80 ! !! r8_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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) R, the real value to be converted. ! ! Input, integer NDIG, the number of decimal digits used. ! ! Output, integer IATOP, IABOT, the numerator and denominator ! of the rational value that approximates the real number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) factor integer i4_gcd integer iabot integer iatop integer ibot integer ifac integer itemp integer itop integer jfac integer ndig real ( kind = rk ) r factor = 10.0D+00**ndig if ( 0 < ndig ) then ifac = 10**ndig jfac = 1 else ifac = 1 jfac = 10**(-ndig) end if itop = nint ( r * factor ) * jfac ibot = ifac ! ! Factor out the greatest common factor. ! itemp = i4_gcd ( itop, ibot ) iatop = itop / itemp iabot = ibot / itemp return end subroutine r8_to_s_left ( rval, s ) !*****************************************************************************80 ! !! r8_to_s_left() represents a real using 14 left_justified characters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 January 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) RVAL, a real number. ! ! Output, character ( len = * ) S, a left-justified character variable ! containing the representation of RVAL. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 14 ) chrtmp integer i real ( kind = rk ) rval character ( len = * ) s ! ! We can't seem to write directly into the string because of compiler ! quibbles. ! if ( real ( int ( rval ), kind = rk ) == rval .and. & abs ( rval ) < 1.0D+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 function r8_uniform_ab ( a, b ) !*****************************************************************************80 ! !! r8_uniform_ab() returns a scaled pseudorandom R8. ! ! Discussion: ! ! An R8 is a real ( kind = rk ) value. ! ! The pseudorandom number should be uniformly distributed ! between A and B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 July 2006 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) A, B, the limits of the interval. ! ! Output: ! ! real ( kind = rk ) R8_UNIFORM_AB, a number strictly between A and B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) r real ( kind = rk ) r8_uniform_ab call random_number ( harvest = r ) r8_uniform_ab = a + ( b - a ) * r return end subroutine r8mat_det ( n, a, det ) !*****************************************************************************80 ! !! r8mat_det() finds the determinant of an N by N R8MAT. ! ! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 June 2002 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of rows and columns of A. ! ! Input, real ( kind = rk ) A(N,N), the matrix whose determinant is desired. ! ! Output, real ( kind = rk ) DET, the determinant of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) real ( kind = rk ) det logical even integer i integer iarray(n) logical more real ( kind = rk ) term more = .false. det = 0.0D+00 do call perm1_next ( n, iarray, more, even ) if ( even ) then term = 1.0D+00 else term = -1.0D+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 r8mat_perm1 ( n, a, p ) !*****************************************************************************80 ! !! r8mat_perm1() permutes the rows and columns of a square R8MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 June 2002 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the order of the matrix. ! ! Input/output, real ( kind = rk ) 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, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer i1 integer is real ( kind = rk ) it integer j integer j1 integer j2 integer k integer lc integer nc integer p(n) call perm1_cycle ( n, 1, p, is, nc ) do i = 1, n i1 = -p(i) if ( 0 < i1 ) 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 r8_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 r8mat_2perm1 ( m, n, a, p, q ) !*****************************************************************************80 ! !! r8mat_2perm1() permutes rows and columns of a rectangular R8MAT, in place. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 1999 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer M, number of rows in the matrix. ! ! Input, integer N, number of columns in the matrix. ! ! Input/output, real ( kind = rk ) 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, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) 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 ( kind = rk ) t call perm1_cycle ( m, 1, p, is, nc ) if ( 0 < q(1) ) then call perm1_cycle ( n, 1, q, is, nc ) end if do i = 1, m i1 = -p(i) if ( 0 < i1 ) 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 r8_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 r8mat_permanent ( n, a, perm ) !*****************************************************************************80 ! !! r8mat_permanent() computes the permanent of an R8MAT. ! ! 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. ! ! Setting the diagonal of A to 0, and ensuring that the offdiagonal ! entries are symmetric, then A is the adjacency matrix of a graph, ! and its permanent counts the number of perfect matchings. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 23 July 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the order of the matrix. ! ! Input, real ( kind = rk ) A(N,N), the value of the matrix. ! ! Output, real ( kind = rk ) PERM, the value of the permanent of the matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n,n) integer i integer iadd integer iwork(n) logical more integer ncard real ( kind = rk ) p real ( kind = rk ) perm real ( kind = rk ) sgn real ( kind = rk ) work(n) real ( kind = rk ) z more = .false. do i = 1, n work(i) = a(i,n) - 0.5D+00 * sum ( a(i,1:n) ) end do p = 0.0D+00 sgn = -1.0D+00 do sgn = - sgn call subset_gray_next ( n - 1, iwork, more, ncard, iadd ) if ( ncard /= 0 ) then z = real ( 2 * iwork(iadd) - 1, kind = rk ) 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, kind = rk ) return end subroutine r8mat_print ( m, n, a, title ) !*****************************************************************************80 ! !! r8mat_print() prints an R8MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A. ! ! Input, real ( kind = rk ) A(M,N), the matrix. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n real ( kind = rk ) a(m,n) character ( len = * ) title call r8mat_print_some ( m, n, a, 1, 1, m, n, title ) return end subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title ) !*****************************************************************************80 ! !! r8mat_print_some() prints some of an R8MAT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 November 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, N, the number of rows and columns. ! ! Input, real ( kind = rk ) A(M,N), an M by N matrix to be printed. ! ! Input, integer ILO, JLO, the first row and column to print. ! ! Input, integer IHI, JHI, the last row and column to print. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: incx = 5 integer m integer n real ( kind = rk ) a(m,n) character ( len = 14 ) ctemp(incx) integer i integer i2hi integer i2lo integer ihi integer ilo integer inc integer j integer j2 integer j2hi integer j2lo integer jhi integer jlo logical r8_is_int character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx j2hi = j2lo + incx - 1 j2hi = min ( j2hi, n ) j2hi = min ( j2hi, jhi ) inc = j2hi + 1 - j2lo write ( *, '(a)' ) '' do j = j2lo, j2hi j2 = j + 1 - j2lo write ( ctemp(j2), '(i7,7x)') j end do write ( *, '('' Col '',5a14)' ) ctemp(1:inc) write ( *, '(a)' ) ' Row' write ( *, '(a)' ) '' i2lo = max ( ilo, 1 ) i2hi = min ( ihi, m ) do i = i2lo, i2hi do j2 = 1, inc j = j2lo - 1 + j2 if ( r8_is_int ( a(i,j) ) ) then write ( ctemp(j2), '(f8.0,6x)' ) a(i,j) else write ( ctemp(j2), '(g14.6)' ) a(i,j) end if end do write ( *, '(i5,1x,5a14)' ) i, ( ctemp(j), j = 1, inc ) end do end do return end subroutine r8poly ( n, a, x0, iopt, val ) !*****************************************************************************80 ! !! r8poly() 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of coefficients in the polynomial ! (in other words, the polynomial degree + 1) ! ! Input/output, real ( kind = rk ) 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 ( kind = rk ) 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 ( kind = rk ) VAL, for IOPT = -1 or 0, the value of the ! polynomial at the point X0. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) eps integer i integer iopt integer m integer n1 real ( kind = rk ) val real ( kind = rk ) w real ( kind = rk ) x0 real ( kind = rk ) z n1 = min ( n, iopt ) n1 = max ( 1, n1 ) if ( iopt < -1 ) then n1 = n end if eps = real ( mod ( max ( -iopt, 0 ), 2 ), kind = rk ) w = - real ( n, kind = rk ) * eps if ( -2 < iopt ) then w = w + x0 end if do m = 1, n1 val = 0.0D+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.0D+00 end if end do return end subroutine r8poly_f2p ( n, a ) !*****************************************************************************80 ! !! r8poly_f2p converts a real polynomial from factorial form to power sum form. ! ! Discussion: ! ! The (falling) 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N), on input, the polynomial ! coefficients in factorial form. On output, the polynomial ! coefficients in power sum form. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i integer m real ( kind = rk ) val real ( kind = rk ) w real ( kind = rk ) z w = - real ( n, kind = rk ) do m = 1, n val = 0.0D+00 z = w do i = m, n z = z + 1.0D+00 val = a(n+m-i) + z * val a(n+m-i) = val end do w = w + 1.0D+00 end do return end subroutine r8poly_fval ( n, a, x, val ) !*****************************************************************************80 ! !! r8poly_fval() evaluates a real polynomial in factorial form. ! ! Discussion: ! ! The (falling) 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)) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real ( kind = rk ) A(N), the coefficients of the polynomial. ! A(1) is the constant term. ! ! Input, real ( kind = rk ) X, the point at which the polynomial is ! to be evaluated. ! ! Output, real ( kind = rk ) VAL, the value of the polynomial at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i real ( kind = rk ) val real ( kind = rk ) x val = 0.0D+00 do i = 1, n val = a(n+1-i) + ( x - n + i ) * val end do return end subroutine r8poly_n2p ( n, a, xarray ) !*****************************************************************************80 ! !! r8poly_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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N). On input, the coefficients ! of the polynomial in Newton form, and on output, the coefficients ! in power sum form. ! ! Input/output, real ( kind = rk ) 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, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i real ( kind = rk ) xarray(n) real ( kind = rk ), parameter :: zero = 0.0D+00 do i = 1, n call r8poly_nx ( n, a, xarray, zero ) end do return end subroutine r8poly_nval ( n, a, xarray, x, val ) !*****************************************************************************80 ! !! r8poly_nval() evaluates a real polynomial in Newton form. ! ! Discussion: ! ! 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)) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real ( kind = rk ) A(N), the coefficients of the polynomial. ! A(1) is the constant term. ! ! Input, real ( kind = rk ) XARRAY(N-1), the N-1 points X which are part ! of the definition of the polynomial. ! ! Input, real ( kind = rk ) X, the point at which the polynomial ! is to be evaluated. ! ! Output, real ( kind = rk ) VAL, the value of the polynomial at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i real ( kind = rk ) val real ( kind = rk ) x real ( kind = rk ) xarray(n-1) val = a(n) do i = n-1, 1, -1 val = a(i) + ( x - xarray(i) ) * val end do return end subroutine r8poly_nx ( n, a, xarray, x ) !*****************************************************************************80 ! !! r8poly_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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N), the polynomial coefficients ! of the Newton form. ! ! Input/output, real ( kind = rk ) 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 ( kind = rk ) X, the new point to be shifted into XARRAY. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i real ( kind = rk ) x real ( kind = rk ) 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 r8poly_p2f ( n, a ) !*****************************************************************************80 ! !! r8poly_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 (falling) factorial form is ! ! p(x) = a(1) ! + a(2) * x ! + a(3) * x * (x-1) ! ... ! + a(n) * x * (x-1) *...* (x-(n-2)) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N), on input, the polynomial ! coefficients in the power sum form, on output, the polynomial ! coefficients in factorial form. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i integer m real ( kind = rk ) val do m = 1, n val = 0.0D+00 do i = m, n val = a(n+m-i) + real ( m - 1, kind = rk ) * val a(n+m-i) = val end do end do return end subroutine r8poly_p2n ( n, a, xarray ) !*****************************************************************************80 ! !! r8poly_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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N). On input, the coefficients ! of the polynomial in power sum form, and on output, the ! coefficients in Newton form. ! ! Input/output, real ( kind = rk ) XARRAY(N). On input, the desired ! abscissas of the Newton form of the polynomial. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i real ( kind = rk ) xarray(n) real ( kind = rk ) work(n) work(1:n) = 0.0D+00 do i = n, 1, -1 call r8poly_nx ( n, a, work, xarray(i) ) end do return end subroutine r8poly_p2t ( n, a, x ) !*****************************************************************************80 ! !! r8poly_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 of a polynomial based at X0 is ! ! p(x) = a(1) ! + a(2) * (x-x0) ! + a(3) * (x-x0)^2 ! ... ! + a(n) * (x-x0)^(n-1) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N), on input, the coefficients in ! power sum form, and on output, the coefficients in Taylor form. ! ! Input, real ( kind = rk ) X, the point at which the Taylor form of the ! polynomial is to be based. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i integer m real ( kind = rk ) val real ( kind = rk ) x do m = 1, n val = 0.0D+00 do i = m, n val = a(n+m-i) + x * val a(n+m-i) = val end do end do return end subroutine r8poly_print ( n, a, title ) !*****************************************************************************80 ! !! r8poly_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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 August 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real ( kind = rk ) 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, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(0:n) integer i real ( kind = rk ) mag character plus_minus character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' if ( a(n) < 0.0D+00 ) then plus_minus = '-' else plus_minus = '' end if mag = abs ( a(n) ) if ( 2 <= n ) then write ( *, '( '' p(x) = '', a1, g14.6, '' * x ^ '', i3 )' ) & plus_minus, mag, n else if ( n == 1 ) then write ( *, '( '' p(x) = '', a1, g14.6, '' * x'' )' ) plus_minus, mag else if ( n == 0 ) then write ( *, '( '' p(x) = '', a1, g14.6 )' ) plus_minus, mag end if do i = n - 1, 0, -1 if ( a(i) < 0.0D+00 ) then plus_minus = '-' else plus_minus = '+' end if mag = abs ( a(i) ) if ( mag /= 0.0D+00 ) then if ( 2 <= i ) 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 r8poly_pval ( n, a, x, val ) !*****************************************************************************80 ! !! r8poly_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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input, real ( kind = rk ) A(0:N), the coefficients of the polynomial. ! A(0) is the constant term. ! ! Input, real ( kind = rk ) X, the point at which the polynomial ! is to be evaluated. ! ! Output, real ( kind = rk ) VAL, the value of the polynomial at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(0:n) integer i real ( kind = rk ) val real ( kind = rk ) x val = 0.0D+00 do i = n, 0, -1 val = val * x + a(i) end do return end subroutine r8poly_t2p ( n, a, x ) !*****************************************************************************80 ! !! r8poly_t2p() converts a real polynomial from Taylor form to power sum form. ! ! Discussion: ! ! The Taylor form of a polynomial based at X0 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) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of A. ! ! Input/output, real ( kind = rk ) A(N). On input, the coefficients ! in Taylor form, and on output, the coefficients in power sum form. ! ! Input, real ( kind = rk ) X, the point at which the Taylor form ! polynomial is based. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i integer j real ( kind = rk ) 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 r8vec_backtrack ( n, maxstack, x, indx, k, nstack, stack, ncan ) !*****************************************************************************80 ! !! r8vec_backtrack() supervises a backtrack search for an R8VEC. ! ! 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; ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 July 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of positions to be filled in ! the vector. ! ! Input, integer MAXSTACK, the maximum length of the stack. ! ! Input/output, real ( kind = rk ) X(N), the partially filled in ! candidate vector. ! ! Input/output, integer INDX, a communication flag. ! On input, ! 0, to begin a backtracking search. ! 2, the requested candidates for position K have been added to ! STACK, and NCAN(K) was updated. ! 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. ! ! Input/output, integer K, the index in X that we are trying ! to fill. ! ! Input/output, integer NSTACK, the current length of the stack. ! ! Input/output, real ( kind = rk ) STACK(MAXSTACK), a list of all current ! candidates for all positions 1 through K. ! ! Input/output, integer NCAN(N), lists the current number of ! candidates for all positions 1 through K. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer maxstack integer indx integer k integer ncan(n) integer nstack real ( kind = rk ) stack(maxstack) real ( kind = rk ) 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 ( 0 < ncan(k) ) 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 r8vec_frac ( n, a, k, afrac ) !*****************************************************************************80 ! !! r8vec_frac() searches for the K-th smallest entry in an R8VEC. ! ! Discussion: ! ! Hoare's algorithm is used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 July 2000 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Input/output, real ( kind = rk ) 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 ( kind = rk ) AFRAC, the value of the K-th fractile of A. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) real ( kind = rk ) afrac integer i integer iryt integer j integer k integer left real ( kind = rk ) x if ( n <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!' write ( *, '(a,i8)' ) ' Illegal nonpositive value of N = ', n stop 1 end if if ( k <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!' write ( *, '(a,i8)' ) ' Illegal nonpositive value of K = ', k stop 1 end if if ( n < k ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'R8VEC_FRAC - Fatal error!' write ( *, '(a,i8)' ) ' Illegal N < K, K = ', k stop 1 end if left = 1 iryt = n do if ( iryt <= left ) then afrac = a(k) exit end if x = a(k) i = left j = iryt do if ( j < i ) 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 r8_swap ( a(i), a(j) ) i = i + 1 j = j - 1 end if end do end do return end subroutine r8vec_indicator1 ( n, a ) !*****************************************************************************80 ! !! r8vec_indicator1() sets an R8VEC to the indicator1 vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of elements of A. ! ! Output, real ( kind = rk ) A(N), the array to be initialized. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i do i = 1, n a(i) = real ( i, kind = rk ) end do return end subroutine r8vec_mirror_next ( n, a, done ) !*****************************************************************************80 ! !! r8vec_mirror_next() steps through all sign variations of an R8VEC. ! ! Discussion: ! ! In normal use, the user would set every element of A to be positive. ! The routine will take the input value of A, and output a copy in ! which the signs of one or more entries have been changed. Repeatedly ! calling the routine with the output from the previous call will generate ! every distinct "variation" of A; that is, all possible sign variations. ! ! When the output variable DONE is TRUE (or equal to 1), then the ! output value of A_NEW is the last in the series. ! ! Note that A may have some zero values. The routine will essentially ! ignore such entries; more exactly, it will not stupidly assume that -0 ! is a proper "variation" of 0! ! ! Also, it is possible to call this routine with the signs of A set ! in any way you like. The routine will operate properly, but it ! will nonethess terminate when it reaches the value of A in which ! every nonzero entry has negative sign. ! ! ! More efficient algorithms using the Gray code seem to require internal ! memory in the routine, which is not one of MATLAB's strong points, ! or the passing back and forth of a "memory array", or the use of ! global variables, or unnatural demands on the user. This form of ! the routine is about as clean as I can make it. ! ! Example: ! ! Input Output ! --------- -------------- ! A A_NEW DONE ! --------- -------- ---- ! 1 2 3 -1 2 3 false ! -1 2 3 1 -2 3 false ! 1 -2 3 -1 -2 3 false ! -1 -2 3 1 2 -3 false ! 1 2 -3 -1 2 -3 false ! -1 2 -3 1 -2 -3 false ! 1 -2 -3 -1 -2 -3 false ! -1 -2 -3 1 2 3 true ! ! 1 0 3 -1 0 3 false ! -1 0 3 1 0 -3 false ! 1 0 -3 -1 0 -3 false ! -1 0 -3 1 0 3 true ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 30 May 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input/output, real ( kind = rk ) A(N), a vector of real numbers. ! On output, some signs have been changed. ! ! Output, logical DONE, is TRUE if the input vector A was the last element ! in the series (every entry was nonpositive); the output vector is reset ! so that all entries are nonnegative, but presumably the ride is over! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) logical done integer i integer positive ! ! Seek the first strictly positive entry of A. ! positive = 0 do i = 1, n if ( 0.0D+00 < a(i) ) then positive = i exit end if end do ! ! If there is no strictly positive entry of A, there is no successor. ! if ( positive == 0 ) then a(1:n) = -a(1:n) done = .true. return end if ! ! Otherwise, negate A up to the positive entry. ! a(1:positive) = -a(1:positive) done = .false. return end subroutine r8vec_print ( n, a, title ) !*****************************************************************************80 ! !! r8vec_print() prints an R8VEC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 December 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, real ( kind = rk ) A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title to be printed first. ! TITLE may be blank. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' do i = 1, n write ( *, '(i8,g14.6)' ) i, a(i) end do return end subroutine r8vec_uniform_01 ( n, r ) !*****************************************************************************80 ! !! r8vec_uniform_01() returns a unit pseudorandom R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of R8's. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 August 2014 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Peter Lewis, Allen Goodman, James Miller ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Input: ! ! integer N, the number of entries in the vector. ! ! Output: ! ! real ( kind = rk ) R(N), the vector of pseudorandom values. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) r(n) call random_number ( harvest = r(1:n) ) return end subroutine r8vec_uniform_ab ( n, a, b, r ) !*****************************************************************************80 ! !! r8vec_uniform_ab() returns a scaled pseudorandom R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of R8's. ! ! Each dimension ranges from A to B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Second Edition, ! Springer, 1987, ! ISBN: 0387964673, ! LC: QA76.9.C65.B73. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, December 1986, pages 362-376. ! ! Pierre L'Ecuyer, ! Random Number Generation, ! in Handbook of Simulation, ! edited by Jerry Banks, ! Wiley, 1998, ! ISBN: 0471134031, ! LC: T57.62.H37. ! ! Peter Lewis, Allen Goodman, James Miller, ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, Number 2, 1969, pages 136-143. ! ! Input: ! ! integer N, the number of entries in the vector. ! ! real ( kind = rk ) A, B, the lower and upper limits. ! ! Output: ! ! real ( kind = rk ) R(N), the vector of pseudorandom values. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) r(n) call random_number ( harvest = r(1:n) ) r(1:n) = a + ( b - a ) * r(1:n) return end subroutine rat_add ( itop1, ibot1, itop2, ibot2, itop, ibot, ierror ) !*****************************************************************************80 ! !! rat_add() adds two rational values. ! ! Discussion: ! ! The routine computes ! ! ITOP/IBOT = ITOP1/IBOT1 + ITOP2/IBOT2 ! ! while trying to avoid integer overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 January 2007 ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i4_gcd integer i4_huge 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 = i4_huge ( ) 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 = i4_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 ( real ( i_max, kind = rk ) & < abs ( real ( jtop1, kind = rk ) * real ( jbot2, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational sum.' itop = 0 stop 1 end if jtop1 = jtop1 * jbot2 if ( real ( i_max, kind = rk ) & < abs ( real ( jtop2, kind = rk ) * real ( jbot1, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational sum.' itop = 0 stop 1 end if jtop2 = jtop2 * jbot1 if ( real ( i_max, kind = rk ) & < abs ( real ( jtop1, kind = rk ) + real ( jtop2, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational sum.' itop = 0 stop 1 end if itop = jtop1 + jtop2 ! ! Check the bottom for overflow. ! if ( real ( i_max, kind = rk ) < & abs ( real ( jbot1, kind = rk ) * real ( jbot2, kind = rk ) & * real ( jbot3, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_ADD - Fatal error!' write ( *, '(a)' ) ' Overflow of bottom of rational sum.' ibot = 1 stop 1 end if ibot = jbot1 * jbot2 * jbot3 ! ! Put the fraction in lowest terms. ! itemp = i4_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 ) !*****************************************************************************80 ! !! rat_div() divides one rational value by another. ! ! Discussion: ! ! The routine computes ! ! ITOP / IBOT = ( ITOP1 / IBOT1 ) / ( ITOP2 / IBOT2 ). ! ! while avoiding integer overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 May 2003 ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer i4_gcd integer i4_huge 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 = i4_huge ( ) 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 = i4_gcd ( jtop1, jbot1 ) jtop1 = jtop1 / itemp jbot1 = jbot1 / itemp itemp = i4_gcd ( jtop1, jbot2 ) jtop1 = jtop1 / itemp jbot2 = jbot2 / itemp itemp = i4_gcd ( jtop2, jbot1 ) jtop2 = jtop2 / itemp jbot1 = jbot1 / itemp itemp = i4_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 ( real ( i_max, kind = rk ) & < abs ( real ( jtop1, kind = rk ) * real ( jtop2, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_DIV - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational fraction.' itop = 0 stop 1 end if itop = jtop1 * jtop2 ! ! Check the bottom IBOT1*ITOP2 for overflow. ! if ( real ( i_max, kind = rk ) & < abs ( real ( jbot1, kind = rk ) * real ( jbot2, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_DIV - Fatal error!' write ( *, '(a)' ) ' Overflow of bottom of rational fraction.' ibot = 1 stop 1 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 ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 June 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 1, Fundamental Algorithms, ! Addison Wesley, 1968, page 157. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 = 0 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 = ( 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 ) !*****************************************************************************80 ! !! 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). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! rat_mul() multiplies two fractions. ! ! Discussion: ! ! The routine computes ! ! ITOP / IBOT = ( ITOP1 / IBOT1 ) * ( ITOP2 / IBOT2 ). ! ! while avoiding integer overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer i4_gcd integer i4_huge 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 = i4_huge ( ) 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 = i4_gcd ( jtop1, jbot1 ) jtop1 = jtop1 / itemp jbot1 = jbot1 / itemp itemp = i4_gcd ( jtop1, jbot2 ) jtop1 = jtop1 / itemp jbot2 = jbot2 / itemp itemp = i4_gcd ( jtop2, jbot1 ) jtop2 = jtop2 / itemp jbot1 = jbot1 / itemp itemp = i4_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 ( real ( i_max, kind = rk ) & < abs ( real ( jtop1, kind = rk ) * real ( jtop2, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_MUL - Fatal error!' write ( *, '(a)' ) ' Overflow of top of rational product.' itop = 0 stop 1 end if itop = jtop1 * jtop2 ! ! Check the bottom IBOT1*IBOT2 for overflow. ! if ( real ( i_max, kind = rk ) & < abs ( real ( jbot1, kind = rk ) * real ( jbot2, kind = rk ) ) ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_MUL - Fatal error!' write ( *, '(a)' ) ' Overflow of bottom of rational product.' ibot = 1 stop 1 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_normalize ( a, b ) !*****************************************************************************80 ! !! rat_normalize() normalizes a rational number. ! ! Discussion: ! ! If A = B = 0, return. ! ! If A = 0 (and B nonzero) set B => 1 and return. ! ! If A nonzero, and B = 0, then A => 1 and return. ! ! If A = B, then set A => 1, B => 1 and return. ! ! If B < 0, then A => -A, B => -B. ! ! If 1 < C = GCD(|A|,|B|), A => A/C, B => B/C. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 June 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer A, B, the rational number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer b integer c integer i4_gcd ! ! Cases where one or both is 0. ! if ( a == 0 .and. b == 0 ) then return else if ( a == 0 .and. b /= 0 ) then b = 1 return else if ( a /= 0 .and. b == 0 ) then a = 1 return end if if ( a == b ) then a = 1 b = 1 return end if if ( b < 0 ) then a = -a b = -b end if c = i4_gcd ( abs ( a ), abs ( b ) ) if ( 1 < c ) then a = a / c b = b / c end if return end subroutine rat_sum_formula ( n, a, b ) !*****************************************************************************80 ! !! 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 coeficient of N^J, which is ! not the case now. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 June 2002 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Robert Owens, ! Sums of Powers of Integers, ! Mathematics Magazine, ! Volume 65, Number 1, February 1992, pages 38-40. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 ( ip, iq, m, n, a, ierror ) !****************************************************************************** ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! Original FORTRAN77 version by John Hart, Ward Cheney, Charles Lawson, ! Hans Maehly, Charles Mesztenyi, John Rice, Henry Thatcher, ! Christoph Witzgall. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, Charles Mesztenyi, ! John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Parameters: ! ! Input, integer IP, IQ, the numerator and denominator of the ! rational value whose continued fraction representation is ! desired. ! ! 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. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ( m < n ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_TO_CFRAC - Fatal error!' write ( *, '(a)' ) ' M < N.' write ( *, '(a)' ) ' M = ', m write ( *, '(a)' ) ' N = ', n ierror = 1 stop 1 end if a(n) = jp / jq jp = mod ( jp, jq ) if ( jp == 0 ) then return end if n = n + 1 if ( m < n ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_TO_CFRAC - Fatal error!' write ( *, '(a)' ) ' M < N.' write ( *, '(a)' ) ' M = ', m write ( *, '(a)' ) ' N = ', n ierror = 1 stop 1 end if a(n) = jq / jp jq = mod ( jq, jp ) if ( jq == 0 ) then exit end if end do return end subroutine rat_to_dec ( rat_top, rat_bot, mantissa, expo ) !*****************************************************************************80 ! !! rat_to_dec() converts a rational to a decimal representation. ! ! Discussion: ! ! A rational value is represented by RAT_TOP / RAT_BOT. ! ! A decimal value is represented as MANTISSA * 10^EXPO. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 November 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer RAT_TOP, RAT_BOT, the rational value. ! ! Output, integer MANTISSA, EXPO, the decimal number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer expo integer gcd integer i4_gcd integer i4_huge integer mantissa real ( kind = rk ) r real ( kind = rk ) r_max integer rat_bot integer rat_bot2 integer rat_top integer rat_top2 integer s if ( rat_top == 0 ) then mantissa = 0 expo = 0 return end if gcd = i4_gcd ( rat_top, rat_bot ) rat_top2 = rat_top / gcd rat_bot2 = rat_bot / gcd if ( rat_bot2 < 0 ) then rat_top2 = -rat_top2 rat_bot2 = -rat_bot2 end if if ( rat_bot2 == 1 ) then mantissa = rat_top2 expo = 0 return end if expo = 0 do while ( mod ( rat_bot2, 10 ) == 0 ) expo = expo - 1 rat_bot2 = rat_bot2 / 10 end do do while ( mod ( rat_top2, 10 ) == 0 ) expo = expo + 1 rat_top2 = rat_top2 / 10 end do r = real ( rat_top2, kind = rk ) / real ( rat_bot2, kind = rk ) if ( r < 0.0D+00 ) then s = -1 r = -r else s = 1 end if r_max = real ( i4_huge ( ), kind = rk ) / 10.0D+00 do while ( r /= real ( int ( r ), kind = rk ) .and. r < r_max ) r = r * 10.0D+00 expo = expo - 1 end do mantissa = s * int ( r ) return end subroutine rat_to_r8 ( a, b, r ) !*****************************************************************************80 ! !! rat_to_r8() converts rational values to real values. ! ! Example: ! ! A B R ! -- -- --- ! 1 2 0.5 ! 7 5 1.4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 June 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the rational quantity to be converted. ! ! Output, real ( kind = rk ) R, the value of the rational quantity ! as a real number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer b real ( kind = rk ) r if ( b == 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'RAT_TO_R8 - Warning!' write ( *, '(a)' ) ' The input fraction to be converted had a' write ( *, '(a)' ) ' zero denominator.' r = 0.0D+00 else r = real ( a, kind = rk ) / real ( b, kind = rk ) end if return end subroutine rat_to_s ( a, b, s ) !*****************************************************************************80 ! !! rat_to_s() returns a left-justified representation of A/B. ! ! Discussion: ! ! If the ratio is negative, a minus sign precedes A. ! A slash separates A and B. ! ! Note that if A is nonzero and B is 0, S will ! be returned as "Inf" or "-Inf" (Infinity), and if both ! A and B are zero, S will be returned as "NaN" ! (Not-a-Number). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 03 June 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the numerator and denominator. ! ! Output, character ( len = * ) S, a left-justified string ! containing the representation of A/B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer b character ( len = * ) s character ( len = 25 ) s2 ! ! Take care of simple cases right away. ! if ( a == 0 ) then if ( b /= 0 ) then s2 = '0' else s2= 'NaN' end if else if ( b == 0 ) then if ( 0 < a ) then s2 = 'Inf' else s2 = '-Inf' end if ! ! Make copies of A and B. ! else if ( b == 1 ) then write ( s2, '(i12)' ) a else write ( s2, '(i12, ''/'', i12)' ) a, b end if call s_blank_delete ( s2 ) end if s = s2 return end function rat_width ( a, b ) !*****************************************************************************80 ! !! rat_width() returns the "width" of a rational number. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 June 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer A, B, the rational number. ! ! Output, integer RAT_WIDTH, the "width" of the rational number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer a integer abs_a integer abs_b integer b integer rat_width integer ten_pow integer value value = 1 ten_pow = 10 if ( a == 0 ) then rat_width = 1 return end if abs_a = abs ( a ) do while ( ten_pow <= abs_a ) value = value + 1 ten_pow = ten_pow * 10 end do ! ! If the fraction is negative, a minus sign will be prepended to the ! numerator. ! if ( a * b < 0 ) then value = value + 1 ten_pow = ten_pow * 10 end if abs_b = abs ( b ) do while ( ten_pow <= abs_b ) value = value + 1 ten_pow = ten_pow * 10 end do rat_width = value return end subroutine ratmat_det ( n, iatop, iabot, idtop, idbot, ierror ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) 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 perm1_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 stop 1 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 stop 1 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 ) !*****************************************************************************80 ! !! ratmat_print() prints out rational vectors or matrices. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m integer n integer a(m,n) integer b(m,n) character ( len = 10 ) chrtmp2 character ( len = 10 ) chrtmp3 character ( len = 40 ) format1 character ( len = 40 ) format2 integer i integer ione integer itemp 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 ( 10 ** ( kmax - 2 ) <= itemp ) kmax = kmax + 1 end do itemp = abs ( b(i,j) ) do while ( 10 ** ( kmax - 2 ) < itemp ) kmax = kmax + 1 end do end do end do kmax = kmax + 1 npline = ncolum / kmax ! ! Create the formats. ! call i4_to_s_left ( npline, chrtmp2 ) call i4_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 ( 1 < jmin .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 ( n, v, vmax, done ) !*****************************************************************************80 ! !! regro_next() computes restricted growth functions one at a time. ! ! Discussion: ! ! 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) ). ! ! 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. ! ! Example: ! ! The 15 restricted growth functions for N = 4 are: ! ! (1111), (1112), (1121), (1122), (1123), ! (1211), (1212), (1213), (1221), (1222), ! (1223), (1231), (1232), (1233), (1234). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 July 1998 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! Parameters: ! ! 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. ! ! 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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! rfrac_to_cfrac() converts rational polynomial fractions to continued fractions. ! ! 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) ... ))) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 April 2000 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, Charles Mesztenyi, ! John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Author: ! ! Original FORTRAN77 version by John Hart, Ward Cheney, Charles Lawson, ! Hans Maehly, Charles Mesztenyi, John Rice, Henry Thatcher, ! Christoph Witzgall. ! FORTRAN90 version by John Burkardt. ! ! 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 ( kind = rk ) P(M), Q(M+1), the coefficients defining ! the rational polynomial fraction. ! ! Output, real ( kind = rk ) 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, parameter :: rk = kind ( 1.0D+00 ) integer m real ( kind = rk ) a(m+1,2*m+1) integer i integer ierror integer k real ( kind = rk ) p(m) real ( kind = rk ) q(m+1) real ( kind = rk ) t(2*m) real ( kind = rk ) 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.0D+00 ) then ierror = 1 write ( *, '(a)' ) '' write ( *, '(a)' ) 'RFRAC_TO_CFRAC - Fatal error!' write ( *, '(a,i8)' ) ' A(1,K+2) is zero for K = ', k stop 1 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 ) !*****************************************************************************80 ! !! 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) )... )) ! ! Thanks to Henry Amuasi for noticing and correcting an error in a ! previous formulation of this routine, 02 October 2010. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 October 2010 ! ! Author: ! ! Original FORTRAN77 version by John Hart, Ward Cheney, Charles Lawson, ! Hans Maehly, Charles Mesztenyi, John Rice, Henry Thatcher, ! Christoph Witzgall. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! John Hart, Ward Cheney, Charles Lawson, Hans Maehly, Charles Mesztenyi, ! John Rice, Henry Thatcher, Christoph Witzgall, ! Computer Approximations, ! Wiley, 1968. ! ! Parameters: ! ! Input, integer M, defines the number of P, R, and S ! coefficients, and is one less than the number of Q coefficients. ! 1 <= M. ! ! Input, real ( kind = rk ) P(M), Q(M+1), the coefficients defining ! the rational polynomial fraction. ! ! Output, real ( kind = rk ) R(M), S(M), the coefficients defining the ! J-fraction. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer m real ( kind = rk ) a(m+1,m+1) integer k real ( kind = rk ) p(m) real ( kind = rk ) q(m+1) real ( kind = rk ) r(m) real ( kind = rk ) s(m) if ( m < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'RFRAC_TO_JFRAC - Fatal error!' write ( *, '(a)' ) ' Input M < 1.' stop 1 end if a(1:m+1,1) = q(1:m+1) a(1:m, 2) = p(1:m) if ( 1 < m ) 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) a(2:m-k,k+2) = r(k) * a(2:m-k,k) - a(1:m-k-1,k+1) - s(k) * a(2:m-k,k+1) if ( a(m-k,k+2) == 0.0D+00 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'RFRAC_TO_JFRAC - Fatal error!' write ( *, '(a,i8)' ) ' A(M-K,K+2) = 0 for K=', k stop 1 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 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 subroutine s_blank_delete ( s ) !*****************************************************************************80 ! !! s_blank_delete() removes blanks from a string, left justifying the remainder. ! ! Discussion: ! ! All TAB characters are also removed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 July 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, character ( len = * ) S, the string to be transformed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer j character newchr character oldchr character ( len = * ) s character, parameter :: TAB = char ( 9 ) j = 0 newchr = '' do i = 1, len ( s ) oldchr = newchr newchr = s(i:i) if ( newchr == TAB ) then newchr = '' end if s(i:i) = '' if ( oldchr /= '' .or. newchr /= '' ) then j = j + 1 s(j:j) = newchr end if end do return end subroutine schroeder ( n, s ) !*****************************************************************************80 ! !! schroeder() generates the Schroeder numbers. ! ! Discussion: ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! RP 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. ! ! Parameters: ! ! Input, integer N, the number of Schroeder numbers desired. ! ! Output, integer S(N), the Schroeder numbers. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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, i1, j1, k0, k1, n1 ) !*****************************************************************************80 ! !! sort_heap_external() externally sorts a list of items into ascending 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 June 2015 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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 J < I; ! * 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; ! 0 <= ISGN means I is greater than or equal to J. ! ! Input/output, integer I1, J1, K0, K1, N1, variables that ! are used for bookkeeping. The user should declare them, and pass the ! output values from one call as input values on the next call. The user ! should not change these variables. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer i1 integer indx integer isgn integer j integer j1 integer k0 integer k1 integer n integer n1 ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then i1 = 0 j1 = 0 k0 = n / 2 k1 = n / 2 n1 = n ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 0 ) then i1 = i1 + 1 end if j1 = k1 k1 = i1 indx = -1 i = i1 j = j1 return end if if ( 0 < isgn ) then indx = 2 i = i1 j = j1 return end if if ( k0 <= 1 ) then if ( n1 == 1 ) then i1 = 0 j1 = 0 indx = 0 else i1 = n1 n1 = n1 - 1 j1 = 1 indx = 1 end if i = i1 j = j1 return end if k0 = k0 - 1 k1 = k0 ! ! 0 < INDX, the user was asked to make an interchange. ! else if ( indx == 1 ) then k1 = k0 end if do i1 = 2 * k1 if ( i1 == n1 ) then j1 = k1 k1 = i1 indx = -1 i = i1 j = j1 return else if ( i1 <= n1 ) then j1 = i1 + 1 indx = -2 i = i1 j = j1 return end if if ( k0 <= 1 ) then exit end if k0 = k0 - 1 k1 = k0 end do if ( n1 == 1 ) then i1 = 0 j1 = 0 indx = 0 i = i1 j = j1 else i1 = n1 n1 = n1 - 1 j1 = 1 indx = 1 i = i1 j = j1 end if return end subroutine subcomp_next ( n, k, a, more, h, t, n2, more2 ) !*****************************************************************************80 ! !! subcomp_next() computes the next subcomposition of N into K parts. ! ! Discussion: ! ! A composition of the integer N into K parts is an ordered sequence ! of K nonnegative integers which sum to a value of N. ! ! A subcomposition of the integer N into K parts is a composition ! of M into K parts, where 0 <= M <= N. ! ! A subcomposition of the integer N into K parts is also a lattice ! point in the simplex whose vertices are the origin, and the K direction ! vectors N*E(I) for I = 1 to K. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 July 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer whose subcompositions ! are desired. ! ! Input, integer K, the number of parts in the subcomposition. ! ! Input/output, integer A(K), the parts of the subcomposition. ! ! Input/output, logical MORE, set by the user to start the computation, ! and by the routine to terminate it. ! ! Input/output, integer H, T, N2, internal parameters needed ! for the computation. The user should allocate space for these in the ! calling program, include them in the calling sequence, but not alter them! ! ! Input/output, logical MORE2, an internal parameter needed for the ! computation. The user should allocate space for this in the calling ! program, include it in the calling sequence, but never alter it! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer h logical more logical more2 integer n integer n2 integer t ! ! The first computation. ! if ( .not. more ) then a(1:k) = 0 more = .true. h = 0 t = 0 n2 = 0 more2 = .false. ! ! Do the next element at the current value of N. ! else if ( more2 ) then call comp_next ( n2, k, a, more2, h, t ) else more2 = .false. n2 = n2 + 1 call comp_next ( n2, k, a, more2, h, t ) end if ! ! Termination occurs if MORE2 = FALSE and N2 = N. ! if ( .not. more2 .and. n2 == n ) then more = .false. end if return end subroutine subcompnz_next ( n, k, a, more, h, t, n2, more2 ) !*****************************************************************************80 ! !! subcompnz_next() computes the next subcomposition of N into K nonzero parts. ! ! Discussion: ! ! A composition of the integer N into K nonzero parts is an ordered sequence ! of K positive integers which sum to a value of N. ! ! A subcomposition of the integer N into K nonzero parts is a composition ! of M into K nonzero parts, where 0 < M <= N. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer whose subcompositions are ! desired. ! ! Input, integer K, the number of parts in the subcomposition. ! K must be no greater than N. ! ! Input/output, integer A(K), the parts of the subcomposition. ! ! Input/output, logical MORE, set by the user to start the computation, ! and by the routine to terminate it. ! ! Input/output, integer H, T, N2, internal parameters needed ! for the computation. The user should allocate space for these in the ! calling program, include them in the calling sequence, but not alter them! ! ! Input/output, logical MORE2, an internal parameter needed for the ! computation. The user should allocate space for this in the calling ! program, include it in the calling sequence, but never alter it! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer h logical more logical more2 integer n integer n2 integer t if ( n < k ) then more = .false. a(1:k) = -1 return end if ! ! The first computation. ! if ( .not. more ) then a(1:k) = 1 more = .true. h = 0 t = 0 n2 = k more2 = .false. ! ! Do the next element at the current value of N. ! else if ( more2 ) then call compnz_next ( n2, k, a, more2, h, t ) else more2 = .false. n2 = n2 + 1 call compnz_next ( n2, k, a, more2, h, t ) end if ! ! Termination occurs if MORE2 = FALSE and N2 = N. ! if ( .not. more2 .and. n2 == n ) then more = .false. end if return end subroutine subcompnz2_next ( n_lo, n_hi, k, a, more, h, t, n2, more2 ) !*****************************************************************************80 ! !! subcompnz2_next() computes the next subcomposition of N into K nonzero parts. ! ! Discussion: ! ! A composition of the integer N into K nonzero parts is an ordered sequence ! of K positive integers which sum to a value of N. ! ! A subcomposition of the integer N into K nonzero parts is a composition ! of M into K nonzero parts, where 0 < M <= N. ! ! This routine computes all compositions of K into nonzero parts which sum ! to values between N_LO and N_HI. ! ! The routine SUBCOMPNZ_NEXT can be regarded as a special case where ! N_LO = K. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N_LO, N_HI, the range of values N for which ! compositions are desired. ! ! Input, integer K, the number of parts in the subcomposition. ! K must be no greater than N_HI. ! ! Input/output, integer A(K), the parts of the subcomposition. ! ! Input/output, logical MORE, set by the user to start the computation, ! and by the routine to terminate it. ! ! Input/output, integer H, T, N2, internal parameters needed ! for the computation. The user should allocate space for these in the ! calling program, include them in the calling sequence, but not alter them! ! ! Input/output, logical MORE2, an internal parameter needed for the ! computation. The user should allocate space for this in the calling ! program, include it in the calling sequence, but never alter it! ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer a(k) integer h logical more logical more2 integer n_hi integer n_lo integer n2 integer t if ( n_hi < k ) then more = .false. a(1:k) = -1 return end if if ( n_hi < n_lo ) then more = .false. a(1:k) = -1 return end if ! ! The first computation. ! if ( .not. more ) then more = .true. n2 = max ( k, n_lo ) more2 = .false. call compnz_next ( n2, k, a, more2, h, t ) ! ! Do the next element at the current value of N. ! else if ( more2 ) then call compnz_next ( n2, k, a, more2, h, t ) else n2 = n2 + 1 call compnz_next ( n2, k, a, more2, h, t ) end if ! ! Termination occurs if MORE2 = FALSE and N2 = N_HI. ! if ( .not. more2 .and. n2 == n_hi ) then more = .false. end if return end subroutine subset_by_size_next ( n, a, subsize, more, more2, m, m2 ) !*****************************************************************************80 ! !! subset_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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the set. ! ! Input/output, integer A(N). The entries A(1:SUBSIZE) contain ! the elements of the subset. The elements are given in ascending ! order. ! ! Input/output, integer SUBSIZE, 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. ! ! Input/output, logical MORE2, a variable for bookkeeping. ! The user should declare this variable, but need not initialize it. ! The output value from one call must be the input value for the next. ! ! Input/output, integer M, M2, variables for bookkeeping. ! The user should declare this variable, but need not initialize it. ! The output value from one call must be the input value for the next. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer m integer m2 logical more logical more2 integer subsize if ( .not. more ) then subsize = n more = .true. more2 = .false. m = 0 m2 = 0 else if ( .not. more2 ) then subsize = subsize - 1 end if ! ! Compute the next subset of size SUBSIZE. ! if ( 0 < subsize ) then call ksub_next ( n, subsize, a, more2, m, m2 ) else if ( subsize == 0 ) then more = .false. end if return end subroutine subset_gray_next ( n, a, more, ncard, iadd ) !*****************************************************************************80 ! !! subset_gray_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. ! ! This uses a Gray code ordering of the subsets. ! ! 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. ! ! Example: ! ! N = 4 ! ! 0 0 0 0 ! 1 0 0 0 ! 1 1 0 0 ! 0 1 0 0 ! 0 1 1 0 ! 1 1 1 0 ! 1 0 1 0 ! 0 0 1 0 ! 0 0 1 1 ! 1 0 1 1 ! 1 1 1 1 ! 0 1 1 1 ! 0 1 0 1 ! 1 1 0 1 ! 1 0 0 1 ! 0 0 0 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 May 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the order of the total set from which ! subsets will be drawn. ! ! Input/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. ! ! Input/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 -1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer iadd logical more integer ncard ! ! The first set returned is the empty set. ! if ( .not. more ) then a(1:n) = 0 more = .true. ncard = 0 iadd = -1 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 ! ! The last set returned is the singleton A(N). ! if ( ncard == a(n) ) then more = .false. end if end if return end subroutine subset_gray_rank ( n, a, rank ) !*****************************************************************************80 ! !! subset_gray_rank() ranks a subset of an N set, using the Gray code ordering. ! ! Example: ! ! N = 4 ! ! A Rank ! ------- ----- ! ! 0 0 0 0 1 ! 0 0 0 1 2 ! 0 0 1 1 3 ! 0 0 1 0 4 ! 0 1 1 0 5 ! 0 1 1 1 6 ! 0 1 0 1 7 ! 0 1 0 0 8 ! 1 1 0 0 9 ! 1 1 0 1 10 ! 1 1 1 1 11 ! 1 1 1 0 12 ! 1 0 1 0 13 ! 1 0 1 1 14 ! 1 0 0 1 15 ! 1 0 0 0 16 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the order of the total set from which ! subsets will be drawn. ! ! Input, integer A(N); A(I) is 1 if element I is in the set, ! and 0 otherwise. ! ! Output, integer RANK, the rank of the subset in the Gray ! code ordering. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer gray integer rank call ubvec_to_ui4 ( n, a, gray ) call gray_rank2 ( gray, rank ) rank = rank + 1 return end subroutine subset_gray_unrank ( rank, n, a ) !*****************************************************************************80 ! !! subset_gray_unrank() produces a subset of an N set of the given Gray code rank. ! ! Example: ! ! N = 4 ! ! Rank A ! ----- ------- ! ! 1 0 0 0 0 ! 2 0 0 0 1 ! 3 0 0 1 1 ! 4 0 0 1 0 ! 5 0 1 1 0 ! 6 0 1 1 1 ! 7 0 1 0 1 ! 8 0 1 0 0 ! 9 1 1 0 0 ! 10 1 1 0 1 ! 11 1 1 1 1 ! 12 1 1 1 0 ! 13 1 0 1 0 ! 14 1 0 1 1 ! 15 1 0 0 1 ! 16 1 0 0 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer RANK, the rank of the subset in the Gray ! code ordering. ! ! Input, integer N, the order of the total set from which ! subsets will be drawn. ! ! Output, integer A(N); A(I) is 1 if element I is in the set, ! and 0 otherwise. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer gray integer rank call gray_unrank2 ( rank - 1, gray ) call ui4_to_ubvec ( gray, n, a ) return end subroutine subset_lex_next ( n, jmp, ndim, k, a ) !*****************************************************************************80 ! !! subset_lex_next() generates the subsets of a set of N elements, one at a time. ! ! Discussion: ! ! The subsets are generated in lexicographical order. ! ! The routine can also be forced to generate only those subsets whose ! size is no greater than some user-specified maximum. ! ! Example: ! ! N = 5, JMP = ( K == 3 ) ! ! 1 ! 1 2 ! 1 2 3 ! 1 2 4 ! 1 2 5 ! 1 3 ! 1 3 4 ! 1 3 5 ! 1 4 ! 1 4 5 ! 1 5 ! 2 ! 2 3 ! 2 3 4 ! 2 3 5 ! 2 4 ! 2 4 5 ! 2 5 ! 3 ! 3 4 ! 3 4 5 ! 3 5 ! 4 ! 4 5 ! 5 ! empty set. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 November 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the order of the main set from which subsets ! are chosen. ! ! 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 == 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. ! ! 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. ! ! Input/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. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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 = 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 subset_random ( n, a ) !*****************************************************************************80 ! !! subset_random() selects a random subset of an N-set. ! ! Example: ! ! N = 4 ! ! 0 0 1 1 ! 0 1 0 1 ! 1 1 0 1 ! 0 0 1 0 ! 0 0 0 1 ! 1 1 0 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 December 2000 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_uniform_ab do i = 1, n a(i) = i4_uniform_ab ( 0, 1 ) end do return end subroutine subtriangle_next ( n, more, i1, j1, i2, j2, i3, j3 ) !*****************************************************************************80 ! !! subtriangle_next() computes the next subtriangle of a triangle. ! ! Discussion: ! ! The three sides of a triangle have been subdivided into N segments, ! inducing a natural subdivision of the triangle into N*N subtriangles. ! It is desired to consider each subtriangle, one at a time, in some ! definite order. This routine can produce information defining each ! of the subtriangles, one after another. ! ! The subtriangles are described in terms of the integer coordinates ! (I,J) of their vertices. These coordinates both range from 0 to N, ! with the additional restriction that I + J <= N. ! ! The vertices of each triangle are listed in counterclockwise order. ! ! Example: ! ! N = 4 ! ! 4 * ! |\ ! 16\ ! 3 *--* ! |14|\ ! 13\15\ ! 2 *--*--* ! |\9|11|\ ! |8\10\12\ ! 1 *--*--*--* ! |\2|\4|\6|\ ! |1\|3\|5\|7\ ! 0 *--*--*--*--* ! ! 0 1 2 3 4 ! ! Rank I1 J1 I2 J2 I3 J3 ! ---- ----- ----- ----- ! 1 0 0 1 0 0 1 ! 2 1 1 0 1 1 0 ! 3 1 0 2 0 1 1 ! 4 2 1 1 1 2 0 ! 5 2 0 3 0 2 1 ! 6 3 1 1 1 3 0 ! 7 3 0 4 0 3 1 ! 8 0 1 1 1 0 2 ! 9 1 2 0 2 1 1 ! 10 1 1 2 1 1 2 ! 11 2 2 1 2 2 1 ! 12 2 1 3 1 2 2 ! 13 0 2 1 2 0 3 ! 14 1 3 0 3 1 2 ! 15 1 2 2 2 1 3 ! 16 0 3 1 3 0 4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 March 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, indicates the number of subdivisions of each ! side of the original triangle. ! ! Input/output, logical MORE. ! On first call, set MORE to FALSE. Thereafter, the output value of MORE ! will be TRUE if there are more subtriangles that can be generated by ! further calls. However, if MORE is returned as FALSE, the accompanying ! subtriangle information refers to the last subtriangle that can be ! generated. ! ! Input/output, integer I1, J1, I2, J2, I3, J3, the indices of ! the vertices of the subtriangle. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i1 integer i2 integer i3 integer j1 integer j2 integer j3 logical more integer n if ( n <= 0 ) then more = .false. return end if if ( .not. more ) then i1 = 0 j1 = 0 i2 = 1 j2 = 0 i3 = 0 j3 = 1 if ( n == 1 ) then more = .false. else more = .true. end if ! ! We last generated a triangle like: ! ! 2---1 ! \ | ! \ | ! \| ! 3 ! else if ( i2 < i3 ) then i1 = i3 j1 = j3 i2 = i1 + 1 j2 = j1 i3 = i1 j3 = j1 + 1 ! ! We last generated a triangle like ! ! 3 ! |\ ! | \ ! | \ ! 1---2 ! else if ( i1 + 1 + j1 + 1 <= n ) then i1 = i1 + 1 j1 = j1 + 1 i2 = i1 - 1 j2 = j1 i3 = i1 j3 = j1 - 1 ! ! We must be at the end of a row. ! else i1 = 0 j1 = j1 + 1 i2 = i1 + 1 j2 = j1 i3 = i1 j3 = j1 + 1 if ( n <= j1 + 1 ) then more = .false. end if end if return end subroutine thue_binary_next ( n, thue ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 November 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. On input, the length of the input ! sequence. On output, the length of the output sequence. ! ! Input/output, integer THUE(N). On input, the initial Thue ! sequence, and on output, the result of applying the substitution rules ! once. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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,i8,a,i8)' ) ' THUE(', i, ') = ', thue(i) stop 1 end if end do n = n_out thue(1:n) = thue_out(1:n) return end subroutine thue_ternary_next ( n, thue ) !*****************************************************************************80 ! !! 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. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 28 October 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Brian Hayes, ! Third Base, ! American Scientist, ! Volume 89, Number 6, pages 490-494, November-December 2001. ! ! Parameters: ! ! Input/output, integer N. On input, the length of the input ! sequence. On output, the length of the output sequence. ! ! Input/output, integer THUE(N). On input, the initial Thue ! sequence, and on output, the result of applying the substitution rules ! once. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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,i8,a,i8)' ) ' THUE(', i, ') = ', thue(i) stop 1 end if end do n = n_out thue(1:n) = thue_out(1:n) return end subroutine timestamp ( ) !*****************************************************************************80 ! !! timestamp() prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 8 ) ampm integer d 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 integer values(8) integer y call date_and_time ( values = 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 ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine triang ( n, zeta, p ) !*****************************************************************************80 ! !! triang() renumbers elements in accordance with a partial ordering. ! ! Discussion: ! ! TRIANG is given a partially ordered set. The partial ordering ! is defined by a matrix ZETA, where element I is partially less than ! or equal to element J if and only if ZETA(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 I4MAT_2PERM1 or R8MAT_2PERM1 with P used for both the row ! and column permutations applied to matrix ZETA will result in ! an upper triangular matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 June 2015 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of elements in the set. ! ! Input, integer ZETA(N,N), describes the partial ordering. ! ZETA(I,J) =: ! 0, for diagonal elements (I = J), or ! for unrelated elements, or ! if J << I. ! 1, if I << 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 ZETA(I,J) = 1, that is, I << J, ! then P(I) < P(J) (in the usual ordering). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer ierror integer iq integer ir integer it integer l integer m integer p(n) integer zeta(n,n) ! ! Make sure ZETA represents a partially ordered set. In other words, ! if ZETA(I,J) = 1, then ZETA(J,I) must NOT be 1. ! call pord_check ( n, zeta, ierror ) if ( ierror /= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'TRIANG - Fatal error!' write ( *, '(a)' ) ' The matrix ZETA does not represent a' write ( *, '(a)' ) ' partial ordering.' stop 1 end if m = 1 l = 0 p(1:n) = 0 it = m + 1 ir = m + 1 do if ( ir <= n ) then if ( p(ir) == 0 .and. zeta(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 ir = m + 1 m = iq else if ( m == n ) then exit else 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 end if end if end do return end subroutine tuple_next ( m1, m2, n, rank, x ) !*****************************************************************************80 ! !! tuple_next() computes the next element of a tuple space. ! ! Discussion: ! ! The elements are N vectors. Each entry is constrained to lie ! between M1 and M2. The elements are produced one at a time. ! The first element is ! (M1,M1,...,M1), ! the second element is ! (M1,M1,...,M1+1), ! and the last element is ! (M2,M2,...,M2) ! Intermediate elements are produced in lexicographic order. ! ! Example: ! ! N = 2, M1 = 1, M2 = 3 ! ! INPUT OUTPUT ! ------- ------- ! Rank X Rank X ! ---- --- ----- --- ! 0 * * 1 1 1 ! 1 1 1 2 1 2 ! 2 1 2 3 1 3 ! 3 1 3 4 2 1 ! 4 2 1 5 2 2 ! 5 2 2 6 2 3 ! 6 2 3 7 3 1 ! 7 3 1 8 3 2 ! 8 3 2 9 3 3 ! 9 3 3 0 0 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 April 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M1, M2, the minimum and maximum entries. ! ! Input, integer N, the number of components. ! ! Input/output, integer RANK, counts the elements. ! On first call, set RANK to 0. Thereafter, the output value of RANK ! will indicate the order of the element returned. When there are no ! more elements, RANK will be returned as 0. ! ! Input/output, integer X(N), on input the previous tuple. ! On output, the next tuple. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer m1 integer m2 integer rank integer x(n) if ( m2 < m1 ) then rank = 0 return end if if ( rank <= 0 ) then x(1:n) = m1 rank = 1 else rank = rank + 1 i = n do if ( x(i) < m2 ) then x(i) = x(i) + 1 exit end if x(i) = m1 if ( i == 1 ) then rank = 0 x(1:n) = m1 exit end if i = i - 1 end do end if return end subroutine tuple_next_fast ( m, n, rank, base, x ) !*****************************************************************************80 ! !! tuple_next_fast() computes the next element of a tuple space, "fast". ! ! 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. ! ! This code was written as a possibly faster version of TUPLE_NEXT. ! ! Example: ! ! N = 2, ! M = 3 ! ! INPUT OUTPUT ! ------- ------- ! Rank X ! ---- ---- ! -1 -1 -1 ! ! 0 1 1 ! 1 1 2 ! 2 1 3 ! 3 2 1 ! 4 2 2 ! 5 2 3 ! 6 3 1 ! 7 3 2 ! 8 3 3 ! 9 1 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 04 June 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the maximum entry in any component. ! M must be greater than 0. ! ! Input, integer N, the number of components. ! N must be greater than 0. ! ! Input, integer RANK, indicates the rank of the tuple. ! Typically, 0 <= RANK < N^M. Values of RANK greater than ! N^M are legal and meaningful; they are equivalent to the ! corresponding value mod (N^M). If RANK < 0, this indicates ! that this is the first call for the given values of (M,N). ! Initialization is done, and X is set to a dummy value. ! ! Input/output, integer BASE(N), a bookkeeping array needed by ! this procedure. The user should allocate space for this array, but ! should not alter it between successive calls. ! ! Output, integer X(N), the next tuple, or a dummy value if ! initialization has just been done. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer base(n) integer i integer m integer rank integer x(n) if ( rank < 0 ) then if ( m <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'TUPLE_NEXT_FAST - Fatal error!' write ( *, '(a)' ) ' The value M <= 0 is not allowed.' write ( *, '(a,i8)' ) ' M = ', m stop 1 end if if ( n <= 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'TUPLE_NEXT_FAST - Fatal error!' write ( *, '(a)' ) ' The value N <= 0 is not allowed.' write ( *, '(a,i8)' ) ' N = ', n stop 1 end if base(n) = 1 do i = n - 1, 1, -1 base(i) = base(i+1) * m end do x(1:n) = -1 else x(1:n) = mod ( rank / base(1:n), m ) + 1 end if return end subroutine tuple_next_ge ( m, n, rank, x ) !*****************************************************************************80 ! !! 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 RANK, ! X(I) <= X(I+RANK) ! ! 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. ! ! Example: ! ! N = 3, M = 3 ! ! RANK 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 ! 0 0 0 0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 June 2004 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer M, the maximum entry. ! ! Input, integer N, the number of components. ! ! Input/output, integer RANK, counts the elements. ! On first call, set RANK to 0. Thereafter, RANK will indicate the ! order of the element returned. When there are no more elements, ! RANK will be returned as 0. ! ! Input/output, integer X(N), on input the previous tuple ! (except on the first call, when the input value of X is not needed.) ! On output, the next tuple. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer m integer rank integer x(n) if ( m < 1 ) then return end if if ( rank <= 0 ) then x(1:n) = 1 rank = 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) rank = rank + 1 return end if end do rank = 0 x(1:n) = 0 return end subroutine tuple_next2 ( n, xmin, xmax, rank, x ) !*****************************************************************************80 ! !! 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). ! ! Example: ! ! 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 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 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. ! ! Input/output, integer X(N), on input the previous tuple. ! On output, the next tuple. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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,i8)' ) ' Illegal value of RANK = ', rank stop 1 end if if ( product ( 1 + abs ( xmax(1:n) - xmin(1:n) ) ) < rank ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'TUPLE_NEXT2 - Fatal error!' write ( *, '(a,i8)' ) ' Illegal value of RANK = ', rank stop 1 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 ubvec_add ( n, bvec1, bvec2, bvec3 ) !*****************************************************************************80 ! !! ubvec_add() adds two unsigned binary vectors. ! ! Discussion: ! ! A UBVEC is a vector of binary digits representing an unsigned integer. ! ! UBVEC(N) contains the units digit, UBVEC(N-1) ! the coefficient of 2, UBVEC(N-2) the coefficient of 4 and so on, ! so that printing the digits in order gives the binary form of the number. ! ! Example: ! ! N = 4 ! ! UBVEC1 + UBVEC2 = UBVEC3 ! ! ( 0 0 0 1 ) + ( 0 0 1 1 ) = ( 0 1 0 0 ) ! ! 1 + 3 = 4 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer BVEC1(N), BVEC2(N), the vectors to be added. ! ! Output, integer BVEC3(N), the sum of the two input vectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 2 integer bvec1(n) integer bvec2(n) integer bvec3(n) integer i logical overflow overflow = .false. bvec3(1:n) = bvec1(1:n) + bvec2(1:n) do i = n, 1, - 1 do while ( base <= bvec3(i) ) bvec3(i) = bvec3(i) - base if ( 1 < i ) then bvec3(i-1) = bvec3(i-1) + 1 else overflow = .true. end if end do end do return end subroutine ubvec_print ( n, bvec, title ) !*****************************************************************************80 ! !! ubvec_print() prints a UBVEC, with an optional title. ! ! Discussion: ! ! A UBVEC is a vector of binary digits representing an unsigned integer. ! ! UBVEC(N) contains the units digit, UBVEC(N-1) ! the coefficient of 2, UBVEC(N-2) the coefficient of 4 and so on, ! so that printing the digits in order gives the binary form of the number. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer BVEC(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer bvec(n) integer ihi integer ilo character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if do ilo = 1, n, 70 ihi = min ( ilo + 70 - 1, n ) write ( *, '(2x,70i1)' ) bvec(ilo:ihi) end do return end subroutine ubvec_to_ui4 ( n, bvec, ui4 ) !*****************************************************************************80 ! !! ubvec_to_ui4() makes an unsigned integer from an unsigned binary vector. ! ! Discussion: ! ! A UBVEC is a vector of binary digits representing an unsigned integer. ! ! UBVEC(N) contains the units digit, UBVEC(N-1) ! the coefficient of 2, UBVEC(N-2) the coefficient of 4 and so on, ! so that printing the digits in order gives the binary form of the number. ! ! Example: ! ! N = 4 ! ! BVEC binary UI4 ! ---------- ----- -- ! 1 2 3 4 ! ---------- ! 0 0 0 1 1 1 ! 0 0 1 0 10 2 ! 0 0 1 1 11 3 ! 0 1 0 0 100 4 ! 1 0 0 1 1001 9 ! 1 1 1 1 1111 15 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of the vector. ! ! Input, integer BVEC(N), the binary representation. ! ! Output, integer UI4, the integer. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 2 integer bvec(n) integer i integer ui4 ui4 = 0 do i = 1, n ui4 = base * ui4 + bvec(i) end do return end subroutine ubvec_xor ( n, bvec1, bvec2, bvec3 ) !*****************************************************************************80 ! !! ubvec_xor() computes the exclusive OR of two unsigned binary vectors. ! ! Discussion: ! ! A UBVEC is a vector of binary digits representing an unsigned integer. ! ! UBVEC(N) contains the units digit, UBVEC(N-1) ! the coefficient of 2, UBVEC(N-2) the coefficient of 4 and so on, ! so that printing the digits in order gives the binary form of the number. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 May 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the length of the vectors. ! ! Input, integer BVEC1(N), BVEC2(N), the vectors ! to be XOR'ed. ! ! Input, integer BVEC3(N), the exclusive OR of the two vectors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer bvec1(n) integer bvec2(n) integer bvec3(n) bvec3(1:n) = mod ( bvec1(1:n) + bvec2(1:n), 2 ) return end subroutine ui4_to_ubvec ( ui4, n, bvec ) !*****************************************************************************80 ! !! ui4_to_ubvec() makes an unsigned binary vector from an unsigned integer. ! ! Discussion: ! ! A UBVEC is a vector of binary digits representing an unsigned integer. ! ! UBVEC(N) contains the units digit, UBVEC(N-1) ! the coefficient of 2, UBVEC(N-2) the coefficient of 4 and so on, ! so that printing the digits in order gives the binary form of the number. ! ! To guarantee that there will be enough space for any ! value of I, it would be necessary to set N = 32. ! ! Example: ! ! I BVEC binary ! -- ---------------- ------ ! 1 0 0 0 0 0 1 1 ! 2 0 0 0 0 1 0 10 ! 3 0 0 0 0 1 1 11 ! 4 0 0 0 1 0 0 100 ! 9 0 0 1 0 0 1 1001 ! 57 1 1 0 1 1 1 110111 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 March 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer UI4, an integer to be represented. ! ! Input, integer N, the dimension of the vector. ! ! Output, integer BVEC(N), the binary representation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer, parameter :: base = 2 integer bvec(n) integer i integer ui4 integer ui4_copy ui4_copy = ui4 do i = n, 1, -1 bvec(i) = mod ( ui4_copy, base ) ui4_copy = ui4_copy / base end do return end subroutine vec_colex_next ( dim_num, base, a, more ) !*****************************************************************************80 ! !! vec_colex_next() generates vectors in colex order. ! ! Discussion: ! ! The vectors are produced in colexical order, starting with ! (0,0,...,0), ! (1,0,...,0), ! ... ! (BASE-1,BASE-1,...,BASE-1). ! ! Example: ! ! DIM_NUM = 2, ! BASE = 3 ! ! 0 0 ! 1 0 ! 2 0 ! 0 1 ! 1 1 ! 2 1 ! 0 2 ! 1 2 ! 2 2 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIM_NUM, the spatial dimension. ! ! Input, integer BASE, the base to be used. BASE = 2 will ! give vectors of 0's and 1's, for instance. ! ! Input/output, integer A(DIM_NUM), the next vector. ! ! Input/output, logical MORE. Set this variable FALSE before ! the first call. On return, MORE is TRUE if another vector has ! been computed. If MORE is returned FALSE, ignore the output ! vector and stop calling the routine. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dim_num integer a(dim_num) integer base integer i logical more if ( .not. more ) then a(1:dim_num) = 0 more = .true. else do i = 1, dim_num a(i) = a(i) + 1 if ( a(i) < base ) then return end if a(i) = 0 end do more = .false. end if return end subroutine vec_colex_next2 ( dim_num, base, a, more ) !*****************************************************************************80 ! !! vec_colex_next2() generates vectors in colex order. ! ! Discussion: ! ! The vectors are produced in colexical order, starting with ! ! (0, 0, ...,0), ! (1, 0, ...,0), ! ... ! (BASE(1)-1,0, ...,0) ! ! (0, 1, ...,0) ! (1, 1, ...,0) ! ... ! (BASE(1)-1,1, ...,0) ! ! (0, 2, ...,0) ! (1, 2, ...,0) ! ... ! (BASE(1)-1,BASE(2)-1,...,BASE(DIM_NUM)-1). ! ! Example: ! ! DIM_NUM = 2, ! BASE = ( 3, 3 ) ! ! 0 0 ! 1 0 ! 2 0 ! 0 1 ! 1 1 ! 2 1 ! 0 2 ! 1 2 ! 2 2 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIM_NUM, the spatial dimension. ! ! Input, integer BASE(DIM_NUM), the bases to be used in each ! dimension. In dimension I, entries will range from 0 to BASE(I)-1. ! ! Input/output, integer A(DIM_NUM). On each return, A ! will contain entries in the range 0 to N-1. ! ! Input/output, logical MORE. Set this variable FALSE before ! the first call. On return, MORE is TRUE if another vector has ! been computed. If MORE is returned FALSE, ignore the output ! vector and stop calling the routine. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dim_num integer a(dim_num) integer base(dim_num) integer i logical more if ( .not. more ) then a(1:dim_num) = 0 more = .true. else do i = 1, dim_num a(i) = a(i) + 1 if ( a(i) < base(i) ) then return end if a(i) = 0 end do more = .false. end if return end subroutine vec_colex_next3 ( dim_num, base, a, more ) !*****************************************************************************80 ! !! vec_colex_next3() generates vectors in colex order. ! ! Discussion: ! ! The vectors are produced in colexical order, starting with ! ! (1, 1, ...,1), ! (2, 1, ...,1), ! ... ! (BASE(1), 1, ...,1) ! ! (1, 2, ...,1) ! (2, 2, ...,1) ! ... ! (BASE(1), 2, ...,0) ! ! (1, 3, ...,1) ! (2, 3, ...,1) ! ... ! (BASE(1), BASE(2), ...,BASE(DIM_NUM)). ! ! Example: ! ! DIM_NUM = 2, ! BASE = ( 3, 3 ) ! ! 1 1 ! 2 1 ! 3 1 ! 1 2 ! 2 2 ! 3 2 ! 1 3 ! 2 3 ! 3 3 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 August 2008 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer DIM_NUM, the spatial dimension. ! ! Input, integer BASE(DIM_NUM), the bases to be used in each ! dimension. In dimension I, entries will range from 1 to BASE(I). ! ! Input/output, integer A(DIM_NUM). ! ! Input/output, logical MORE. Set this variable FALSE before ! the first call. On return, MORE is TRUE if another vector has ! been computed. If MORE is returned FALSE, ignore the output ! vector and stop calling the routine. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dim_num integer a(dim_num) integer base(dim_num) integer i logical more if ( .not. more ) then a(1:dim_num) = 1 more = .true. else do i = 1, dim_num a(i) = a(i) + 1 if ( a(i) <= base(i) ) then return end if a(i) = 1 end do more = .false. end if return end subroutine vec_gray_next ( n, base, a, done, active, dir, change ) !*****************************************************************************80 ! !! vec_gray_next() computes the next vector in Gray code order. ! ! 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. ! ! A method similar to the Gray code is used, so that successive ! elements returned by this routine differ by only a single element. ! ! Example: ! ! N = 2, BASE = ( 2, 3 ), DONE = TRUE ! ! A DONE CHANGE ! --- ----- ------ ! 0 0 FALSE 1 ! 0 1 FALSE 2 ! 0 2 FALSE 2 ! 1 2 FALSE 1 ! 1 1 FALSE 2 ! 1 0 FALSE 2 ! 1 0 TRUE -1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 May 2015 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, integer BASE(N), contains the number of degrees of ! freedom of each component. The output values of A will ! satisfy 0 <= A(I) < BASE(I). ! ! Input/output, integer A(N). On the first call, the input ! value of A doesn't matter. Thereafter, it should be the same as ! its output value from the previous call. On output, if DONE ! is FALSE, then A contains the next element of the space. ! ! 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 A. If DONE is TRUE, ! then there are no more entries, and the program should not be ! called for any more. ! ! Input/output, integer ACTIVE(N), DIR(N), two work arrays which the user ! must allocate before the first call, and not change thereafter. ! ! Output, integer CHANGE, is set to the index of the element ! whose value was changed. On return from the first call, CHANGE ! is 1, even though all the elements have been "changed". On ! return with DONE equal to TRUE, CHANGE is -1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer active(n) integer base(n) integer change integer dir(n) logical done integer i ! ! The user is calling for the first time. ! if ( done ) then done = .false. a(1:n) = 0 dir(1:n) = 1 active(1:n) = 1 do i = 1, n if ( base(i) < 1 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'VEC_GRAY_NEXT - Warning!' write ( *, '(a,i8)' ) ' For index I = ',i write ( *, '(a,i8)' ) ' the nonpositive value of BASE(I) = ', base(i) write ( *, '(a)' ) ' which was reset to 1!' base(i) = 1 active(i) = 0 else if ( base(i) == 1 ) then active(i) = 0 end if end do change = 1 return end if ! ! Seek the maximum active index. ! change = -1 do i = n, 1, -1 if ( active(i) == 1 ) then change = i exit end if end do ! ! If there are NO active indices, we have generated all vectors. ! if ( change == -1 ) then done = .true. return end if ! ! Increment the element with maximum active index. ! a(change) = a(change) + dir(change) ! ! If we attained a minimum or maximum value, reverse the direction ! vector, and deactivate the index. ! if ( a(change) == 0 .or. a(change) == base(change) - 1 ) then dir(change) = -dir(change) active(change) = 0 end if ! ! Activate all subsequent indices. ! do i = change + 1, n if ( 1 < base(i) ) then active(i) = 1 end if end do return end subroutine vec_gray_rank ( n, base, a, rank ) !*****************************************************************************80 ! !! vec_gray_rank() computes the rank of a vector in the Gray code. ! ! Discussion: ! ! The rank applies only to the elements as produced by the routine ! VEC_GRAY_NEXT ! ! Example: ! ! N = 2, BASE = (/ 2, 3 /), A = ( 1, 2 ), ! ! RANK = 4. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 May 2007 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, integer BASE(N), contains the number of degrees of ! freedom of each component. The output values of A will ! satisfy 0 <= A(I) < BASE(I). ! ! Input, integer A(N), the product space element, with the ! property that 0 <= A(I) < BASE(I) for each entry I. ! ! 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, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer base(n) integer c integer i integer rank rank = 0 do i = 1, n if ( mod ( rank, 2 ) == 1 ) then c = base(i) - a(i) - 1 else c = a(i) end if rank = base(i) * rank + c end do rank = rank + 1 return end subroutine vec_gray_unrank ( n, base, rank, a ) !*****************************************************************************80 ! !! vec_gray_unrank() computes the Gray code vector of given rank. ! ! Discussion: ! ! The rank applies only to the elements as produced by the routine ! VEC_GRAY_NEXT. ! ! Example: ! ! N = 2, BASE = ( 2, 3 ), RANK = 4. ! ! A = ( 1, 2 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 May 2007 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Reference: ! ! Dennis Stanton, Dennis White, ! Constructive Combinatorics, ! Springer, 1986, ! ISBN: 0387963472, ! LC: QA164.S79. ! ! Parameters: ! ! Input, integer N, the number of components. ! ! Input, integer BASE(N), contains the number of degrees of ! freedom of each component. The output values of A will ! satisfy 0 <= A(I) < BASE(I). ! ! 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 RANK_MAX = Product ( 1 <= I <= N ) BASE(I). ! ! Output, integer A(N), the product space element of the ! given rank. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer base(n) integer i integer rank integer s s = rank - 1 do i = n, 1, -1 a(i) = mod ( s, base(i) ) s = s / base(i) if ( mod ( s, 2 ) == 1 ) then a(i) = base(i) - a(i) - 1 end if end do return end subroutine vec_lex_next ( dim_num, base, a, more ) !*****************************************************************************80 ! !! vec_lex_next() generates vectors in lex order. ! ! Discussion: ! ! The vectors are produced in lexical order, starting with ! (0,0,...,0), ! (0,0,...,1), ! ... ! (BASE-1,BASE-1,...,BASE-1). ! ! Example: ! ! DIM_NUM = 2, ! BASE = 3 ! ! 0 0 ! 0 1 ! 0 2 ! 1 0 ! 1 1 ! 1 2 ! 2 0 ! 2 1 ! 2 2 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 May 2007 ! ! Author: ! ! FORTRAN90 version by John Burkardt ! ! Parameters: ! ! Input, integer DIM_NUM, the size of the vectors to be used. ! ! Input, integer BASE, the base to be used. BASE = 2 will ! give vectors of 0's and 1's, for instance. ! ! Input/output, integer A(DIM_NUM), the next vector. ! ! Input/output, logical MORE. Set this variable FALSE before ! the first call. On return, MORE is TRUE if another vector has ! been computed. If MORE is returned FALSE, ignore the output ! vector and stop calling the routine. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer dim_num integer a(dim_num) integer base integer i logical more if ( .not. more ) then a(1:dim_num) = 0 more = .true. else do i = dim_num, 1, -1 a(i) = a(i) + 1 if ( a(i) < base ) then return end if a(i) = 0 end do more = .false. end if return end subroutine vec_random ( n, base, a ) !*****************************************************************************80 ! !! vec_random() selects a random N-vector of integers modulo a given base. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the size of the vector to be generated. ! ! Input, integer BASE, the base to be used. ! ! Output, integer A(N), a list of N random values between ! 0 and BASE-1. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer base integer i integer i4_uniform_ab do i = 1, n a(i) = i4_uniform_ab ( 0, base-1 ) end do return end subroutine vector_constrained_next ( n, x_min, x_max, x, constraint, more ) !*****************************************************************************80 ! !! vector_constrained_next() returns the "next" constrained vector. ! ! Discussion: ! ! We consider all vectors of dimension N satisfying: ! ! X_MIN(1:N) <= X(1:N) <= X_MAX(1:N). ! ! We are only interested in the subset of these vectors which ! satisfy the following constraint: ! ! sum ( 1 <= I <= N ) ( ( X(I) - 1 ) / X_MAX(I) ) <= 1 ! ! We can carry out this check using integer arithmetic if we ! multiply through by P = product ( X_MAX(1:N) ): ! ! sum ( 1 <= I <= N ) ( ( X(I) - 1 ) * ( P / X_MAX(I) ) ) <= P. ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! X_MIN: 2 2 1 ! X_MAX: 4 5 3 ! ! P = 60 ! ! # X(1) X(2) X(3) CONSTRAINT ! ! 1 2 2 1 27 ! 2 3 2 1 42 ! 3 4 2 1 57 ! 4 2 3 1 39 ! 5 3 3 1 54 ! 6 2 4 1 51 ! 7 2 2 2 47 ! 8 2 3 2 59 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 May 2015 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, integer X_MIN(N), X_MAX(N), the minimum and maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE), the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Output, integer CONSTRAINT, the constraint value for X. ! Valid vectors X will have a CONSTRAINT value between product(X_MIN(1:N)) ! (automatically) and product(X_MAX(1:N)) (because we skip over vectors ! with a constraint larger than this value). ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer constraint integer i logical more integer x(n) integer x_max(n) integer x_min(n) integer x_prod x_prod = product ( x_max(1:n) ) if ( .not. more ) then x(1:n) = x_min(1:n) constraint = sum ( ( x(1:n) - 1 ) * ( x_prod / x_max(1:n) ) ) if ( x_prod < constraint ) then more = .false. else more = .true. end if return else i = 1 do if ( x(i) < x_max(i) ) then x(i) = x(i) + 1 constraint = sum ( ( x(1:n) - 1 ) * ( x_prod / x_max(1:n) ) ) if ( constraint <= x_prod ) then exit end if end if x(i) = x_min(i) i = i + 1 if ( n < i ) then more = .false. exit end if end do end if return end subroutine vector_constrained_next2 ( n, x_min, x_max, x, constraint, more ) !*****************************************************************************80 ! !! vector_constrained_next2() returns the "next" constrained vector. ! ! Discussion: ! ! We consider all vectors of dimension N satisfying ! ! X_MIN(1:N) <= X(1:N) <= X_MAX(1:N). ! ! We are only interested in the subset of these vectors which ! satisfy the following constraint: ! ! sum ( 1 <= I <= N ) ( X(I) / X_MAX(I) ) <= 1 ! ! We can carry out this check using integer arithmetic if we ! multiply through by P = product ( X_MAX(1:N) ): ! ! sum ( 1 <= I <= N ) ( X(I) * ( P / X_MAX(I) ) ) <= P. ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! X_MIN: 1 1 1 ! X_MAX: 5 6 4 ! ! P = 120 ! ! # X(1) X(2) X(3) CONSTRAINT ! ! 1 1 1 1 74 ! 2 2 1 1 98 ! 3 1 2 1 94 ! 4 2 2 1 119 ! 5 1 3 1 114 ! 6 1 1 2 104 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 March 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, integer X_MIN(N), X_MAX(N), the minimum and maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Output, integer CONSTRAINT, the constraint value for X. ! Valid vectors X will have a CONSTRAINT value between product(X_MIN(1:N)) ! (automatically) and product(X_MAX(1:N)) (because we skip over vectors ! with a constraint larger than this value). ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer constraint integer i logical more integer x(n) integer x_max(n) integer x_min(n) integer x_prod x_prod = product ( x_max(1:n) ) if ( .not. more ) then x(1:n) = x_min(1:n) constraint = sum ( x(1:n) * ( x_prod / x_max(1:n) ) ) if ( x_prod < constraint ) then more = .false. else more = .true. end if return else i = 1 do if ( x(i) < x_max(i) ) then x(i) = x(i) + 1 constraint = sum ( x(1:n) * ( x_prod / x_max(1:n) ) ) if ( constraint <= x_prod ) then exit end if end if x(i) = x_min(i) i = i + 1 if ( n < i ) then more = .false. exit end if end do end if return end subroutine vector_constrained_next3 ( n, x_min, x_max, x, constraint, more ) !*****************************************************************************80 ! !! vector_constrained_next3() returns the "next" constrained vector. ! ! Discussion: ! ! This routine addresses the same problem as VECTOR_CONSTRAINED_NEXT2, ! and differs only in that real arithmetic is used, rather than ! integer arithmetic. Integer arithmetic allows us to do an exact ! calculation, but we run into overflow problems in simple cases ! where N is 10 and the X_MAX entries are of order 10, for instance. ! ! We consider all vectors X of dimension N satisfying ! ! X_MIN(1:N) <= X(1:N) <= X_MAX(1:N). ! ! We are only interested in the subset of these vectors which ! satisfy the following constraint: ! ! sum ( 1 <= I <= N ) ( X(I) / X_MAX(I) ) <= 1 ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! X_MIN: 1 1 1 ! X_MAX: 5 6 4 ! ! P = 120 ! ! # X(1) X(2) X(3) CONSTRAINT ! ! 1 1 1 1 0.62 ! 2 2 1 1 0.82 ! 3 1 2 1 0.78 ! 4 2 2 1 0.98 ! 5 1 3 1 0.95 ! 6 1 1 2 0.87 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 April 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, integer X_MIN(N), X_MAX(N), the minimum and maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Output, real ( kind = rk ) CONSTRAINT, the constraint value for X. ! Valid vectors X will have a CONSTRAINT value between ! product(X_MIN(1:N)) / product(X_MAX(1:N)) ! and 1.0. ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) constraint integer i logical more integer x(n) integer x_max(n) integer x_min(n) if ( .not. more ) then x(1:n) = x_min(1:n) constraint = sum ( real ( x(1:n), kind = rk ) & / real ( x_max(1:n), kind = rk ) ) if ( 1.0D+00 < constraint ) then more = .false. else more = .true. end if return else i = 1 do if ( x(i) < x_max(i) ) then x(i) = x(i) + 1 constraint = sum ( real ( x(1:n), kind = rk ) & / real ( x_max(1:n), kind = rk ) ) if ( constraint <= 1.0D+00 ) then exit end if end if x(i) = x_min(i) i = i + 1 if ( n < i ) then more = .false. exit end if end do end if return end subroutine vector_constrained_next4 ( n, alpha, x_min, x_max, x, q, more ) !*****************************************************************************80 ! !! vector_constrained_next4() returns the "next" constrained vector. ! ! Discussion: ! ! This routine is similar to VECTOR_CONSTRAINED_NEXT2 and ! VECTOR_CONSTRAINED_NEXT3. ! ! We consider all vectors X of dimension N satisfying ! ! X_MIN(1:N) <= X(1:N) <= X_MAX(1:N). ! ! We are only interested in the subset of these vectors which ! satisfy the following constraint: ! ! sum ( 1 <= I <= N ) ALPHA(I) * X(I) <= Q ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! ALPHA 4.0 3.0 5.0 ! Q 20.0 ! X_MIN: 1 1 1 ! X_MAX: 5 6 4 ! ! # X(1) X(2) X(3) Total ! ! 1 1 1 1 12.0 ! 2 2 1 1 16.0 ! 3 3 1 1 20.0 ! 4 1 2 1 15.0 ! 5 2 2 1 19.0 ! 6 1 3 1 18.0 ! 7 1 1 2 17.0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 May 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, real ( kind = rk ) ALPHA(N), the coefficient vector. ! ! Input, integer X_MIN(N), X_MAX(N), the minimum and maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Input, real ( kind = rk ) Q, the limit on the sum. ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha(n) integer i logical more real ( kind = rk ) q real ( kind = rk ) total integer x(n) integer x_max(n) integer x_min(n) if ( .not. more ) then x(1:n) = x_min(1:n) total = dot_product ( alpha(1:n), real ( x(1:n), kind = rk ) ) if ( q < total ) then more = .false. else more = .true. end if return else i = 1 do if ( x(i) < x_max(i) ) then x(i) = x(i) + 1 total = dot_product ( alpha(1:n), real ( x(1:n), kind = rk ) ) if ( total <= q ) then exit end if end if x(i) = x_min(i) i = i + 1 if ( n < i ) then more = .false. exit end if end do end if return end subroutine vector_constrained_next5 ( n, x, sum_min, sum_max, base, more ) !*****************************************************************************80 ! !! vector_constrained_next5() returns the "next" constrained vector. ! ! Discussion: ! ! We consider all positive integer vectors X dimension N satisfying: ! ! SUM_MIN <= X(1:N) <= SUM_MAX. ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! SUM_MIN = 5 ! SUM_MAX = 6 ! ! # X(1) X(2) X(3) SUM ! ! 1 3 1 1 5 ! 2 2 2 1 5 ! 3 2 1 2 5 ! 4 1 3 1 5 ! 5 1 2 2 5 ! 6 1 1 3 5 ! ! 7 4 1 1 6 ! 8 3 2 1 6 ! 9 3 1 2 6 ! 10 2 3 1 6 ! 11 2 2 2 6 ! 12 2 1 3 6 ! 13 1 4 1 6 ! 14 1 3 2 6 ! 15 1 2 3 6 ! 16 1 1 4 6 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 December 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, integer SUM_MIN, SUM_MAX, the minimum and maximum sums. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Input/output, integer BASE, a value controlled by the program. ! The user must declare this variable, and pass the output value of ! one call as input on the next call, but should not alter its value. ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer base integer i integer j logical more integer sum_max integer sum_min integer x(n) ! ! Initialization. ! if ( .not. more ) then if ( sum_max < n ) then more = .false. return end if if ( sum_max < sum_min ) then more = .false. return end if more = .true. base = max ( sum_min, n ) x(1) = base - n + 1 x(2:n) = 1 return ! ! Next element. ! else ! ! Search from the right, seeking an index I < N for which 1 < X(I). ! do i = n - 1, 1, -1 ! ! If you find such an I, decrease X(I) by 1, and add that to X(I+1). ! if ( 1 < x(i) ) then x(i) = x(i) - 1 x(i+1) = x(i+1) + 1 ! ! Now grab all the "excess" 1's from the entries to the right of X(I+1). ! do j = i + 2, n if ( 1 < x(j) ) then x(i+1) = x(i+1) + x(j) - 1 x(j) = 1 end if end do return end if end do ! ! The current vector is (1,1,1,...,BASE-N+1). ! If BASE < SUM_MAX, then increase BASE by 1, and start the new series. ! if ( base < sum_max ) then base = base + 1 x(1) = base - n + 1 x(2:n) = 1 return end if ! ! We returned the last legal vector on the previous call. ! The calculation is done. ! more = .false. end if return end subroutine vector_constrained_next6 ( n, alpha, x_min, x_max, x, q_min, & q_max, more ) !*****************************************************************************80 ! !! vector_constrained_next6() returns the "next" constrained vector. ! ! Discussion: ! ! We consider vectors X of dimension N satisfying: ! ! X_MIN(1:N) <= X(1:N) <= X_MAX(1:N). ! ! We are only interested in the subset of these vectors which ! satisfy the following constraint: ! ! Q_MIN <= sum ( 1 <= I <= N ) ALPHA(I) * X(I) <= Q_MAX ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! ALPHA 4.0 3.0 5.0 ! Q_MIN 16.0 ! Q_MAX 20.0 ! X_MIN: 1 1 1 ! X_MAX: 5 6 4 ! ! # X(1) X(2) X(3) Total ! ! 1 2 1 1 16.0 ! 2 3 1 1 20.0 ! 3 2 2 1 19.0 ! 4 1 3 1 18.0 ! 5 1 1 2 17.0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 February 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, real ( kind = rk ) ALPHA(N), the coefficient vector. ! ! Input, integer X_MIN(N), X_MAX(N), the minimum and maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Input, real ( kind = rk ) Q_MIN, Q_MAX, the lower and upper ! limits on the sum. ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) alpha(n) integer i logical more real ( kind = rk ) q_max real ( kind = rk ) q_min real ( kind = rk ) total integer x(n) integer x_max(n) integer x_min(n) if ( .not. more ) then more = .true. x(1:n) = x_min(1:n) total = dot_product ( alpha(1:n), real ( x(1:n), kind = rk ) ) if ( q_min <= total .and. total <= q_max ) then return end if end if do i = n do if ( x(i) < x_max(i) ) then exit end if if ( i <= 1 ) then more = .false. return end if i = i - 1 end do x(i) = x(i) + 1 x(i+1:n) = x_min(i+1:n) total = dot_product ( alpha(1:n), real ( x(1:n), kind = rk ) ) if ( q_min <= total .and. total <= q_max ) then exit end if end do return end subroutine vector_constrained_next7 ( n, level_weight, x_max, x, q_min, q_max, & more ) !*****************************************************************************80 ! !! vector_constrained_next7() returns the "next" constrained vector. ! ! Discussion: ! ! We consider vectors X of dimension N satisfying: ! ! 0 <= X(1:N) <= X_MAX(1:N). ! ! and the following constraint: ! ! Q_MIN < sum ( 1 <= I <= N ) LEVEL_WEIGHT(I) * X(I) <= Q_MAX ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, exactly those vectors which satisfy ! the constraint. ! ! Example: ! ! N = 3 ! LEVEL_WEIGHT 4.0 3.0 5.0 ! Q_MIN 16.0 ! Q_MAX 20.0 ! X_MAX: 5 6 4 ! ! # X(1) X(2) X(3) Total ! ! 1 3 1 1 20.0 ! 2 2 2 1 19.0 ! 3 1 3 1 18.0 ! 4 1 1 2 17.0 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 August 2009 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, real ( kind = rk ) LEVEL_WEIGHT(N), the coefficient vector. ! ! Input, integer X_MAX(N), the maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, (with MORE = TRUE), the value of X will be the "next" ! vector in the reverse lexicographical list of vectors that satisfy ! the condition. However, on output with MORE = FALSE, the vector ! X is meaningless, because there are no more vectors in the list. ! ! Input, real ( kind = rk ) Q_MIN, Q_MAX, the lower and upper ! limits on the sum. ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i real ( kind = rk ) level_weight(n) logical more real ( kind = rk ) q_max real ( kind = rk ) q_min real ( kind = rk ) total integer x(n) integer x_max(n) if ( .not. more ) then more = .true. x(1:n) = 0 total = dot_product ( level_weight(1:n), real ( x(1:n), kind = rk ) ) if ( q_min < total .and. total <= q_max ) then return end if end if do i = n do if ( x(i) < x_max(i) ) then exit end if if ( i <= 1 ) then more = .false. return end if i = i - 1 end do x(i) = x(i) + 1 x(i+1:n) = 0 total = dot_product ( level_weight(1:n), real ( x(1:n), kind = rk ) ) if ( q_min < total .and. total <= q_max ) then exit end if end do return end subroutine vector_next ( n, x_min, x_max, x, more ) !*****************************************************************************80 ! !! vector_next() returns the "next" integer vector between two ranges. ! ! Discussion: ! ! We consider all integer vectors of dimension N satisfying: ! ! X_MIN(1:N) <= X(1:N) <= X_MAX(1:N). ! ! This routine returns, one at a time, and in right-to-left ! lexicographic order, all these vectors. ! ! Example: ! ! N = 3 ! X_MIN: 2 2 0 ! X_MAX: 4 3 1 ! ! # X(1) X(2) X(3) ! ! 1 2 2 0 ! 2 3 2 0 ! 3 4 2 0 ! 4 2 3 0 ! 5 3 3 0 ! 6 4 3 0 ! 7 2 2 1 ! 8 3 2 1 ! 9 4 2 1 ! 10 2 3 1 ! 11 3 3 1 ! 12 4 3 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 July 2010 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components in the vector. ! ! Input, integer X_MIN(N), X_MAX(N), the minimum and maximum ! values allowed in each component. ! ! Input/output, integer X(N). On first call, with ! MORE = FALSE, the input value of X is not important. On subsequent calls, ! the input value of X should be the output value from the previous call. ! On output, with MORE = TRUE, the value of X will be the "next" ! vector in the reverse lexicographical list of vectors. However, on ! output with MORE = FALSE, the vector X is meaningless, because there ! are no more vectors in the list. ! ! Input/output, logical MORE. On input, if the user has set MORE ! FALSE, the user is requesting the initiation of a new sequence ! of values. If MORE is TRUE, then the user is requesting "more" ! values in the current sequence. On output, if MORE is TRUE, ! then another value was found and returned in X, but if MORE is ! FALSE, then there are no more values in the sequence, and X is ! NOT the next value. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i logical more integer x(n) integer x_max(n) integer x_min(n) if ( .not. more ) then x(1:n) = x_min(1:n) more = .true. else i = 1 do if ( x(i) < x_max(i) ) then x(i) = x(i) + 1 exit end if x(i) = x_min(i) i = i + 1 if ( n < i ) then more = .false. exit end if end do end if return end subroutine vector_sumlex_next ( n, x ) !*****************************************************************************80 ! !! vector_sumlex_next() returns the next integer vector in sumlex order. ! ! Discussion: ! ! Consider integer vectors of length N, ordered by their sum. ! Vectors of equal sum are ordered lexically. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 September 2022 ! ! Author: ! ! John Burkardt ! ! Input: ! ! integer N: the vector size. ! ! integer X(N), the current vector. ! ! Output: ! ! integer X(N), the next vector. ! implicit none integer n integer j integer s integer t integer x(n) s = sum ( x ) ! ! Case: (0,0,0,...0,S) -> (S+1,0,0,...,0) ! if ( x(1) == s ) then x(1) = 0 x(n) = s + 1 ! ! Case: ! Rightmost nonzero sends one unit left, and the rest to last position. ! else t = 0 do j = n, 2, -1 if ( x(j) /= 0 ) then t = x(j) x(j) = 0 x(j-1) = x(j-1) + 1 x(n) = t - 1 exit end if end do if ( t == 0 ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'vector_sumlex_next: Fatal error!' write ( *, '(a)' ) 1, ' Could not find an entry to borrow from.' stop 1 end if end if return end subroutine ytb_enum ( n, ytb_num ) !*****************************************************************************80 ! !! ytb_enum() enumerates the Young tables of size N. ! ! Discussion: ! ! If A(N) is the number of Young table of size N, then A(1) = 1, ! A(2) = 2, and ! ! A(N) = A(N-1) + (N-1) * A(N-2). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! 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 tables of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) 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, a, more ) !*****************************************************************************80 ! !! ytb_next() computes the next Young table 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 the user ! must also make sure that LAMBDA(M+1) = 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 June 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer which is to be partitioned. ! ! Input/output, integer LAMBDA(N), contains a partition of N. ! The elements of LAMBDA are nonnegative integers that sum to N. ! On the first call, with MORE = FALSE, the user sets LAMBDA. ! After the first call, the input value of LAMBDA is not important. ! On output, the value of LAMBDA is the partition corresponding ! to the Young table. ! ! Input/output, integer A(N). On the first call, with ! MORE = FALSE, no value of A needs to be set. After the first call, the ! input value of A should be its output value from the previous call. ! The output value of A is the next Young table. A(I) is the ! row containing I in the output table. ! ! Input/output, logical MORE. Set MORE to FALSE before the first call. ! It is reset to TRUE as the program returns a new table ! on each call, until the last table is computed, when ! the program also sets MORE = FALSE. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer ir integer it integer j integer k integer lambda(n) integer isave logical more it = n if ( more ) then lambda(1) = 1 lambda(2:n) = 0 isave = 0 do i = 2, n lambda(a(i)) = lambda(a(i)) + 1 if ( a(i) < a(i-1) ) then isave = i exit end if end do if ( isave == 0 ) then more = .false. return end if it = lambda(1+a(isave)) do i = n, 1, -1 if ( lambda(i) == it ) then a(isave) = i lambda(i) = lambda(i) - 1 it = isave - 1 exit end if end do end if k = 1 ir = 1 do if ( n < ir ) then exit end if if ( lambda(ir) /= 0 ) then a(k) = ir lambda(ir) = lambda(ir) - 1 k = k + 1 ir = ir + 1 cycle end if if ( it < k ) then exit end if ir = 1 end do if ( n == 1 ) then more = .false. return end if do j = 2, n if ( a(j) < a(j-1) ) then more = .true. return end if end do more = .false. return end subroutine ytb_print ( n, a, title ) !*****************************************************************************80 ! !! ytb_print() prints a Young table. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 May 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the integer that is partitioned. ! ! Input, integer A(N), describes the Young table. ! A(I) is the row of the table on which I occurs. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer j integer jarray(n) integer row_i integer row_length character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) '' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) '' row_i = 0 do row_i = row_i + 1 row_length = 0 do j = 1, n if ( a(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, a ) !*****************************************************************************80 ! !! ytb_random() selects a random Young table of a given shape. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 May 2003 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Second Edition, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the integer which has been partitioned. ! ! Input, integer LAMBDA(N), the partition of N. ! N = sum ( 1 <= I <= N ) LAMBDA(I). ! ! Output, integer A(N), the vector describing the Young table. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i integer i4_uniform_ab integer ih integer j integer k integer lambda(n) integer m a(1:n) = 0 i = 0 k = 0 do i = i + 1 do j = 1, lambda(i) a(j) = a(j) + 1 k = k + 1 end do if ( n <= k ) then exit end if end do do m = 1, n do i = i4_uniform_ab ( 1, a(1) ) j = i4_uniform_ab ( 1, lambda(1) ) if ( i <= a(j) .and. j <= lambda(i) ) then exit end if end do do ih = a(j) + lambda(i) - i - j if ( ih == 0 ) then exit end if k = i4_uniform_ab ( 1, ih ) if ( k <= lambda(i)-j ) then j = j + k else i = k - lambda(i) + i + j end if end do lambda(i) = lambda(i) - 1 a(j) = a(j) - 1 a(n+1-m) = i end do do i = 1, n lambda(a(i)) = lambda(a(i)) + 1 end do return end