function a_to_i4 ( ch )

!*****************************************************************************80
!
!! A_TO_I4 returns the index of an alphabetic character.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Example:
!
!    CH  A_TO_I4
!
!    'A'   1
!    'B'   2
!    ...   
!    'Z'  26
!    'a'  27
!    'b'  28
!    ...
!    'z'  52
!    '$'   0
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    22 February 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, a character.
!
!    Output, integer ( kind = 4 ) A_TO_I4, is the alphabetic index of the
!    character, between 1 and 26 if the character is a capital letter,
!    between 27 and 52 if it is lower case, and 0 otherwise.
!
  implicit none

  integer ( kind = 4 ) a_to_i4
  integer ( kind = 4 ), parameter :: cap_shift = 64
  character ch
  integer ( kind = 4 ), parameter :: low_shift = 96

  if ( lle ( 'A', ch ) .and. lle ( ch, 'Z' ) ) then
    a_to_i4 = iachar ( ch ) - cap_shift
  else if ( lle ( 'a', ch ) .and. lle ( ch, 'z' ) ) then
    a_to_i4 = iachar ( ch ) - low_shift + 26
  else
    a_to_i4 = 0
  end if

  return
end
subroutine b4_ieee_to_r4 ( word, r )

!*****************************************************************************80
!
!! B4_IEEE_TO_R4 converts a 4 byte IEEE word into an R4.
!
!  Discussion:
!
!    An "R4" value is simply a real number to be stored as a
!    variable of type "real ( kind = 4 )".
!
!    This routine does not seem to work reliably for unnormalized data.
!
!    The word containing the real value may be interpreted as:
!
!      /SEEEEEEE/EFFFFFFF/FFFFFFFF/FFFFFFFF/
!
!      /33222222/22222222/22222100/00000000/
!      /10987654/32109876/54321098/76543210/  <-- Bit numbering
!
!    where
!
!      S is the sign bit,
!      E are the exponent bits,
!      F are the mantissa bits.
!
!    The mantissa is usually "normalized"; that is, there is an implicit
!    leading 1 which is not stored.  However, if the exponent is set to
!    its minimum value, this is no longer true.
!
!    The exponent is "biased".  That is, you must subtract a bias value
!    from the exponent to get the true value.
!
!    If we read the three fields as integers S, E and F, then the
!    value of the resulting real number R can be determined by:
!
!    * if E = 255
!        if F is nonzero, then R = NaN;
!        if F is zero and S is 1, R = -Inf;
!        if F is zero and S is 0, R = +Inf;
!    * else if 0 < E then R = (-1)**(S) * 2**(E-127) * (1 + (F/2**24))
!    * else if E = 0
!        if F is nonzero, R = (-1)**(S) * 2**(E-126) * (F/2**24)
!        if F is zero and S is 1, R = -0;
!        if F is zero and S is 0, R = +0;
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    10 November 2001
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    IEEE Standards Committee 754,
!    IEEE Standard for Binary Floating Point Arithmetic,
!    ANSI/IEEE Standard 754-1985,
!    SIGPLAN Notices,
!    Volume 22, Number 2, 1987, pages 9-25.
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) WORD, the word to be decoded.
!
!    Output, real ( kind = 4 ) R, the value of the real number.
!
  implicit none

  integer ( kind = 4 ) e
  integer ( kind = 4 ) f
  integer ( kind = 4 ) i
  real    ( kind = 4 ) r
  integer ( kind = 4 ) s
  integer ( kind = 4 ) word
!
!  Read the fields.
!
  s = 0
  call mvbits ( word, 31, 1, s, 0 )

  e = 0
  call mvbits ( word, 23, 8, e, 0 )

  f = 0
  call mvbits ( word, 0, 23, f, 0 )
!
!  Don't bother trying to return NaN or Inf just yet.
!
  if ( e == 255 ) then
    r = 0.0E+00
  else if ( 0 < e ) then
    r = ( -1.0E+00 )**s * 2.0E+00**(e-127-23) * real ( 8388608 + f, kind = 4 ) 
  else if ( e == 0 ) then
    r = ( -1.0E+00 )**s * 2.0E+00**(-126) * real ( f, kind = 4 )
    do i = 1, 23
      r = r / 2.0E+00
    end do
  end if

  return
end
subroutine b4_ieee_to_sef ( word, s, e, f )

!*****************************************************************************80
!
!! B4_IEEE_TO_SEF converts an IEEE real word to S * 2**E * F format.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    22 November 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) WORD, a word containing an IEEE real number.
!
!    Output, integer ( kind = 4 ) S, the sign bit:
!    0, if R is nonnegative;
!    1, if R is negative.
!
!    Output, integer ( kind = 4 ) E, the exponent base 2.
!
!    Output, integer ( kind = 4 ) F, the mantissa.
!
  implicit none

  integer ( kind = 4 ) e
  integer ( kind = 4 ) e2
  integer ( kind = 4 ) f
  integer ( kind = 4 ), parameter :: i4_two = 2
  integer ( kind = 4 ) s
  integer ( kind = 4 ) word

  s = 0
  call mvbits ( word, 31, 1, s, 0 )

  e2 = 0
  call mvbits ( word, 23, 8, e2, 0 )

  if ( e2 == 255 ) then

    e = 128

    call mvbits ( word, 0, 23, f, 0 )

    if ( f == 0 ) then
      f = 0
    else
      f = 2**23 - 1
    end if

  else if ( 0 < e2 ) then 

    e = e2 - 127 - 23
    f = 2**23
    call mvbits ( word, 0, 23, f, 0 )

    do while ( mod ( f, i4_two ) == 0 )
      f = f / 2
      e = e + 1
    end do

  else if ( e2 == 0 ) then

    e = e2 - 127 - 23
    f = 0
    call mvbits ( word, 0, 23, f, 0 )

    if ( f == 0 ) then

      e = 0

    else

      do while ( 0 < f .and. mod ( f, i4_two ) == 0 )
        f = f / 2
        e = e + 1
      end do

    end if

  end if

  return
end
subroutine base_to_i4 ( s, base, i )

!*****************************************************************************80
!
!! BASE_TO_I4 returns the value of an integer represented in some base.
!
!  Discussion:
!
!    BASE = 1 is allowed, in which case we allow the digits '1' and '0',
!    and we simply count the '1' digits for the result.
!
!    Negative bases between -16 and -2 are allowed.  
!
!    The base -1 is allowed, and essentially does a parity check on
!    a string of 1's.
!
!  Example:
!
!        Input      Output
!    -------------  ------
!         S   BASE       I
!    ------  -----  ------
!      '101'     2       5
!    '-1000'     3     -27
!      '100'     4      16
!   '111111'     2      63
!   '111111'    -2      21
!   '111111'     1       6
!   '111111'    -1       0
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    27 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string.  The elements of S are
!    blanks, a plus or minus sign, and digits.  Normally, the digits
!    are representations of integers between 0 and |BASE-1|.  In the
!    special case of base 1 or base -1, we allow both 0 and 1 as digits.
!
!    Input, integer ( kind = 4 ) BASE, the base in which the representation is given.  
!    Normally, 2 <= BASE <= 16.  However, there are two exceptions.
!
!    Output, integer ( kind = 4 ) I, the integer.
!
  implicit none

  integer ( kind = 4 ) base
  character c
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ichr
  integer ( kind = 4 ) idig
  integer ( kind = 4 ) isgn
  character ( len = * ) s
  integer ( kind = 4 ) s_length
  integer ( kind = 4 ) state

  i = 0
  s_length = len_trim ( s )
 
  if ( base == 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BASE_TO_I4 - Serious error!'
    write ( *, '(a)' ) '  The input base is zero.'
    i = -1
    return
  end if

  if ( 16 < abs ( base ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BASE_TO_I4 - Serious error!'
    write ( *, '(a)' ) '  The input base is greater than 16!'
    i = -1
    return
  end if
 
  state = 0
  isgn = 1 
  ichr = 1

  do while ( ichr <= s_length )

    c = s(ichr:ichr)
!
!  Blank.
!
    if ( c == ' ' ) then
 
      if ( state == 2 ) then
        exit
      end if
!
!  Sign, + or -.
!
    else if ( c == '-' ) then
 
      if ( state /= 0 ) then
        exit
      end if

      state = 1
      isgn = -1
 
    else if ( c == '+' ) then
 
      if ( state /= 0 ) then
        exit
      end if

      state = 1

    else
!
!  Digit?
!
      call ch_to_digit_hex ( c, idig )
 
      if ( abs ( base ) == 1 .and. ( idig == 0 .or. idig == 1 ) ) then

        i = base * i + idig
        state = 2
      
      else if ( 0 <= idig .and. idig < abs ( base ) ) then

        i = base * i + idig
        state = 2

      else

        write ( *, '(a)' ) ' '
        write ( *, '(a)' ) 'BASE_TO_I4 - Serious error!'
        write ( *, '(a)' ) '  Illegal digit = "' // c // '"'
        write ( *, '(a)' ) '  Conversion halted prematurely!'
        return

      end if

    end if

    ichr = ichr + 1

  end do
!
!  Once we're done reading information, we expect to be in state 2.
!
  if ( state /= 2 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'BASE_TO_I4 - Serious error!'
    write ( *, '(a)' ) '  Unable to decipher input!'
    return
  end if
!
!  Account for the sign.
!
  i = isgn * i
 
  return
end
subroutine binary_to_i4 ( s, i )

!*****************************************************************************80
!
!! BINARY_TO_I4 converts a binary representation into an integer value.
!
!  Example:
!
!        S        I
!
!      '101'      5  
!    '-1000'     -8 
!        '1'      1
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    28 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the binary representation.
!
!    Output, integer ( kind = 4 ) I, the integer whose representation was input.
!
  implicit none

  character c
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ichr
  integer ( kind = 4 ) isgn
  character ( len = * ) s
  integer ( kind = 4 ) s_length
  integer ( kind = 4 ) state

  s_length = len_trim ( s )
 
  i = 0
  ichr = 1
  state = 0
  isgn = 1
 
  do while ( ichr <= s_length )

    c = s(ichr:ichr)
!
!  Blank.
!
    if ( c == ' ' ) then
 
      if ( state == 2 ) then
        state = 3
      end if
!
!  Sign, + or -.
!
    else if ( c == '-' ) then

      if ( state == 0 ) then
        state = 1
        isgn = -1
      else
        state = -1
      end if

    else if ( c == '+' ) then

      if ( state == 0 ) then
        state = 1
      else
        state = -1
      end if
!
!  Digit, 0 or 1.
!
    else if ( c == '1' ) then

      i = 2 * i
      i = i + 1
      state = 2

    else if ( c == '0' ) then
 
      i = 2 * i
      state = 2
!
!  Illegal or unknown sign.
!
    else

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BINARY_TO_I4 - Serious error!'
      write ( *, '(a)' ) '  Illegal digit = "' // c // '"'
      write ( *, '(a)' ) '  Conversion halted prematurely!'
      return

    end if

    if ( state == -1 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BINARY_TO_I4 - Serious error!'
      write ( *, '(a)' ) '  Unable to decipher input!'
      return
    end if

    if ( 3 <= state ) then
      exit
    end if

    ichr = ichr + 1

  end do
!
!  Apply the sign.
!
  i = isgn * i

  return
end
subroutine binary_to_r4 ( s, r )

!*****************************************************************************80
!
!! BINARY_TO_R4 converts a binary representation into an R4.
!
!  Discussion:
!
!    An "R4" value is simply a real number to be stored as a
!    variable of type "real ( kind = 4 )".
!
!  Example:
!
!        S                         R
!
!    -1010.11                   -10.75
!    0.011011                     0.4218750
!    0.01010101010101010101010    0.3333333
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    28 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the binary representation.
!
!    Output, real ( kind = 4 ) R, the real number.
!
  implicit none

  character c
  integer ( kind = 4 ) ichr
  integer ( kind = 4 ) intval
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) power
  real    ( kind = 4 ) r
  character ( len = * ) s
  integer ( kind = 4 ) s_length
  integer ( kind = 4 ) state

  s_length = len_trim ( s )
 
  intval = 0
  ichr = 1
  state = 0
  isgn = 1
  r = 0.0E+00
  power = 0
 
  do while ( ichr <= s_length )

    c = s(ichr:ichr)
!
!  Blank.
!
    if ( c == ' ' ) then
 
      if ( state == 4 ) then
        state = 5
      end if
!
!  Sign, + or -.
!
    else if ( c == '-' ) then

      if ( state == 0 ) then
        state = 1
        isgn = -1
      else
        state = -1
      end if

    else if ( c == '+' ) then
 
      if ( state == 0 ) then
        state = 1
      else
        state = -1
      end if
!
!  Digit, 0 or 1.
!
    else if ( c == '1' ) then

      intval = 2 * intval + 1

      if ( state == 0 .or. state == 1 ) then
        state = 2
      else if ( state == 3 ) then
        state = 4
      end if

      if ( state == 4 ) then
        power = power + 1
      end if

    else if ( c == '0' ) then

      intval = 2 * intval

      if ( state == 0 .or. state == 1 ) then
        state = 2
      else if ( state == 3 ) then
        state = 4
      end if

      if ( state == 4 ) then
        power = power + 1
      end if
!
!  Decimal point.
!
    else if ( c == '.' ) then

      if ( state <= 2 ) then
        state = 3
      else
        state = -1
      end if
!
!  Illegal or unknown sign.
!
    else

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BINARY_TO_R4 - Serious error!'
      write ( *, '(a)' ) '  Illegal character = "' // c // '"'
      write ( *, '(a)' ) '  Conversion halted prematurely!'
      stop

    end if

    if ( state == -1 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BINARY_TO_R4 - Serious error!'
      write ( *, '(a)' ) '  Unable to decipher input!'
      stop
    end if
 
    if ( 5 <= state ) then
      exit
    end if

    ichr = ichr + 1

  end do
!
!  Apply the sign and the scale factor.
!
  r = real ( isgn * intval, kind = 4 ) / 2.0E+00**power
 
  return
end
subroutine binary_to_r8 ( s, r )

!*****************************************************************************80
!
!! BINARY_TO_R8 converts a binary representation into an R8.
!
!  Discussion:
!
!    An "R8" value is simply a real number to be stored as a
!    variable of type "real ( kind = 8 )".
!
!  Example:
!
!        S                         R
!
!    -1010.11                   -10.75
!    0.011011                     0.4218750
!    0.01010101010101010101010    0.3333333
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    10 June 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the binary representation.
!
!    Output, real ( kind = 8 ) R, the real number.
!
  implicit none

  character c
  integer ( kind = 4 ) ichr
  integer ( kind = 4 ) intval
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) power
  real    ( kind = 8 ) r
  character ( len = * ) s
  integer ( kind = 4 ) s_length
  integer ( kind = 4 ) state

  s_length = len_trim ( s )
 
  intval = 0
  ichr = 1
  state = 0
  isgn = 1
  r = 0.0D+00
  power = 0
 
  do while ( ichr <= s_length )

    c = s(ichr:ichr)
!
!  Blank.
!
    if ( c == ' ' ) then
 
      if ( state == 4 ) then
        state = 5
      end if
!
!  Sign, + or -.
!
    else if ( c == '-' ) then

      if ( state == 0 ) then
        state = 1
        isgn = -1
      else
        state = -1
      end if

    else if ( c == '+' ) then
 
      if ( state == 0 ) then
        state = 1
      else
        state = -1
      end if
!
!  Digit, 0 or 1.
!
    else if ( c == '1' ) then

      intval = 2 * intval + 1

      if ( state == 0 .or. state == 1 ) then
        state = 2
      else if ( state == 3 ) then
        state = 4
      end if

      if ( state == 4 ) then
        power = power + 1
      end if

    else if ( c == '0' ) then

      intval = 2 * intval

      if ( state == 0 .or. state == 1 ) then
        state = 2
      else if ( state == 3 ) then
        state = 4
      end if

      if ( state == 4 ) then
        power = power + 1
      end if
!
!  Decimal point.
!
    else if ( c == '.' ) then

      if ( state <= 2 ) then
        state = 3
      else
        state = -1
      end if
!
!  Illegal or unknown sign.
!
    else

      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BINARY_TO_R8 - Serious error!'
      write ( *, '(a)' ) '  Illegal character = "' // c // '"'
      write ( *, '(a)' ) '  Conversion halted prematurely!'
      stop

    end if

    if ( state == -1 ) then
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'BINARY_TO_R8 - Serious error!'
      write ( *, '(a)' ) '  Unable to decipher input!'
      stop
    end if
 
    if ( 5 <= state ) then
      exit
    end if

    ichr = ichr + 1

  end do
!
!  Apply the sign and the scale factor.
!
  r = real ( isgn * intval, kind = 8 ) / 2.0D+00**power
 
  return
end
subroutine ch_cap ( ch )

!*****************************************************************************80
!
!! CH_CAP capitalizes a single character.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, 
!    which guarantee the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    19 July 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character CH, the character to capitalize.
!
  implicit none

  character ch
  integer ( kind = 4 ) itemp

  itemp = iachar ( ch )
 
  if ( 97 <= itemp .and. itemp <= 122 ) then
    ch = achar ( itemp - 32 )
  end if
 
  return
end
subroutine ch_count_chvec_add ( n, chvec, count )

!*****************************************************************************80
!
!! CH_COUNT_CHVEC_ADD adds a character vector to a character count.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the vector.
!
!    Input, character CHVEC(N), a vector of characters.
!
!    Input/output, integer ( kind = 4 ) COUNT(0:255), the character counts.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) count(0:255)
  character chvec(n)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j

  do i = 1, n
    j = iachar ( chvec(i) )
    count(j) = count(j) + 1
  end do

  return
end
subroutine ch_count_file_add ( file_name, count )

!*****************************************************************************80
!
!! CH_COUNT_FILE_ADD adds characters in a file to a character count.
!
!  Discussion:
!
!    Each line is counted up to the last nonblank.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) FILE_NAME, the name of the file to examine.
!
!    Output, integer ( kind = 4 ) COUNT(0:255), the character counts.
!
  implicit none

  integer ( kind = 4 ) count(0:255)
  character ( len = * ) file_name
  integer ( kind = 4 ) ios
  integer ( kind = 4 ) iunit
  character ( len = 256 ) line
!
!  Open the file.
!
  call get_unit ( iunit )

  open ( unit = iunit, file = file_name, status = 'old', iostat = ios )

  if ( ios /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CH_COUNT_FILE_ADD - Fatal error!'
    write ( *, '(a)' ) '  Could not open the file:'
    write ( *, '(a)' ) '    ' // trim ( file_name )
    return
  end if

  do

    read ( iunit, '(a)', iostat = ios ) line

    if ( ios /= 0 ) then
      exit
    end if

    call ch_count_s_add ( trim ( line ), count )

  end do

  close ( unit = iunit )

  return
end
subroutine ch_count_histogram_print ( count, title )

!*****************************************************************************80
!
!! CH_COUNT_HISTOGRAM_PRINT prints a histogram of a set of character counts.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) COUNT(0:255), the character counts.
!
!    Input, character ( len = * ) TITLE, a title to be printed.
!
  implicit none

  character c
  character ( len = 4 ) ch4(0:255)
  integer ( kind = 4 ) count(0:255)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) percent
  integer ( kind = 4 ) row
  character ( len = 4 ) s(0:255)
  character ( len = * ) title
  integer ( kind = 4 ) total

  total = sum ( count )

  do i = 0, 255
    c = achar ( i )
    call ch_to_sym ( c, ch4(i) )
  end do

  do i = 0, 255

    if ( total == 0 ) then
      percent = 0
    else
      percent = nint ( real ( 100 * count(i), kind = 4 ) &
        / real ( total, kind = 4 ) )
    end if

    if ( percent == 0 ) then
      s(i) = '   .'
    else
      write ( s(i), '(i4)' ) percent
    end if

  end do

  if ( 0 < len_trim ( title ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )
  end if

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Character Histogram (Percentages).'
  write ( *, '(a)' ) ' '

  do row = 1, 16
    ilo = ( row - 1 ) * 16
    ihi =   row       * 16 - 1
    write ( *, '(2x,i3,a4,i3,3x,16a4)' ) ilo, ' to ', ihi, ch4(ilo:ihi)
    write ( *, '(12x,16a4)' ) s(ilo:ihi)
  end do

  return
end
subroutine ch_count_init ( count )

!*****************************************************************************80
!
!! CH_COUNT_INIT initializes a character count.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) COUNT(0:255), the character counts.
!
  implicit none

  integer ( kind = 4 ) count(0:255)

  count(0:255) = 0

  return
end
subroutine ch_count_print ( count, title )

!*****************************************************************************80
!
!! CH_COUNT_PRINT prints a set of character counts.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) COUNT(0:255), the character counts.
!
!    Input, character ( len = * ) TITLE, a title to be printed.
!
  implicit none

  character c
  character ( len = 4 ) ch4(0:255)
  integer ( kind = 4 ) count(0:255)
  integer ( kind = 4 ) i
  real ( kind = 4 ) percent
  character ( len = * ) title
  integer ( kind = 4 ) total

  total = sum ( count )

  do i = 0, 255
    c = achar ( i )
    call ch_to_sym ( c, ch4(i) )
  end do

  if ( 0 < len_trim ( title ) ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )
  end if

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Char  Count  Percentages.'
  write ( *, '(a)' ) ' '
  do i = 0, 255
    if ( 0 < count(i) ) then
      if ( total == 0 ) then
        percent = 0.0E+00
      else
        percent = real ( 100 * count(i), kind = 4 ) / real ( total, kind = 4 )
      end if
      write ( *, '(2x,a4,2x,i8,2x,f6.3)' ) ch4(i), count(i), percent
    end if
  end do

  return
