program football_main
!
!*******************************************************************************
!
!! FOOTBALL_MAIN is the main program for the football game analysis.
!
!
!  Discussion:
!
!    Only some of the options have been implemented.
!
!    I could use a SMALL database for testing.
!
!  Modified:
!
!    25 January 2002
!
!  Reference:
!
!    Donald Knuth,
!    The Stanford Graph Base.
!
!    James Keener,
!    The Perron-Frobenius Theorem and the Ranking of Football Teams,
!    SIAM Review, Volume 35, Number 1, pages 80-93, March 1993.
!
!  Author:
!
!    John Burkardt
!
  implicit none
!
  integer, parameter :: game_max = 700
  integer, parameter :: team_num = 120
!
  integer game_num
  integer game_score1(game_max)
  integer game_score2(game_max)
  integer game_team1(game_max)
  integer game_team2(game_max)
  integer i
  integer i1
  integer i2
  integer iunit
  integer rank(team_num)
  real rank_factor
  real rank_vector(team_num)
  integer rank_option
  real, dimension ( team_num, team_num ) :: score_matrix
  integer :: score_option = 1
  integer team
  character ( len = 5 ) team_abbrev(team_num)
  character ( len = 30 ) team_name(team_num)
  integer team_games(team_num)
  integer team_loss(team_num)
  integer team_tie(team_num)
  integer team_won(team_num)
!
  call timestamp ( )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'FOOTBALL'
  write ( *, '(a)' ) '  Read a set of football scores and rank the teams.'
!
!  Read the game score data file.
!
  call get_unit ( iunit )

  open ( unit = iunit, file = 'football.dat', status = 'old' )

  call games_read ( game_max, game_num, game_score1, game_score2, game_team1, &
    game_team2, iunit, team_abbrev, team_name, team_num )
  close ( unit = iunit )
!
!  Compute win/loss/tie
!
  team_games(1:team_num) = 0
  team_loss(1:team_num) = 0
  team_tie(1:team_num) = 0
  team_won(1:team_num) = 0

  do i = 1, game_num
    i1 = game_team1(i)
    i2 = game_team2(i)
    team_games(i1) = team_games(i1) + 1
    team_games(i2) = team_games(i2) + 1
    if ( game_score1(i) > game_score2(i) ) then
      team_won(i1) = team_won(i1) + 1
      team_loss(i2) = team_loss(i2) + 1
    else if ( game_score1(i) < game_score2(i) ) then
      team_loss(i1) = team_loss(i1) + 1
      team_won(i2) = team_won(i2) + 1
    else if ( game_score1(i) == game_score2(i) ) then
      team_tie(i1) = team_tie(i1) + 1
      team_tie(i2) = team_tie(i2) + 1
    end if
  end do
!
!  Print information from the file.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) 'Number of scores in the data file is ', game_num

  game_num = min ( game_num, game_max )

  call team_print ( team_abbrev, team_name, team_num )

  call game_print ( game_num, game_score1, game_score2, game_team1, &
    game_team2, team_abbrev, team_num )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'Choose the ranking option:'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  1: compute a scoring matrix, find its eigenvector;'
  write ( *, '(a)' ) '  2: find a fixed point of a nonlinear mapping.'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Enter option, 1 or 2:'
  read ( *, * ) rank_option
  write ( *, '(a)' ) ' '
  write ( *, '(a,i6)' ) '  Using RANK_OPTION = ', rank_option

  if ( rank_option == 1 ) then
!
!  Compute the scoring matrix.
!
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Prepare the scoring matrix.'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  If team I scores Sij and team J scores Sji,'
    write ( *, '(a)' ) '    then the formula for the score matrix entry S(I,J)'
    write ( *, '(a)' ) '    can be:'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  1:  0, 1/2, or 1 for loss, tie or win;'
    write ( *, '(a)' ) '  2:  Sij;'
    write ( *, '(a)' ) '  3:  Sij / (Sij+Sji);'
    write ( *, '(a)' ) '  4:  (Sij+1) / (Sij+Sji+2);'
    write ( *, '(a)' ) '  5:  H(Sij,Sji).'
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Enter the scoring option you want, from 1 to 5:'

    read ( *, * ) score_option

    write ( *, '(a)' ) ' '
    write ( *, '(a,i6)' ) '  Using SCORE_OPTION = ', score_option

    call score_matrix_set ( game_num, game_score1, game_score2, game_team1, &
      game_team2, score_option, team_num, score_matrix )
!
!  Determine the rankings.
!
    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) '  Determine the rankings.'

    call rmat_power_method ( team_num, team_num, score_matrix, &
      rank_factor, rank_vector )
