subroutine hyperball01_monomial_integral ( m, e, integral ) c*********************************************************************72 c cc HYPERBALL01_MONOMIAL_INTEGRAL: monomial integrals in unit hyperball. c c Discussion: c c The integration region is c c sum ( 1 <= I <= M ) X(I)^2 <= 1. c c The monomial is F(X) = product ( 1 <= I <= M ) X(I)^E(I) c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 04 January 2014 c c Author: c c John Burkardt c c Reference: c c Gerald Folland, c How to Integrate a Polynomial Over a Sphere, c American Mathematical Monthly, c Volume 108, Number 5, May 2001, pages 446-448. c c Parameters: c c Input, integer M, the spatial dimension. c c Input, integer E(M), the exponents. Each exponent must be nonnegative. c c Output, double precision INTEGRAL, the integral. c implicit none integer m double precision arg integer e(m) integer i integer i4vec_sum double precision integral double precision r parameter ( r = 1.0D+00 ) double precision r8_gamma double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision s do i = 1, m if ( e(i) < 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) & 'HYPERBALL01_MONOMIAL_INTEGRAL - Fatal error!' write ( *, '(a)' ) ' All exponents must be nonnegative.' stop 1 end if end do c c Integrate over the surface. c do i = 1, m if ( mod ( e(i), 2 ) == 1 ) then integral = 0.0D+00 return end if end do integral = 2.0D+00 do i = 1, m arg = 0.5D+00 * dble ( e(i) + 1 ) integral = integral * r8_gamma ( arg ) end do s = i4vec_sum ( m, e ) + m arg = 0.5D+00 * dble ( s ) integral = integral / r8_gamma ( arg ) c c The surface integral is now adjusted to give the volume integral. c integral = integral * r ** s / dble ( s ) return end subroutine hyperball01_sample ( m, n, seed, x ) c*********************************************************************72 c cc HYPERBALL01_SAMPLE uniformly samples points from the unit hyperball. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 04 January 2014 c c Author: c c John Burkardt c c Reference: c c Russell Cheng, c Random Variate Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley, 1998, pages 168. c c Reuven Rubinstein, c Monte Carlo Optimization, Simulation, and Sensitivity c of Queueing Networks, c Krieger, 1992, c ISBN: 0894647644, c LC: QA298.R79. c c Parameters: c c Input, integer M, the spatial dimension. c c Input, integer N, the number of points. c c Input/output, integer SEED, a seed for the random c number generator. c c Output, double precision X(M,N), the points. c implicit none integer m integer n double precision exponent integer i integer j double precision norm double precision r double precision r8_uniform_01 integer seed double precision x(m,n) exponent = 1.0D+00 / real ( m, kind = 8 ) do j = 1, n c c Fill a vector with normally distributed values. c call r8vec_normal_01 ( m, seed, x(1:m,j) ) c c Compute the length of the vector. c norm = 0.0D+00 do i = 1, m norm = norm + x(i,j)**2 end do norm = sqrt ( norm ) c c Normalize the vector. c do i = 1, m x(i,j) = x(i,j) / norm end do c c Now compute a value to map the point ON the sphere INTO the sphere. c r = r8_uniform_01 ( seed ) do i = 1, m x(i,j) = r ** exponent * x(i,j) end do end do return end function hyperball01_volume ( m ) c*********************************************************************72 c cc HYPERBALL01_VOLUME returns the volume of the unit hyperball. c c Discussion: c c M Volume c c 1 2 c 2 1 * PI c 3 ( 4 / 3) * PI c 4 ( 1 / 2) * PI^2 c 5 ( 8 / 15) * PI^2 c 6 ( 1 / 6) * PI^3 c 7 (16 / 105) * PI^3 c 8 ( 1 / 24) * PI^4 c 9 (32 / 945) * PI^4 c 10 ( 1 / 120) * PI^5 c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 04 January 2014 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the spatial dimension. c c Output, double precision HYPERBALL01_VOLUME, the volume. c implicit none double precision hyperball01_volume integer i integer m integer m_half double precision r parameter ( r = 1.0D+00 ) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision volume if ( mod ( m, 2 ) .eq. 0 ) then m_half = m / 2 volume = r8_pi ** m_half do i = 1, m_half volume = volume / dble ( i ) end do else m_half = ( m - 1 ) / 2 volume = r8_pi ** m_half * 2.0D+00 ** m do i = m_half + 1, 2 * m_half + 1 volume = volume / dble ( i ) end do end if hyperball01_volume = volume return end function i4vec_sum ( n, a ) c*********************************************************************72 c cc I4VEC_SUM returns the sum of the entries of an I4VEC. c c Discussion: c c An I4VEC is a vector of I4's. c c In FORTRAN90, this facility is offered by the built in c SUM function: c c I4VEC_SUM ( N, A ) = SUM ( A(1:N) ) c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 03 January 2007 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of entries in the array. c c Input, integer A(N), the array. c c Output, integer I4VEC_SUM, the sum of the entries. c implicit none integer n integer a(n) integer i integer i4vec_sum i4vec_sum = 0 do i = 1, n i4vec_sum = i4vec_sum + a(i) end do return end subroutine monomial_value ( m, n, e, x, v ) c*********************************************************************72 c cc MONOMIAL_VALUE evaluates a monomial. c c Discussion: c c This routine evaluates a monomial of the form c c product ( 1 <= i <= m ) x(i)^e(i) c c where the exponents are nonnegative integers. Note that c if the combination 0^0 is encountered, it should be treated c as 1. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 07 May 2014 c c Author: c c John Burkardt c c Parameters: c c Input, integer M, the spatial dimension. c c Input, integer N, the number of points at which the c monomial is to be evaluated. c c Input, integer E(M), the exponents. c c Input, double precision X(M,N), the point coordinates. c c Output, double precision V(N), the value of the monomial. c implicit none integer m integer n integer e(m) integer i integer j double precision v(n) double precision x(m,n) do j = 1, n v(j) = 1.0D+00 end do do i = 1, m if ( 0 .ne. e(i) ) then do j = 1, n v(j) = v(j) * x(i,j) ** e(i) end do end if end do return end function r8_gamma ( x ) c*********************************************************************72 c cc R8_GAMMA evaluates Gamma(X) for a real argument. c c Discussion: c c This routine calculates the gamma function for a real argument X. c Computation is based on an algorithm outlined in reference 1. c The program uses rational functions that approximate the gamma c function to at least 20 significant decimal digits. Coefficients c for the approximation over the interval (1,2) are unpublished. c Those for the approximation for 12 <= X are from reference 2. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 18 January 2008 c c Author: c c Original FORTRAN77 version by William Cody, Laura Stoltz. c This version by John Burkardt. c c Reference: c c William Cody, c An Overview of Software Development for Special Functions, c in Numerical Analysis Dundee, 1975, c edited by GA Watson, c Lecture Notes in Mathematics 506, c Springer, 1976. c c John Hart, Ward Cheney, Charles Lawson, Hans Maehly, c Charles Mesztenyi, John Rice, Henry Thatcher, c Christoph Witzgall, c Computer Approximations, c Wiley, 1968, c LC: QA297.C64. c c Parameters: c c Input, double precision X, the argument of the function. c c Output, double precision R8_GAMMA, the value of the function. c implicit none double precision c(7) double precision eps double precision fact integer i integer n double precision p(8) logical parity double precision pi double precision q(8) double precision r8_gamma double precision res double precision sqrtpi double precision sum double precision x double precision xbig double precision xden double precision xinf double precision xminin double precision xnum double precision y double precision y1 double precision ysq double precision z c c Mathematical constants c data sqrtpi / 0.9189385332046727417803297D+00 / data pi / 3.1415926535897932384626434D+00 / c c Machine dependent parameters c data xbig / 171.624D+00 / data xminin / 2.23D-308 / data eps / 2.22D-16 / data xinf /1.79D+308 / c c Numerator and denominator coefficients for rational minimax c approximation over (1,2). c data p / & -1.71618513886549492533811d+00, & 2.47656508055759199108314d+01, & -3.79804256470945635097577d+02, & 6.29331155312818442661052d+02, & 8.66966202790413211295064d+02, & -3.14512729688483675254357d+04, & -3.61444134186911729807069d+04, & 6.64561438202405440627855d+04 / data q / & -3.08402300119738975254353D+01, & 3.15350626979604161529144D+02, & -1.01515636749021914166146D+03, & -3.10777167157231109440444D+03, & 2.25381184209801510330112D+04, & 4.75584627752788110767815D+03, & -1.34659959864969306392456D+05, & -1.15132259675553483497211D+05 / c c Coefficients for minimax approximation over (12, INF). c data c / & -1.910444077728D-03, & 8.4171387781295D-04, & -5.952379913043012D-04, & 7.93650793500350248D-04, & -2.777777777777681622553D-03, & 8.333333333333333331554247D-02, & 5.7083835261D-03 / parity = .false. fact = 1.0D+00 n = 0 y = x c c Argument is negative. c if ( y .le. 0.0D+00 ) then y = - x y1 = aint ( y ) res = y - y1 if ( res .ne. 0.0D+00 ) then if ( y1 .ne. aint ( y1 * 0.5D+00 ) * 2.0D+00 ) then parity = .true. end if fact = - pi / sin ( pi * res ) y = y + 1.0D+00 else res = xinf r8_gamma = res return end if end if c c Argument is positive. c if ( y .lt. eps ) then c c Argument < EPS. c if ( xminin .le. y ) then res = 1.0D+00 / y else res = xinf r8_gamma = res return end if else if ( y .lt. 12.0D+00 ) then y1 = y c c 0.0 < argument < 1.0. c if ( y .lt. 1.0D+00 ) then z = y y = y + 1.0D+00 c c 1.0 < argument < 12.0. c Reduce argument if necessary. c else n = int ( y ) - 1 y = y - dble ( n ) z = y - 1.0D+00 end if c c Evaluate approximation for 1.0 < argument < 2.0. c xnum = 0.0D+00 xden = 1.0D+00 do i = 1, 8 xnum = ( xnum + p(i) ) * z xden = xden * z + q(i) end do res = xnum / xden + 1.0D+00 c c Adjust result for case 0.0 < argument < 1.0. c if ( y1 .lt. y ) then res = res / y1 c c Adjust result for case 2.0 < argument < 12.0. c else if ( y .lt. y1 ) then do i = 1, n res = res * y y = y + 1.0D+00 end do end if else c c Evaluate for 12.0 <= argument. c if ( y .le. xbig ) then ysq = y * y sum = c(7) do i = 1, 6 sum = sum / ysq + c(i) end do sum = sum / y - y + sqrtpi sum = sum + ( y - 0.5D+00 ) * log ( y ) res = exp ( sum ) else res = xinf r8_gamma = res return end if end if c c Final adjustments and return. c if ( parity ) then res = - res end if if ( fact .ne. 1.0D+00 ) then res = fact / res end if r8_gamma = res return end function r8_uniform_01 ( seed ) c*********************************************************************72 c cc R8_UNIFORM_01 returns a pseudorandom R8 scaled to [0,1]. c c Discussion: c c This routine implements the recursion c c seed = 16807 * seed mod ( 2^31 - 1 ) c r8_uniform_01 = seed / ( 2^31 - 1 ) c c The integer arithmetic never requires more than 32 bits, c including a sign bit. c c If the initial seed is 12345, then the first three computations are c c Input Output R8_UNIFORM_01 c SEED SEED c c 12345 207482415 0.096616 c 207482415 1790989824 0.833995 c 1790989824 2035175616 0.947702 c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 11 August 2004 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Springer Verlag, pages 201-202, 1983. c c Pierre L'Ecuyer, c Random Number Generation, c in Handbook of Simulation, c edited by Jerry Banks, c Wiley Interscience, page 95, 1998. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, pages 362-376, 1986. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, pages 136-143, 1969. c c Parameters: c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R8_UNIFORM_01, a new pseudorandom variate, c strictly between 0 and 1. c implicit none double precision r8_uniform_01 integer k integer seed if ( seed .eq. 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + 2147483647 end if r8_uniform_01 = dble ( seed ) * 4.656612875D-10 return end subroutine r8vec_normal_01 ( n, seed, x ) c*********************************************************************72 c cc R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c The standard normal probability distribution function (PDF) has c mean 0 and standard deviation 1. c c This routine can generate a vector of values on one call. It c has the feature that it should provide the same results c in the same order no matter how we break up the task. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 07 January 2014 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the number of values desired. If N is negative, c then the code will flush its internal memory; in particular, c if there is a saved value to be used on the next call, it is c instead discarded. This is useful if the user has reset the c random number seed, for instance. c c Input/output, integer SEED, a seed for the random number generator. c c Output, double precision X(N), a sample of the standard normal PDF. c c Local parameters: c c Local, integer X_LO_INDEX, X_HI_INDEX, records the range of entries of c X that we need to compute. This starts off as 1:N, but is adjusted c if we have a saved value that can be immediately stored in X(1), c and so on. c implicit none integer n integer i integer m double precision r(n+1) double precision r8_pi parameter ( r8_pi = 3.141592653589793D+00 ) double precision r8_uniform_01 integer seed double precision x(n) integer x_hi_index integer x_lo_index c c Record the range of X we need to fill in. c x_lo_index = 1 x_hi_index = n c c Maybe we don't need any more values. c if ( x_hi_index - x_lo_index + 1 .eq. 1 ) then r(1) = r8_uniform_01 ( seed ) if ( r(1) .eq. 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop 1 end if r(2) = r8_uniform_01 ( seed ) x(x_hi_index) = & sqrt ( -2.0D+00 * log ( r(1) ) ) & * cos ( 2.0D+00 * r8_pi * r(2) ) c c If we require an even number of values, that's easy. c else if ( mod ( x_hi_index - x_lo_index + 1, 2 ) .eq. 0 ) then m = ( x_hi_index - x_lo_index + 1 ) / 2 call r8vec_uniform_01 ( 2 * m, seed, r ) do i = 1, 2 * m, 2 x(x_lo_index+i-1) = & sqrt ( -2.0D+00 * log ( r(i) ) ) & * cos ( 2.0D+00 * r8_pi * r(i+1) ) x(x_lo_index+i) = & sqrt ( -2.0D+00 * log ( r(i) ) ) & * sin ( 2.0D+00 * r8_pi * r(i+1) ) end do c c If we require an odd number of values, we generate an even number, c and handle the last pair specially, storing one in X(N), and c saving the other for later. c else x_hi_index = x_hi_index - 1 m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1 call r8vec_uniform_01 ( 2 * m, seed, r ) do i = 1, 2 * m - 3, 2 x(x_lo_index+i-1) = & sqrt ( -2.0D+00 * log ( r(i) ) ) & * cos ( 2.0D+00 * r8_pi * r(i+1) ) x(x_lo_index+i) = & sqrt ( -2.0D+00 * log ( r(i) ) ) & * sin ( 2.0D+00 * r8_pi * r(i+1) ) end do x(n) = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * cos ( 2.0D+00 * r8_pi * r(2*m) ) end if return end function r8vec_sum ( n, v1 ) c*********************************************************************72 c cc R8VEC_SUM sums the entries of an R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c In FORTRAN90, the system routine SUM should be called c directly. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 22 July 2008 c c Author: c c John Burkardt c c Parameters: c c Input, integer N, the dimension of the vectors. c c Input, double precision V1(N), the vector. c c Output, double precision R8VEC_SUM, the sum of the entries. c implicit none integer n integer i double precision r8vec_sum double precision v1(n) double precision value value = 0.0D+00 do i = 1, n value = value + v1(i) end do r8vec_sum = value return end subroutine r8vec_uniform_01 ( n, seed, r ) c*********************************************************************72 c cc R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. c c Discussion: c c An R8VEC is a vector of R8's. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 17 July 2006 c c Author: c c John Burkardt c c Reference: c c Paul Bratley, Bennett Fox, Linus Schrage, c A Guide to Simulation, c Springer Verlag, pages 201-202, 1983. c c Bennett Fox, c Algorithm 647: c Implementation and Relative Efficiency of Quasirandom c Sequence Generators, c ACM Transactions on Mathematical Software, c Volume 12, Number 4, pages 362-376, 1986. c c Peter Lewis, Allen Goodman, James Miller, c A Pseudo-Random Number Generator for the System/360, c IBM Systems Journal, c Volume 8, pages 136-143, 1969. c c Parameters: c c Input, integer N, the number of entries in the vector. c c Input/output, integer SEED, the "seed" value, which should NOT be 0. c On output, SEED has been updated. c c Output, double precision R(N), the vector of pseudorandom values. c implicit none integer n integer i integer k integer seed double precision r(n) do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed .lt. 0 ) then seed = seed + 2147483647 end if r(i) = dble ( seed ) * 4.656612875D-10 end do return end subroutine timestamp ( ) c*********************************************************************72 c cc TIMESTAMP prints out the current YMDHMS date as a timestamp. c c Licensing: c c This code is distributed under the MIT license. c c Modified: c c 12 January 2007 c c Author: c c John Burkardt c c Parameters: c c None c implicit none character * ( 8 ) ampm integer d character * ( 8 ) date integer h integer m integer mm character * ( 9 ) month(12) integer n integer s character * ( 10 ) time integer y save month data month / & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' / call date_and_time ( date, time ) read ( date, '(i4,i2,i2)' ) y, m, d read ( time, '(i2,i2,i2,1x,i3)' ) h, n, s, mm if ( h .lt. 12 ) then ampm = 'AM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h .lt. 12 ) then ampm = 'PM' else if ( h .eq. 12 ) then if ( n .eq. 0 .and. s .eq. 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, month(m), y, h, ':', n, ':', s, '.', mm, ampm return end