end
subroutine ch_count_s_add ( s, count )

!*****************************************************************************80
!
!! CH_COUNT_S_ADD adds a character string to a character histogram.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 October 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, a string to be examined.
!
!    Input/output, integer ( kind = 4 ) COUNT(0:255), the character counts.
!
  implicit none

  integer ( kind = 4 ) count(0:255)
  integer ( kind = 4 ) i
  integer ( kind = 4 ) j
  character ( len = * ) s

  do i = 1, len ( s )
    j = iachar ( s(i:i) )
    count(j) = count(j) + 1
  end do

  return
end
function ch_eqi ( c1, c2 )

!*****************************************************************************80
!
!! CH_EQI is a case insensitive comparison of two characters for equality.  
!
!  Discussion:
!
!    CH_EQI ( 'A', 'a' ) is TRUE.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    28 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character C1, C2, the characters to compare.
!
!    Output, logical CH_EQI, the result of the comparison.
!
  implicit none

  character c1
  character c1_cap
  character c2
  character c2_cap
  logical ch_eqi

  c1_cap = c1
  c2_cap = c2

  call ch_cap ( c1_cap )
  call ch_cap ( c2_cap )

  if ( c1_cap == c2_cap ) then
    ch_eqi = .true.
  else
    ch_eqi = .false.
  end if

  return
end
subroutine ch_extract ( s, ch )

!*****************************************************************************80
!
!! CH_EXTRACT extracts the next nonblank character from a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    28 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S, the string.  On output, the 
!    first nonblank character has been removed, and the string 
!    has been shifted left.
!
!    Output, character CH, the leading character of the string.
!
  implicit none

  character ch
  integer ( kind = 4 ) get
  character ( len = * ) s
  integer ( kind = 4 ) s_len

  s_len = len_trim ( s )
  ch = ' '

  get = 1

  do while ( get <= s_len )

    if ( s(get:get) /= ' ' ) then
      ch = s(get:get)
      call s_shift_left ( s, get )
      exit
    end if

    get = get + 1

  end do

  return
end
function ch_index ( s, ch )

!*****************************************************************************80
!
!! CH_INDEX is the first occurrence of a character in a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string to be searched.
!
!    Input, character CH, the character to be searched for.
!
!    Output, integer ( kind = 4 ) CH_INDEX, the location of the first 
!    occurrence of the character in the string, or -1 if it does not occur.
!
  implicit none

  character ch
  integer ( kind = 4 ) ch_index
  integer ( kind = 4 ) i
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  ch_index = -1
  s_length = len_trim ( s )

  do i = 1, s_length

    if ( s(i:i) == ch ) then
      ch_index = i
      return
    end if

  end do
 
  return
end
function ch_index_last ( s, ch )

!*****************************************************************************80
!
!! CH_INDEX_LAST is the last occurrence of a character in a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    03 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string to be searched.
!
!    Input, character CH, the character to be searched for.
!
!    Output, integer ( kind = 4 ) CH_INDEX_LAST, the location of the last occurrence of 
!    the character in the string, or -1 if it does not occur.
!
  implicit none

  character ch
  integer ( kind = 4 ) ch_index_last
  integer ( kind = 4 ) i
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  ch_index_last = -1
  s_length = len_trim ( s )

  do i = s_length, 1, -1

    if ( s(i:i) == ch ) then
      ch_index_last = i
      return
    end if

  end do
 
  return
end
function ch_indexi ( s, ch )

!*****************************************************************************80
!
!! CH_INDEXI: (case insensitive) first occurrence of a character in a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    03 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string to be searched.
!
!    Input, character CH, the character to be searched for.
!
!    Output, integer ( kind = 4 ) CH_INDEXI, the location of the first 
!    occurrence of the character (upper or lowercase), or -1 if it does 
!    not occur.
!
  implicit none

  character ch
  logical ch_eqi
  integer ( kind = 4 ) ch_indexi
  integer ( kind = 4 ) i
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  ch_indexi = -1
  s_length = len_trim ( s )

  do i = 1, s_length

    if ( ch_eqi ( s(i:i), ch ) ) then
      ch_indexi = i
      return
    end if

  end do
 
  return
end
function ch_is_alpha ( ch )

!*****************************************************************************80
!
!! CH_IS_ALPHA is TRUE if CH is an alphabetic character.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, a character to check.
!
!    Output, logical CH_IS_ALPHA is TRUE if CH is an alphabetic character.
!
  implicit none

  character ch
  logical ch_is_alpha

  if ( ( lle ( 'a', ch ) .and. lle ( ch, 'z' ) ) .or. &
       ( lle ( 'A', ch ) .and. lle ( ch, 'Z' ) ) ) then
    ch_is_alpha = .true.
  else
    ch_is_alpha = .false.
  end if

  return
end
function ch_is_alphanumeric ( ch )

!*****************************************************************************80
!
!! CH_IS_ALPHANUMERIC is TRUE if CH is alphanumeric.
!
!  Discussion:
!
!    Alphanumeric characters are 'A' through 'Z', 'a' through 'z' and
!    '0' through '9'.
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be checked.
!
!    Output, logical CH_IS_ALPHANUMERIC, is TRUE if the character is
!    alphabetic or numeric.
!
  implicit none

  character ch
  logical ch_is_alphanumeric
  integer ( kind = 4 ) i

  i = iachar ( ch )
 
  if ( ( 65 <= i .and. i <= 90 ) .or. &
       ( 97 <= i .and. i <= 122 ) .or. &
       ( 48 <= i .and. i <= 57 ) ) then

    ch_is_alphanumeric = .true.

  else

    ch_is_alphanumeric = .false.

  end if

  return
end
function ch_is_control ( ch )

!*****************************************************************************80
!
!! CH_IS_CONTROL is TRUE if a character is a control character.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!    A "control character" has ASCII code <= 31 or 127 <= ASCII code.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be tested.
!
!    Output, logical CH_IS_CONTROL, TRUE if the character is a control
!    character, and FALSE otherwise.
!
  implicit none

  character ch
  logical ch_is_control

  if ( iachar ( ch ) <= 31 .or. 127 <= iachar ( ch ) ) then
    ch_is_control = .true.
  else
    ch_is_control = .false.
  end if
 
  return
end
function ch_is_digit ( ch )

!*****************************************************************************80
!
!! CH_IS_DIGIT is TRUE if a character is a decimal digit.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    09 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be analyzed.
!
!    Output, logical CH_IS_DIGIT, is TRUE if the character is a digit.
!
  implicit none

  character ch
  logical ch_is_digit

  if ( lle ( '0', ch ) .and. lle ( ch, '9' ) ) then
    ch_is_digit = .true.
  else
    ch_is_digit = .false.
  end if
 
  return
end
function ch_is_format_code ( ch )

!*****************************************************************************80
!
!! CH_IS_FORMAT_CODE is TRUE if a character is a FORTRAN format code.
!
!  Discussion:
!
!    The format codes accepted here are not the only legal format
!    codes in FORTRAN90.  However, they are more than sufficient
!    for my needs!
!
!  Table:
!
!    A  Character
!    B  Binary digits
!    D  Real number, exponential representation
!    E  Real number, exponential representation
!    F  Real number, fixed point
!    G  General format
!    I  Integer
!    L  Logical variable
!    O  Octal digits
!    Z  Hexadecimal digits
!    *  Free format
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    21 November 2003
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be analyzed.
!
!    Output, logical CH_IS_FORMAT_CODE, is TRUE if the character is a 
!    FORTRAN format code.
!
  implicit none

  character ch
  logical ch_eqi
  logical ch_is_format_code

  ch_is_format_code = .true.

       if ( ch_eqi ( ch, 'A' ) ) then
    return
  else if ( ch_eqi ( ch, 'B' ) ) then
    return
  else if ( ch_eqi ( ch, 'D' ) ) then
    return
  else if ( ch_eqi ( ch, 'E' ) ) then
    return
  else if ( ch_eqi ( ch, 'F' ) ) then
    return
  else if ( ch_eqi ( ch, 'G' ) ) then
    return
  else if ( ch_eqi ( ch, 'I' ) ) then
    return
  else if ( ch_eqi ( ch, 'L' ) ) then
    return
  else if ( ch_eqi ( ch, 'O' ) ) then
    return
  else if ( ch_eqi ( ch, 'Z' ) ) then
    return
  else if ( ch == '*' ) then
    return
  end if

  ch_is_format_code = .false.

  return