!
!  METHOD 2
!
  else if ( rank_option == 2 ) then

    rank_vector(1:team_num) = 1.0E+00

    call score_matrix_set2 ( game_num, game_score1, game_score2, game_team1, &
      game_team2, team_num, score_matrix )

    call picard ( team_num, score_matrix, rank_vector, team_games )

  end if
!
!  Compute RANK from RANK_VECTOR.
!
  call rvec_sort_insert_index_d ( team_num, rank_vector, rank )

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  #  Team  Games/Won/Loss/Tie  Strength'
  write ( *, '(a)' ) ' '

  do i = 1, team_num
    team = rank(i)
    write ( *, '(i3,2x,a5,2x,4i3,f10.4)' ) i, team_abbrev(team), &
      team_games(team), team_won(team), team_loss(team), team_tie(team), &
      rank_vector(team) 
  end do 

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'FOOTBALL'
  write ( *, '(a)' ) '  Normal end of execution.'

  stop
end
subroutine ch_cap ( c )
!
!*******************************************************************************
!
!! CH_CAP capitalizes a single character.
!
!
!  Modified:
!
!    19 July 1998
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character C, the character to capitalize.
!
  implicit none
!
  character c
  integer itemp
!
  itemp = ichar ( c )

  if ( 97 <= itemp .and. itemp <= 122 ) then
    c = char ( itemp - 32 )
  end if

  return
end
subroutine ch_extract ( string, c )
!
!*******************************************************************************
!
!! CH_EXTRACT extracts the next nonblank character from a string.
!
!
!  Modified:
!
!    22 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) STRING, the string.  On output, the 
!    first nonblank character of STRING has been removed, and STRING 
!    has been shifted left.
!
!    Output, character C, the leading character of STRING.
!
  implicit none
!
  character c
  integer iget
  integer lchar
  character ( len = * ) string
!
  c = ' '

  lchar = len_trim ( string )
!
!  Find the first nonblank.
!
  iget = 0

  do

    iget = iget + 1

    if ( iget > lchar ) then
      return
    end if

    if ( string(iget:iget) /= ' ' ) then
      exit
    end if

  end do
!
!  Copy the nonblank character.
!
  c = string(iget:iget)
!
!  Shift the string.
!
  string(1:iget) = ' '
  string = adjustl ( string(iget+1:) )

  return
end
subroutine game_print ( game_num, game_score1, game_score2, game_team1, &
  game_team2, team_abbrev, team_num )
!
!*******************************************************************************
!
!! GAME_PRINT prints the game information.
!
!
!  Modified:
!
!    06 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer GAME_NUM, the number of games.
!
!    Input, integer GAME_SCORE1(GAME_NUM), GAME_SCORE2(GAME_NUM), 
!    the scores for each game.
!
!    Input, integer GAME_TEAM1(GAME_NUM), GAME_TEAM2(GAME_NUM), 
!    the teams for each game.
!
!    Input, character ( len = 5 ) TEAM_ABBREV(TEAM_NUM), the abbreviations for
!    each team.
!
!    Input, integer TEAM_NUM, the number of teams.
!
  implicit none
!
  integer game_num
  integer team_num
!
  integer game_i
  integer game_score1(game_num)
  integer game_score2(game_num)
  integer game_team1(game_num)
  integer game_team2(game_num)
  character ( len = 5 ) team_abbrev(team_num)
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'Game scores:'
  write ( *, '(a)' ) ' '
  do game_i = 1, game_num

    write ( *, '(i3,2x,a,2x,i3,4x,a,2x,i3)' ) game_i, &
      team_abbrev(game_team1(game_i)), game_score1(game_i), &
      team_abbrev(game_team2(game_i)), game_score2(game_i)

  end do

  return
end
subroutine games_read ( game_max, game_num, game_score1, game_score2, &
  game_team1, game_team2, iunit, team_abbrev, team_name, team_num )
!
!*******************************************************************************
!
!! GAMES_READ reads the game score data file.
!
!
!  Modified:
!
!    06 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer GAME_MAX, the maximum number of games.
!
!    Output, integer GAME_NUM, the number of games.
!
!    Output, integer GAME_SCORE1(GAME_NUM), GAME_SCORE2(GAME_NUM), 
!    the scores for each game.
!
!    Output, integer GAME_TEAM1(GAME_NUM), GAME_TEAM2(GAME_NUM), 
!    the teams for each game.
!
!    Input, integer IUNIT, the FORTRAN unit number of the file being read.
!
!    Input, character ( len = 5 ) TEAM_ABBREV(TEAM_NUM), the abbreviations for
!    each team.
!
!    Output, character ( len = 30 ) TEAM_NAME(TEAM_NUM), the full name of 
!    each team.
!
!    Input, integer TEAM_NUM, the number of teams.
!
  implicit none
!
  integer game_max
  integer team_num
