function c4_normal_01 ( seed ) !*****************************************************************************80 ! !! C4_NORMAL_01 returns a unit pseudonormal C4. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, complex ( kind = 4 ) C4_NORMAL_01, a unit pseudonormal value. ! implicit none complex ( kind = 4 ) c4_normal_01 real ( kind = 4 ), parameter :: pi = 3.141592653589793E+00 real ( kind = 4 ) r4_uniform_01 integer ( kind = 4 ) seed real ( kind = 4 ) v1 real ( kind = 4 ) v2 real ( kind = 4 ) x_c real ( kind = 4 ) x_r v1 = r4_uniform_01 ( seed ) v2 = r4_uniform_01 ( seed ) x_r = sqrt ( - 2.0E+00 * log ( v1 ) ) * cos ( 2.0E+00 * pi * v2 ) x_c = sqrt ( - 2.0E+00 * log ( v1 ) ) * sin ( 2.0E+00 * pi * v2 ) c4_normal_01 = cmplx ( x_r, x_c ) return end function c8_normal_01 ( seed ) !*****************************************************************************80 ! !! C8_NORMAL_01 returns a unit pseudonormal C8. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random number ! generator. ! ! Output, complex ( kind = 8 ) C8_NORMAL_01, a sample of the PDF. ! implicit none complex ( kind = 8 ) c8_normal_01 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ) seed real ( kind = 8 ) v1 real ( kind = 8 ) v2 real ( kind = 8 ) x_c real ( kind = 8 ) x_r v1 = r8_uniform_01 ( seed ) v2 = r8_uniform_01 ( seed ) x_r = sqrt ( - 2.0D+00 * log ( v1 ) ) * cos ( 2.0D+00 * pi * v2 ) x_c = sqrt ( - 2.0D+00 * log ( v1 ) ) * sin ( 2.0D+00 * pi * v2 ) c8_normal_01 = cmplx ( x_r, x_c, kind = 8 ) return end function i4_huge ( ) !*****************************************************************************80 ! !! I4_HUGE returns a "huge" I4. ! ! Discussion: ! ! On an IEEE 32 bit machine, I4_HUGE should be 2**31 - 1, and its ! bit pattern should be ! ! 01111111111111111111111111111111 ! ! In this case, its numerical value is 2147483647. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ( kind = 4 ) I4_HUGE, a "huge" I4. ! implicit none integer ( kind = 4 ) i4 integer ( kind = 4 ) i4_huge i4_huge = 2147483647 return end function i4_normal ( a, b, seed ) !*****************************************************************************80 ! !! I4_NORMAL returns a scaled pseudonormal I4. ! ! Discussion: ! ! The normal probability distribution function (PDF) is sampled, ! with mean A and standard deviation B. ! ! The result is then rounded to the nearest integer. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 4 ) A, the mean of the PDF. ! ! Input, real ( kind = 4 ) B, the standard deviation of the PDF. ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the ! random number generator. ! ! Output, integer ( kind = 4 ) I4_NORMAL, a sample of the normal PDF. ! implicit none real ( kind = 4 ) a real ( kind = 4 ) b integer ( kind = 4 ) i4_normal real ( kind = 4 ), parameter :: pi = 3.141592653589793E+00 real ( kind = 4 ) r1 real ( kind = 4 ) r2 real ( kind = 4 ) r4_uniform_01 integer ( kind = 4 ) seed integer ( kind = 4 ), save :: seed2 = 0 integer ( kind = 4 ), parameter :: two = 2 integer ( kind = 4 ), save :: used = 0 real ( kind = 4 ) x real ( kind = 4 ), save :: y = 0.0E+00 ! ! On odd numbered calls, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, two ) == 0 ) then r1 = r4_uniform_01 ( seed ) if ( r1 == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4_NORMAL - Fatal error!' write ( *, '(a)' ) ' R4_UNIFORM_01 returned a value of 0.' stop end if seed2 = seed r2 = r4_uniform_01 ( seed2 ) x = sqrt ( -2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * pi * r2 ) y = sqrt ( -2.0E+00 * log ( r1 ) ) * sin ( 2.0E+00 * pi * r2 ) ! ! On odd calls, return the second normal and its corresponding seed. ! else seed = seed2 x = y end if used = used + 1 i4_normal = nint ( a + b * x ) return end function i8_normal ( a, b, seed ) !*****************************************************************************80 ! !! I8_NORMAL returns a scaled pseudonormal I8. ! ! Discussion: ! ! The normal probability distribution function (PDF) is sampled, ! with mean A and standard deviation B. ! ! The result is then rounded to the nearest integer. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the mean of the PDF. ! ! Input, real ( kind = 8 ) B, the standard deviation of the PDF. ! ! Input/output, integer ( kind = 8 ) SEED, a seed for the ! random number generator. ! ! Output, integer ( kind = 8 ) I8_NORMAL, a sample of the normal PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b integer ( kind = 8 ) i8_normal real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r1 real ( kind = 8 ) r2 real ( kind = 8 ) r8_uniform_01 integer ( kind = 8 ) seed integer ( kind = 8 ), save :: seed2 = 0 integer ( kind = 8 ), parameter :: two = 2 integer ( kind = 8 ), save :: used = 0 real ( kind = 8 ) x real ( kind = 8 ), save :: y = 0.0D+00 ! ! On odd numbered calls, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, two ) == 0 ) then r1 = r8_uniform_01 ( seed ) if ( r1 == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I8_NORMAL - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop end if seed2 = seed r2 = r8_uniform_01 ( seed2 ) x = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 ) y = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 ) ! ! On odd calls, return the second normal and its corresponding seed. ! else seed = seed2 x = y end if used = used + 1 i8_normal = nint ( a + b * x ) return end function r4_normal ( a, b, seed ) !*****************************************************************************80 ! !! R4_NORMAL returns a scaled pseudonormal R4. ! ! Discussion: ! ! The normal probability distribution function (PDF) is sampled, ! with mean A and standard deviation B. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 4 ) A, the mean of the PDF. ! ! Input, real ( kind = 4 ) B, the standard deviation of the PDF. ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random number generator. ! ! Output, real ( kind = 4 ) R4_NORMAL, a sample of the normal PDF. ! implicit none real ( kind = 4 ) a real ( kind = 4 ) b real ( kind = 4 ), parameter :: pi = 3.141592653589793E+00 real ( kind = 4 ) r1 real ( kind = 4 ) r2 real ( kind = 4 ) r4_normal real ( kind = 4 ) r4_uniform_01 integer ( kind = 4 ) seed integer ( kind = 4 ), save :: seed2 = 0 integer ( kind = 4 ), parameter :: two = 2 integer ( kind = 4 ), save :: used = 0 real ( kind = 4 ) x real ( kind = 4 ), save :: y = 0.0E+00 ! ! On odd numbered calls, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, two ) == 0 ) then r1 = r4_uniform_01 ( seed ) if ( r1 == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R4_NORMAL - Fatal error!' write ( *, '(a)' ) ' R4_UNIFORM_01 returned a value of 0.' stop end if seed2 = seed r2 = r4_uniform_01 ( seed2 ) x = sqrt ( -2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * pi * r2 ) y = sqrt ( -2.0E+00 * log ( r1 ) ) * sin ( 2.0E+00 * pi * r2 ) ! ! On odd calls, return the second normal and its corresponding seed. ! else seed = seed2 x = y end if used = used + 1 r4_normal = a + b * x return end function r4_normal_01 ( seed ) !*****************************************************************************80 ! !! R4_NORMAL_01 returns a unit pseudonormal R4. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! Because this routine uses the Box Muller method, it requires pairs ! of uniform random values to generate a pair of normal random values. ! This means that on every other call, essentially, the input value of ! SEED is ignored, since the code saves the second normal random value. ! ! If you didn't know this, you might be confused since, usually, the ! output of a random number generator can be completely controlled by ! the input value of the SEED. If I were more careful, I could rewrite ! this routine so that it would distinguish between cases where the input ! value of SEED is the output value from the previous call (all is well) ! and those cases where it is not (the user has decided to do something ! new. Restart the uniform random number sequence.) But I'll leave ! that for later. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, real ( kind = 4 ) R4_NORMAL_01, a sample of the standard ! normal PDF. ! implicit none real ( kind = 4 ), parameter :: pi = 3.141592653589793E+00 real ( kind = 4 ) r1 real ( kind = 4 ) r2 real ( kind = 4 ) r4_normal_01 real ( kind = 4 ) r4_uniform_01 integer ( kind = 4 ) seed integer ( kind = 4 ), save :: seed2 = 0 integer ( kind = 4 ), parameter :: two = 2 integer ( kind = 4 ), save :: used = 0 real ( kind = 4 ) x real ( kind = 4 ), save :: y = 0.0E+00 ! ! On odd numbered calls, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, two ) == 0 ) then r1 = r4_uniform_01 ( seed ) if ( r1 == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R4_NORMAL_01 - Fatal error!' write ( *, '(a)' ) ' R4_UNIFORM_01 returned a value of 0.' stop end if seed2 = seed r2 = r4_uniform_01 ( seed2 ) x = sqrt ( -2.0E+00 * log ( r1 ) ) * cos ( 2.0E+00 * pi * r2 ) y = sqrt ( -2.0E+00 * log ( r1 ) ) * sin ( 2.0E+00 * pi * r2 ) ! ! On odd calls, return the second normal and its corresponding seed. ! else seed = seed2 x = y end if used = used + 1 r4_normal_01 = x return end function r4_uniform_01 ( seed ) !*****************************************************************************80 ! !! R4_UNIFORM_01 returns a unit pseudorandom R4. ! ! Discussion: ! ! An R4 is a real ( kind = 4 ) value. ! ! This routine implements the recursion ! ! seed = 16807 * seed mod ( 2**31 - 1 ) ! r4_uniform_01 = seed / ( 2**31 - 1 ) ! ! The integer arithmetic never requires more than 32 bits, ! including a sign bit. ! ! If the initial seed is 12345, then the first three computations are ! ! Input Output R4_UNIFORM_01 ! SEED SEED ! ! 12345 207482415 0.096616 ! 207482415 1790989824 0.833995 ! 1790989824 2035175616 0.947702 ! ! Licensing: ! ! This code is distributed under the GNU LGPL 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/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, real ( kind = 4 ) R4_UNIFORM_01, a new pseudorandom variate, ! strictly between 0 and 1. ! implicit none integer ( kind = 4 ), parameter :: i4_huge = 2147483647 integer ( kind = 4 ) k integer ( kind = 4 ) seed real ( kind = 4 ) r4_uniform_01 if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R4_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop end if k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + i4_huge end if r4_uniform_01 = real ( seed, kind = 4 ) * 4.656612875E-10 return end subroutine r4vec_normal ( n, a, b, seed, x ) !*****************************************************************************80 ! !! R4VEC_NORMAL returns a scaled pseudonormal R4VEC. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! This routine can generate a vector of values on one call. It ! has the feature that it should provide the same results ! in the same order no matter how we break up the task. ! ! Before calling this routine, the user may call RANDOM_SEED ! in order to set the seed of the random number generator. ! ! The Box-Muller method is used, which is efficient, but ! generates an even number of values each time. On any call ! to this routine, an even number of new values are generated. ! Depending on the situation, one value may be left over. ! In that case, it is saved for the next call. ! ! An R4VEC is a vector of R4's. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of values desired. If N is ! negative, then the code will flush its internal memory; in particular, ! if there is a saved value to be used on the next call, it is ! instead discarded. This is useful if the user has reset the ! random number seed, for instance. ! ! Input, real ( kind = 4 ) A, B, the mean and standard deviation. ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, real ( kind = 4 ) X(N), a sample of the standard normal PDF. ! ! Local parameters: ! ! Local, integer ( kind = 4 ) MADE, records the number of values that have ! been computed. On input with negative N, this value overwrites ! the return value of N, so the user can get an accounting of ! how much work has been done. ! ! Local, real ( kind = 4 ) R(N+1), is used to store some uniform ! random values. Its dimension is N+1, but really it is only needed ! to be the smallest even number greater than or equal to N. ! ! Local, integer ( kind = 4 ) SAVED, is 0 or 1 depending on whether ! there is a single saved value left over from the previous call. ! ! Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range ! of entries of X that we need to compute. This starts off as 1:N, but ! is adjusted if we have a saved value that can be immediately stored ! in X(1), and so on. ! ! Local, real ( kind = 4 ) Y, the value saved from the previous call, if ! SAVED is 1. ! implicit none integer ( kind = 4 ) n real ( kind = 4 ) a real ( kind = 4 ) b integer ( kind = 4 ) m integer ( kind = 4 ), save :: made = 0 real ( kind = 4 ), parameter :: pi = 3.141592653589793E+00 real ( kind = 4 ) r(n+1) real ( kind = 4 ) r4_uniform_01 integer ( kind = 4 ), save :: saved = 0 integer ( kind = 4 ) seed integer ( kind = 4 ), parameter :: two = 2 real ( kind = 4 ) x(n) integer ( kind = 4 ) x_hi_index integer ( kind = 4 ) x_lo_index real ( kind = 4 ), save :: y = 0.0E+00 ! ! I'd like to allow the user to reset the internal data. ! But this won't work properly if we have a saved value Y. ! I'm making a crock option that allows the user to signal ! explicitly that any internal memory should be flushed, ! by passing in a negative value for N. ! if ( n < 0 ) then n = made made = 0 saved = 0 y = 0.0E+00 return else if ( n == 0 ) then return end if ! ! Record the range of X we need to fill in. ! x_lo_index = 1 x_hi_index = n ! ! Use up the old value, if we have it. ! if ( saved == 1 ) then x(1) = y saved = 0 x_lo_index = 2 end if ! ! Maybe we don't need any more values. ! if ( x_hi_index - x_lo_index + 1 == 0 ) then ! ! If we need just one new value, do that here to avoid null arrays. ! else if ( x_hi_index - x_lo_index + 1 == 1 ) then r(1) = r4_uniform_01 ( seed ) if ( r(1) == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R4VEC_NORMAL - Fatal error!' write ( *, '(a)' ) ' R4_UNIFORM_01 returned a value of 0.' stop end if r(2) = r4_uniform_01 ( seed ) x(x_hi_index) = & sqrt ( -2.0E+00 * log ( r(1) ) ) * cos ( 2.0E+00 * pi * r(2) ) y = sqrt ( -2.0E+00 * log ( r(1) ) ) * sin ( 2.0E+00 * pi * r(2) ) saved = 1 made = made + 2 ! ! If we require an even number of values, that's easy. ! else if ( mod ( x_hi_index - x_lo_index, two ) == 1 ) then m = ( x_hi_index - x_lo_index + 1 ) / 2 call r4vec_uniform_01 ( 2*m, seed, r ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0E+00 * log ( r(1:2*m-1:2) ) ) & * cos ( 2.0E+00 * pi * r(2:2*m:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0E+00 * log ( r(1:2*m-1:2) ) ) & * sin ( 2.0E+00 * pi * r(2:2*m:2) ) made = made + x_hi_index - x_lo_index + 1 ! ! If we require an odd number of values, we generate an even number, ! and handle the last pair specially, storing one in X(N), and ! saving the other for later. ! else x_hi_index = x_hi_index - 1 m = ( x_hi_index - x_lo_index + 1 ) / 2 + 1 call r4vec_uniform_01 ( 2*m, seed, r ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0E+00 * log ( r(1:2*m-3:2) ) ) & * cos ( 2.0E+00 * pi * r(2:2*m-2:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0E+00 * log ( r(1:2*m-3:2) ) ) & * sin ( 2.0E+00 * pi * r(2:2*m-2:2) ) x(n) = sqrt ( -2.0E+00 * log ( r(2*m-1) ) ) & * cos ( 2.0E+00 * pi * r(2*m) ) y = sqrt ( -2.0E+00 * log ( r(2*m-1) ) ) & * sin ( 2.0E+00 * pi * r(2*m) ) saved = 1 made = made + x_hi_index - x_lo_index + 2 end if x(1:n) = a + b * x(1:n) return end subroutine r4vec_uniform_01 ( n, seed, r ) !*****************************************************************************80 ! !! R4VEC_UNIFORM_01 returns a unit pseudorandom R4VEC. ! ! Discussion: ! ! An R4VEC is an array of real ( kind = 4 ) values. ! ! Licensing: ! ! This code is distributed under the GNU LGPL 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 ( kind = 4 ) N, the number of entries in the vector. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, ! which should NOT be 0. ! On output, SEED has been updated. ! ! Output, real ( kind = 4 ) R(N), the vector of pseudorandom values. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ), parameter :: i4_huge = 2147483647 integer ( kind = 4 ) k integer ( kind = 4 ) seed real ( kind = 4 ) r(n) if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R4VEC_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop end if do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + i4_huge end if r(i) = real ( seed, kind = 4 ) * 4.656612875E-10 end do return end function r8_normal ( a, b, seed ) !*****************************************************************************80 ! !! R8_NORMAL returns a scaled pseudonormal R8. ! ! Discussion: ! ! The normal probability distribution function (PDF) is sampled, ! with mean A and standard deviation B. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) A, the mean of the PDF. ! ! Input, real ( kind = 8 ) B, the standard deviation of the PDF. ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, real ( kind = 8 ) R8_NORMAL, a sample of the normal PDF. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r1 real ( kind = 8 ) r2 real ( kind = 8 ) r8_normal real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ) seed integer ( kind = 4 ), save :: seed2 = 0 integer ( kind = 4 ), parameter :: two = 2 integer ( kind = 4 ), save :: used = 0 real ( kind = 8 ) x real ( kind = 8 ), save :: y = 0.0D+00 ! ! On odd numbered calls, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, two ) == 0 ) then r1 = r8_uniform_01 ( seed ) if ( r1 == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_NORMAL - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop end if seed2 = seed r2 = r8_uniform_01 ( seed2 ) x = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 ) y = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 ) ! ! On odd calls, return the second normal and its corresponding seed. ! else seed = seed2 x = y end if used = used + 1 r8_normal = a + b * x return end function r8_normal_01 ( seed ) !*****************************************************************************80 ! !! R8_NORMAL_01 returns a unit pseudonormal R8. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! Because this routine uses the Box Muller method, it requires pairs ! of uniform random values to generate a pair of normal random values. ! This means that on every other call, the code can use the second ! value that it calculated. ! ! However, if the user has changed the SEED value between calls, ! the routine automatically resets itself and discards the saved data. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, real ( kind = 8 ) R8_NORMAL_01, a normally distributed ! random value. ! implicit none real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r1 real ( kind = 8 ) r2 real ( kind = 8 ) r8_normal_01 real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ) seed integer ( kind = 4 ), save :: seed1 = 0 integer ( kind = 4 ), save :: seed2 = 0 integer ( kind = 4 ), save :: seed3 = 0 integer ( kind = 4 ), parameter :: two = 2 integer ( kind = 4 ), save :: used = 0 real ( kind = 8 ) v1 real ( kind = 8 ), save :: v2 = 0.0D+00 ! ! If USED is odd, but the input SEED does not match ! the output SEED on the previous call, then the user has changed ! the seed. Wipe out internal memory. ! if ( mod ( used, two ) == 1 ) then if ( seed /= seed2 ) then used = 0 seed1 = 0 seed2 = 0 seed3 = 0 v2 = 0.0D+00 end if end if ! ! If USED is even, generate two uniforms, create two normals, ! return the first normal and its corresponding seed. ! if ( mod ( used, two ) == 0 ) then seed1 = seed r1 = r8_uniform_01 ( seed ) if ( r1 == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_NORMAL_01 - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop end if seed2 = seed r2 = r8_uniform_01 ( seed ) seed3 = seed v1 = sqrt ( -2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * pi * r2 ) v2 = sqrt ( -2.0D+00 * log ( r1 ) ) * sin ( 2.0D+00 * pi * r2 ) r8_normal_01 = v1 seed = seed2 ! ! If USED is odd (and the input SEED matched the output value from ! the previous call), return the second normal and its corresponding seed. ! else r8_normal_01 = v2 seed = seed3 end if used = used + 1 return end function r8_uniform_01 ( seed ) !*****************************************************************************80 ! !! R8_UNIFORM_01 returns a unit pseudorandom R8. ! ! Discussion: ! ! This routine implements the recursion ! ! seed = 16807 * seed mod ( 2**31 - 1 ) ! r8_uniform_01 = seed / ( 2**31 - 1 ) ! ! The integer arithmetic never requires more than 32 bits, ! including a sign bit. ! ! If the initial seed is 12345, then the first three computations are ! ! Input Output R8_UNIFORM_01 ! SEED SEED ! ! 12345 207482415 0.096616 ! 207482415 1790989824 0.833995 ! 1790989824 2035175616 0.947702 ! ! Licensing: ! ! This code is distributed under the GNU LGPL 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, 1969, pages 136-143. ! ! Parameters: ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. ! On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R8_UNIFORM_01, a new pseudorandom variate, ! strictly between 0 and 1. ! implicit none integer ( kind = 4 ) k real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ) seed k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if ! ! Although SEED can be represented exactly as a 32 bit integer, ! it generally cannot be represented exactly as a 32 bit real number! ! r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10 return end subroutine r8mat_normal ( m, n, a, b, seed, r ) !*****************************************************************************80 ! !! R8MAT_NORMAL returns a scaled pseudonormal R8MAT. ! ! Licensing: ! ! This code is distributed under the GNU LGPL 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, 1969, pages 136-143. ! ! Parameters: ! ! Input, integer ( kind = 4 ) M, N, the number of rows and columns ! in the array. ! ! Input, real ( kind = 8 ) A, B, the mean and standard deviation. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values. ! implicit none integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) a real ( kind = 8 ) b integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) seed real ( kind = 8 ) r(m,n) do j = 1, n call r8vec_normal ( m, a, b, seed, r(1:m,j) ) end do return end subroutine r8mat_normal_01 ( m, n, seed, r ) !*****************************************************************************80 ! !! R8MAT_NORMAL_01 returns a unit pseudonormal R8MAT. ! ! Licensing: ! ! This code is distributed under the GNU LGPL 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, 1969, pages 136-143. ! ! Parameters: ! ! Input, integer ( kind = 4 ) M, N, the number of rows and columns ! in the array. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R(M,N), the array of pseudonormal values. ! implicit none integer ( kind = 4 ) m integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) seed real ( kind = 8 ) r(m,n) do j = 1, n call r8vec_normal_01 ( m, seed, r(1:m,j) ) end do return end subroutine r8vec_normal ( n, a, b, seed, x ) !*****************************************************************************80 ! !! R8VEC_NORMAL returns a scaled pseudonormal R8VEC. ! ! Discussion: ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! This routine can generate a vector of values on one call. It ! has the feature that it should provide the same results ! in the same order no matter how we break up the task. ! ! Before calling this routine, the user may call RANDOM_SEED ! in order to set the seed of the random number generator. ! ! The Box-Muller method is used, which is efficient, but ! generates an even number of values each time. On any call ! to this routine, an even number of new values are generated. ! Depending on the situation, one value may be left over. ! In that case, it is saved for the next call. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of values desired. If N is ! negative, then the code will flush its internal memory; in particular, ! if there is a saved value to be used on the next call, it is ! instead discarded. This is useful if the user has reset the ! random number seed, for instance. ! ! Input, real ( kind = 8 ) A, B, the mean and standard deviation. ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. ! ! Local parameters: ! ! Local, integer ( kind = 4 ) MADE, records the number of values that have ! been computed. On input with negative N, this value overwrites ! the return value of N, so the user can get an accounting of ! how much work has been done. ! ! Local, real ( kind = 8 ) R(N+1), is used to store some uniform ! random values. Its dimension is N+1, but really it is only needed ! to be the smallest even number greater than or equal to N. ! ! Local, integer ( kind = 4 ) SAVED, is 0 or 1 depending on whether ! there is a single saved value left over from the previous call. ! ! Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range ! of entries of X that we need to compute. This starts off as 1:N, but ! is adjusted if we have a saved value that can be immediately stored ! in X(1), and so on. ! ! Local, real ( kind = 8 ) Y, the value saved from the previous call, if ! SAVED is 1. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) a real ( kind = 8 ) b integer ( kind = 4 ) m integer ( kind = 4 ), save :: made = 0 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r(n+1) real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ), save :: saved = 0 integer ( kind = 4 ) seed integer ( kind = 4 ), parameter :: two = 2 real ( kind = 8 ) x(n) integer ( kind = 4 ) x_hi_index integer ( kind = 4 ) x_lo_index real ( kind = 8 ), save :: y = 0.0D+00 ! ! I'd like to allow the user to reset the internal data. ! But this won't work properly if we have a saved value Y. ! I'm making a crock option that allows the user to signal ! explicitly that any internal memory should be flushed, ! by passing in a negative value for N. ! if ( n < 0 ) then n = made made = 0 saved = 0 y = 0.0D+00 return else if ( n == 0 ) then return end if ! ! Record the range of X we need to fill in. ! x_lo_index = 1 x_hi_index = n ! ! Use up the old value, if we have it. ! if ( saved == 1 ) then x(1) = y saved = 0 x_lo_index = 2 end if ! ! Maybe we don't need any more values. ! if ( x_hi_index - x_lo_index + 1 == 0 ) then ! ! If we need just one new value, do that here to avoid null arrays. ! else if ( x_hi_index - x_lo_index + 1 == 1 ) then r(1) = r8_uniform_01 ( seed ) if ( r(1) == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8VEC_NORMAL - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop end if r(2) = r8_uniform_01 ( seed ) x(x_hi_index) = & sqrt ( -2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * pi * r(2) ) y = sqrt ( -2.0D+00 * log ( r(1) ) ) * sin ( 2.0D+00 * pi * r(2) ) saved = 1 made = made + 2 ! ! If we require an even number of values, that's easy. ! else if ( mod ( x_hi_index - x_lo_index, two ) == 1 ) then m = ( x_hi_index - x_lo_index + 1 ) / 2 call r8vec_uniform_01 ( 2*m, seed, r ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-1:2) ) ) & * cos ( 2.0D+00 * pi * r(2:2*m:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-1:2) ) ) & * sin ( 2.0D+00 * pi * r(2:2*m:2) ) made = made + x_hi_index - x_lo_index + 1 ! ! If we require an odd number of values, we generate an even number, ! and handle the last pair specially, storing one in X(N), and ! saving the other for later. ! 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 ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-3:2) ) ) & * cos ( 2.0D+00 * pi * r(2:2*m-2:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-3:2) ) ) & * sin ( 2.0D+00 * pi * r(2:2*m-2:2) ) x(n) = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * cos ( 2.0D+00 * pi * r(2*m) ) y = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * sin ( 2.0D+00 * pi * r(2*m) ) saved = 1 made = made + x_hi_index - x_lo_index + 2 end if x(1:n) = a + b * x(1:n) return end subroutine r8vec_normal_01 ( n, seed, x ) !*****************************************************************************80 ! !! R8VEC_NORMAL_01 returns a unit pseudonormal R8VEC. ! ! Discussion: ! ! An R8VEC is an array of double precision real values. ! ! The standard normal probability distribution function (PDF) has ! mean 0 and standard deviation 1. ! ! This routine can generate a vector of values on one call. It ! has the feature that it should provide the same results ! in the same order no matter how we break up the task. ! ! Before calling this routine, the user may call RANDOM_SEED ! in order to set the seed of the random number generator. ! ! The Box-Muller method is used, which is efficient, but ! generates an even number of values each time. On any call ! to this routine, an even number of new values are generated. ! Depending on the situation, one value may be left over. ! In that case, it is saved for the next call. ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of values desired. If N is ! negative, then the code will flush its internal memory; in particular, ! if there is a saved value to be used on the next call, it is ! instead discarded. This is useful if the user has reset the ! random number seed, for instance. ! ! Input/output, integer ( kind = 4 ) SEED, a seed for the random ! number generator. ! ! Output, real ( kind = 8 ) X(N), a sample of the standard normal PDF. ! ! Local parameters: ! ! Local, integer ( kind = 4 ) MADE, records the number of values that have ! been computed. On input with negative N, this value overwrites ! the return value of N, so the user can get an accounting of ! how much work has been done. ! ! Local, real ( kind = 8 ) R(N+1), is used to store some uniform ! random values. Its dimension is N+1, but really it is only needed ! to be the smallest even number greater than or equal to N. ! ! Local, integer ( kind = 4 ) SAVED, is 0 or 1 depending on whether there is a ! single saved value left over from the previous call. ! ! Local, integer ( kind = 4 ) X_LO_INDEX, X_HI_INDEX, records the range ! of entries of X that we need to compute. This starts off as 1:N, but ! is adjusted if we have a saved value that can be immediately stored ! in X(1), and so on. ! ! Local, real ( kind = 8 ) Y, the value saved from the previous call, if ! SAVED is 1. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) m integer ( kind = 4 ), save :: made = 0 real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r(n+1) real ( kind = 8 ) r8_uniform_01 integer ( kind = 4 ), save :: saved = 0 integer ( kind = 4 ) seed integer ( kind = 4 ), parameter :: two = 2 real ( kind = 8 ) x(n) integer ( kind = 4 ) x_hi_index integer ( kind = 4 ) x_lo_index real ( kind = 8 ), save :: y = 0.0D+00 ! ! I'd like to allow the user to reset the internal data. ! But this won't work properly if we have a saved value Y. ! I'm making a crock option that allows the user to signal ! explicitly that any internal memory should be flushed, ! by passing in a negative value for N. ! if ( n < 0 ) then n = made made = 0 saved = 0 y = 0.0D+00 return else if ( n == 0 ) then return end if ! ! Record the range of X we need to fill in. ! x_lo_index = 1 x_hi_index = n ! ! Use up the old value, if we have it. ! if ( saved == 1 ) then x(1) = y saved = 0 x_lo_index = 2 end if ! ! Maybe we don't need any more values. ! if ( x_hi_index - x_lo_index + 1 == 0 ) then ! ! If we need just one new value, do that here to avoid null arrays. ! else if ( x_hi_index - x_lo_index + 1 == 1 ) then r(1) = r8_uniform_01 ( seed ) if ( r(1) == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8VEC_NORMAL_01 - Fatal error!' write ( *, '(a)' ) ' R8_UNIFORM_01 returned a value of 0.' stop end if r(2) = r8_uniform_01 ( seed ) x(x_hi_index) = & sqrt ( -2.0D+00 * log ( r(1) ) ) * cos ( 2.0D+00 * pi * r(2) ) y = sqrt ( -2.0D+00 * log ( r(1) ) ) * sin ( 2.0D+00 * pi * r(2) ) saved = 1 made = made + 2 ! ! If we require an even number of values, that's easy. ! else if ( mod ( x_hi_index - x_lo_index, two ) == 1 ) then m = ( x_hi_index - x_lo_index + 1 ) / 2 call r8vec_uniform_01 ( 2*m, seed, r ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-1:2) ) ) & * cos ( 2.0D+00 * pi * r(2:2*m:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-1:2) ) ) & * sin ( 2.0D+00 * pi * r(2:2*m:2) ) made = made + x_hi_index - x_lo_index + 1 ! ! If we require an odd number of values, we generate an even number, ! and handle the last pair specially, storing one in X(N), and ! saving the other for later. ! 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 ) x(x_lo_index:x_hi_index-1:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-3:2) ) ) & * cos ( 2.0D+00 * pi * r(2:2*m-2:2) ) x(x_lo_index+1:x_hi_index:2) = & sqrt ( -2.0D+00 * log ( r(1:2*m-3:2) ) ) & * sin ( 2.0D+00 * pi * r(2:2*m-2:2) ) x(n) = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * cos ( 2.0D+00 * pi * r(2*m) ) y = sqrt ( -2.0D+00 * log ( r(2*m-1) ) ) & * sin ( 2.0D+00 * pi * r(2*m) ) saved = 1 made = made + x_hi_index - x_lo_index + 2 end if return end subroutine r8vec_uniform_01 ( n, seed, r ) !*****************************************************************************80 ! !! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. ! ! Licensing: ! ! This code is distributed under the GNU LGPL 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, 1969, pages 136-143. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of entries in the vector. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) seed real ( kind = 8 ) r(n) do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r(i) = real ( seed, kind = 8 ) * 4.656612875D-10 end do return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! May 31 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 15 March 2003 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 40 ) string call timestring ( string ) write ( *, '(a)' ) trim ( string ) return end subroutine timestring ( string ) !*****************************************************************************80 ! !! TIMESTRING writes the current YMDHMS date into a string. ! ! Example: ! ! STRING = 'May 31 2001 9:45:54.872 AM' ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, character ( len = * ) STRING, contains the date information. ! A character length of 40 should always be sufficient. ! implicit none character ( len = 8 ) ampm integer ( kind = 4 ) d character ( len = 8 ) date integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer ( kind = 4 ) n integer ( kind = 4 ) s character ( len = * ) string character ( len = 10 ) time integer ( kind = 4 ) values(8) integer ( kind = 4 ) y character ( len = 5 ) zone call date_and_time ( date, time, zone, values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( string, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end