end
function ch_is_lower ( ch )

!*****************************************************************************80
!
!! CH_IS_LOWER is TRUE if a character is a lower case letter.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be analyzed.
!
!    Output, logical CH_IS_LOWER, is TRUE if the character is a lower 
!    case letter.
!
  implicit none

  character ch
  logical ch_is_lower

  if ( lle ( 'a', ch ) .and. lle ( ch, 'z' ) ) then
    ch_is_lower = .true.
  else
    ch_is_lower = .false.
  end if
 
  return
end
function ch_is_printable ( ch )

!*****************************************************************************80
!
!! CH_IS_PRINTABLE is TRUE if C is printable.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    03 July 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, a character to check.
!
!    Output, logical CH_IS_PRINTABLE is TRUE if C is a printable character.
!
  implicit none

  character ch
  logical ch_is_printable
  integer ( kind = 4 ) i

  i = iachar ( ch )

  if ( 32 <= i .and. i <= 126 ) then
    ch_is_printable = .true.
  else
    ch_is_printable = .false.
  end if

  return
end
function ch_is_space ( ch )

!*****************************************************************************80
!
!! CH_IS_SPACE is TRUE if a character is a whitespace character.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!    A whitespace character is a space, a form feed, a newline,
!    a carriage return, a tab, or a vertical tab.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 October 2004
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, a character to check.
!
!    Output, logical CH_IS_SPACE is TRUE if the character is a whitespace
!    character.
!
  implicit none

  character ch
  logical ch_is_space

  if ( ch == ' ' ) then
    ch_is_space = .true.
  else if ( ch == achar ( 12 ) ) then
    ch_is_space = .true.
  else if ( ch == achar ( 10 ) ) then
    ch_is_space = .true.
  else if ( ch == achar ( 13 ) ) then
    ch_is_space = .true.
  else if ( ch == achar ( 9 ) ) then
    ch_is_space = .true.
  else if ( ch == achar ( 11 ) ) then
    ch_is_space = .true.
  else
    ch_is_space = .false.
  end if

  return
end
function ch_is_upper ( ch )

!*****************************************************************************80
!
!! CH_IS_UPPER is TRUE if CH is an upper case letter.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be analyzed.
!
!    Output, logical CH_IS_UPPER, is TRUE if CH is an upper case letter.
!
  implicit none

  character ch
  logical ch_is_upper

  if ( lle ( 'A', ch ) .and. lle ( ch, 'Z' ) ) then
    ch_is_upper = .true.
  else
    ch_is_upper = .false.
  end if
 
  return
end
subroutine ch_low ( ch )

!*****************************************************************************80
!
!! CH_LOW lowercases a single character.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, 
!    which guarantee the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    19 July 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character CH, the character to be lowercased.
!
  implicit none

  character ch
  integer ( kind = 4 ) i

  i = iachar ( ch )

  if ( 65 <= i .and. i <= 90 ) then
    ch = achar ( i + 32 )
  end if
 
  return
end
subroutine ch_next ( s, ch, done )

!*****************************************************************************80
!
!! CH_NEXT reads the next character from a string, ignoring blanks and commas.
!
!  Example:
!
!    Input:
!
!      S = ' A  B, C    DE  F'
!
!    Output:
!
!      'A', 'B', 'C', 'D', 'E', 'F', and then blanks.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    18 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, a string of characters.  Blanks and
!    commas are considered insignificant.
!
!    Output, character CH.  If DONE is FALSE, then the
!    "next" character.  If DONE is TRUE, then a blank.
!
!    Input/output, logical DONE.
!    On input with a fresh value of S, the user should set
!    DONE to TRUE.
!    On output, the routine sets DONE to FALSE if another character
!    was read, or TRUE if no more characters could be read.
!
  implicit none

  character ch
  logical done
  integer ( kind = 4 ) i
  integer ( kind = 4 ), save :: next = 1
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  if ( done ) then
    next = 1
    done = .false.
  end if

  s_length = len_trim ( s )
 
  do i = next, s_length

    if ( s(i:i) /= ' ' .and. s(i:i) /= ',' ) then
      ch = s(i:i)
      next = i + 1
      return
    end if

  end do

  done = .true.
  next = 1
  ch = ' '

  return
end
function ch_not_control ( ch )

!*****************************************************************************80
!
!! CH_NOT_CONTROL = CH is NOT a control character.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 January 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH is the character to be tested.
!
!    Output, logical CH_NOT_CONTROL, TRUE if CH is not a control character,
!    and FALSE otherwise.
!
  implicit none

  character ch
  logical ch_not_control

  if ( iachar ( ch ) <= 31 .or. 128 <= iachar ( ch ) ) then
    ch_not_control = .true.
  else
    ch_not_control = .false.
  end if
 
  return
end
function ch_roman_to_i4 ( ch )

!*****************************************************************************80
!
!! CH_ROMAN_TO_I4 returns the integer value of a single Roman digit.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    09 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, a Roman digit.
!
!    Output, integer ( kind = 4 ) CH_ROMAN_TO_I4, the value of the Roman 
!    numeral.  If the Roman numeral was not recognized, 0 is returned.
!
  implicit none

  character ch
  integer ( kind = 4 ) ch_roman_to_i4
  integer ( kind = 4 ) i

  if ( ch == 'M' .or. ch == 'm' ) then
    i = 1000
  else if ( ch == 'D' .or. ch == 'd' ) then
    i = 500
  else if ( ch == 'C' .or. ch == 'c' ) then
    i = 100
  else if ( ch == 'L' .or. ch == 'l' ) then
    i = 50
  else if ( ch == 'X' .or. ch == 'x' ) then
    i = 10
  else if ( ch == 'V' .or. ch == 'v' ) then
    i = 5
  else if ( ch == 'I' .or. ch == 'i' .or. &
            ch == 'J' .or. ch == 'j' ) then
    i = 1
  else
    i = 0
  end if

  ch_roman_to_i4 = i

  return
end
function ch_scrabble ( tile )

!*****************************************************************************80
!
!! CH_SCRABBLE returns the character on a given Scrabble tile.
!
!  Discussion:
!
!    The tiles are numbered 1 to 100, and are labeled 'A' through 'Z',
!    plus two blanks.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) TILE, the index of the desired Scrabble tile.
!
!    Output, character CH_SCRABBLE, the character on the given tile.
!
  implicit none

  character ch_scrabble
  character, dimension ( 1 : 100 ) :: scrabble = (/ &
    'A', 'A', 'A', 'A', 'A', 'A', 'A', 'A', 'A', 'B', &
    'B', 'C', 'C', 'D', 'D', 'D', 'D', 'E', 'E', 'E', &
    'E', 'E', 'E', 'E', 'E', 'E', 'E', 'E', 'E', 'F', &
    'F', 'G', 'G', 'G', 'H', 'H', 'I', 'I', 'I', 'I', &
    'I', 'I', 'I', 'I', 'I', 'J', 'K', 'L', 'L', 'L', &
    'L', 'M', 'M', 'N', 'N', 'N', 'N', 'N', 'N', 'O', &
    'O', 'O', 'O', 'O', 'O', 'O', 'O', 'P', 'P', 'Q', &
    'R', 'R', 'R', 'R', 'R', 'R', 'S', 'S', 'S', 'S', &
    'T', 'T', 'T', 'T', 'T', 'T', 'U', 'U', 'U', 'U', &
    'V', 'V', 'W', 'W', 'X', 'X', 'Y', 'Z', ' ', ' ' /)
  integer ( kind = 4 ) tile

  if ( 1 <= tile .and. tile <= 100 ) then
    ch_scrabble = scrabble(tile)
  else
    ch_scrabble = '?'
  end if

  return
end
function ch_scrabble_frequency ( ch )

!*****************************************************************************80
!
!! CH_SCRABBLE_FREQUENCY returns the Scrabble frequency of a character.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character.
!
!    Output, integer ( kind = 4 ) CH_SCRABBLE_FREQUENCY, the frequency of 
!    the character.
!
  implicit none

  character ch
  integer ( kind = 4 ) ch_scrabble_frequency
  integer ( kind = 4 ) ch_to_scrabble
  integer ( kind = 4 ), dimension ( 27 ) :: frequency = (/ &
     9,  2,  2,  4, 12, &
     2,  3,  2,  9,  1, &
     1,  4,  2,  6,  8, &
     2,  1,  6,  4,  6, &
     4,  2,  2,  1,  2, &
     1,  2 /)
  integer ( kind = 4 ) ic
!
!  Convert character to a Scrabble character index.
!
  ic = ch_to_scrabble ( ch )

  if ( 1 <= ic .and. ic <= 27 ) then
    ch_scrabble_frequency = frequency(ic)
  else
    ch_scrabble_frequency = 0
  end if

  return
end
function ch_scrabble_points ( ch )

!*****************************************************************************80
!
!! CH_SCRABBLE_POINTS returns the Scrabble point value of a character.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character.
!
!    Output, integer ( kind = 4 ) CH_SCRABBLE_POINTS, the point value of 
!    the character.
!
  implicit none

  character ch
  integer ( kind = 4 ) ch_scrabble_points
  integer ( kind = 4 ) ch_to_scrabble
  integer ( kind = 4 ) ic
  integer ( kind = 4 ), dimension ( 27 ) :: points = (/ &
     1,  3,  3,  2,  1, &
     4,  2,  4,  1,  8, &
     5,  1,  3,  1,  1, &
     3, 10,  1,  1,  1, &
     1,  4,  4,  8,  4, &
    10,  0 /)
!
!  Convert character to a Scrabble character index.
!
  ic = ch_to_scrabble ( ch )

  if ( 1 <= ic .and. ic <= 27 ) then
    ch_scrabble_points = points(ic)
  else
    ch_scrabble_points = 0
  end if

  return
end
function ch_scrabble_select ( seed )

!*****************************************************************************80
!
!! CH_SCRABBLE_SELECT selects a character with the Scrabble probability.
!
!  Discussion:
!
!    There are 100 Scrabble tiles, including two blanks.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random 
!    number generator.
!
!    Output, character CH_SCRABBLE_SELECT, the character on a randomly
!    chosen Scrabble tile.
!
  implicit none

  character ch_scrabble
  character ch_scrabble_select
  integer ( kind = 4 ) i4_uniform
  integer ( kind = 4 ) seed
  integer ( kind = 4 ) tile
!
!  Choose a tile between 1 and 100.
!
  tile = i4_uniform ( 1, 100, seed )
!
!  Retrieve the character on that tile.
!
  ch_scrabble_select = ch_scrabble ( tile )

  return
end
subroutine ch_swap ( ch1, ch2 )

!*****************************************************************************80
!
!! CH_SWAP swaps two characters.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    30 July 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character CH1, CH2.  On output, the values
!    have been interchanged.
!
  implicit none

  character ch1
  character ch2
  character ch3

  ch3 = ch1
  ch1 = ch2
  ch2 = ch3

  return
end
subroutine ch_to_amino_name ( ch, amino_name )

!*****************************************************************************80
!
!! CH_TO_AMINO_NAME converts a character to an amino acid name.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    16 June 2000
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Carl Branden, John Tooze,
!    Introduction to Protein Structure,
!    Garland Publishing, 1991.
!
!  Parameters:
!
!    Input, character CH, the one letter code for an amino acid.
!    Lower and upper case letters are treated the same.
!
!    Output, character ( len = * ) AMINO_NAME, the full name of the
!    corresponding amino acid.  The longest name is 27 characters.  
!    If the input code is not recognized, then AMINO_NAME will be set to '???'.
!
  implicit none

  integer ( kind = 4 ), parameter :: n = 23

  character ( len = * ) amino_name
  character ( len = 27 ), dimension ( n ) :: amino_table = (/ &
    'Alanine                    ', &
    'Aspartic acid or Asparagine', &
    'Cysteine                   ', &
    'Aspartic acid              ', &
    'Glutamic acid              ', &
    'Phenylalanine              ', &
    'Glycine                    ', &
    'Histidine                  ', &
    'Isoleucine                 ', &
    'Lysine                     ', &
    'Leucine                    ', &
    'Methionine                 ', &
    'Asparagine                 ', &
    'Proline                    ', &
    'Glutamine                  ', &
    'Arginine                   ', &
    'Serine                     ', &
    'Threonine                  ', &
    'Valine                     ', &
    'Tryptophan                 ', &
    'Undetermined amino acid    ', &
    'Tyrosine                   ', &
    'Glutamic acid or Glutamine ' /)
  character ch
  logical ch_eqi
  character, dimension ( n ) :: ch_table = (/ &
    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', &
    'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', &
    'X', 'Y', 'Z' /)
  integer ( kind = 4 ) i

  do i = 1, n
    if ( ch_eqi ( ch, ch_table(i) ) ) then
      amino_name = amino_table(i)
      return
    end if
  end do

  amino_name = '???'

  return
end
subroutine ch_to_braille ( ch, ncol, braille )

!*****************************************************************************80
!
!! CH_TO_BRAILLE converts an ASCII character to a Braille character string.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    24 August 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the ASCII character.
!
!    Output, integer ( kind = 4 ) NCOL, the number of columns used to represent
!    the character.
!
!    Output, character ( len = 6 ) BRAILLE(3), contains, in rows 1 
!    through 3 and character columns 1 through NCOL, either a '*' or a ' '.
!
  implicit none

  integer ( kind = 4 ), parameter :: num_symbol = 37

  character ( len = 6 ) braille(3)
  character ch
  logical ch_is_digit
  logical ch_is_upper
  integer ( kind = 4 ) iascii
  integer ( kind = 4 ) ic_to_ibraille
  integer ( kind = 4 ) ibraille
  integer ( kind = 4 ) ncol
!
!       space       Aa1        Bb2        Cc3        Dd4
!       Ee5         Ff6        Gg7        Hh8        Ii9
!       Jj0         Kk         Ll         Mm         Nn
!       Oo          Pp         Qq         Rr         Ss
!       Tt          Uu         Vv         Ww         Xx
!       Yy          Zz         &          ,          ;
!       :           .          !          ()         "?
!       '           -
!
  character ( len = 6 ), parameter, dimension ( num_symbol ) :: symbol = (/ &
    '      ',  '*     ',  '* *   ',  '**    ',  '** *  ', &
    '*  *  ',  '***   ',  '****  ',  '* **  ',  ' **   ', &
    ' ***  ',  '*   * ',  '* * * ',  '**  * ',  '** ** ', &
    '*  ** ',  '*** * ',  '***** ',  '* *** ',  ' ** * ', &
    ' **** ',  '*   **',  '* * **',  ' *** *',  '**  **', &
    '** ***',  '*  ***',  '*** **',  '  *   ',  '  * * ', &
    '  **  ',  '  ** *',  '  *** ',  '  ****',  '  * **', &
    '    * ',  '    **' /)

  ncol = 0

  braille(1)(1:6) = ' '
  braille(2)(1:6) = ' '
  braille(3)(1:6) = ' '