!
  character c
  integer game_num
  integer game_score1(game_max)
  integer game_score2(game_max)
  integer game_team1(game_max)
  integer game_team2(game_max)
  integer i
  integer ierror
  integer ios
  integer iunit
  integer ival1
  integer ival2
  character ( len = 100 ) line
  integer match1
  integer match2
  character ( len = 5 ) team_abbrev(team_num)
  character ( len = 30 ) team_name(team_num)
!
!  Phase 0: skip header
!
  do i = 1, 4
    read ( iunit, '(a)' ) line
  end do
!
!  Phase 1: Read school abbreviations and names
!
  call team_read ( iunit, team_abbrev, team_name, team_num )
!
!  Phase 2: Read scores
!
  game_num = 0

  do

    read ( iunit, '(a)', iostat = ios ) line
 
    if ( ios /= 0 ) then
      exit
    end if
!
!  Phase 2.1: Is this a comment?
!
    if ( line(1:1) == '*' ) then
      cycle
    end if
!
!  Phase 2.2: Is this a date?
!
    if ( line(1:1) == '>' ) then
      cycle
    end if
!
!  Phase 2.3: This is a game.
!
    call token_extract ( line, team_num, team_abbrev, match1 )
    call i_extract ( line, ival1, ierror )
    call ch_extract ( line, c )
    call token_extract ( line, team_num, team_abbrev, match2 )
    call i_extract ( line, ival2, ierror )

    game_num = game_num + 1

    if ( game_num <= game_max ) then
      game_team1(game_num) = match1
      game_score1(game_num) = ival1
      game_team2(game_num) = match2
      game_score2(game_num) = ival2
    end if

  end do

  return
end
subroutine get_unit ( iunit )
!
!*******************************************************************************
!
!! 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.
!
!  Modified:
!
!    02 March 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer 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 i
  integer ios
  integer 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 i_extract ( string, ival, ierror )
!
!*******************************************************************************
!
!! I_EXTRACT "extracts" an integer from the beginning of a string.
!
!
!  Modified:
!
!    22 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) STRING; on input, a string from
!    whose beginning an integer is to be extracted.  On output, 
!    the integer, if found, has been removed.
!
!    Output, integer IVAL.  If IERROR is 0, then IVAL contains the
!    "next" integer read from LINE; otherwise IVAL is 0.
!
!    Output, integer IERROR.
!    0, no error.
!    nonzero, an integer could not be extracted from the beginning of the
!    string.  IVAL is 0 and STRING is unchanged.
!
  implicit none
!
  integer ierror
  integer ival
  integer lchar
  character ( len = * ) string
!
  ival = 0
 
  call s_to_i ( string, ival, ierror, lchar )
 
  if ( ierror /= 0 .or. lchar == 0 ) then
    ierror = 1
    ival = 0
    return
  end if

  string = adjustl ( string(lchar+1:) )
 
  return
end
subroutine ivec_identity ( n, a )
!
!*******************************************************************************
!
!! IVEC_IDENTITY sets an integer vector to the identity vector A(I)=I.
!
!
!  Modified:
!
!    09 November 2000
!
!  Parameters:
!
!    Input, integer N, the number of elements of A.
!
!    Output, integer A(N), the array to be initialized.
!
  implicit none
!
  integer n
!
  integer a(n)
  integer i
!
  do i = 1, n
    a(i) = i
  end do

  return
end
subroutine picard ( team_num, score_matrix, rank_vector, team_games )
!
!*******************************************************************************
!
!! PICARD uses Picard iteration to find an approximate nonlinear ranking.
!
!
!  Modified:
!
!    12 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
  implicit none
!
  integer team_num
!
  real dx
  integer i
  integer iteration
  integer j
  integer, parameter :: picard_max = 20
  real, parameter :: picard_tolerance = 0.001E+00
  real rank_vector(team_num)
  real rank2(team_num)
  real score_matrix(team_num,team_num)
  integer team_games(team_num)
  real warp2
  real xnrm
!
  iteration = 0

  do 

    do i = 1, team_num
      rank2(i) = 0.0E+00
      do j = 1, team_num
        rank2(i) = rank2(i) + warp2 ( score_matrix(i,j) * rank_vector(j) )
      end do
      rank2(i) = rank2(i) / team_games(i)
    end do

    rank2(1:team_num) = rank2(1:team_num) / real ( team_games(1:team_num) )

    dx = maxval ( abs ( rank_vector(1:team_num) - rank2(1:team_num) ) )
    xnrm = maxval ( abs ( rank_vector(1:team_num) ) )

    rank_vector(1:team_num) = rank2(1:team_num)

    iteration = iteration + 1

    if ( dx <= picard_tolerance * ( xnrm + 1.0E+00 ) ) then
      exit
    end if

    if ( iteration > picard_max ) then
      exit
    end if

  end do

  return
