subroutine i4vec_print ( n, a, title ) !*****************************************************************************80 ! !! I4VEC_PRINT prints an I4VEC. ! ! Discussion: ! ! An I4VEC is a vector of I4's. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 02 May 2010 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of components of the vector. ! ! Input, integer A(N), the vector to be printed. ! ! Input, character ( len = * ) TITLE, a title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a(n) integer i character ( len = * ) title write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) write ( *, '(a)' ) ' ' do i = 1, n write ( *, '(2x,i8,a,2x,i12)' ) i, ':', a(i) end do return end subroutine i4vec_uniform_ab ( n, a, b, seed, x ) !*****************************************************************************80 ! !! I4VEC_UNIFORM_AB returns a scaled pseudorandom I4VEC. ! ! Discussion: ! ! An I4VEC is a vector of I4's. ! ! The pseudorandom numbers should be scaled to be uniformly distributed ! between A and B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 27 November 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the dimension of the vector. ! ! Input, integer A, B, the limits of the interval. ! ! Input/output, integer SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, integer X(N), a vector of numbers between A and B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer a integer b integer i integer, parameter :: i4_huge = 2147483647 integer k real ( kind = 4 ) r integer seed integer value integer x(n) if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I4VEC_UNIFORM_AB - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop 1 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 = real ( seed, kind = 4 ) * 4.656612875E-10 ! ! Scale R to lie between A-0.5 and B+0.5. ! r = ( 1.0E+00 - r ) * ( real ( min ( a, b ), kind = 4 ) - 0.5E+00 ) & + r * ( real ( max ( a, b ), kind = 4 ) + 0.5E+00 ) ! ! Use rounding to convert R to an integer between A and B. ! value = nint ( r, kind = 4 ) value = max ( value, min ( a, b ) ) value = min ( value, max ( a, b ) ) x(i) = value end do return end subroutine sort_rc ( n, indx, i, j, isgn ) !*****************************************************************************80 ! !! SORT_RC externally sorts a list of items into ascending order. ! ! Discussion: ! ! The actual list of data is not passed to the routine. Hence this ! routine may be used to sort integers, reals, numbers, names, ! dates, shoe sizes, and so on. After each call, the routine asks ! the user to compare or interchange two items, until a special ! return value signals that the sorting is completed. ! ! Note that this function uses internal persistent memory during the sort. ! ! Example: ! ! n = 100 ! indx = 0 ! i = 0 ! j = 0 ! isgn = 0 ! ! do ! ! call sort_rc ( n, indx, i, j, isgn ) ! ! if ( indx < 0 ) then ! ! isgn = 1 ! if ( a(i) <= a(j) ) then ! isgn = -1 ! end if ! ! else if ( 0 < indx ) then ! ! k = a(i) ! a(i) = a(j) ! a(j) = k ! ! else ! ! exit ! ! end if ! ! end do ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 February 2004 ! ! Author: ! ! Original FORTRAN77 version by Albert Nijenhuis, Herbert Wilf. ! FORTRAN90 version by John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of items to be sorted. ! ! Input/output, integer INDX, the main communication signal. ! The user must set INDX to 0 before the first call. ! Thereafter, the user should not change the value of INDX until ! the sorting is done. ! On return, if INDX is ! * greater than 0, ! > interchange items I and J; ! > call again. ! * less than 0, ! > compare items I and J; ! > set ISGN = -1 if I < J, ISGN = +1 if J < I; ! > call again. ! * equal to 0, the sorting is done. ! ! Output, integer I, J, the indices of two items. ! On return with INDX positive, elements I and J should be interchanged. ! On return with INDX negative, elements I and J should be compared, and ! the result reported in ISGN on the next call. ! ! Input, integer ISGN, results of comparison of elements ! I and J. (Used only when the previous call returned INDX less than 0). ! ISGN <= 0 means I is less than or equal to J; ! 0 <= ISGN means I is greater than or equal to J. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer, save :: i_save = 0 integer indx integer isgn integer j integer, save :: j_save = 0 integer, save :: k_save = 0 integer, save :: l_save = 0 integer n integer, save :: n_save = 0 ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then i_save = 0 j_save = 0 k_save = n / 2 l_save = n / 2 n_save = n ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 0 ) then i_save = i_save + 1 end if j_save = l_save l_save = i_save indx = -1 i = i_save j = j_save return end if if ( 0 < isgn ) then indx = 2 i = i_save j = j_save return end if if ( k_save <= 1 ) then if ( n_save == 1 ) then i_save = 0 j_save = 0 indx = 0 else i_save = n_save n_save = n_save - 1 j_save = 1 indx = 1 end if i = i_save j = j_save return end if k_save = k_save - 1 l_save = k_save ! ! 0 < INDX, the user was asked to make an interchange. ! else if ( indx == 1 ) then l_save = k_save end if do i_save = 2 * l_save if ( i_save == n_save ) then j_save = l_save l_save = i_save indx = -1 i = i_save j = j_save return else if ( i_save <= n_save ) then j_save = i_save + 1 indx = -2 i = i_save j = j_save return end if if ( k_save <= 1 ) then exit end if k_save = k_save - 1 l_save = k_save end do if ( n_save == 1 ) then i_save = 0 j_save = 0 indx = 0 i = i_save j = j_save else i_save = n_save n_save = n_save - 1 j_save = 1 indx = 1 i = i_save j = j_save end if return end subroutine sort_safe_rc ( n, indx, i, j, isgn, i_save, j_save, & k_save, l_save, n_save ) !*****************************************************************************80 ! !! SORT_SAFE_RC externally ascending sorts a list of items. ! ! Discussion: ! ! This is a version of SORT_RC which does not rely on ! storing certain work variables internally to the function. This makes ! the function somewhat more awkward to call, but easier to program ! in a variety of languages, and safe to use in a parallel programming ! environment, or in cases where the sorting of several vectors is to ! be carried out at more or less the same time. ! ! The actual list of data is not passed to the routine. Hence this ! routine may be used to sort integers, reals, numbers, names, ! dates, shoe sizes, and so on. After each call, the routine asks ! the user to compare or interchange two items, until a special ! return value signals that the sorting is completed. ! ! Example: ! ! n = 100 ! indx = 0 ! ! do ! ! call sort_safe_rc ( n, indx, i, j, isgn, i_save, j_save, ! k_save, l_save, n_save ) ! ! if ( indx < 0 ) then ! ! isgn = 1 ! if ( a(i) <= a(j) ) then ! isgn = -1 ! end if ! ! else if ( 0 < indx ) then ! ! k = a(i) ! a(i) = a(j) ! a(j) = k ! ! else ! ! exit ! ! end if ! ! end do ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2015 ! ! Author: ! ! John Burkardt. ! ! Reference: ! ! Albert Nijenhuis, Herbert Wilf, ! Combinatorial Algorithms for Computers and Calculators, ! Academic Press, 1978, ! ISBN: 0-12-519260-6, ! LC: QA164.N54. ! ! Parameters: ! ! Input, integer N, the number of items to be sorted. ! ! Input/output, integer INDX, the main communication signal. ! The user must set INDX to 0 before the first call. ! Thereafter, the user should not change the value of INDX until ! the sorting is done. ! On return, if INDX is ! * greater than 0, ! > interchange items I and J; ! > call again. ! * less than 0, ! > compare items I and J; ! > set ISGN = -1 if I < J, ISGN = +1 if J < I; ! > call again. ! * equal to 0, the sorting is done. ! ! Output, integer I, J, the indices of two items. ! On return with INDX positive, elements I and J should be interchanged. ! On return with INDX negative, elements I and J should be compared, and ! the result reported in ISGN on the next call. ! ! Input, integer ISGN, results of comparison of elements ! I and J. (Used only when the previous call returned INDX less than 0). ! ISGN <= 0 means I is less than or equal to J; ! 0 <= ISGN means I is greater than or equal to J. ! ! Input/output, integer I_SAVE, J_SAVE, K_SAVE, L_SAVE, ! N_SAVE, workspace needed by the routine. Before calling the function, ! the user should declare variables to hold these values, but should ! not change them, and need not ever examine them. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer i_save integer indx integer isgn integer j integer j_save integer k_save integer l_save integer n integer n_save ! ! INDX = 0: This is the first call. ! if ( indx == 0 ) then i_save = 0 j_save = 0 k_save = n / 2 l_save = n / 2 n_save = n ! ! INDX < 0: The user is returning the results of a comparison. ! else if ( indx < 0 ) then if ( indx == -2 ) then if ( isgn < 0 ) then i_save = i_save + 1 end if j_save = l_save l_save = i_save indx = -1 i = i_save j = j_save return end if if ( 0 < isgn ) then indx = 2 i = i_save j = j_save return end if if ( k_save <= 1 ) then if ( n_save == 1 ) then i_save = 0 j_save = 0 indx = 0 else i_save = n_save n_save = n_save - 1 j_save = 1 indx = 1 end if i = i_save j = j_save return end if k_save = k_save - 1 l_save = k_save ! ! 0 < INDX, the user was asked to make an interchange. ! else if ( indx == 1 ) then l_save = k_save end if do i_save = 2 * l_save if ( i_save == n_save ) then j_save = l_save l_save = i_save indx = -1 i = i_save j = j_save return else if ( i_save <= n_save ) then j_save = i_save + 1 indx = -2 i = i_save j = j_save return end if if ( k_save <= 1 ) then exit end if k_save = k_save - 1 l_save = k_save end do if ( n_save == 1 ) then i_save = 0 j_save = 0 indx = 0 i = i_save j = j_save else i_save = n_save n_save = n_save - 1 j_save = 1 indx = 1 i = i_save j = j_save end if return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 8 ) ampm integer d integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s integer values(8) integer y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end