!
!  A space is treated specially.
!
  if ( ch == ' ' ) then

    braille(1)(1:2) = '  '
    braille(2)(1:2) = '  '
    braille(3)(1:2) = '  '
    ncol = 2
    return

  end if
!
!  Get the ASCII numeric code of the character.
!
  iascii = iachar ( ch )
!
!  Get the index of the Braille equivalent.
!
  ibraille = ic_to_ibraille ( iascii )

  if ( 0 <= ibraille ) then
!
!  Upper case characters are preceded by a special mark.
!
    if ( ch_is_upper ( ch ) ) then

      braille(1)(1:3) = '   '
      braille(2)(1:3) = '   '
      braille(3)(1:3) = ' * '

      ncol = 3
!
!  Digits are preceded by a special mark.
!
    else if ( ch_is_digit ( ch ) ) then

      braille(1)(1:3) = ' * '
      braille(2)(1:3) = ' * '
      braille(3)(1:3) = '** '

      ncol = 3

    end if

    braille(1)(ncol+1:ncol+2) = symbol(ibraille)(1:2)
    braille(2)(ncol+1:ncol+2) = symbol(ibraille)(3:4)
    braille(3)(ncol+1:ncol+2) = symbol(ibraille)(5:6)

    ncol = ncol + 2
!
!  Add a trailing "half space".
!
    braille(1)(ncol+1:ncol+1) = ' '
    braille(2)(ncol+1:ncol+1) = ' '
    braille(3)(ncol+1:ncol+1) = ' '
 
    ncol = ncol + 1

  end if

  return
end
subroutine ch_to_ch3_amino ( ch, ch3 )

!*****************************************************************************80
!
!! CH_TO_CH3_AMINO converts a 1 character to a 3 character code for amino acids.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    18 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Carl Branden, John Tooze,
!    Introduction to Protein Structure,
!    Garland Publishing, 1991.
!
!  Parameters:
!
!    Input, character CH, the one letter code for an amino acid.  
!    Lower and upper case letters are treated the same.
!
!    Output, character ( len = 3 ) CH3, the three letter code for the 
!    amino acid.  If the input code is not recognized, then CH3 will be '???'.
!
  implicit none

  integer ( kind = 4 ), parameter :: n = 23

  character ch
  logical ch_eqi
  character, parameter, dimension ( n ) :: ch_table = (/ &
    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', &
    'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', &
    'X', 'Y', 'Z' /)
  character ( len = 3 ) ch3
  character ( len = 3 ), parameter, dimension ( n ) :: ch3_table = (/ &
    'Ala', 'Asx', 'Cys', 'Asp', 'Glu', 'Phe', 'Gly', 'His', 'Ise', 'Lys', &
    'Leu', 'Met', 'Asn', 'Pro', 'Gln', 'Arg', 'Ser', 'Thr', 'Val', 'Trp', &
    'X  ', 'Tyr', 'Glx' /)
  integer ( kind = 4 ) i

  do i = 1, n
    if ( ch_eqi ( ch, ch_table(i) ) ) then
      ch3 = ch3_table(i)
      return
    end if
  end do

  ch3 = '???'

  return
end
subroutine ch_to_digit ( ch, digit )

!*****************************************************************************80
!
!! CH_TO_DIGIT returns the integer value of a base 10 digit.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Example:
!
!     CH  DIGIT
!    ---  -----
!    '0'    0
!    '1'    1
!    ...  ...
!    '9'    9
!    ' '    0
!    'X'   -1
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    04 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the decimal digit, '0' through '9' or blank
!    are legal. 
!
!    Output, integer ( kind = 4 ) DIGIT, the corresponding integer value.  
!    If CH was 'illegal', then DIGIT is -1.
!
  implicit none

  character ch
  integer ( kind = 4 ) digit

  if ( lle ( '0', ch ) .and. lle ( ch, '9' ) ) then
 
    digit = iachar ( ch ) - 48
 
  else if ( ch == ' ' ) then
 
    digit = 0
 
  else

    digit = -1

  end if
 
  return
end
subroutine ch_to_digit_bin ( ch, digit )

!*****************************************************************************80
!
!! CH_TO_DIGIT_BIN returns the integer value of a binary digit.
!
!  Discussion:
!
!    This routine handles other traditional binary pairs of "digits"
!    besides '0' and '1'.
!
!  Example:
!
!     CH  DIGIT
!    ---  -----
!    '0'    0
!    '1'    1
!    'T'    1
!    'F'    0
!    'Y'    1
!    'N'    0
!    '+'    1
!    '-'    0
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the binary digit. 
!
!    Output, integer ( kind = 4 ) DIGIT, the corresponding integer value.  
!    If CH was 'illegal', then DIGIT is -1.
!
  implicit none

  character ch
  integer ( kind = 4 ) digit

  if ( ch == '0' .or. &
       ch == 'F' .or. &
       ch == 'f' .or. &
       ch == '-' .or. &
       ch == 'N' .or. &
       ch == 'n' ) then
 
    digit = 0
 
  else if ( ch == '1' .or. &
            ch == 'T' .or. &
            ch == 't' .or. &
            ch == '+' .or. &
            ch == 'Y' .or. &
            ch == 'y' ) then

    digit = 1
 
  else

    digit = -1

  end if
 
  return
end
subroutine ch_to_digit_hex ( ch, i )

!*****************************************************************************80
!
!! CH_TO_DIGIT_HEX returns the integer value of a hexadecimal digit.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the hexadecimal digit, '0'
!    through '9', or 'A' through 'F', or also 'a' through 'f'
!    are allowed.
!
!    Output, integer ( kind = 4 ) I, the corresponding integer, or -1 if 
!    CH was illegal.
!
  implicit none

  character ch
  integer ( kind = 4 ) i

  i = iachar ( ch )

  if ( lle ( '0', ch ) .and. lle ( ch, '9' ) ) then
 
    i = i - 48
 
  else if ( 65 <= i .and. i <= 70 ) then
 
    i = i - 55
 
  else if ( 97 <= i .and. i <= 102 ) then
 
    i = i - 87
 
  else if ( ch == ' ' ) then
 
    i = 0
 
  else
    
    i = -1

  end if
 
  return
end
subroutine ch_to_digit_oct ( ch, i )

!*****************************************************************************80
!
!! CH_TO_DIGIT_OCT returns the integer value of an octal digit.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the octal digit, '0' through '7'.
!
!    Output, integer ( kind = 4 ) I, the corresponding integer value, or
!    -1 if CH was illegal.
!
  implicit none

  character ch
  integer ( kind = 4 ) i

  i = iachar ( ch )

  if ( lle ( '0', ch ) .and. lle ( ch, '7' ) ) then
 
    i = i - 48
 
  else if ( ch == ' ' ) then
 
    i = 0
 
  else
    
    i = -1

  end if
 
  return
end
function ch_to_ebcdic ( ch )

!*****************************************************************************80
!
!! CH_TO_EBCDIC converts a character to EBCDIC.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, which
!    guarantee the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the ASCII character.
!
!    Output, character CH_TO_EBCDIC, the corresponding EBCDIC character, or a
!    blank character if no correspondence holds.
!
  implicit none

  character ch
  character ch_to_ebcdic
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ic_to_iebcdic

  i = ic_to_iebcdic ( iachar ( ch ) )
 
  if ( i /= -1 ) then
    ch_to_ebcdic = achar ( i )
  else
    ch_to_ebcdic = ' '
  end if
 
  return
end
subroutine ch_to_military ( ch, military )

!*****************************************************************************80
!
!! CH_TO_MILITARY converts an ASCII character to a Military code word.
!
!  Example:
!
!    'A'  'Alpha'
!    'B'  'Bravo'
!    'Z'  'Zulu'
!    'a'  'alpha'
!    '7'  '7'
!    '%'  '%'
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 December 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the ASCII character.
!
!    Output, character ( len = 8 ) MILITARY, the military code word.
!    If CH is not an alphabetic letter, then MILITARY is simply set equal to CH.
!
  implicit none

  integer ( kind = 4 ) a_to_i4
  character ch
  character ( len = 8 ), parameter, dimension ( 26 ) :: code = (/ &
    'alpha   ', 'bravo   ', 'charlie ', 'delta   ', 'echo    ', &
    'foxtrot ', 'golf    ', 'hotel   ', 'india   ', 'juliet  ', &
    'kilo    ', 'lima    ', 'mike    ', 'november', 'oscar   ', &
    'papa    ', 'quebec  ', 'romeo   ', 'sierra  ', 'tango   ', &
    'uniform ', 'victor  ', 'whiskey ', 'x-ray   ', 'yankee  ', &
    'zulu    ' /)
  integer ( kind = 4 ) i
  character ( len = * ) military

  if ( 'A' <= ch .and. ch <= 'Z' ) then
    i = a_to_i4 ( ch )
    military = code(i)
    call ch_cap ( military(1:1) )
  else if ( 'a' <= ch .and. ch <= 'z' ) then
    i = a_to_i4 ( ch ) - 26
    military = code(i)
  else
    military = ch
  end if

  return
end
subroutine ch_to_morse ( ch, morse )

!*****************************************************************************80
!
!! CH_TO_MORSE converts an ASCII character to a Morse character string.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    26 September 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the ASCII character.
!
!    Output, character ( len = 6 ) MORSE, the Morse character string.
!
  implicit none

  integer ( kind = 4 ), parameter :: num_symbol = 45

  character ch
  integer ( kind = 4 ) iascii
  integer ( kind = 4 ) ic_to_imorse
  integer ( kind = 4 ) imorse
  character ( len = 6 ) morse
  character ( len = 6 ), parameter, dimension ( num_symbol ) :: msymbol = (/ &
    '      ', '.-    ', '-...  ', '-.-.  ', '-..   ', &
    '.     ', '..-.  ', '--.   ', '....  ', '..    ', &
    '.---  ', '-.-   ', '.-..  ', '--    ', '-.    ', &
    '---   ', '.--.  ', '--.-  ', '.-.   ', '...   ', &
    '-     ', '..-   ', '...-  ', '.--   ', '-..-  ', &
    '-.--  ', '--..  ', '.---- ', '..--- ', '...-- ', &
    '....- ', '..... ', '-.... ', '--... ', '---.. ', &
    '----. ', '----- ', '.-.-.-', '--..--', '---...', &
    '..--..', '.----.', '-....-', '-..-. ', '.-..-.' /)

  iascii = iachar ( ch )
  imorse = ic_to_imorse ( iascii )

  if ( imorse == -1 ) then
    morse = ' '
  else
    morse = msymbol ( imorse )
  end if

  return
end
function ch_to_rot13 ( ch )

!*****************************************************************************80
!
!! CH_TO_ROT13 converts a character to its ROT13 equivalent.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, which
!    guarantees the ASCII collating sequence.
!
!    Two applications of CH_TO_ROT13 to a character will return the original.
!
!    As a further scrambling, digits are similarly rotated using
!    a "ROT5" scheme.
!
!  Example:
!
!    Input:  Output:
!
!    a       n
!    C       P
!    J       W
!    1       6
!    5       0
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    22 March 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be converted.
!
!    Output, character CH_TO_ROT13, the ROT13 equivalent of the character.
!
  implicit none

  character ch
  character ch_to_rot13
  integer ( kind = 4 ) itemp

  itemp = iachar ( ch )
!
!  [0:4] -> [5:9]
!
  if ( 48 <= itemp .and. itemp <= 52 ) then
    itemp = itemp + 5
!
!  [5:9] -> [0:4]
!
  else if ( 53 <= itemp .and. itemp <= 57 ) then
    itemp = itemp - 5
!
!  [A:M] -> [N:Z]
!
  else if ( 65 <= itemp .and. itemp <= 77 ) then
    itemp = itemp + 13
!
!  [N:Z] -> [A:M]
!
  else if ( 78 <= itemp .and. itemp <= 90 ) then
    itemp = itemp - 13
!
!  [a:m] -> [n:z]
!
  else if ( 97 <= itemp .and. itemp <= 109 ) then
    itemp = itemp + 13
!
!  [n:z] -> [a:m]
!
  else if ( 110 <= itemp .and. itemp <= 122 ) then
    itemp = itemp - 13
  end if
 
  ch_to_rot13 = achar ( itemp )
 
  return
end
function ch_to_scrabble ( ch )

!*****************************************************************************80
!
!! CH_TO_SCRABBLE returns the Scrabble index of a character.
!
!  Discussion:
!
!    'A' through 'Z' have indices 1 through 26, and blank is index 27.
!    Case is ignored.  All other characters return index -1.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 April 2006
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character.
!
!    Output, integer ( kind = 4 ) CH_TO_SCRABBLE, the Scrabble index of
!    the character.
!
  implicit none

  integer ( kind = 4 ) a_to_i4
  character ch
  character ch_copy
  integer ( kind = 4 ) ch_to_scrabble
  integer ( kind = 4 ) ic

  if ( ch == ' ' ) then
    ch_to_scrabble = 27
    return
  end if

  ch_copy = ch
  call ch_cap ( ch_copy )
  ic = a_to_i4 ( ch_copy )

  if ( 1 <= ic .and. ic <= 26 ) then
    ch_to_scrabble = ic
  else
    ch_to_scrabble = -1
  end if

  return
end
subroutine ch_to_soundex ( ch, soundex )

!*****************************************************************************80
!
!! CH_TO_SOUNDEX converts an ASCII character to a Soundex character.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, which
!    guarantees the ASCII collating sequence.
!
!    The soundex code is used to replace words by a code of up to four
!    digits.  Similar sounding words will often have identical soundex
!    codes.  
!
!    Soundex  Letters
!    -------  ---------------
!       0     A E I O U Y H W
!       1     B B P V
!       2     C G J K Q S X Z
!       3     D T
!       4     L
!       5     M N
!       6     R
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 January 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the ASCII character.
!
!    Output, character SOUNDEX, the Soundex character, which is
!    '0', '1', '2', '3', '4', '5', '6', or ' '.
!
  implicit none

  character ch
  integer ( kind = 4 ) iascii
  integer ( kind = 4 ) ic_to_isoundex
  integer ( kind = 4 ) isoundex
  character soundex

  iascii = iachar ( ch )
  isoundex = ic_to_isoundex ( iascii )

  if ( isoundex == -1 ) then
    soundex = ' '
  else
    soundex = achar ( isoundex )
  end if

  return
end
subroutine ch_to_sym ( ch, sym )