end
subroutine rmat_power_method ( lda, n, a, r, v )
!
!*******************************************************************************
!
!! RMAT_POWER_METHOD applies the power method to a matrix.
!
!
!  Discussion:
!
!    If the power method has not converged, then calling the routine
!    again immediately with the output from the previous call will
!    continue the iteration.
!
!  Modified:
!
!    06 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer LDA, the leading dimension of A.
!
!    Input, integer N, the order of A.
!
!    Input, real A(LDA,N), the matrix.
!
!    Output, real R, V(N), the estimated eigenvalue and eigenvector.
!
  implicit none
!
  integer lda
  integer n
!
  real a(lda,n)
  real av(n)
  real eps
  integer i
  real, parameter :: it_eps = 0.0001E+00
  integer, parameter :: it_max = 100
  integer, parameter :: it_min = 10
  integer j
  real r
  real r2
  real r_old
  real v(n)
!
  eps = sqrt ( epsilon ( 1.0E+00 ) )

  r = sqrt ( sum ( v(1:n)**2 ) )

  if ( r == 0.0E+00 ) then
    v(1:n) = 1.0E+00
    r = sqrt ( real ( n ) )
  end if

  v(1:n) = v(1:n) / r

  do i = 1, it_max

    av(1:n) = matmul ( a(1:n,1:n), v(1:n) )

    r_old = r
    r = sqrt ( sum ( av(1:n)**2 ) )

    if ( i > it_min ) then
      if ( abs ( r - r_old ) <= it_eps * ( 1.0E+00 + abs ( r ) ) ) then
        exit
      end if
    end if

    v(1:n) = av(1:n)

    if ( r /= 0.0E+00 ) then
      v(1:n) = v(1:n) / r
    end if
!
!  Perturb V a bit, to avoid cases where the initial guess is exactly
!  the eigenvector of a smaller eigenvalue.
!
    if ( i < it_max / 2 ) then
      j = 1 + mod ( i-1, n )
      v(j) = v(j) + eps * ( 1.0E+00 + abs ( v(j) ) )
      r2 = sqrt ( sum ( v(1:n)**2 ) )
      v(1:n) = v(1:n) / r2
    end if

  end do

  return
end
subroutine rvec_sort_insert_index_d ( n, a, indx )
!
!*******************************************************************************
!
!! RVEC_SORT_INSERT_INDEX_D descending index sorts a real vector using insertion.
!
!
!  Reference:
!
!    Algorithm 1.1,
!    Donald Kreher and Douglas Simpson,
!    Combinatorial Algorithms,
!    CRC Press, 1998, page 11.
!
!  Modified:
!
!    06 February 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer N, the number of items in the vector.
!    N must be positive.
!
!    Input, real A(N), the array to be sorted.
!
!    Output, integer INDX(N), the sorted indices.  The array is sorted
!    when listed from A(INDX(1)) through A(INDX(N)).
!
  implicit none
!
  integer n
!
  real a(n)
  integer i
  integer indx(n)
  integer j
  real x
!
  call ivec_identity ( n, indx )

  do i = 2, n

    x = a(i)

    j = i - 1

    do while ( j >= 1 )

      if ( a(indx(j)) >= x ) then
        exit
      end if

      indx(j+1) = indx(j)
      j = j - 1

    end do

    indx(j+1) = i

  end do

  return
end
subroutine s_before_ss_copy ( s, ss, s2 )
!
!*******************************************************************************
!
!! S_BEFORE_SS_COPY copies a string up to a given substring.
!
!
!  Discussion:
!
!    S and S2 can be the same object, in which case the string is
!    overwritten by a copy of itself up to the substring, followed
!    by blanks.
!
!  Example:
!
!    Input:
!
!      S = 'ABCDEFGH'
!      SS = 'EF'
!
!    Output:
!
!      S2 = 'ABCD'.
!
!  Modified:
!
!    21 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, the string to be copied.
!
!    Input, character ( len = * ) SS, the substring before which the copy stops.
!
!    Output, character ( len = * ) S2, the copied portion of S.
!
  implicit none
!
  integer last
  integer last_s2
  character ( len = * ) s
  character ( len = * ) s2
  character ( len = * ) ss
!
!  Find the first occurrence of the substring.
!
  last = index ( s, ss )
!
!  If the substring doesn't occur at all, behave as though it begins
!  just after the string terminates.
!
!  Now redefine LAST to point to the last character to copy before
!  the substring begins.
!
  if ( last == 0 ) then
    last = len ( s )
  else
    last = last - 1
  end if
!
!  Now adjust again in case the copy holder is "short".
!
  last_s2 = len ( s2 )

  last = min ( last, last_s2 )
!
!  Copy the beginning of the string.
!  Presumably, compilers now understand that if LAST is 0, we don't
!  copy anything.
!  Clear out the rest of the copy.
!
  s2(1:last) = s(1:last)
  s2(last+1:last_s2) = ' '

  return
