program main !*****************************************************************************80 ! !! uniform_test() tests uniform(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 December 2014 ! ! Author: ! ! John Burkardt ! implicit none call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'uniform_test():' write ( *, '(a)' ) ' Fortran90 version' write ( *, '(a)' ) ' Test uniform().' call bvec_uniform_test ( ) call c8_uniform_01_test ( ) call c8mat_uniform_01_test ( ) call c8vec_uniform_01_test ( ) call ch_uniform_ab_test ( ) call i4_seed_advance_test ( ) call i4_uniform_0i_test ( ) call i4_uniform_ab_test ( ) call i4mat_uniform_ab_test ( ) call i4vec_uniform_ab_test ( ) call l4_uniform_test ( ) call l4mat_uniform_test ( ) call l4vec_uniform_test ( ) call lcrg_anbn_test ( ) call r8_uniform_01_test ( ) call r8_uniform_ab_test ( ) call r8mat_uniform_01_test ( ) call r8vec_uniform_01_test ( ) call r8vec_uniform_ab_test ( ) call r8col_uniform_ab_test ( ) call r8col_uniform_abvec_test ( ) call r8row_uniform_abvec_test ( ) call r8vec_uniform_abvec_test ( ) ! ! Terminate. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'uniform_test():' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop end subroutine bvec_uniform_test ( ) !*****************************************************************************80 ! !! bvec_uniform_test() tests bvec_uniform(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 December 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: n = 10 logical b(n) integer i write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'bvec_uniform_test():' write ( *, '(a)' ) ' bvec_uniform() computes a binary vector.' write ( *, '(a)' ) '' do i = 1, 10 call bvec_uniform ( n, b ) call bvec_print ( n, b, '' ) end do return end subroutine c8_uniform_01_test ( ) !*****************************************************************************80 ! !! c8_uniform_01_test() tests c8_uniform_01(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) complex ( kind = ck ) c8_uniform_01 integer i write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'c8_uniform_01_test():' write ( *, '(a)' ) ' c8_uniform_01() computes pseudorandom double precision' write ( *, '(a)' ) ' complex values uniformly distributed in the unit' write ( *, '(a)' ) ' circle.' write ( *, '(a)' ) ' ' do i = 1, 10 write ( *, '(2x,i8,2x,f14.8,2x,f14.8)' ) i, c8_uniform_01 ( ) end do return end subroutine c8mat_uniform_01_test ( ) !*****************************************************************************80 ! !! c8mat_uniform_01_test() tests c8mat_uniform_01(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2025 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer, parameter :: m = 4 integer, parameter :: n = 2 complex ( kind = ck ) c(m,n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'c8mat_uniform_01_test():' write ( *, '(a)' ) ' c8mat_uniform_01() computes pseudorandom complex values ' write ( *, '(a)' ) ' uniformly distributed in the unit circle.' call c8mat_uniform_01 ( m, n, c ) call c8mat_print ( m, n, c, ' Uniform C8MAT:' ) return end subroutine c8vec_uniform_01_test ( ) !*****************************************************************************80 ! !! c8vec_uniform_01_test() tests c8vec_uniform_01(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer, parameter :: n = 10 complex ( kind = ck ) c(n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'c8vec_uniform_01_test():' write ( *, '(a)' ) ' c8vec_uniform_01() computes pseudorandom ' write ( *, '(a)' ) ' double precision complex values uniformly distributed ' write ( *, '(a)' ) ' in the unit circle.' call c8vec_uniform_01 ( n, c ) call c8vec_print ( n, c, ' The Uniform C8VEC:' ) return end subroutine ch_uniform_ab_test ( ) !*****************************************************************************80 ! !! ch_uniform_ab_test() tests ch_uniform_ab(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2025 ! ! Author: ! ! John Burkardt ! implicit none character ch_uniform_ab character chi character clo integer i clo = 'A' chi = 'J' write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CH_UNIFORM_AB_TEST' write ( *, '(a)' ) ' CH_UNIFORM_AB computes pseudorandom characters ' write ( *, '(a)' ) ' in an interval [CLO,CHI].' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' The lower endpoint CLO = "' // clo // '".' write ( *, '(a)' ) ' The upper endpoint CHI = "' // chi // '".' write ( *, '(a)' ) ' ' do i = 1, 10 write ( *, '(2x,i8,2x,a1)' ) i, ch_uniform_ab ( clo, chi ) end do return end subroutine i4_seed_advance_test ( ) !*****************************************************************************80 ! !! i4_seed_advance_test() tests i4_seed_advance(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 14 December 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i4_seed_advance integer seed integer seed_new integer step seed_new = 12345 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4_SEED_ADVANCE_TEST' write ( *, '(a)' ) ' I4_SEED_ADVANCE advances the seed.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Step SEED input SEED output' write ( *, '(a)' ) ' ' do step = 1, 10 seed = seed_new seed_new = i4_seed_advance ( seed ) write ( *, '(2x,i4,2x,i16,2x,i16)' ) step, seed, seed_new end do return end subroutine i4_uniform_0i_test ( ) !*****************************************************************************80 ! !! I4_UNIFORM_0I_TEST tests I4_UNIFORM_0I ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer i4_uniform_0i real ( kind = rk ) mean integer, parameter :: n = 1000 integer seed real ( kind = rk ) variance integer x(n) seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4_UNIFORM_0I_TEST' write ( *, '(a)' ) ' I4_UNIFORM_0I samples a uniform random' write ( *, '(a)' ) ' integer distribution in [0,2**31-1].' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' Starting with seed = ', seed do i = 1, n x(i) = i4_uniform_0i ( seed ) end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' First few values:' write ( *, '(a)' ) ' ' do i = 1, 5 write ( *, '(2x,i8,2x,i12)' ) i, x(i) end do mean = sum ( real ( x(1:n), kind = rk ) / real ( n, kind = rk ) ) variance = sum ( ( real ( x(1:n), kind = rk ) - mean )**2 ) & / real ( n - 1, kind = rk ) write ( *, '(a)' ) ' ' write ( *, '(a,i8)' ) ' Number of values computed was N = ', n write ( *, '(a,g14.6)' ) ' Average value was ', mean write ( *, '(a,i12)' ) ' Minimum value was ', minval ( x(1:n) ) write ( *, '(a,i12)' ) ' Maximum value was ', maxval ( x(1:n) ) write ( *, '(a,g14.6)' ) ' Variance was ', variance return end subroutine i4_uniform_ab_test ( ) !*****************************************************************************80 ! !! i4_uniform_ab_test() tests i4_uniform_ab(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 August 2021 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: a = -100 integer, parameter :: b = 200 integer i integer i4_uniform_ab integer j write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'i4_uniform_ab_test():' write ( *, '(a)' ) ' i4_uniform_ab() computes pseudorandom values ' write ( *, '(a)' ) ' in an interval [A,B].' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' The lower endpoint A = ', a write ( *, '(a,i12)' ) ' The upper endpoint B = ', b write ( *, '(a)' ) ' ' do i = 1, 20 j = i4_uniform_ab ( a, b ) write ( *, '(2x,i8,2x,i8)' ) i, j end do return end subroutine i4mat_uniform_ab_test ( ) !*****************************************************************************80 ! !! I4MAT_UNIFORM_AB_TEST tests I4MAT_UNIFORM_AB. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 17 December 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: m = 5 integer, parameter :: n = 4 integer, parameter :: a = -100 integer, parameter :: b = 200 integer v(m,n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'i4mat_uniform_ab_test():' write ( *, '(a)' ) ' i4mat_uniform_ab() computes pseudorandom values ' write ( *, '(a)' ) ' in an interval [A,B].' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' The lower endpoint A = ', a write ( *, '(a,i12)' ) ' The upper endpoint B = ', b call i4mat_uniform_ab ( m, n, a, b, v ) call i4mat_print ( m, n, v, ' Uniform I4MAT:' ) return end subroutine i4vec_uniform_ab_test ( ) !*****************************************************************************80 ! !! i4vec_uniform_ab_test() tests i4vec_uniform_ab(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 2025 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: n = 20 integer, parameter :: a = -100 integer, parameter :: b = 200 integer v(n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4VEC_UNIFORM_AB_TEST():' write ( *, '(a)' ) ' I4VEC_UNIFORM_AB() computes pseudorandom values ' write ( *, '(a)' ) ' in an interval [A,B].' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' The lower endpoint A = ', a write ( *, '(a,i12)' ) ' The upper endpoint B = ', b call i4vec_uniform_ab ( n, a, b, v ) call i4vec_print ( n, v, ' Uniform I4VEC:' ) return end subroutine l4_uniform_test ( ) !*****************************************************************************80 ! !! L4_UNIFORM_TEST tests L4_UNIFORM. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 01 December 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i logical l4_uniform write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'L4_UNIFORM_TEST' write ( *, '(a)' ) ' L4_UNIFORM computes pseudorandom logical values.' write ( *, '(a)' ) ' ' do i = 1, 10 write ( *, '(2x,i8,2x,l1)' ) i, l4_uniform ( ) end do return end subroutine l4mat_uniform_test ( ) !*****************************************************************************80 ! !! l4mat_uniform_test() tests l4mat_uniform(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2025 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: m = 5 integer, parameter :: n = 4 logical l(m,n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'l4mat_uniform_test():' write ( *, '(a)' ) ' l4mat_uniform() computes a vector of' write ( *, '(a)' ) ' pseudorandom logical values.' call l4mat_uniform ( m, n, l ) call l4mat_print ( m, n, l, ' Uniform L4MAT:' ) return end subroutine l4vec_uniform_test ( ) !*****************************************************************************80 ! !! l4vec_uniform_test() tests l4vec_uniform(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2025 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: n = 10 logical l(n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'l4vec_uniform_test():' write ( *, '(a)' ) ' l4vec_uniform() computes a vector of' write ( *, '(a)' ) ' pseudorandom logical values.' call l4vec_uniform ( n, l ) call l4vec_print ( n, l, ' Uniform L4VEC:' ) return end subroutine lcrg_anbn_test ( ) !*****************************************************************************80 ! !! LCRG_ANBN_TEST tests LCRG_ANBN. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 April 2008 ! ! Author: ! ! John Burkardt ! implicit none integer a integer an integer b integer bn integer c integer j integer k integer n integer u integer v integer, allocatable, dimension ( : ) :: x integer, allocatable, dimension ( : ) :: y write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'LCRG_ANBN_TEST' write ( *, '(a)' ) ' LCRG_ANBN determines a linear congruential random' write ( *, '(a)' ) ' number generator equivalent to N steps of a given one.' ! ! These parameters define the old (1969) IBM 360 random number generator: ! a = 16807 b = 0 c = 2147483647 write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' LCRG parameters:' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' A = ', a write ( *, '(a,i12)' ) ' B = ', b write ( *, '(a,i12)' ) ' C = ', c write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' N A B' write ( *, '(a)' ) ' ' do n = 0, 10 call lcrg_anbn ( a, b, c, n, an, bn ) write ( *, '(2x,i12,2x,i12,2x,i12)' ) n, an, bn end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' N In Out' write ( *, '(a)' ) ' ' k = 0 u = 12345 write ( *, '(2x,12x,2x,i12,2x,12x,2x,i12)' ) k, u do k = 1, 11 call lcrg_evaluate ( a, b, c, u, v ) write ( *, '(2x,12x,2x,i12,2x,i12,2x,i12)' ) k, u, v u = v end do ! ! Now try to replicate these results using N procesors. ! n = 4 allocate ( x(1:n) ) allocate ( y(1:n) ) call lcrg_anbn ( a, b, c, n, an, bn ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' LCRG parameters:' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' AN = ', an write ( *, '(a,i12)' ) ' BN = ', bn write ( *, '(a,i12)' ) ' C = ', c write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' J N In Out' write ( *, '(a)' ) ' ' x(1) = 12345 do j = 2, n call lcrg_evaluate ( a, b, c, x(j-1), x(j) ) end do do j = 1, n write ( *, '(2x,i12,2x,i12,2x,12x,2x,i12)' ) j, j-1, x(j) end do do k = n + 1, 12, n do j = 1, n call lcrg_evaluate ( an, bn, c, x(j), y(j) ) write ( *, '(2x,i12,2x,i12,2x,i12,2x,i12)' ) j, k+j-2, x(j), y(j) x(j) = y(j) end do end do deallocate ( x ) deallocate ( y ) return end subroutine r8_uniform_01_test ( ) !*****************************************************************************80 ! !! r8_uniform_01_test() tests r8_uniform_01(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) r8_uniform_01 integer i write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8_UNIFORM_01_TEST' write ( *, '(a)' ) ' R8_UNIFORM_01 computes pseudorandom values ' write ( *, '(a)' ) ' in the interval [0,1].' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' do i = 1, 10 write ( *, '(2x,i8,2x,g14.6)' ) i, r8_uniform_01 ( ) end do return end subroutine r8_uniform_ab_test ( ) !*****************************************************************************80 ! !! r8_uniform_ab_test tests r8_uniform_ab. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) r8_uniform_ab integer i a = 5.0D+00 b = 10.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8_uniform_ab_test():' write ( *, '(a)' ) ' r8_uniform_ab() computes pseudorandom values ' write ( *, '(a)' ) ' in an interval [A,B].' write ( *, '(a)' ) ' ' write ( *, '(a,g14.6)' ) ' The lower endpoint A = ', a write ( *, '(a,g14.6)' ) ' The upper endpoint B = ', b write ( *, '(a)' ) ' ' do i = 1, 10 write ( *, '(2x,i8,2x,g14.6)' ) i, r8_uniform_ab ( a, b ) end do return end subroutine r8col_uniform_ab_test ( ) !*****************************************************************************80 ! !! r8col_uniform_ab_test() tests r8col_uniform_ab(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 May 2025 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 5 integer, parameter :: n = 4 real ( kind = rk ) :: a = 10.0D+00 real ( kind = rk ) :: b = 20.0D+00 integer i real ( kind = rk ) v(m,n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8col_uniform_ab_test():' write ( *, '(a)' ) ' r8col_uniform_ab() computes a random R8COL.' call r8col_uniform_ab ( m, n, a, b, v ) write ( *, '(a)' ) '' do i = 1, m write ( *, '(2x,f8.4,a3,4(2x,f8.4),2x,a3,f8.4)' ) & a, ': ', v(i,1:n), ' :', b end do return end subroutine r8col_uniform_abvec_test ( ) !*****************************************************************************80 ! !! r8col_uniform_abvec_test() tests r8col_uniform_abvec(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 December 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 5 integer, parameter :: n = 4 real ( kind = rk ), dimension ( m ) :: a = (/ & 0.0D+00, 0.20D+00, 10.0D+00, 52.0D+00, -1.0D+00 /) real ( kind = rk ), dimension ( m ) :: b = (/ & 1.0D+00, 0.25D+00, 20.0D+00, 54.0D+00, +1.0D+00 /) integer i integer seed real ( kind = rk ) v(m,n) seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8col_uniform_abvec_test():' WRITE ( *, '(A)' ) ' r8col_uniform_abvec() computes a random R8COL.' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' The initial seed is ', seed call r8col_uniform_abvec ( m, n, a, b, seed, v ) write ( *, '(a)' ) '' do i = 1, m write ( *, '(2x,f8.4,a3,4(2x,f8.4),2x,a3,f8.4)' ) & a(i), ': ', v(i,1:n), ' :', b(i) end do return end subroutine r8mat_uniform_01_test ( ) !*****************************************************************************80 ! !! r8mat_uniform_01_test() tests r8mat_uniform_01(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 December 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 5 integer, parameter :: n = 4 real ( kind = rk ) v(m,n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8mat_uniform_01_test():' write ( *, '(a)' ) ' r8mat_uniform_01() computes a random R8MAT.' call r8mat_uniform_01 ( m, n, v ) call r8mat_print ( m, n, v, ' Uniform R8MAT' ) return end subroutine r8row_uniform_abvec_test ( ) !*****************************************************************************80 ! !! R8ROW_UNIFORM_ABVEC_TEST tests R8ROW_UNIFORM_ABVEC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 December 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: m = 4 integer, parameter :: n = 5 real ( kind = rk ), dimension ( n ) :: a = (/ & 0.0D+00, 0.20D+00, 10.0D+00, 52.0D+00, -1.0D+00 /) real ( kind = rk ), dimension ( n ) :: b = (/ & 1.0D+00, 0.25D+00, 20.0D+00, 54.0D+00, +1.0D+00 /) integer i integer seed real ( kind = rk ) v(m,n) seed = 123456789 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8ROW_UNIFORM_ABVEC_TEST' write ( *, '(a)' ) ' R8ROW_UNIFORM_ABVEC computes a random R8ROW.' write ( *, '(a)' ) ' ' write ( *, '(a,i12)' ) ' The initial seed is ', seed call r8row_uniform_abvec ( m, n, a, b, seed, v ) write ( *, '(a)' ) '' write ( *, '(5(2x,f8.4))' ) b(1:n) write ( *, '(a)' ) '' do i = 1, m write ( *, '(5(2x,f8.4))' ) v(i,1:n) end do write ( *, '(a)' ) '' write ( *, '(5(2x,f8.4))' ) a(1:n) return end subroutine r8vec_uniform_01_test ( ) !*****************************************************************************80 ! !! r8vec_uniform_01_test() tests r8vec_uniform_01(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 October 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 10 real ( kind = rk ) v(n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8vec_uniform_01_test():' write ( *, '(a)' ) ' r8vec_uniform_01() computes a random R8VEC.' write ( *, '(a)' ) ' ' call r8vec_uniform_01 ( n, v ) call r8vec_print ( n, v, ' Uniform R8VEC' ) return end subroutine r8vec_uniform_ab_test ( ) !*****************************************************************************80 ! !! r8vec_uniform_ab_test() tests r8vec_uniform_ab(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 October 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 10 real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) v(n) a = -1.0D+00 b = +5.0D+00 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8vec_uniform_ab_test():' write ( *, '(a)' ) ' r8vec_uniform_ab() computes a random R8VEC.' write ( *, '(a)' ) ' ' write ( *, '(a,g14.6,a,g14.6)' ) ' ', a, ' <= X <= ', b call r8vec_uniform_ab ( n, a, b, v ) call r8vec_print ( n, v, ' Uniform R8VEC' ) return end subroutine r8vec_uniform_abvec_test ( ) !*****************************************************************************80 ! !! r8vec_uniform_abvec_test() tests r8vec_uniform_abvec(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 26 December 2014 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n = 5 real ( kind = rk ), dimension ( n ) :: a = (/ & 0.0D+00, 0.20D+00, 10.0D+00, 52.0D+00, -1.0D+00 /) real ( kind = rk ), dimension ( n ) :: b = (/ & 1.0D+00, 0.25D+00, 20.0D+00, 54.0D+00, +1.0D+00 /) integer i real ( kind = rk ) v(n) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'r8vec_uniform_abvec_test():' write ( *, '(a)' ) ' r8vec_uniform_abvec() computes a random R8VEC.' call r8vec_uniform_abvec ( n, a, b, v ) write ( *, '(a)' ) '' write ( *, '(a)' ) ' I A X B' write ( *, '(a)' ) '' do i = 1, n write ( *, '(2x,i4,2x,f8.4,2x,f8.4,2x,f8.4)' ) i, a(i), v(i), b(i) end do 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 ! implicit none 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