!*****************************************************************************80
!
!! CH_TO_SYM returns a printable symbol for any ASCII character.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 April 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CH, the character to be represented.
!
!    Output, character ( len = 4 ) SYM, is the printable symbol for CHR.
!
  implicit none

  character ch
  integer ( kind = 4 ) i
  integer ( kind = 4 ), parameter :: i4_128 = 128
  integer ( kind = 4 ) put
  character ( len = 4 ) sym

  i = iachar ( ch )
 
  sym = ' '
 
  put = 0
!
!  Characters 128-255 are symbolized with a ! prefix.
!  Then shift them down by 128.  
!  Now all values of I are between 0 and 127.
!
  if ( 128 <= i ) then
    i = mod ( i, i4_128 )
    put = put + 1
    sym(put:put) = '!'
  end if
!
!  Characters 0-31 are symbolized with a ^ prefix.
!  Shift them up by 64.  Now all values of I are between 32 and 127.
!
  if ( i <= 31 ) then
    i = i + 64
    put = put + 1
    sym(put:put) = '^'
  end if
!
!  Character 32 becomes SP.
!  Characters 32 through 126 are themselves.
!  Character 127 is DEL.
!
  if ( i == 32 ) then
    put = put + 1
    sym(put:put+1) = 'SP'
  else if ( i <= 126 ) then
    put = put + 1
    sym(put:put) = achar ( i )
  else if ( i == 127 ) then
    put = put + 1
    sym(put:put+2) = 'DEL'
  end if
 
  return
end
function ch_uniform ( clo, chi, seed )

!*****************************************************************************80
!
!! CH_UNIFORM returns a random character in a given range.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, 
!    which guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    04 May 2005
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character CLO, CHI, the minimum and maximum acceptable characters.
!
!    Input/output, integer ( kind = 4 ) SEED, a seed for the random 
!    number generator.
!
!    Output, character CH_UNIFORM, the randomly chosen character.
!
  implicit none

  character ch_uniform
  character chi
  character clo
  real ( kind = 4 ) r4_uniform_01
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) seed

  ilo = iachar ( clo )
  ihi = iachar ( chi )

  i = ilo + int ( r4_uniform_01 ( seed ) * real ( ihi + 1 - ilo, kind = 4 ) )

  i = max ( i, ilo )
  i = min ( i, ihi )

  ch_uniform = achar ( i )

  return
end
subroutine ch3_to_ch_amino ( ch3, ch )

!*****************************************************************************80
!
!! CH3_TO_CH_AMINO converts a 3 character to a 1 character code for amino acids.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    18 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    Carl Branden, John Tooze,
!    Introduction to Protein Structure,
!    Garland Publishing, 1991.
!
!  Parameters:
!
!    Input, character ( len = 3 ) CH3, presumably the 3 letter code for an 
!    amino acid.  Lower and upper case letters are treated the same.
!
!    Output, character CH, the one letter code for the amino acid.
!    If the input code is not recognized, then CH will be '?'.
!
  implicit none

  integer ( kind = 4 ), parameter :: n = 23

  character ch
  character, parameter, dimension ( n ) :: ch_table = (/ &
    'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'K', &
    'L', 'M', 'N', 'P', 'Q', 'R', 'S', 'T', 'V', 'W', &
    'X', 'Y', 'Z' /)
  character ( len = 3 ) ch3
  character ( len = 3 ), parameter, dimension ( n ) :: ch3_table = (/ &
    'Ala', 'Asx', 'Cys', 'Asp', 'Glu', 'Phe', 'Gly', 'His', 'Ise', 'Lys', &
    'Leu', 'Met', 'Asn', 'Pro', 'Gln', 'Arg', 'Ser', 'Thr', 'Val', 'Trp', &
    'X  ', 'Tyr', 'Glx' /)
  integer ( kind = 4 ) i
  logical s_eqi

  do i = 1, n
    if ( s_eqi ( ch3, ch3_table(i) ) ) then
      ch = ch_table(i)
      return
    end if
  end do

  ch = '?'

  return
end
subroutine ch4_to_i4 ( ch4, i4 )

!*****************************************************************************80
!
!! CH4_TO_I4 converts a four character string to an integer.
!
!  Example:
!
!    Adam    1097097581
!    Bill    1114205292
!    Crow    1131573111
!    Dave    1147237989
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    21 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = 4 ) CH4, the character value.
!
!    Output, integer ( kind = 4 ) I4, a corresponding integer value.
!
  implicit none

  character c1
  character c2
  character c3
  character c4
  character ( len = 4 ) ch4
  integer ( kind = 4 ) i4
  integer ( kind = 4 ) j1
  integer ( kind = 4 ) j2
  integer ( kind = 4 ) j3
  integer ( kind = 4 ) j4

  read ( ch4, '(4a1)' ) c1, c2, c3, c4

  j1 = iachar ( c1 )
  j2 = iachar ( c2 )
  j3 = iachar ( c3 )
  j4 = iachar ( c4 )

  call mvbits ( j1, 0, 8, i4,  0 )
  call mvbits ( j2, 0, 8, i4,  8 )
  call mvbits ( j3, 0, 8, i4, 16 )
  call mvbits ( j4, 0, 8, i4, 24 )  

  return
end
subroutine ch4_to_r4 ( ch4, r4 )

!*****************************************************************************80
!
!! CH4_TO_R4 converts a 4 character string to an R4.
!
!  Discussion:
!
!    The MVBITS routine requires the two word arguments to be of the
!    same arithmetic type, so we first need to use the TRANSFER
!    function so that the data inside an integer word can be copied
!    verbatin into a real.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    21 May 2007
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = 4 ) CH4, the character value.
!
!    Output, real ( kind = 4 ) R4, a corresponding real value.
!
  implicit none

  character c1
  character c2
  character c3
  character c4
  character ( len = 4 ) ch4
  integer ( kind = 4 ) i4
  integer ( kind = 4 ) j
  real    ( kind = 4 ) r4

  read ( ch4, '(4a1)' ) c1, c2, c3, c4

  j = iachar ( c1 )
  call mvbits ( j, 0, 8, i4,  0 )

  j = iachar ( c2 )
  call mvbits ( j, 0, 8, i4,  8 )

  j = iachar ( c3 )
  call mvbits ( j, 0, 8, i4, 16 )

  j = iachar ( c4 )
  call mvbits ( j, 0, 8, i4, 24 )  

  r4 = transfer ( i4, r4 )

  return
end
subroutine ch4vec_to_i4vec ( n, s, i4vec )

!*****************************************************************************80
!
!! CH4VEC_TO_I4VEC converts an string of characters into an array of integers.
!
!  Discussion:
!
!    This routine can be useful when trying to write character data to an
!    unformatted direct access file.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    27 November 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of sets of 4 characters 
!    in the string.
!
!    Input, character ( len = 4*N ) S, the string of characters.
!    Each set of 4 characters is assumed to represent an integer.
!
!    Output, integer ( kind = 4 ) I4VEC(N), the integers encoded in the string.
!
  implicit none

  integer ( kind = 4 ) n

  integer ( kind = 4 ) i
  integer ( kind = 4 ) i4vec(n)
  integer ( kind = 4 ) j
  character ( len = 4*n ) s

  do i = 1, n
    j = 4 * ( i - 1 ) + 1
    call ch4_to_i4 ( s(j:j+3), i4vec(i) )
  end do

  return
end
subroutine chr4_to_8 ( s1, s2 )

!*****************************************************************************80
!
!! CHR4_TO_8 replaces pairs of hexadecimal digits by a character.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    05 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S1, the string to be decoded.
!
!    Output, character ( len = * ) S2, the output string.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) i1
  integer ( kind = 4 ), parameter :: i4_two = 2
  integer ( kind = 4 ) j1
  integer ( kind = 4 ) k1
  integer ( kind = 4 ) nchar2
  integer ( kind = 4 ) nroom
  character ( len = * ) s1
  integer ( kind = 4 ) s1_length
  character ( len = * ) s2
!
!  Set S1_LENGTH to the number of characters to be copied.
!
  nchar2 = 0
  s1_length = len ( s1 )

  if ( mod ( s1_length, i4_two ) == 1 ) then
    s1_length = s1_length - 1
  end if
 
  if ( s1_length <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CHR4_TO_8 - Serious error!'
    write ( *, '(a)' ) '  The input string has nonpositive length!'
    return
  end if
!
!  Make sure we have enough room.
!
  nroom = len ( s2 )
 
  if ( 2 * nroom < s1_length ) then

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CHR4_TO_8 - Warning!'
    write ( *, '(a)' ) '  Not enough room in the output string.'
    write ( *, '(a,i8)' ) '  Positions available = ', nroom
    write ( *, '(a,i8)' ) '  Positions needed =    ', s1_length / 2
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  The program will drop excess characters.'

    s1_length = 2 * nroom

  end if
 
  do i = 1, s1_length, 2

    call ch_to_digit_hex ( s1(i:i), j1 )
    call ch_to_digit_hex ( s1(i+1:i+1), k1 )
!
!  Make sure that the values of J1 and K1 are legal.  If not,
!  set I1 so that it returns a blank character.
!
    if ( ( 0 <= j1 .and. j1 <= 15) .and. ( 0 <= k1 .and. k1 <= 15) ) then
      i1 = 16 * j1 + k1
    else
      i1 = 0
    end if
 
    nchar2 = nchar2 + 1
    s2(nchar2:nchar2) = achar ( i1 )
 
  end do
 
  return
end
subroutine chr8_to_4 ( s1, s2 )

!*****************************************************************************80
!
!! CHR8_TO_4 replaces characters by a pair of hexadecimal digits.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!    Unprintable characters (0 through 31, or 127 through 255)
!    can be displayed.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S1, the string to be replaced.
!
!    Output, character ( len = * ) S2, the output string.
!
  implicit none

  character c
  integer ( kind = 4 ) i
  integer ( kind = 4 ) i1
  integer ( kind = 4 ) j
  integer ( kind = 4 ) j1
  integer ( kind = 4 ) k1
  integer ( kind = 4 ) nroom
  character ( len = * ) s1
  integer ( kind = 4 ) s1_length
  character ( len = * ) s2
!
!  Set S1_LENGTH to the number of characters to be copied.
!
  s1_length = len ( s1 )

  if ( s1_length <= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CHR8_TO_4 - Serious error!'
    write ( *, '(a)' ) '  The input string has nonpositive length!'
    return
  end if
!
!  Make sure we have enough room.
!
  nroom = len ( s2 )
 
  if ( nroom < 2 * s1_length ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CHR8_TO_4 - Warning!'
    write ( *, '(a)' ) '  The output string isn''t long enough to hold'
    write ( *, '(a)' ) '  all the information!'
    write ( *, '(a,i8)' ) '  Positions available: ', nroom
    write ( *, '(a,i8)' ) '  Positions needed:    ', 2 * s1_length
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  We will do a partial conversion.'

    s1_length = nroom / 2

  end if
 
  j = 0

  do i = 1, s1_length

    c = s1(i:i)
 
    i1 = iachar ( c )
!
!  Compute J1 and K1 so that I1 = J1*16+K1.
!
    j1 = i1 / 16
    k1 = i1 - 16 * j1
 
    j = j + 1
    call digit_hex_to_ch ( j1, s2(j:j) )

    j = j + 1
    call digit_hex_to_ch ( k1, s2(j:j) )

  end do
 
  return
end
subroutine chra_to_s ( s1, s2 )

!*****************************************************************************80
!
!! CHRA_TO_S replaces control characters by printable symbols.
!
!  Discussion:
!
!    Instead of ICHAR, we now use the IACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Table:
!
!    IACHAR(c)    Symbol
!    --------    ------
!      0          ^@
!      1          ^A
!    ...         ...
!     31          ^_
!     32         (space)
!    ...         ...
!    126         ~
!    127         DEL
!    128         !^@
!    ...         ...
!    159         !^_
!    160         !(space)
!    ...         ...
!    254         !~
!    255         !DEL
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S1, the string to be operated on.
!
!    Output, character ( len = * ) S2, a copy of S1, except that each
!    control character has been replaced by a symbol.
!
  implicit none

  logical ch_is_control
  integer ( kind = 4 ) get
  integer ( kind = 4 ) put
  integer ( kind = 4 ) lsym
  character ( len = * ) s1
  integer ( kind = 4 ) s1_length
  character ( len = * ) s2
  character ( len = 4 ) sym

  s1_length = len_trim ( s1 )
  s2 = ' '
 
  put = 1

  do get = 1, s1_length
 
    if ( ch_is_control ( s1(get:get) ) ) then
 
      call ch_to_sym ( s1(get:get), sym )
      lsym = len_trim ( sym )
 
      s2(put:put+lsym-1) = sym(1:lsym)
      put = put + lsym
 
    else
 
      s2(put:put) = s1(get:get)
      put = put + 1
 
    end if
 
  end do
 
  return
end
subroutine chrasc ( iascii, nascii, string )

!*****************************************************************************80
!
!! CHRASC converts a vector of ASCII codes into character strings.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) IASCII(NASCII), a vector presumed to
!    contain entries between 0 and 255, the ASCII codes of
!    individual characters.
!
!    Input, integer ( kind = 4 ) NASCII, the number of ASCII codes input.
!
!    Output, character ( len = * ) STRING(*).  STRING is assumed to be
!    a vector of sufficient size to contain the information
!    input in IASCII.
!
!    The length of the strings is determined via the
!    LEN function.  The entries in IASCII are converted and
!    stored into the characters of STRING(1), and when that is
!    full, into STRING(2) and so on until all the entries have
!    been converted.
!
!    If any entry of IASCII is less than 0, or greater than
!    255, it is handled as though it were 0.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) iascii(*)
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) itemp
  integer ( kind = 4 ) ix
  integer ( kind = 4 ) j
  integer ( kind = 4 ) nascii
  integer ( kind = 4 ) nchar
  character ( len = * ) string(*)

  nchar = len ( string(1) )
 
  ix = 0
  ihi = ( (nascii-1) / nchar ) + 1
 
  do i = 1, ihi
    do j = 1, nchar
 
      ix = ix + 1
 
      if ( nascii <= ix ) then
        return
      end if
 
      itemp = iascii ( ix )
 
      if ( itemp < 0 .or. 255 < itemp ) then
        itemp = 0
      end if
 
      string(i)(j:j) = achar ( itemp )
 
    end do
  end do
 
  return
end
subroutine chrass ( s, lhs, rhs )