end
function s_eqi ( strng1, strng2 )
!
!*******************************************************************************
!
!! S_EQI is a case insensitive comparison of two strings for equality.
!
!
!  Examples:
!
!    S_EQI ( 'Anjana', 'ANJANA' ) is .TRUE.
!
!  Modified:
!
!    14 April 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) STRNG1, STRNG2, the strings to compare.
!
!    Output, logical S_EQI, the result of the comparison.
!
  implicit none
!
  integer i
  integer len1
  integer len2
  integer lenc
  logical s_eqi
  character s1
  character s2
  character ( len = * ) strng1
  character ( len = * ) strng2
!
  len1 = len ( strng1 )
  len2 = len ( strng2 )
  lenc = min ( len1, len2 )

  s_eqi = .false.

  do i = 1, lenc

    s1 = strng1(i:i)
    s2 = strng2(i:i)
    call ch_cap ( s1 )
    call ch_cap ( s2 )

    if ( s1 /= s2 ) then
      return
    end if

  end do

  do i = lenc + 1, len1
    if ( strng1(i:i) /= ' ' ) then
      return
    end if
  end do

  do i = lenc + 1, len2
    if ( strng2(i:i) /= ' ' ) then
      return
    end if
  end do

  s_eqi = .true.

  return
end
subroutine s_to_i ( s, ival, ierror, last )
!
!*******************************************************************************
!
!! S_TO_I reads an integer value from a string.
!
!
!  Modified:
!
!    28 June 2000
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) S, a string to be examined.
!
!    Output, integer IVAL, the integer value read from the string.
!    If the string is blank, then IVAL will be returned 0.
!
!    Output, integer IERROR, an error flag.
!    0, no error.
!    1, an error occurred.
!
!    Output, integer LAST, the last character of S used to make IVAL.
!
  implicit none
!
  character c
  integer i
  integer ierror
  integer isgn
  integer istate
  integer ival
  integer last
  character ( len = * ) s
!
  ierror = 0
  istate = 0
  isgn = 1
  ival = 0

  do i = 1, len_trim ( s )

    c = s(i:i)
!
!  Haven't read anything.
!
    if ( istate == 0 ) then

      if ( c == ' ' ) then

      else if ( c == '-' ) then
        istate = 1
        isgn = -1
      else if ( c == '+' ) then
        istate = 1
        isgn = + 1
      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        istate = 2
        ival = ichar ( c ) - ichar ( '0' )
      else
        ierror = 1
        return
      end if
!
!  Have read the sign, expecting digits.
!
    else if ( istate == 1 ) then

      if ( c == ' ' ) then

      else if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        istate = 2
        ival = ichar ( c ) - ichar ( '0' )
      else
        ierror = 1
        return
      end if
!
!  Have read at least one digit, expecting more.
!
    else if ( istate == 2 ) then

      if ( lle ( '0', c ) .and. lle ( c, '9' ) ) then
        ival = 10 * ival + ichar ( c ) - ichar ( '0' )
      else
        ival = isgn * ival
        last = i - 1
        return
      end if

    end if

  end do
!
!  If we read all the characters in the string, see if we're OK.
!
  if ( istate == 2 ) then
    ival = isgn * ival
    last = len_trim ( s )
  else
    ierror = 1
    last = 0
  end if

  return
end
subroutine s_token_match ( string, token_num, token, match )
!
!*******************************************************************************
!
!! S_TOKEN_MATCH matches the beginning of a string and a set of tokens.
!
!
!  Example:
!
!    Input:
!
!      STRING = 'TOMMYGUN'
!      TOKEN = 'TOM', 'ZEBRA', 'TOMMY', 'TOMMYKNOCKER'
!
!    Output:
!
!      MATCH = 3
!
!  Discussion:
!
!    The longest possible match is taken.  
!    Matching is done without regard to case or trailing blanks.
!
!  Modified:
!
!    21 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = * ) STRING, the string to be examined.
!
!    Input, integer TOKEN_NUM, the number of tokens to be compared.
!
!    Input, character ( len = * ) TOKEN(TOKEN_NUM), the tokens.
!
!    Output, integer MATCH, the index of the (longest) token that matched
!    the string, or 0 if no match was found.
!
  implicit none
!
  integer token_num
!
  integer match
  integer match_length
  logical s_eqi
  character ( len = * ) string
  integer string_length
  integer token_i
  integer token_length
  character ( len = * ) token(token_num)
!
  match = 0
  match_length = 0

  string_length = len_trim ( string )

  do token_i = 1, token_num

    token_length = len_trim ( token ( token_i ) )

    if ( token_length > match_length ) then

      if ( token_length <= string_length ) then

        if ( s_eqi ( string(1:token_length), &
                     token(token_i)(1:token_length) ) ) then
          match_length = token_length
          match = token_i
        end if

      end if

    end if
    
  end do

  return
