program main !*****************************************************************************80 ! !! machine_test() tests machine(). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 April 2007 ! ! Author: ! ! John Burkardt ! implicit none call timestamp ( ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MACHINE_TEST():' write ( *, '(a)' ) ' FORTRAN90 version' write ( *, '(a)' ) ' Test MACHINE().' call d1mach_test ( ) call i1mach_test ( ) call r1mach_test ( ) ! ! Terminate. ! write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'MACHINE_TEST:' write ( *, '(a)' ) ' Normal end of execution.' write ( *, '(a)' ) ' ' call timestamp ( ) stop 0 end subroutine d1mach_test ( ) !*****************************************************************************80 ! !! D1MACH_TEST reports the constants returned by D1MACH. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) d1mach write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1MACH_TEST' write ( *, '(a)' ) ' D1MACH reports the value of constants associated' write ( *, '(a)' ) ' with real double precision computer arithmetic.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Assume that double precision numbers are stored ' write ( *, '(a)' ) ' with a mantissa of T digits in base B, with an ' write ( *, '(a)' ) ' exponent whose value must lie between EMIN and EMAX.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' For input arguments of 1 <= I <= 5,' write ( *, '(a)' ) ' D1MACH will return the following values:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' D1MACH(1) = B^(EMIN-1), the smallest positive magnitude.' write ( *, * ) d1mach(1) write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' D1MACH(2) = B^EMAX*(1-B^(-T)), the largest magnitude.' write ( *, * ) d1mach(2) write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' D1MACH(3) = B^(-T), the smallest relative spacing.' write ( *, * ) d1mach(3) write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' D1MACH(4) = B^(1-T), the largest relative spacing.' write ( *, * ) d1mach(4) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' D1MACH(5) = log10(B).' write ( *, * ) d1mach(5) return end subroutine i1mach_test ( ) !*****************************************************************************80 ! !! I1MACH_TEST reports the constants returned by I1MACH. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2007 ! ! Author: ! ! John Burkardt ! implicit none integer i1mach write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I1MACH_TEST' write ( *, '(a)' ) ' I1MACH reports the value of constants associated' write ( *, '(a)' ) ' with integer computer arithmetic.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Numbers associated with input/output units:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(1) = the standard input unit.' write ( *, * ) i1mach(1) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(2) = the standard output unit.' write ( *, * ) i1mach(2) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(3) = the standard punch unit.' write ( *, * ) i1mach(3) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(4) = the standard error message unit.' write ( *, * ) i1mach(4) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Numbers associated with words:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(5) = the number of bits per integer.' write ( *, * ) i1mach(5) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(6) = the number of characters per integer.' write ( *, * ) i1mach(6) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Numbers associated with integer values:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Assume integers are represented in the S digit ' write ( *, '(a)' ) ' base A form:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Sign * (X(S-1)*A^(S-1) + ... + X(1)*A + X(0))' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' where the digits X satisfy 0 <= X(1:S-1) < A.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(7) = A, the base.' write ( *, * ) i1mach(7) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(8) = S, the number of base A digits.' write ( *, * ) i1mach(8) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(9) = A^S-1, the largest integer.' write ( *, * ) i1mach(9) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Numbers associated with floating point values:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Assume floating point numbers are represented ' write ( *, '(a)' ) ' in the T digit base B form:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Sign * (B^E) * ((X(1)/B) + ... + (X(T)/B^T) )' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' where ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' 0 <= X(1:T) < B,' write ( *, '(a)' ) ' 0 < X(1) (unless the value being represented is 0),' write ( *, '(a)' ) ' EMIN <= E <= EMAX.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(10) = B, the base.' write ( *, * ) i1mach(10) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Numbers associated with single precision values:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(11) = T, the number of base B digits.' write ( *, * ) i1mach(11) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(12) = EMIN, the smallest exponent E.' write ( *, * ) i1mach(12) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(13) = EMAX, the largest exponent E.' write ( *, * ) i1mach(13) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Numbers associated with double precision values:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(14) = T, the number of base B digits.' write ( *, * ) i1mach(14) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(15) = EMIN, the smallest exponent E.' write ( *, * ) i1mach(15) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' I1MACH(16) = EMAX, the largest exponent E.' write ( *, * ) i1mach(16) return end subroutine r1mach_test ( ) !*****************************************************************************80 ! !! R1MACH_TEST reports the constants returned by R1MACH. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 March 2007 ! ! Author: ! ! John Burkardt ! implicit none integer, parameter :: rk = kind ( 1.0E+00 ) real ( kind = rk ) r1mach write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R1MACH_TEST' write ( *, '(a)' ) ' R1MACH reports the value of constants associated' write ( *, '(a)' ) ' with real single precision computer arithmetic.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Assume that single precision numbers are stored ' write ( *, '(a)' ) ' with a mantissa of T digits in base B, with an ' write ( *, '(a)' ) ' exponent whose value must lie between EMIN and EMAX.' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' For input arguments of 1 <= I <= 5,' write ( *, '(a)' ) ' R1MACH will return the following values:' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' R1MACH(1) = B^(EMIN-1), the smallest positive magnitude.' write ( *, * ) r1mach(1) write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' R1MACH(2) = B^EMAX*(1-B^(-T)), the largest magnitude.' write ( *, * ) r1mach(2) write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' R1MACH(3) = B^(-T), the smallest relative spacing.' write ( *, * ) r1mach(3) write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' R1MACH(4) = B^(1-T), the largest relative spacing.' write ( *, * ) r1mach(4) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' R1MACH(5) = log10(B).' write ( *, * ) r1mach(5) 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: ! ! 06 August 2005 ! ! 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