!*****************************************************************************80
!
!! CHRASS "understands" an assignment statement of the form LHS = RHS.
!
!  Discussion:
!
!    CHRASS returns a string containing the left hand side, and another
!    string containing the right hand side.
!
!    Leading and trailing spaces are removed from the right hand side
!    and the left hand side.
!
!  Example:
!
!    S                            Rhs               Lhs
!
!    'a = 1.0'                    'a'               '1.0'
!    'n = -17'                      'n'               '-17'
!    'scale = +5.3E-2'            'scale'           '+5.3E-2'
!    'filename = myprog.f'        'filename'        'myprog.f'
!    '= A pot of gold'            ' '               'A pot of gold'
!    'Fred'                       'Fred'            ' '
!    '= Bob'                      ' '               'Bob'
!    '1=2, 2=3, 3=4'              '1'               '2, 2=3, 3=4'
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the assignment statement to be broken up.
!
!    Output, character ( len = * ) LHS.
!
!    LHS contains the left hand side of the assignment statement.
!
!    Normally, this will be the name of a variable, which is
!    assumed to be whatever appears before the first equals
!    sign in the string.
!
!    If the input line was blank, then LHS will equal ' '.
!
!    If the input line contains an equal sign, but nothing
!    before the equals sign except blanks, then LHS will be ' '.
!
!    If the input line does not contain an "=" sign, then
!    NAME will contain the text of the whole line.
!
!    If an error occurred while trying to process the
!    input line, NAME will contain the text of the line..
!
!    If the line began with "#", then NAME will contain the
!    text of the line.
!
!    If the line equals "end-of-input", then NAME will contain
!    the text of the line.
!
!    Output, character ( len = * ) RHS.
!
!    RHS contains the right hand side of the assignment statement.
!
!    RHS is whatever appears on the right hand side of the
!    first equals sign in the string.
!
!    If S is blank, then RHS is ' '.
!
!    If the string contains no equals sign, then RHS is ' '.
!
!    If the string contains nothing to the right of the first equals
!    sign, but blanks, then RHS is ' '.
!
!    The user may read the data in RHS by
!
!      calling S_TO_R8 to read real ( kind = 8 ) data,
!      calling CHRCTR to read real data,
!      calling CHRCTI to read integer data,
!      calling CHRCTL to read logical data,
!      calling CHRCTC to read complex data.
!
  implicit none

  integer ( kind = 4 ) first
  integer ( kind = 4 ) iequal
  character ( len = * ) lhs
  character ( len = * ) rhs
  character ( len = * ) s
  integer ( kind = 4 ) s_first_nonblank
  integer ( kind = 4 ) s_length
!
!  Set default values
!
  lhs = ' '
  rhs = ' '
!
!  Find the last nonblank.
!
  s_length = len_trim ( s )

  if ( s_length <= 0 ) then
    return
  end if
!
!  Look for the first equals sign.
!
  iequal = index ( s, '=' )
!
!  If no equals sign, then LHS = S and return.
!
  if ( iequal == 0 ) then
    first = s_first_nonblank ( s )
    lhs = s(first:s_length)
    return
  end if
!
!  Otherwise, copy LHS = S(1:IEQUAL-1), RHS = S(IEQUAL+1:).
!
  lhs = s(1:iequal-1)

  if ( iequal + 1 <= s_length ) then
    rhs = s(iequal+1:)
  end if
!
!  Now shift the strings to the left.
!
  lhs = adjustl ( lhs )
  rhs = adjustl ( rhs )
 
  return
end
subroutine chrctf ( s, itop, ibot, ierror, length )

!*****************************************************************************80
!
!! CHRCTF reads an integer or rational fraction from a string.
!
!  Discussion:
!
!    The integer may be in real format, for example '2.25'.  The routine
!    returns ITOP and IBOT.  If the input number is an integer, ITOP
!    equals that integer, and IBOT is 1.  But in the case of 2.25,
!    the program would return ITOP = 225, IBOT = 100.
!
!    Legal input is:
!
!      blanks,
!      initial sign,
!      blanks,
!      integer ( kind = 4 ) part,
!      decimal point,
!      fraction part,
!      'E' or 'e' or 'D' or 'd', exponent marker,
!      exponent sign,
!      exponent integer part,
!      blanks,
!      final comma or semicolon.
!
!    with most quantities optional.
!
!  Example:
!
!    S               ITOP      IBOT
!
!    '1'               1         1
!    '     1   '       1         1
!    '1A'              1         1
!    '12,34,56'        12        1
!    '  34 7'          34        1
!    '-1E2ABCD'        -100      1
!    '-1X2ABCD'        -1        1
!    ' 2E-1'           2         10
!    '23.45'           2345      100
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 December 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string containing the
!    data to be read.  Reading will begin at position 1 and
!    terminate when no more characters
!    can be read to form a legal integer.  Blanks, commas,
!    or other nonnumeric data will, in particular, cause
!    the conversion to halt.
!
!    Output, integer ( kind = 4 ) ITOP, the integer read from the string,
!    assuming that no negative exponents or fractional parts
!    were used.  Otherwise, the 'integer' is ITOP/IBOT.
!
!    Output, integer ( kind = 4 ) IBOT, the integer divisor required to
!    represent numbers which are in real format or have a
!    negative exponent.
!
!    Output, integer ( kind = 4 ) IERROR, error flag.
!    0 if no errors,
!    Value of IHAVE when error occurred otherwise.
!
!    Output, integer ( kind = 4 ) LENGTH, the number of characters read from
!    the string to form the number.
!
  implicit none

  logical ch_eqi
  character c
  integer ( kind = 4 ) ibot
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) ihave
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) iterm
  integer ( kind = 4 ) itop
  integer ( kind = 4 ) jsgn
  integer ( kind = 4 ) jtop
  integer ( kind = 4 ) length
  integer ( kind = 4 ) ndig
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  s_length = len_trim ( s )
 
  ierror = 0
  length = -1
  isgn = 1
  itop = 0
  ibot = 1
  jsgn = 1
  jtop = 0
  ihave = 1
  iterm = 0

  do while ( length < s_length )

    length = length + 1
    c = s(length+1:length+1)
!
!  Blank.
!
    if ( c == ' ' ) then
 
      if ( ihave == 2 ) then
 
      else if ( ihave == 6 .or. ihave == 7 ) then
        iterm = 1
      else if ( 1 < ihave ) then
        ihave = 11
      end if
!
!  Comma.
!
    else if ( c == ',' .or. c == ';' ) then
 
      if ( ihave /= 1 ) then
        iterm = 1
        ihave = 12
        length = length + 1
      end if
!
!  Minus sign.
!
    else if ( c == '-' ) then
 
      if ( ihave == 1 ) then
        ihave = 2
        isgn = -1
      else if ( ihave == 6 ) then
        ihave = 7
        jsgn = -1
      else
        iterm = 1
      end if
!
!  Plus sign.
!
    else if ( c == '+' ) then
 
      if ( ihave == 1 ) then
        ihave = 2
      else if ( ihave == 6 ) then
        ihave = 7
      else
        iterm = 1
      end if
!
!  Decimal point.
!
    else if ( c == '.' ) then
 
      if ( ihave < 4 ) then
        ihave = 4
      else
        iterm = 1
      end if
!
!  Exponent marker.
!
    else if ( ch_eqi ( c, 'E' ) .or. ch_eqi ( c, 'D' ) ) then
 
      if ( ihave < 6 ) then
        ihave = 6
      else
        iterm = 1
      end if
!
!  Digit.
!
    else if ( lle ( '0', c ) .and. lle ( c, '9' ) .and. ihave < 11 ) then
 
      if ( ihave <= 2 ) then
        ihave = 3
      else if ( ihave == 4 ) then
        ihave = 5
      else if ( ihave == 6 .or. ihave == 7 ) then
        ihave = 8
      end if
 
      call ch_to_digit ( c, ndig )
 
      if ( ihave == 3 ) then
        itop = 10 * itop + ndig
      else if ( ihave == 5 ) then
        itop = 10 * itop + ndig
        ibot = 10 * ibot
      else if ( ihave == 8 ) then
        jtop = 10 * jtop + ndig
      end if
!
!  Anything else is regarded as a terminator.
!
    else
      iterm = 1
    end if

    if ( iterm == 1 ) then
      exit
    end if

  end do

  if ( iterm /= 1 .and. length+1 == s_length ) then
    length = s_length
  end if
!
!  Number seems to have terminated.  Have we got a legal number?
!
  if ( ihave == 1 .or. ihave == 2 .or. ihave == 6 .or. ihave == 7 ) then
    ierror = ihave
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CHRCTF - Serious error!'
    write ( *, '(a)' ) '  Illegal input:' // trim ( s ) 
    return
  end if
!
!  Number seems OK.  Form it.
!
  if ( jsgn == 1 ) then
    itop = itop * 10**jtop
  else
    ibot = ibot * 10**jtop
  end if
 
  itop = isgn * itop
 
  return
end
subroutine chrctg ( s, itop, ibot, ierror, length )

!*****************************************************************************80
!
!! CHRCTG reads an integer, decimal fraction or a ratio from a string.
!
!  Discussion:
!
!    CHRCTG returns an equivalent ratio (ITOP/IBOT).
!
!    If the input number is an integer, ITOP equals that integer, and
!    IBOT is 1.   But in the case of 2.25, the program would return
!    ITOP = 225, IBOT = 100.
!
!    A ratio is either
!      a number
!    or
!      a number, "/", a number.
!
!    A "number" is defined as:
!
!      blanks,
!      initial sign,
!      integer ( kind = 4 ) part,
!      decimal point,
!      fraction part,
!      E,
!      exponent sign,
!      exponent integer part,
!      blanks,
!      final comma or semicolon,
!
!    Examples of a number:
!
!      15, 15.0, -14E-7, E2, -12.73E-98, etc.
!
!    Examples of a ratio:
!
!      15, 1/7, -3/4.9, E2/-12.73
!
!  Example:
!
!    S               ITOP      IBOT
!
!    '1'               1         1
!    '     1   '       1         1
!    '1A'              1         1
!    '12,34,56'        12        1
!    '  34 7'          34        1
!    '-1E2ABCD'        -100      1
!    '-1X2ABCD'        -1        1
!    ' 2E-1'           2         10
!    '23.45'           2345      100
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string containing the
!    data to be read.  Reading will begin at position 1 and
!    terminate when no more characters
!    can be read to form a legal integer.  Blanks, commas,
!    or other nonnumeric data will, in particular, cause
!    the conversion to halt.
!
!    Output, integer ( kind = 4 ) ITOP, the integer read from the string,
!    assuming that no negative exponents or fractional parts
!    were used.  Otherwise, the 'integer' is ITOP/IBOT.
!
!    Output, integer ( kind = 4 ) IBOT, the integer divisor required to
!    represent numbers which are in decimal format or have a
!    negative exponent.
!
!    Output, integer ( kind = 4 ) IERROR, error flag.
!    0 if no errors,
!    Value of IHAVE in CHRCTF when error occurred otherwise.
!
!    Output, integer ( kind = 4 ) LENGTH, the number of characters read.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) i4_gcd
  integer ( kind = 4 ) ibot
  integer ( kind = 4 ) ibotb
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) itemp
  integer ( kind = 4 ) itop
  integer ( kind = 4 ) itopb
  integer ( kind = 4 ) length
  integer ( kind = 4 ) length2
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  itop = 0
  ibot = 1
  length = 0
 
  call chrctf ( s, itop, ibot, ierror, length )

  if ( ierror /= 0) then
    return
  end if
!
!  The number is represented as a fraction.
!  If the next nonblank character is "/", then read another number.
!
  s_length = len_trim ( s )
 
  do i = length + 1, s_length - 1
 
    if ( s(i:i) == '/' ) then
 
      call chrctf ( s(i+1:), itopb, ibotb, ierror, length2 )

      if ( ierror /= 0 ) then
        return
      end if
 
      itop = itop * ibotb
      ibot = ibot * itopb
 
      itemp = i4_gcd ( itop, ibot )
 
      itop = itop / itemp
      ibot = ibot / itemp
 
      length = i + length2
 
      return
 
    else if ( s(i:i) /= ' ' ) then
 
      return
 
    end if
 
  end do
 
  return
end
subroutine chrcti2 ( s, intval, ierror, length )

!*****************************************************************************80
!
!! CHRCTI2 finds and reads an integer from a string.
!
!  Discussion:
!
!    The routine is given a string which may contain one or more integers.
!    Starting at the first character position, it looks for the first
!    substring that could represent an integer.  If it finds such a string,
!    it returns the integer's value, and the position of the last character
!    read.
!
!  Example:
!
!    S               INTVAL      LENGTH
!
!    'Apollo 13'       13          9
!    '     1   '       1           6
!    '1A'              1           1
!    '12,34,56'        12          2
!    'A1A2A3'          1           2
!    '-1E2ABCD'        -1          2
!    '-X20ABCD'        20          4
!    '23.45'           23          2
!    ' N = 34, $'      34          7
!    'Oops!'           0           0
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    26 September 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string to be read.
!    Reading will begin at position 1 and terminate at the end of the 
!    string, or when no more characters can be read to form a legal integer. 
!    Blanks, commas, or other nonnumeric data will, in particular,
!    cause the conversion to halt.
!
!    Output, integer ( kind = 4 ) INTVAL, the integer read from the string, 
!    or 0 if there was an error.
!
!    Output, integer ( kind = 4 ) IERROR, 0 an integer was found, 
!    1 if no integer found.
!
!    Output, integer ( kind = 4 ) LENGTH, the number of characters read.
!
  implicit none

  character c
  integer ( kind = 4 ) i
  integer ( kind = 4 ) idig
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) ihave
  integer ( kind = 4 ) intval
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) iterm
  integer ( kind = 4 ) length
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  s_length = len_trim ( s )
  ierror = 0
  i = 0
  isgn = 1
  intval = 0
  ihave = 0
  iterm = 0
!
!  Examine the next character.
!
  do while ( iterm /= 1 )
 
    i = i + 1

    if ( s_length < i ) then

      iterm = 1

    else

      c = s(i:i)
!
!  Minus sign.
!
      if ( c == '-' ) then
 
        if ( ihave == 0 ) then
          ihave = 1
          isgn = -1
        else
          iterm = 1
        end if
!
!  Plus sign.
!
      else if ( c == '+' ) then
  
        if ( ihave == 0 ) then
          ihave = 1
        else
          iterm = 1
        end if
!
!  Digit.
!
      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
 
        ihave = 2

        call ch_to_digit ( c, idig )

        intval = 10 * intval + idig
!
!  Blank or TAB.
!
      else 

        if ( ihave == 2 ) then
          iterm = 1
        else
          ihave = 0
        end if

      end if

    end if

  end do

  if ( ihave == 2 ) then
    length = i - 1
    intval = isgn * intval
  else
    ierror = 0
    length = 0
    intval = 0
  end if
 
  return
end
subroutine chrctp ( s, cval, ierror, length )