end
subroutine score_matrix_set ( game_num, game_score1, game_score2, game_team1, &
  game_team2, score_option, team_num, score_matrix )
!
!*******************************************************************************
!
!! SCORE_MATRIX_SET sets the entries of the score matrix.
!
!
!  Modified:
!
!    05 February 2001
!
!  Reference:
!
!    James Keener,
!    The Perron-Frobenius Theorem and the Ranking of Football Teams,
!    SIAM Review, Volume 35, Number 1, pages 80-93, March 1993.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer GAME_NUM, the number of games.
!
!    Input, integer GAME_SCORE1(GAME_NUM), GAME_SCORE2(GAME_NUM), 
!    the scores for each game.
!
!    Input, integer GAME_TEAM1(GAME_NUM), GAME_TEAM2(GAME_NUM), 
!    the teams for each game.
!
!    Input, integer SCORE_OPTION.
!    1, score = 0/0.5/1 for each loss, tie, or win.
!    2, score = Sij
!    3, score = Sij/(Sij+Sji)
!    4, score = (Sij+1)/(Sij+Sji+2)
!    5, score = h(Sij,Sji)
!
!    Input, integer TEAM_NUM, the number of teams.
!
!    Output, real SCORE_MATRIX(TEAM_NUM,TEAM_NUM), the scoring matrix.
!
  implicit none
!
  integer game_num
  integer team_num
!
  real dij
  real dji
  integer game
  integer game_score1(game_num)
  integer game_score2(game_num)
  integer game_team1(game_num)
  integer game_team2(game_num)
  integer i
  integer j
  real score_matrix(team_num,team_num)
  integer score_option
  integer sij
  integer sji
  integer team_games(team_num)
  real warp
!
  score_matrix(1:team_num,1:team_num) = 0.0E+00
  team_games(1:team_num) = 0

  do game = 1, game_num

    i = game_team1(game)
    team_games(i) = team_games(i) + 1
    j = game_team2(game)
    team_games(j) = team_games(j) + 1
    sij = game_score1(game)
    sji = game_score2(game)

    if ( score_option == 1 ) then

      if ( sij > sji ) then
        dij = 1.0E+00
        dji = 0.0E+00
      else if ( sij == sji ) then
        dij = 0.5E+00
        dji = 0.5E+00
      else if ( sij < sji ) then
        dij = 0.0E+00
        dji = 1.0E+00
      end if

    else if ( score_option == 2 ) then

      dij = real ( sij )
      dji = real ( sji )

    else if ( score_option == 3 ) then

      if ( sij + sji == 0 ) then
        dij = 0.0E+00
        dji = 0.0E+00
      else
        dij = real ( sij ) / real ( sij + sji )
        dji = real ( sji ) / real ( sij + sji )
      end if

    else if ( score_option == 4 ) then
      dij = real ( sij + 1 ) / real ( sij + sji + 2 )
      dji = real ( sji + 1 ) / real ( sij + sji + 2 )
    else if ( score_option == 5 ) then
      dij = real ( sij + 1 ) / real ( sij + sji + 2 )
      dij = warp ( dij )
      dji = real ( sji + 1 ) / real ( sij + sji + 2 )
      dji = warp ( dji )
    else
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'SCORE_MATRIX_SET - Fatal error!'
      write ( *, '(a,i6)' ) '  Illegal score option: ', score_option
      stop
    end if

    score_matrix(i,j) = score_matrix(i,j) + dij
    score_matrix(j,i) = score_matrix(j,i) + dji

  end do
!
!  Divide each team's row by the number of games it played.
!
  do i = 1, team_num
    if ( team_games(i) > 1 ) then
      score_matrix(i,1:team_num) = score_matrix(i,1:team_num) &
        / real ( team_games(i) )
    end if
  end do

  return
end
subroutine score_matrix_set2 ( game_num, game_score1, game_score2, game_team1, &
  game_team2, team_num, score_matrix )
!
!*******************************************************************************
!
!! SCORE_MATRIX_SET2 sets the entries of the score matrix.
!
!
!  Modified:
!
!    12 February 2001
!
!  Reference:
!
!    James Keener,
!    The Perron-Frobenius Theorem and the Ranking of Football Teams,
!    SIAM Review, Volume 35, Number 1, pages 80-93, March 1993.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer GAME_NUM, the number of games.
!
!    Input, integer GAME_SCORE1(GAME_NUM), GAME_SCORE2(GAME_NUM), 
!    the scores for each game.
!
!    Input, integer GAME_TEAM1(GAME_NUM), GAME_TEAM2(GAME_NUM), 
!    the teams for each game.
!
!    Input, integer TEAM_NUM, the number of teams.
!
!    Output, real SCORE_MATRIX(TEAM_NUM,TEAM_NUM), the scoring matrix.
!
  implicit none
!
  integer game_num
  integer team_num
!
  real dij
  real dji
  integer game
  integer game_score1(game_num)
  integer game_score2(game_num)
  integer game_team1(game_num)
  integer game_team2(game_num)
  integer i
  integer j
  integer score_count(team_num,team_num)
  real score_matrix(team_num,team_num)
  integer sij
  integer sji
  integer team_games(team_num)
!
  score_matrix(1:team_num,1:team_num) = 0.0E+00
  team_games(1:team_num) = 0

  do game = 1, game_num

    i = game_team1(game)
    team_games(i) = team_games(i) + 1
    j = game_team2(game)
    team_games(j) = team_games(j) + 1
    sij = game_score1(game)
    sji = game_score2(game)

    dij = ( 5.0E+00 + real ( sij ) + real ( sij )**(2.0E+00/3.0E+00) ) &
        / ( 5.0E+00 + real ( sji ) + real ( sij )**(2.0E+00/3.0E+00) )

    dji = ( 5.0E+00 + real ( sji ) + real ( sji )**(2.0E+00/3.0E+00) ) &
        / ( 5.0E+00 + real ( sij ) + real ( sji )**(2.0E+00/3.0E+00) )

    score_matrix(i,j) = score_matrix(i,j) + dij
    score_count(i,j) = score_count(i,j) + 1

    score_matrix(j,i) = score_matrix(j,i) + dji
    score_count(j,i) = score_count(j,i) + 1

  end do
!
!  A WHERE statement would be handy here.
!
  do i = 1, team_num
    do j = 1, team_num
      if ( score_count(i,j) > 1 ) then
        score_matrix(i,j) = score_matrix(i,j) / real ( score_count(i,j) )
      end if
    end do
  end do

  return
end
subroutine team_print ( team_abbrev, team_name, team_num )
!
!*******************************************************************************
!
!! TEAM_PRINT prints the team name information.
!
!
!  Modified:
!
!    21 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = 5 ) TEAM_ABBREV(TEAM_NUM), the abbreviations for
!    each team.
!
!    Input, character ( len = 30 ) TEAM_NAME(TEAM_NUM), the full name of 
!    each team.
! 
!    Input, integer TEAM_NUM, the number of teams.
!
  implicit none
!
  integer team_num
!
  character ( len = 5 ) team_abbrev(team_num)
  integer team_i
  character ( len = 30 ) team_name(team_num)
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'ABBREV  Full Name of Team'
  write ( *, '(a)' ) ' '

  do team_i = 1, team_num
    write ( *, '(i3,2x,a,2x,a)' ) team_i, team_abbrev(team_i), team_name(team_i)
  end do

  return
end
subroutine team_read ( iunit, team_abbrev, team_name, team_num )
!
!*******************************************************************************
!
!! TEAM_READ reads the team name information from the game score data file.
!
!
!  Modified:
!
!    21 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer IUNIT, the FORTRAN unit number of the file being read.
!
!    Output, character ( len = 5 ) TEAM_ABBREV(TEAM_NUM), the abbreviations for
!    each team.
!
!    Output, character ( len = 30 ) TEAM_NAME(TEAM_NUM), the full name of 
!    each team.
!    
!    Input, integer TEAM_NUM, the number of teams.
!
  implicit none
!
  integer team_num
!
  integer iunit
  character ( len = 100 ) line
  character ( len = 5 ) team_abbrev(team_num)
  integer team_i
  character ( len = 30 ) team_name(team_num)
  character ( len = 10 ) word
!
  do team_i = 1, team_num
    read ( iunit, '(a)' ) line
    call word_extract ( line, word )
    team_abbrev(team_i) = word
    call s_before_ss_copy ( line, '(', line )
    team_name(team_i) = line
  end do

  return
end
subroutine timestamp ( )
!
!*******************************************************************************
!
!! TIMESTAMP prints the current YMDHMS date as a time stamp.
!
!
!  Example:
!
!    May 31 2001   9:45:54.872 AM
!
!  Modified:
!
!    31 May 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    None
!
  implicit none
!
  character ( len = 8 ) ampm
  integer d
  character ( len = 8 ) date
  integer h
  integer m
  integer mm
  character ( len = 9 ), parameter, dimension(12) :: month = (/ &
    'January  ', 'February ', 'March    ', 'April    ', &
    'May      ', 'June     ', 'July     ', 'August   ', &
    'September', 'October  ', 'November ', 'December ' /)
  integer n
  integer s
  character ( len = 10 )  time
  integer values(8)
  integer y
  character ( len = 5 ) zone