!*****************************************************************************80
!
!! CHRCTP reads a parenthesized complex number from a string.
!
!  Discussion:
!
!    The routine will read as many characters as possible until it reaches
!    the end of the string, or encounters a character which cannot be
!    part of the number.
!
!    Legal input is:
!
!       1 blanks,
!
!       2 left parenthesis, REQUIRED
!
!       3 blanks
!       4 '+' or '-' sign,
!       5 blanks
!       6 integer part,
!       7 decimal point,
!       8 fraction part,
!       9 'E' or 'e' or 'D' or 'd', exponent marker,
!      10 exponent sign,
!      11 exponent integer part,
!      12 exponent decimal point,
!      13 exponent fraction part,
!      14 blanks,
!
!      15 comma, REQUIRED
!
!      16 blanks
!      17 '+' or '-' sign,
!      18 blanks
!      19 integer part,
!      20 decimal point,
!      21 fraction part,
!      22 'E' or 'e' or 'D' or 'd', exponent marker,
!      23 exponent sign,
!      24 exponent integer part,
!      25 exponent decimal point,
!      26 exponent fraction part,
!      27 blanks,
!
!      28 right parenthesis, REQUIRED
!
!  Example:
!
!    S                   CVAL      IERROR     LENGTH
!
!    '(1, 1)'              1 + 1 i   0           5
!    '( 20 , 99 )'        20+99i     0          11
!    '(-1.2E+2, +30E-2)'  -120+0.3i  0          17
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string containing the
!    data to be read.  Reading will begin at position 1 and
!    terminate at the end of the string, or when no more
!    characters can be read to form a legal real.  Blanks,
!    commas, or other nonnumeric data will, in particular,
!    cause the conversion to halt.
!
!    Output, complex ( kind = 4 ) CVAL, the value read from the string.
!
!    Output, integer ( kind = 4 ) IERROR, error flag.
!    0, no errors occurred.
!    1, the string was empty.
!    2, Did not find left parenthesis.
!    3, Could not read A correctly.
!    4, Did not find the comma.
!    5, Could not read B correctly.
!    6, Did not find right parenthesis.
!
!    Output, integer ( kind = 4 ) LENGTH, the number of characters read.
!
  implicit none

  real    ( kind = 4 ) aval
  real    ( kind = 4 ) bval
  character c
  complex ( kind = 4 ) cval
  integer ( kind = 4 ) ichr
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) length
  character ( len = * ) s
!
!  Initialize the return arguments.
!
  ierror = 0
  aval = 0
  bval = 0
  cval = cmplx ( aval, bval, kind = 4 )
  length = 0
!
!  Get the length of the line, and if it's zero, return.
!
  if ( len_trim ( s ) <= 0 ) then
    ierror = 1
    return
  end if
!
!  Is the next character a left parenthesis, like it must be?
!
  call nexchr ( s, ichr, c )
 
  if ( c /= '(' ) then
    ierror = 2
    return
  end if
 
  length = ichr
!
!  Is the next character a comma?  Then a = 0.
!
  call nexchr ( s(length+1:), ichr, c )
 
  if ( c == ',' ) then
    aval = 0
    length = length + ichr
!
!  Read the A value.
!
  else
 
    call s_to_r4 ( s(length+1:), aval, ierror, ichr )
 
    if ( ierror /= 0 ) then
      ierror = 3
      length = 0
      return
    end if
 
    length = length + ichr
!
!  Expect to read the comma
!
    if ( s(length:length) /= ',' ) then
      ierror = 4
      length = 0
      return
    end if
 
  end if
!
!  Is the next character a left parenthesis?  Then b = 0.
!
  call nexchr ( s(length+1:), ichr, c )
 
  if ( c == ')' ) then
    bval = 0
    length = length + ichr
!
!  Read the B value.
!
  else
 
    call s_to_r4 ( s(length+1:), bval, ierror, ichr )
 
    if ( ierror /= 0 ) then
      ierror = 5
      length = 0
      return
    end if
 
    length = length + ichr
!
!  Expect to read the right parenthesis.
!
    call nexchr ( s(length+1:), ichr, c )
 
    if ( c /= ')' ) then
      ierror = 6
      length = 0
      return
    end if
 
  end if
 
  length = length + ichr
 
  cval = cmplx ( aval, bval, kind = 4 )
 
  return
end
subroutine chrs_to_a ( s1, s2 )

!*****************************************************************************80
!
!! CHRS_TO_A replaces all control symbols by control characters.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S1 is the string to be operated on.
!
!    Output, character ( len = * ) S2 is a copy of S1, except that each
!    control symbol has been replaced by a control character.
!
  implicit none

  character c
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) put
  integer ( kind = 4 ) nchar2
  character ( len = * ) s1
  integer ( kind = 4 ) s1_length
  character ( len = * ) s2

  s1_length = len_trim ( s1 )
  nchar2 = len ( s2 )
 
  ihi = 0 
  put = 0
 
  do
 
    if ( s1_length <= ihi ) then
      return
    end if
 
    ilo = ihi + 1
 
    call sym_to_ch ( s1(ilo:), c, ihi )
 
    put = put + 1
 
    if ( nchar2 < put ) then
      exit
    end if

    s2(put:put) = c

  end do

  return 
end
subroutine chvec_permute ( n, a, p )

!*****************************************************************************80
!
!! CHVEC_PERMUTE permutes a character vector in place.
!
!  Discussion:
!
!    This routine permutes an array of character "objects", but the same
!    logic can be used to permute an array of objects of any arithmetic
!    type, or an array of objects of any complexity.  The only temporary
!    storage required is enough to store a single object.  The number
!    of data movements made is N + the number of cycles of order 2 or more,
!    which is never more than N + N/2.
!
!  Example:
!
!    Input:
!
!      N = 5
!      P = (   2,   4,   5,   1,   3 )
!      A = (  'B', 'D', 'E', 'A', 'C' )
!
!    Output:
!
!      A    = ( 'A', 'B', 'C', 'D', 'E' ).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    20 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of objects.
!
!    Input/output, character A(N), the array to be permuted.
!
!    Input, integer ( kind = 4 ) P(N), the permutation.  P(I) = J means
!    that the I-th element of the output array should be the J-th
!    element of the input array.  P must be a legal permutation
!    of the integers from 1 to N, otherwise the algorithm will
!    fail catastrophically.
!
  implicit none

  integer ( kind = 4 ) n

  character a(n)
  character a_temp
  integer ( kind = 4 ) ierror
  integer ( kind = 4 ) get
  integer ( kind = 4 ) put
  integer ( kind = 4 ) istart
  integer ( kind = 4 ) p(n)

  call perm_check ( n, p, ierror )

  if ( ierror /= 0 ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) 'CHVEC_PERMUTE - Fatal error!'
    write ( *, '(a)' ) '  The input array does not represent'
    write ( *, '(a)' ) '  a proper permutation.  In particular, the'
    write ( *, '(a,i8)' ) '  array is missing the value ', ierror
    stop
  end if
!
!  Search for the next element of the permutation that has not been used.
!
  do istart = 1, n

    if ( p(istart) < 0 ) then

      cycle

    else if ( p(istart) == istart ) then

      p(istart) = -p(istart)
      cycle

    else

      a_temp = a(istart)
      get = istart
!
!  Copy the new value into the vacated entry.
!
      do

        put = get
        get = p(get)

        p(put) = -p(put)

        if ( get < 1 .or. n < get ) then
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'CHVEC_PERMUTE - Fatal error!'
          write ( *, '(a)' ) '  "get" character is out of bounds.'
          stop
        end if

        if ( get == istart ) then
          a(put) = a_temp
          exit
        end if

        a(put) = a(get)

      end do

    end if

  end do
!
!  Restore the signs of the entries.
!
  p(1:n) = -p(1:n)

  return
end
subroutine chvec_print ( n, a, title )

!*****************************************************************************80
!
!! CHVEC_PRINT prints a character vector.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    20 July 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of components of the vector.
!
!    Input, character A(N), the vector to be printed.
!
!    Input, character ( len = * ) TITLE, a title to be printed first.
!    TITLE may be blank.
!
  implicit none

  integer ( kind = 4 ) n

  character a(n)
  logical ch_is_printable
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ihi
  integer ( kind = 4 ) ilo
  integer ( kind = 4 ) j
  character ( len = 80 ) string
  character ( len = * ) title

  if ( title /= ' ' ) then
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )
  end if

  write ( *, '(a)' ) ' '
  do ilo = 1, n, 80
    ihi = min ( ilo + 79, n )
    string = ' '
    do i = ilo, ihi
      j = i + 1 - ilo
      if ( ch_is_printable ( a(i) ) ) then
        string(j:j) = a(i)
      end if
    end do
    
    write ( *, '(a)' ) trim ( string )

  end do

  return
end
subroutine chvec_reverse ( n, x )

!*****************************************************************************80
!
!! CHVEC_REVERSE reverses the elements of a character vector.
!
!  Example:
!
!    Input:
!
!      N = 4, X = ( 'L', 'I', 'V', 'E' ).
!
!    Output:
!
!      X = ( 'E', 'V', 'I', 'L' ).
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    26 July 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of entries in the array.
!
!    Input/output, character X(N), the array to be reversed.
!
  implicit none

  integer ( kind = 4 ) n

  character cval
  integer ( kind = 4 ) i
  character x(n)

  do i = 1, n/2
    cval = x(i)
    x(i) = x(n+1-i)
    x(n+1-i) = cval
  end do

  return
end
subroutine chvec_to_s ( n, chvec, s )

!*****************************************************************************80
!
!! CHVEC_TO_S converts a character vector to a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    23 March 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) N, the number of characters to convert.
!
!    Input, character CHVEC(N), a vector of characters.
!
!    Output, character ( len = * ) S, a string of characters.
!
  implicit none

  integer ( kind = 4 ) n

  character chvec(n)
  integer ( kind = 4 ) i
  character ( len = * ) s

  do i = 1, min ( n, len ( s ) )
    s(i:i) = chvec(i)
  end do
 
  return
end
subroutine chvec2_print ( m, a, n, b, title )

!*****************************************************************************80
!
!! CHVEC2_PRINT prints two vectors of characters.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    09 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) M, the length of the first sequence.
!
!    Input, character A(M), the first sequence.
!
!    Input, integer ( kind = 4 ) N, the length of the second sequence.
!
!    Input, character B(N), the second sequence.
!
!    Input, character ( len = * ), a title.
!
  implicit none

  integer ( kind = 4 ) m
  integer ( kind = 4 ) n

  character a(m)
  character ai
  character b(n)
  character bi
  integer ( kind = 4 ) i
  character ( len = * ) title

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) trim ( title )
  write ( *, '(a)' ) ' '

  do i = 1, max ( m, n )

    if ( i <= m ) then
      ai = a(i)
    else
      ai = ' '
    end if

    if ( i <= n ) then
      bi = b(i)
    else
      bi = ' '
    end if

    write ( *, '(i3,2x,a1,2x,a1)' ) i, ai, bi

  end do 

  return
end
subroutine comma ( s )

!*****************************************************************************80
!
!! COMMA moves commas left through blanks in a string.
!
!  Example:
!
!    Input:                    Output:
!    -----                     ------
!    "To Henry , our dog"      "To Henry,  our dog"
!    " , , ,"                  ",,,  "
!    "  14.0   ,"              "  14.0,  "
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 December 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S, a string in which the
!    commas are to be shifted left through blanks.
!
  implicit none

  integer ( kind = 4 ) iblank
  integer ( kind = 4 ) icomma
  character ( len = * ) s

  icomma = len_trim ( s )

  do while ( 1 < icomma )

    if ( s(icomma:icomma) == ',' ) then

      iblank = icomma

      do while ( 1 < iblank )
        if ( s(iblank-1:iblank-1) /= ' ' ) then
          exit
        end if
        iblank = iblank - 1
      end do

      if ( icomma /= iblank ) then
        s(icomma:icomma) = ' '
        s(iblank:iblank) = ','
      end if

    end if

    icomma = icomma - 1

  end do
  
  return
end
subroutine dec_to_s_left ( ival, jval, s )

!*****************************************************************************80
!
!! DEC_TO_S_LEFT returns a left-justified representation of IVAL * 10**JVAL.
!
!  Example:
!
!    IVAL     JVAL       S
!    ----     ----       ------
!       0        0       0
!      21        3       21000
!      -3        0       -3
!     147       -2       14.7
!      16       -5       0.00016
!      34       30       Inf
!     123      -21       0.0000000000000000012
!      34      -30       0.0
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    13 September 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) IVAL, JVAL, integers which represent 
!    the decimal.
!
!    Output, character ( len = * ) S, the representation of the value.
!    The string is 'Inf' or '0.0' if the value was too large 
!    or small to represent with a fixed point format.
!
  implicit none

  character ( len = 22 ) chrrep
  integer ( kind = 4 ) i
  integer ( kind = 4 ) get1
  integer ( kind = 4 ) get2
  integer ( kind = 4 ) put1
  integer ( kind = 4 ) put2
  integer ( kind = 4 ) ival
  integer ( kind = 4 ) jval
  integer ( kind = 4 ) ndigit
  integer ( kind = 4 ) nleft
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  s = ' '

  if ( ival == 0 ) then
    s = '0'
    return
  end if

  s_length = len ( s )
!
!  Store a representation of IVAL in CHRREP.
!
  write ( chrrep, '(i22)' ) ival
  call s_blank_delete ( chrrep )
  ndigit = len_trim ( chrrep )
!
!  Inf if JVAL is positive, and S_LENGTH < NDIGIT + JVAL.
!
  if ( 0 < jval ) then
    if ( s_length < ndigit + jval ) then
      s = 'Inf'
      return
    end if
  end if
!
!  Underflow if JVAL is negative, and S_LENGTH < 3 + NDIGIT - JVAL.
!
  if ( jval < 0 ) then
    if ( 0 < ival ) then
      if ( s_length < 3 - ndigit - jval ) then
        s = '0.0'
        return
      end if
    else
      if ( s_length < 5 - ndigit - jval ) then
        s = '0.0'
        return
      end if
    end if
  end if
!
!  If JVAL is nonnegative, insert trailing zeros.
!
  if ( 0 <= jval ) then

    s(1:ndigit) = chrrep(1:ndigit)

    do i = ndigit+1, ndigit+jval
      s(i:i) = '0'
    end do

  else if ( jval < 0 ) then

    put2 = 0
    get2 = 0
!
!  Sign.
!
    if ( ival < 0 ) then
      put1 = 1
      put2 = 1
      get2 = 1
      s(put1:put2) = '-'
      ndigit = ndigit - 1
    end if
!
!  Digits of the integral part.
!
    if ( 0 < ndigit + jval ) then
      put1 = put2 + 1
      put2 = put1 + ndigit + jval -1
      get1 = get2 + 1
      get2 = get1 + ndigit+jval - 1
      s(put1:put2) = chrrep(get1:get2)
    else
      put1 = put2 + 1
      put2 = put1
      s(put1:put2) = '0'
    end if
!
!  Decimal point.
!
    put1 = put2 + 1
    put2 = put1
    s(put1:put2) = '.'
!
!  Leading zeroes.
!
    do i = 1, - jval - ndigit
      put1 = put2 + 1
      put2 = put1
      s(put1:put2) = '0'
    end do

    nleft = min ( -jval, ndigit )
    nleft = min ( nleft, s_length - put2 )
    put1 = put2 + 1
    put2 = put1 + nleft - 1
    get1 = get2 + 1
    get2 = get1 + nleft - 1
    s(put1:put2) = chrrep(get1:get2)

  end if

  return