!
  call date_and_time ( date, time, zone, values )

  y = values(1)
  m = values(2)
  d = values(3)
  h = values(5)
  n = values(6)
  s = values(7)
  mm = values(8)

  if ( h < 12 ) then
    ampm = 'AM'
  else if ( h == 12 ) then
    if ( n == 0 .and. s == 0 ) then
      ampm = 'Noon'
    else
      ampm = 'PM'
    end if
  else
    h = h - 12
    if ( h < 12 ) then
      ampm = 'PM'
    else if ( h == 12 ) then
      if ( n == 0 .and. s == 0 ) then
        ampm = 'Midnight'
      else
        ampm = 'AM'
      end if
    end if
  end if

  write ( *, '(a,1x,i2,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
    trim ( month(m) ), d, y, h, ':', n, ':', s, '.', mm, trim ( ampm )

  return
end
subroutine token_extract ( string, token_num, token, match )
!
!*******************************************************************************
!
!! TOKEN_EXTRACT "extracts" a token from the beginning of a string.
!
!
!  Modified:
!
!    22 November 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) STRING; on input, a string from
!    whose beginning a token is to be extracted.  On output, 
!    the token, if found, has been removed.
!
!    Input, integer TOKEN_NUM, the number of tokens to be compared.
!
!    Input, character ( len = * ) TOKEN(TOKEN_NUM), the tokens.
!
!    Output, integer MATCH, the index of the (longest) token that matched
!    the string, or 0 if no match was found.
!
  implicit none
!
  integer token_num
!
  integer left
  integer match
  character ( len = * ) string
  character ( len = * ) token(token_num)
!
  call s_token_match ( string, token_num, token, match )

  if ( match /= 0 ) then
    left = len_trim ( token(match) )
    string = adjustl ( string(left+1:) )
  end if
 
  return
end
function warp ( x )
!
!*******************************************************************************
!
!! WARP computes a score that tries to factor out wipeouts.
!
!
!  Modified:
!
!    05 February 2001
!
!  Reference:
!
!    James Keener,
!    The Perron-Frobenius Theorem and the Ranking of Football Teams,
!    SIAM Review, Volume 35, Number 1, pages 80-93, March 1993.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real X, the input argument, the partial score.
!
!    Output, real WARP, a "warped" value of X.
!
  implicit none
!
  real warp
  real x
!
  if ( x < 0.5E+00 ) then
    warp = 0.5E+00 * ( 1.0E+00 - sqrt ( abs ( 2.0E+00 * x - 1.0E+00 ) ) )
  else if ( x == 0.5E+00 ) then
    warp = 0.5E+00
  else if ( x > 0.5E+00 ) then
    warp = 0.5E+00 * ( 1.0E+00 + sqrt ( abs ( 2.0E+00 * x - 1.0E+00 ) ) )
  end if

  return
end
function warp2 ( x )
!
!*******************************************************************************
!
!! WARP2 computes a score that tries to factor out wipeouts.
!
!
!  Modified:
!
!    12 February 2001
!
!  Reference:
!
!    James Keener,
!    The Perron-Frobenius Theorem and the Ranking of Football Teams,
!    SIAM Review, Volume 35, Number 1, pages 80-93, March 1993.
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, real X, the input argument, the partial score.
!
!    Output, real WARP2, a "warped" value of X.
!
  implicit none
!
  real warp2
  real x
!
  warp2 = x * ( x + 0.05E+00 ) / ( x**2 + 0.05E+00 * x + 2.0E+00 )

  return
end
subroutine word_extract ( s, w )
!
!*******************************************************************************
!
!! WORD_EXTRACT extracts the next word from a string.
!
!
!  Discussion:
!
!    A "word" is a string of characters terminated by a blank or
!    the end of the string.
!
!  Modified:
!
!    31 January 2001
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, character ( len = * ) S, the string.  On output, the first
!    word has been removed, and the remaining string has been shifted left.
!
!    Output, character ( len = * ) W, the leading word of the string.
!
  implicit none
!
  integer iget1
  integer iget2
  integer lchar
  character ( len = * ) s
  character ( len = * ) w
!
  w = ' '

  lchar = len ( s )
!
!  Find the first nonblank.
!
  iget1 = 0

  do

    iget1 = iget1 + 1

    if ( iget1 > lchar ) then
      return
    end if

    if ( s(iget1:iget1) /= ' ' ) then
      exit
    end if

  end do
!
!  Look for the last contiguous nonblank.
!
  iget2 = iget1

  do

    if ( iget2 >= lchar ) then
      exit
    end if

    if ( s(iget2+1:iget2+1) == ' ' ) then
      exit
    end if

    iget2 = iget2 + 1

  end do
!
!  Copy the word.
!
  w = s(iget1:iget2)
!
!  Shift the string.
!
  s(1:iget2) = ' '
  s = adjustl ( s(iget2+1:) )

  return
end