end
subroutine dec_to_s_right ( ival, jval, s )

!*****************************************************************************80
!
!! DEC_TO_S_RIGHT returns a right justified representation of IVAL * 10**JVAL.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) IVAL, JVAL, the integers which represent the
!    decimal fraction.
!
!    Output, character ( len = * ) S, a right justified string
!    containing the representation of the decimal fraction.
!
  implicit none

  integer ( kind = 4 ) ival
  integer ( kind = 4 ) jval
  character ( len = * ) s

  call dec_to_s_left ( ival, jval, s )
  call s_adjustr ( s )
 
  return
end
subroutine digit_bin_to_ch ( i, ch )

!*****************************************************************************80
!
!! DIGIT_BIN_TO_CH returns the character representation of a binary digit.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the integer, between 0 and 1.
!
!    Output, character CH, the character representation of the integer.
!
  implicit none

  character ch
  integer ( kind = 4 ) i

  if ( i == 0 ) then
    ch = '0'
  else if ( i == 1 ) then
    ch = '1'
  else
    ch = '*'
  end if
 
  return
end
subroutine digit_hex_to_ch ( i, ch )

!*****************************************************************************80
!
!! DIGIT_HEX_TO_CH returns the character representation of a hexadecimal digit.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the integer, between 0 and 15.
!
!    Output, character CH, the hexadecimal representation of the integer.
!
  implicit none

  character ch
  integer ( kind = 4 ) i

  if ( 0 <= i .and. i <= 9 ) then
    ch = achar ( i + 48 )
  else if ( 10 <= i .and. i <= 15 ) then
    ch = achar ( i + 55 )
  else
    ch = '*'
  end if
 
  return
end
subroutine digit_inc ( ch )

!*****************************************************************************80
!
!! DIGIT_INC increments a decimal digit.  
!
!  Example:
!
!    Input  Output
!    -----  ------
!    '0'    '1'
!    '1'    '2'
!    ...
!    '8'    '9'
!    '9'    '0'
!    'A'    'A'
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    04 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character CH, a digit to be incremented.
!
  implicit none

  character ch
  integer ( kind = 4 ) digit

  call ch_to_digit ( ch, digit )

  if ( digit == -1 ) then
    return
  end if

  digit = digit + 1

  if ( digit == 10 ) then
    digit = 0
  end if

  call digit_to_ch ( digit, ch )

  return
end
subroutine digit_oct_to_ch ( i, ch )

!*****************************************************************************80
!
!! DIGIT_OCT_TO_CH returns the character representation of an octal digit.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) I, the integer, between 0 and 7.
!
!    Output, character CH, the character representation of the integer.
!
  character ch
  integer ( kind = 4 ) i

  if ( 0 <= i .and. i <= 7 ) then
    ch = achar ( i + 48 )
  else 
    ch = '*'
  end if
 
  return
end
subroutine digit_to_ch ( digit, ch )

!*****************************************************************************80
!
!! DIGIT_TO_CH returns the character representation of a decimal digit.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Example:
!
!    DIGIT   CH 
!    -----  ---
!      0    '0'
!      1    '1'
!    ...    ...
!      9    '9'
!     17    '*'
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    04 August 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) DIGIT, the digit value between 0 and 9.
!
!    Output, character CH, the corresponding character.
!
  implicit none

  character ch
  integer ( kind = 4 ) digit

  if ( 0 <= digit .and. digit <= 9 ) then

    ch = achar ( digit + 48 )

  else

    ch = '*'

  end if
 
  return
end
function ebcdic_to_ch ( e )

!*****************************************************************************80
!
!! EBCDIC_TO_CH converts an EBCDIC character to ASCII.
!
!  Discussion:
!
!    Instead of CHAR and ICHAR, we now use the ACHAR and IACHAR functions, which
!    guarantees the ASCII collating sequence.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character E, the EBCDIC character.
!
!    Output, character EBCDIC_TO_CH, the corresponding ASCII
!    character, or a blank character if no correspondence holds.
!
  implicit none

  character e
  character ebcdic_to_ch
  integer ( kind = 4 ) i
  integer ( kind = 4 ) iebcdic_to_ic

  i = iebcdic_to_ic ( iachar ( e ) )
 
  if ( i /= -1 ) then
    ebcdic_to_ch = achar ( i )
  else
    ebcdic_to_ch = ' '
  end if
 
  return
end
subroutine ebcdic_to_s ( s )

!*****************************************************************************80
!
!! EBCDIC_TO_S converts a string of EBCDIC characters to ASCII.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S.  
!    On input, the EBCDIC string.  
!    On output, the ASCII string.
!
  implicit none

  character ebcdic_to_ch
  integer ( kind = 4 ) i
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  s_length = len ( s )

  do i = 1, s_length
    s(i:i) = ebcdic_to_ch ( s(i:i) )
  end do
 
  return
end
subroutine fillch ( s1, field, s2 )

!*****************************************************************************80
!
!! FILLCH writes a string into a subfield of a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S1, a string which is presumed
!    to contain, somewhere, a substring that is to be filled in.
!    The substring might be '?', for instance.
!
!    On output, the substring has been overwritten.
!
!    Input, character ( len = * ) FIELD, a substring to be searched for in
!    S, which denotes the spot where the value should be placed.  
!    Trailing blanks are ignored.
!
!    Input, character ( len = * ) S2, the character string to be written 
!    into the subfield.  Trailing blanks are ignored.
!
  implicit none

  character ( len = * ) field
  integer ( kind = 4 ) i
  integer ( kind = 4 ) lenc
  integer ( kind = 4 ) s_indexi
  character ( len = * ) s1
  character ( len = * ) s2

  i = s_indexi ( s1, field )

  if ( i /= 0 ) then

    lenc = len_trim ( field )
    call s_chop ( s1, i, i+lenc-1 )

    lenc = len_trim ( s2 )
    call s_s_insert ( s1, i, s2(1:lenc) )

  end if

  return
end
subroutine fillin ( s, field, ival )

!*****************************************************************************80
!
!! FILLIN writes an integer into a subfield of a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S, a string which is presumed
!    to contain, somewhere, a substring that is to be filled in.
!    The substring might be '?', for instance.
!
!    On output, the substring has been overwritten by the value of IVAL.
!
!    Input, character ( len = * ) FIELD, a substring to be searched for in
!    S, which denotes the spot where the value should be placed.  
!    Trailing blanks are ignored.
!
!    Input, integer ( kind = 4 ) IVAL, the value to be written 
!    into the subfield.
!
  implicit none

  character ( len = * ) field
  integer ( kind = 4 ) i
  integer ( kind = 4 ) ival
  integer ( kind = 4 ) lenc
  integer ( kind = 4 ) s_indexi
  character ( len = * ) s
  character ( len = 14 ) sval

  i = s_indexi ( s, field )

  if ( i /= 0 ) then

    lenc = len_trim ( field )
    call s_chop ( s, i, i+lenc-1 )

    call i4_to_s_left ( ival, sval )

    lenc = len_trim ( sval )
    call s_s_insert ( s, i, sval(1:lenc) )

  end if

  return
end
subroutine fillrl ( s, field, r )

!*****************************************************************************80
!
!! FILLRL writes a real into a subfield of a string.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S, a string which is presumed
!    to contain, somewhere, a substring that is to be filled in.
!    The substring might be '?', for instance.
!    On output, the substring has been overwritten by the value.
!
!    Input, character ( len = * ) FIELD, a substring to be searched for in
!    S, which denotes the spot where the value should be placed.  
!    Trailing blanks are ignored.
!
!    Input, real  ( kind = 4 ) R, the value to be written into the subfield.
!
  implicit none

  character ( len = * ) field
  integer ( kind = 4 ) i
  integer ( kind = 4 ) lenc
  real    ( kind = 4 ) r
  character ( len = * ) s
  integer ( kind = 4 ) s_indexi
  character ( len = 10 ) sval

  i = s_indexi ( s, field )

  if ( i /= 0 ) then

    lenc = len_trim ( field )

    call s_chop ( s, i, i+lenc-1 )

    call r4_to_s_right ( r, sval )
    call s_blank_delete ( sval )
    lenc = len_trim ( sval )

    call s_s_insert ( s, i, sval(1:lenc) )

  end if

  return
end
subroutine flt_to_s ( mant, iexp, ndig, s )

!*****************************************************************************80
!
!! FLT_TO_S returns a representation of MANT * 10**IEXP.
!
!  Example:
!
!    MANT   IEXP   S
!
!       1      2   100
!     101     -1   10.1
!      23     -3   0.023
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    27 May 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ( kind = 4 ) MANT, the mantissa of the representation.
!    This is an integer whose magnitude is between 0 and
!    10**NDIG, that is, 0 <= MANT < 10**NDIG.
!
!    Input, integer ( kind = 4 ) IEXP, the exponent of 10 that multiplies MULT.
!
!    Input, integer ( kind = 4 ) NDIG, the number of digits of accuracy
!    in the representation.
!
!    Output, character ( len = * ) S, the representation of the quantity.
!
  implicit none

  integer ( kind = 4 ) iexp
  integer ( kind = 4 ) jexp
  integer ( kind = 4 ) mant
  integer ( kind = 4 ) ndig
  character ( len = * ) s
!
!  Get the length of the string, and set it all to blanks.
!
  s = ' '
!
!  If the mantissa is zero, the number is zero, and we have
!  a special case: S = '0'.
!
  if ( mant == 0 ) then
    s = '0'
    return
  else if ( 0 < mant ) then
    s(1:2) = '  '
  else if ( mant < 0 ) then
    s(1:2) = '- '
  end if
!
!  Now write the mantissa into S in positions 3 to NDIG+2.
!
  call i4_to_s_left ( abs ( mant ), s(3:ndig+2) )
!
!  Insert a decimal place after the first digit.
!
  s(2:2) = s(3:3)
  s(3:3) = '.'
!
!  Place the "e" representing the exponent.
!
  s(ndig+3:ndig+3) = 'e'
!
!  Write the exponent.
!
  jexp = 0

  do while ( 10**jexp <= abs ( mant ) ) 
    jexp = jexp + 1
  end do
 
  jexp = jexp + iexp - 1
 
  call i4_to_s_zero ( jexp, s(ndig+4:ndig+6) )
!
!  Remove all blanks, effectively shifting the string left too.
!
  call s_blank_delete ( s )
 
  return
end
subroutine forcom ( s, fortran, comment )

!*****************************************************************************80
!
!! FORCOM splits a FORTRAN line into "fortran" and "comment".
!
!  Discussion:
!
!    The "comment" portion is everything following the first occurrence
!    of an exclamation mark (and includes the exclamation mark).
!
!    The "fortran" portion is everything before the first exclamation 
!    mark.
!
!    Either or both the data and comment portions may be blank.
!
!  Example:
!
!    S                             FORTRAN           COMMENT
!
!    '      x = 1952   ! Wow'      '      x = 1952'  '! Wow'
!    '      continue'              '      continue'  ' '
!    '! Hey, Abbott!'              ' '               '! Hey, Abbott!'
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string to be analyzed.
!
!    Output, character ( len = * ) FORTRAN, the initial portion of the string,
!    containing a FORTRAN statement.
!
!    Output, character COMMENT, the final portion of the string, 
!    containing a comment.
!
  implicit none

  character ( len = * ) comment
  character ( len = * ) fortran
  integer ( kind = 4 ) i
  character ( len = * ) s

  i = index ( s, '!' )

  if ( i == 0 ) then
    fortran = s
    comment = ' '
  else if ( i == 1 ) then
    fortran = ' '
    comment = s
  else
    fortran = s ( 1:i-1)
    comment = s ( i: )
  end if
 
  return
end
subroutine get_unit ( iunit )

!*****************************************************************************80
!
!! GET_UNIT returns a free FORTRAN unit number.
!
!  Discussion:
!
!    A "free" FORTRAN unit number is an integer between 1 and 99 which
!    is not currently associated with an I/O device.  A free FORTRAN unit
!    number is needed in order to open a file with the OPEN command.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    02 March 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ( kind = 4 ) IUNIT.
!
!    If IUNIT = 0, then no free FORTRAN unit could be found, although
!    all 99 units were checked (except for units 5 and 6).
!
!    Otherwise, IUNIT is an integer between 1 and 99, representing a
!    free FORTRAN unit.  Note that GET_UNIT assumes that units 5 and 6
!    are special, and will never return those values.
!
  implicit none

  integer ( kind = 4 ) i
  integer ( kind = 4 ) ios
  integer ( kind = 4 ) iunit
  logical lopen

  iunit = 0

  do i = 1, 99

    if ( i /= 5 .and. i /= 6 ) then

      inquire ( unit = i, opened = lopen, iostat = ios )

      if ( ios == 0 ) then
        if ( .not. lopen ) then
          iunit = i
          return
        end if
      end if

    end if

  end do

  return
end
subroutine hex_to_i4 ( s, intval )

!*****************************************************************************80
!
!! HEX_TO_I4 converts a hexadecimal string to its integer value.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    07 December 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string of hexadecimal digits.
!
!    Output, integer ( kind = 4 ) INTVAL, the corresponding integer value.
!
  implicit none

  integer ( kind = 4 ) first
  integer ( kind = 4 ) idig
  integer ( kind = 4 ) intval
  integer ( kind = 4 ) isgn
  integer ( kind = 4 ) j
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  s_length = len_trim ( s )
!
!  Determine if there is a plus or minus sign.
!
  isgn = 1

  first = s_length + 1

  do j = 1, s_length

    if ( s(j:j) == '-' ) then
      isgn = -1
    else if ( s(j:j) == '+' ) then
      isgn = + 1 
    else if ( s(j:j) /= ' ' ) then
      first = j
      exit
    end if

  end do
!
!  Read the numeric portion of the string.
!
  intval = 0

  do j = first, s_length
    call ch_to_digit_hex ( s(j:j), idig )
    intval = intval * 16 + idig
  end do
 
  intval = isgn * intval
 
  return
end
subroutine hex_to_s ( hex, s )

!*****************************************************************************80
!
!! HEX_TO_S converts a hexadecimal string into characters.
!
!  Discussion:
!
!    Instead of CHAR, we now use the ACHAR function, which
!    guarantees the ASCII collating sequence.
!
!  Example:
!
!    Input: 
!
!      '414243' 
!
!    Output: 
!
!      'ABC'.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license. 
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) HEX, a string of pairs of hexadecimal values.
!
!    Output, character ( len = * ) S, the corresponding character string.
!
  implicit none

  character ( len = * ) hex
  integer ( kind = 4 ) i
  integer ( kind = 4 ) intval
  integer ( kind = 4 ) j
  integer ( kind = 4 ) ndo
  integer ( kind = 4 ) nhex
  character ( len = * ) s
  integer ( kind = 4 ) s_length

  s_length = len ( s )
  nhex = len