subroutine adj_print ( adj, label, maxobj, nobject )
!
!*******************************************************************************
!
!! ADJ_PRINT prints the known adjacency information.
!
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ADJ(MAXOBJ,MAXOBJ), object I to object J adjacency:
!
!    -3, it is not known if I is directly linked to J;
!    -2, I is not directly linked to J;
!     0, I = J;
!     1, I is directly linked to J.
!
!    Input, character ( len = 3 ) LABEL(MAXOBJ), labels or names for the
!    objects.
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
  implicit none
!
  integer, parameter :: UNKNOWN = -3
  integer, parameter :: NOT_ADJACENT = -2
  integer, parameter :: SELF = 0
  integer, parameter :: ADJACENT = 1

  integer maxobj
!
  integer adj(maxobj,maxobj)
  integer i
  integer j
  character ( len = 3 ) label(maxobj)
  integer nobject
  character ( len = 80 ) string
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'ADJ_PRINT:'
  write ( *, '(a)' ) '  Current knowledge about adjacency:'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    ? = UNKNOWN;'
  write ( *, '(a)' ) '    * = NOT  ADJACENT;'
  write ( *, '(a)' ) '    0 = SELF ADJACENT;'
  write ( *, '(a)' ) '    1 =      ADJACENT.'
  write ( *, '(a)' ) ' '
  write ( *, '(3x,20a1)' ) ( label(i), i = 1, nobject )
  write ( *, '(a)' ) ' '

  do i = 1, nobject

    do j = 1, nobject

      if ( adj(i,j) == UNKNOWN ) then
        string(j:j) = '?'
      else if ( adj(i,j) == NOT_ADJACENT ) then
        string(j:j) = '*'
      else if ( adj(i,j) == SELF ) then
        string(j:j) = '0'
      else if ( adj(i,j) == ADJACENT ) then
        string(j:j) = '1'
      else
        string(j:j) = ' '
      end if

    end do

    write ( *, '(a1,2x,a)') label(i), string(1:nobject)

  end do

  return
end
subroutine adj_update ( adj, maxobj, nobject, reach, test_set, test_type )
!
!*******************************************************************************
!
!! ADJ_UPDATE uses the latest test results to update the adjacency guesses.
!
!
!  Modified:
!
!    15 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input/output, integer ADJ(MAXOBJ,MAXOBJ), object-to-object adjacency:
!
!    -3, it is not known if I is directly linked to J;
!    -2, I is not directly linked to J;
!     0, I = J;
!     1, I is directly linked to J.
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Input/output, integer REACH(MAXOBJ,MAXOBJ), object-to-object reachability:
!    K = -3, it is not known if from I you can reach J;
!    K = -1, from I you cannot reach J;
!    K =  0, I = J;
!    K >  0, from I you can reach J in K steps or less.
!
!    Input, integer TEST_SET(MAXOBJ), describes a partition of the objects.
!
!    Input, character ( len = 15 ) TEST_TYPE, the type of the current test.
!
  implicit none
!
  integer, parameter :: UNKNOWN = -3
  integer, parameter :: NOT_ADJACENT = -2
  integer, parameter :: NOT_REACHABLE = -1
  integer, parameter :: SELF = 0
  integer, parameter :: ADJACENT = 1
!
  integer maxobj
!
  integer adj(maxobj,maxobj)
  integer i
  integer j
  integer nobject
  integer reach(maxobj,maxobj)
  integer test_set(maxobj)
  character ( len = 15 ) test_type
!
!  Each object that WAS stimulated on this test cannot be upwind
!  from any object that WAS NOT stimulated.
!
  if ( test_type == 'ACTIVE' ) then

    do i = 1, nobject
      if ( test_set(i) /= 0 ) then
        do j = 1, nobject
          if ( test_set(j) == 0 ) then

            if ( reach(i,j) == UNKNOWN ) then

              adj(i,j) = NOT_ADJACENT
              reach(i,j) = NOT_REACHABLE

            else if ( reach(i,j) == NOT_REACHABLE ) then

            else
              write ( *, * ) 'ACTIVE data conflict!'
            end if

          end if
        end do
      end if
    end do

  else if ( test_type == 'ADJACENT' ) then

    do i = 1, nobject
      if ( test_set(i) > 0 ) then
        do j = 1, nobject
          if ( test_set(j) == test_set(i) + 1 ) then

            if ( adj(i,j) == NOT_ADJACENT ) then

              write ( *, * ) 'ADJACENT data conflict!'
              write ( *, * ) '  I = ', i
              write ( *, * ) '  J = ', j
              write ( *, * ) '  ADJ(i,j) = ', adj(i,j)

            else if ( reach(i,j) == NOT_REACHABLE ) then

              write ( *, * ) 'ADJACENT data conflict!'
              write ( *, * ) '  I = ', i
              write ( *, * ) '  J = ', j
              write ( *, * ) '  REACH(i,j) = ', reach(i,j)

            else

              adj(i,j) = ADJACENT
              reach(i,j) = 1

            end if

          end if
        end do
      end if
    end do
!
!  INITIAL
!  TEST_SET(J) = 1 means node J is an initial node.
!  No other node can reach node J.
!
!  I dropped the check for conflicts here.  I really should
!  restore it, and think through how all the conflict checking
!  should be done.
!
  else if ( test_type == 'INITIAL' ) then

    do j = 1, nobject
      if ( test_set(j) == 1 ) then
        do i = 1, nobject

          if ( i == j ) then

            adj(i,j) = SELF
            reach(i,j) = SELF

          else if ( reach(i,j) == UNKNOWN ) then

            adj(i,j) = NOT_ADJACENT
            reach(i,j) = NOT_REACHABLE

          end if

        end do
      end if
    end do

  else if ( test_type == 'NOADJACENT' ) then

    do i = 1, nobject

      if ( test_set(i) /= 0 ) then

        do j = 1, nobject

          if ( test_set(j) == test_set(i) + 1 ) then

            if ( adj(i,j) == UNKNOWN ) then

              adj(i,j) = NOT_ADJACENT

            else if ( adj(i,j) == NOT_ADJACENT ) then

            else if ( adj(i,j) == SELF ) then

            else
              write ( *, * ) 'NOADJACENT data conflict!'
            end if

          end if

        end do
      end if
    end do

  else if ( test_type == 'NONE' ) then

  else if ( test_type == 'NOREACH' ) then

    do i = 1, nobject

      if ( test_set(i) /= 0 ) then

        do j = 1, nobject

          if ( test_set(j) == test_set(i) + 1 ) then

            if ( adj(i,j) == UNKNOWN ) then

              adj(i,j) = NOT_ADJACENT

            else if ( adj(i,j) == ADJACENT ) then

              write ( *, * ) 'NOREACH data conflict!'

            end if

            if ( reach(i,j) == UNKNOWN ) then

              reach(i,j) = NOT_REACHABLE

            else if ( reach(i,j) == NOT_REACHABLE ) then

            else if ( reach(i,j) == SELF ) then

            else
              write ( *, * ) 'NOREACH data conflict!'
            end if

          end if

        end do
      end if
    end do

  else if ( test_type == 'PARTIAL_ORDER' ) then

!       do i = 1, nobject
!         if ( test_set(i) /= 0 ) then
!           do j = 1, nobject

!             if ( test_set(j) == 0 ) then

!               if ( reach(i,j) == UNKNOWN ) then
!                 reach(i,j) = NOT_REACHABLE
!               else if ( reach(i,j) == NOT_REACHABLE ) then

!               else
!                 write ( *, * ) 'SEQUENCE data conflict!'
!                 write ( *, * ) '  I = ', i
!                 write ( *, * ) '  J = ', j
!                 write ( *, * ) '  REACH(I,J) = ', reach(i,j)
!               end if

!             end if

!           end do
!         end if
!       end do

  else if ( test_type == 'REACH' ) then

    do i = 1, nobject
      if ( test_set(i) /= 0 ) then
        do j = 1, nobject

          if ( test_set(j) == test_set(i) + 1 ) then

            if ( reach(i,j) == NOT_REACHABLE ) then
              write ( *, * ) 'REACH data conflict!'
            else if ( i == j ) then
              reach(i,j) = SELF
            else if ( reach(i,j) == UNKNOWN ) then
              reach(i,j) = nobject - 1
            end if

          end if

        end do
      end if
    end do
!
!  A stimulus was applied.
!  Items labeled 1 were activated first; then items labeled 2, and so on.
!
!  I don't know if we have certain guarantees or not, namely, are ALL
!  the active items at each stage listed?  (In that case, we know for
!  example that items in set 3 cannot be direct descendants of items in
!  set 1, and that the set of immediate descendants of set 1 is 
!  exactly set 2, and so on.
!
!  If set1 = 1 and set2 = 2, do we even know that 2 is reachable from 1?
!
  else if ( test_type == 'SEQUENCE' ) then

    do i = 1, nobject
      if ( test_set(i) /= 0 ) then
        do j = 1, nobject

          if ( test_set(j) == 0 ) then

            if ( reach(i,j) == UNKNOWN ) then
              reach(i,j) = NOT_REACHABLE
            else if ( reach(i,j) == NOT_REACHABLE ) then

            else
              write ( *, * ) 'SEQUENCE data conflict!'
              write ( *, * ) '  I = ', i
              write ( *, * ) '  J = ', j
              write ( *, * ) '  REACH(I,J) = ', reach(i,j)
            end if

          end if

        end do
      end if
    end do

  else if ( test_type == 'TERMINAL' ) then

    do i = 1, nobject
      if ( test_set(i) == 1 ) then
        do j = 1, nobject

          if ( i == j ) then

            adj(i,j) = SELF
            reach(i,j) = SELF

          else if ( reach(i,j) == UNKNOWN ) then

            adj(i,j) = NOT_ADJACENT
            reach(i,j) = NOT_REACHABLE

          else if ( adj(i,j) == ADJACENT .or. reach(i,j) >= 0 ) then

            write ( *, * ) 'TERMINAL data conflict!'
            write ( *, * ) '  I = ', i
            write ( *, * ) '  J = ', j
            write ( *, * ) '  REACH(I,J) = ', reach(i,j)

          end if

        end do
      end if
    end do

  end if

  return
end
function alphabet ( i )
!
!*******************************************************************************
!
!! ALPHABET returns the I-th alphabetic character.
!
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer I, the index of the letter to be returned.
!    1 through 26 requests 'A' through 'Z', (ASCII 65:90);
!    27 through 52 requests 'a' through 'z', (ASCII 97:122);
!    Values of I less than 1 or greater than 52 are illegal, and
!    result in a returned value of '?'.
!
!    Output, character ALPHABET, the requested letter.
!
  implicit none
!
  character alphabet
  integer i
!
  if ( 1 <= i .and. i <= 26 ) then
    alphabet = char ( 64 + i )
  else if ( 27 <= i .and. i <= 52 ) then
    alphabet = char ( 96 + i )
  else
    alphabet = '?'
  end if

  return
end
subroutine init ( adj, label, maxobj, maxtest, nobject, ntest, reach, table, &
  test_set, test_type )
!
!*******************************************************************************
!
!! INIT initializes the data.
!
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Output, integer ADJ(MAXOBJ,MAXOBJ), object-to-object adjacency:
!
!    -3, it is not known if I is directly linked to J;
!    -2, I is not directly linked to J;
!     0, I = J;
!     1, I is directly linked to J.
!
!    Output, character ( len = 3 ) LABEL(MAXOBJ), labels for the objects.
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer MAXTEST, the maximum number of tests.
!
!    Output, integer NOBJECT, the number of objects.
!
!    Output, integer NTEST, the number of tests.  
!
!    Output, integer REACH(MAXOBJ,MAXOBJ), object-to-object reachability:
!    K = -3, it is not known if from I you can reach J;
!    K = -1, from I you cannot reach J;
!    K =  0, I = J;
!    K >  0, from I you can reach J in K steps or less.
!
!    Output, integer TABLE(MAXTEST,MAXOBJ+1).  
!    For J = 1 to NOBJECT, TABLE(I,J), the results of test I.
!    TABLE(I,NOBJECT+1) contains a code for the test type.
!
!    Output, integer TEST_SET(MAXOBJ), a partition of the objects.
!
!    Output, character ( len = 15 ) TEST_TYPE, the type of the test.
!
  implicit none
!
  integer, parameter :: UNKNOWN = -3
  integer, parameter :: SELF = 0

  integer maxobj
  integer maxtest
!
  integer adj(maxobj,maxobj)
  character alphabet
  integer i
  integer j
  character ( len = 3 ) label(maxobj)
  integer nobject
  integer ntest
  integer reach(maxobj,maxobj)
  integer table(maxtest,maxobj+1)
  integer test_set(maxobj)
  character ( len = 15 ) test_type
!
  do i = 1, maxobj
    do j = 1, maxobj
      if ( i == j ) then
        adj(i,j) = SELF
      else
        adj(i,j) = UNKNOWN
      end if
    end do
  end do

  do i = 1, maxobj
    label(i) = alphabet ( i )
  end do

  nobject = 0

  ntest = 0

  do i = 1, maxobj
    do j = 1, maxobj
      if ( i == j ) then
        reach(i,j) = SELF
      else
        reach(i,j) = UNKNOWN
      end if
    end do
  end do

  table(1:maxtest,1:maxobj+1) = 0
  test_set(1:maxtest) = 0
  test_type = 'NONE'

  return
end
subroutine reach_from_adj ( adj, maxobj, nobject, reach )
!
!*******************************************************************************
!
!! REACH_FROM_ADJ computes the reachability matrix from the adjacency matrix.
!
!
!  Discussion:
!
!    We assume that the adjacency matrix is consistent and don't check
!    that the entries are within the proper range and that diagonal entries
!    are 0.
!
!  Modified:
!
!    15 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer ADJ(MAXOBJ,MAXOBJ), object-to-object adjacency:
!
!    -3, it is not known if I is directly linked to J;
!    -2, I is not directly linked to J;
!     0, I = J;
!     1, I is directly linked to J.
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Output, integer REACH(MAXOBJ,MAXOBJ), object-to-object reachability:
!    K = -3, it is not known if from I you can reach J;
!    K = -1, from I you cannot reach J;
!    K =  0, I = J;
!    K >  0, from I you can reach J in K steps or less.
!
  implicit none
!
  integer, parameter :: UNKNOWN = -3
  integer, parameter :: NOT_REACHABLE = -1
  integer, parameter :: SELF = 0
  integer, parameter :: ADJACENT = 1
!
  integer maxobj
!
  integer adj(maxobj,maxobj)
  integer i
  integer j
  integer k
  integer nobject
  integer nstep
  integer reach(maxobj,maxobj)
!
!  Step 0:
!  Every object is definitely reachable from itself in 0 steps.
!
  do i = 1, nobject
    reach(i,i) = SELF
  end do
!
!  Step 1:
!  Determine NOT_REACHABLE nodes.
!  Assume everything is NOT_REACHABLE, but then walk through the
!  network using both real and possible adjacency links, and
!  mark everything you can reach as "UNKNOWN" (which we will interpret
!  right now to mean that we don't know it isn't reachable).
!
  do i = 1, nobject
    do j = 1, nobject
      if ( i /= j ) then
        reach(i,j) = NOT_REACHABLE
      end if
    end do
  end do

  do nstep = 1, nobject - 1
    do i = 1, nobject
      do j = 1, nobject
        if ( reach(i,j) == NOT_REACHABLE ) then
          do k = 1, nobject

            if ( reach(i,k) == UNKNOWN .and. &
               ( adj(k,j) == ADJACENT .or. adj(k,j) == UNKNOWN ) ) then
              reach(i,j) = UNKNOWN
            end if

          end do
        end if
      end do
    end do
  end do
!
!  If REACH(I,J) is still NOT_REACHABLE, then we now definitely know
!  we can't get from I to J.  Now let's go back and see what we know
!  that we can reach.
!
!  Step 2:
!  Determine REACHABLE nodes.
!
!  If an object is knowably reachable in NSTEP steps, that's because an
!  adjacent object is reachable in NSTEP-1 steps.
!
  do nstep = 1, nobject - 1
    do i = 1, nobject
      do j = 1, nobject
        if ( reach(i,j) == UNKNOWN ) then
          do k = 1, nobject

            if ( reach(i,k) > 0 .and. adj(k,j) == ADJACENT ) then
              reach(i,j) = reach(i,k) + 1
            end if

          end do
        end if
      end do
    end do
  end do

  return
end
subroutine reach_print ( label, maxobj, nobject, reach )
!
!*******************************************************************************
!
!! REACH_PRINT prints the known reachability information.
!
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = 3 ) LABEL(MAXOBJ), labels for the objects.
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Input, integer REACH(MAXOBJ,MAXOBJ), object-to-object reachability:
!    K = -3, it is not known if from I you can reach J;
!    K = -1, from I you cannot reach J;
!    K =  0, I = J;
!    K >  0, from I you can reach J in K steps or less.
!
  implicit none
!
  integer, parameter :: UNKNOWN = -3
  integer, parameter :: NOT_REACHABLE = -1
  integer, parameter :: SELF = 0
!
  integer maxobj
!
  character char1
  integer i
  integer j
  character ( len = 3 ) label(maxobj)
  integer nobject
  integer reach(maxobj,maxobj)
  character ( len = 80 ) string
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'REACH_PRINT:'
  write ( *, '(a)' ) '  Current knowledge about reachability:'
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '    ? = UNKNOWN;'
  write ( *, '(a)' ) '    * = NOT_REACHABLE;'
  write ( *, '(a)' ) '    0 = SELF;'
  write ( *, '(a)' ) '    # =   REACHABLE in # steps or less.'
  write ( *, '(a)' ) ' '
  write ( *, '(3x,20a1)' ) ( label(i), i = 1, nobject )
  write ( *, '(a)' ) ' '

  do i = 1, nobject

    do j = 1, nobject

      if ( reach(i,j) == UNKNOWN ) then

        string(j:j) = '?'

      else if ( reach(i,j) == NOT_REACHABLE ) then

        string(j:j) = '*'

      else if ( reach(i,j) == SELF ) then

        string(j:j) = '0'

      else if ( reach(i,j) > 0 ) then

        if ( reach(i,j) <= 9 ) then
          write ( char1, '(i1)' ) reach(i,j)
          string(j:j) = char1
        else
          string(j:j) = '#'
        end if

      else

        string(j:j) = ' '

      end if

    end do

    write ( *, '(a1,2x,a)') label(i), string(1:nobject)

  end do

  return
end
subroutine reach_update ( maxobj, nfix, nobject, reach )
!
!*******************************************************************************
!
!! REACH_UPDATE updates a reachability matrix for consistency.
!
!
!  Discussion:
!
!    This routine performs consistency updates to the reachability
!    matrix after individual reachability items have been modified 
!    because of test information.
!
!    If the reachability matrix now says you can get from I to J, and 
!    from J to K, then this routine ensures that the matrix also says you 
!    can get from I to K.
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Input/output, integer REACH(MAXOBJ,MAXOBJ), object-to-object reachability:
!    K = -3, it is not known if from I you can reach J;
!    K = -1, from I you cannot reach J;
!    K =  0, I = J;
!    K >  0, from I you can reach J in K steps or less.
!
  implicit none
!
  integer, parameter :: UNKNOWN = -3
  integer, parameter :: NOT_REACHABLE = -1
!
  integer maxobj
!
  integer i
  integer ifix
  integer j
  integer k
  integer n_ij
  integer n_ik
  integer n_ik_alt
  integer n_jk
  integer nfix
  integer nobject
  integer reach(maxobj,maxobj)
!
  nfix = 0

  do

    ifix = 0

    do i = 1, nobject
      do j = 1, nobject

        n_ij = reach(i,j)

       if ( n_ij > 0 ) then

          do k = 1, nobject

            n_jk = reach(j,k)

            if ( n_jk > 0 ) then

              n_ik = reach(i,k)

              n_ik_alt = min ( n_ij + n_jk, nobject - 1 )

              if ( n_ik == UNKNOWN ) then

                ifix = ifix + 1
                reach(i,k) = n_ik_alt

              else if ( n_ik == NOT_REACHABLE ) then

                write ( *, * ) ' '
                write ( *, * ) 'REACH_UPDATE - Data conflict!'
                write ( *, * ) '  REACH matrix says:'
                write ( *, * ) '  I = ', i, ' to J = ', j, ' in ', n_ij, ' steps,'
                write ( *, * ) '  J = ', j, ' to K = ', k, ' in ', n_jk, ' steps,'
                write ( *, * ) '  but I to K not possible.'

              else if ( n_ik > n_ik_alt ) then

                ifix = ifix + 1
                reach(i,k) = n_ik_alt

              end if

            end if

          end do
 
        end if

      end do
    end do

    nfix = nfix + ifix

    if ( ifix <= 0 ) then
      exit
    end if
 
  end do

  write ( *, * ) ' '
  write ( *, * ) 'REACH_UPDATE updated ', nfix, ' reachabilities.'

  return
end
subroutine test_add ( maxobj, maxtest, nobject, ntest, table, test_set, &
  test_type )
!
!*******************************************************************************
!
!! TEST_ADD adds the current test results to the test table.
!
!
!  Discussion:
!
!    The current test results comprise:
!
!    * TEST_TYPE, the test type, and
!    * TEST_SET, a partition of the objects into subsets.
!
!    The following test types are considered:
!
!    * ACTIVE ( set0, set1, set2 )
!      A stimulus was applied, and objects in set1 responded positively,
!      and objects in set2 responded negatively.
!
!    * ADJACENT ( set0, set1, set2, set3, ... ) 
!      There is a path, consisting of a single link, from any member
!      of set1 to any member of set2; and from any member of set2
!      to any member of set3, and so on.
!
!    * INITIAL ( set0, set1 )
!      Objects in set1 are "initial" objects.  Changes to any object
!      (except itself) will not affect an object in set1.
!
!    * NOADJACENT ( set0, set1, set2, ... )
!      There is no direct link from any object in set 1 to any object in
!      set 2, and no direct link from any object in set 2 to any object
!      in set 3, and so on.
!
!    * NONE ( )
!      No test was performed.
!
!    * NOREACH ( set0, set1, set2, set3, ... )
!      There is definitely no path from any object in set1 to any
!      object in set2, from any object in set2 to any object in set3,
!      and so on.
!
!    * PARTIAL_ORDER ( set0, set1, set2, set3, ... )
!      There is a path from any element in set1 to any element in set2,
!      and there is no path from any element in set2 to any element in set1.
!      Similarly, from set2 to set3, but not set3 to set 1 or 2.
!      This implies a partial ordering of the objects in sets 1, 2, 3, ...
!      This is similar to the SEQUENCE test, but stronger.
!
!    * REACH ( set0, set1, set2, set3, ... ) 
!      There is a path starting at any element of set1, to any element
!      of set2, to any element of set3, and so on.
!
!    * SEQUENCE ( set0, set1, set2, set3, ... )
!      A stimulus was applied.  Items in set1 were activated, THEN
!      items in set2, and so on.  
!
!    * TERMINAL ( set0, set1 )
!      Objects in set1 are "terminal" objects.  Changes to an object
!      in set1 will not affect any other objects.
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer MAXTEST, the maximum number of tests.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Input, integer NTEST, the number of tests.  It is assumed that
!    the data for the NTEST-th test has just been input.
!
!    Input/output, integer TABLE(MAXTEST,MAXOBJ+1).  
!    For J = 1 to NOBJECT, TABLE(I,J) contains the results of test I.
!    TABLE(I,NOBJECT+1) contains a code for the test type.
!
!    Input, integer TEST_SET(MAXOBJ), a partition of the objects.
!
!    Input, character ( len = 15 ) TEST_TYPE, the type of the test.
!
  implicit none
!
  integer maxobj
  integer maxtest
!
  integer j
  integer nobject
  integer ntest
  integer table(maxtest,maxobj+1)
  integer test_set(maxobj)
  character ( len = 15 ) test_type
!
  do j = 1, nobject
    table(ntest,j) = test_set(j)
  end do

  if ( test_type == 'ACTIVE' ) then
    table(ntest,nobject+1) = 1
  else if ( test_type == 'ADJACENT' ) then
    table(ntest,nobject+1) = 2
  else if ( test_type == 'INITIAL' ) then
    table(ntest,nobject+1) = 3
  else if ( test_type == 'NOADJACENT' ) then
    table(ntest,nobject+1) = 4
  else if ( test_type == 'NONE' ) then
    table(ntest,nobject+1) = 5
  else if ( test_type == 'NOREACH' ) then
    table(ntest,nobject+1) = 6
  else if ( test_type == 'PARTIAL_ORDER' ) then
    table(ntest,nobject+1) = 7
  else if ( test_type == 'REACH' ) then
    table(ntest,nobject+1) = 8
  else if ( test_type == 'SEQUENCE' ) then
    table(ntest,nobject+1) = 9
  else if ( test_type == 'TERMINAL' ) then
    table(ntest,nobject+1) = 10
  end if

  return
end
subroutine test_next ( maxobj, nobject, ntest, test_set, test_type )
!
!*******************************************************************************
!
!! TEST_NEXT returns the results for the next test.
!
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Input/output, integer NTEST, the number of tests.  On output,
!    NTEST has been incremented by 1.
!
!    Output, integer TEST_SET(MAXOBJ), a partition of the objects.
!
!    Output, character ( len = 15 ) TEST_TYPE, the type of the test.
!
  implicit none
!
  integer maxobj
!
  integer i
  integer nobject
  integer ntest
  integer test_set(maxobj)
  character ( len = 15 ) test_type
!
  ntest = ntest + 1
  
  do i = 1, nobject
    test_set(i) = 0
  end do

  if ( ntest == 1 ) then

    test_type = 'ACTIVE'

    test_set(2) = 1
    test_set(3) = 2
    test_set(5) = 1
    test_set(6) = 1
    test_set(8) = 2
      
  else if ( ntest == 2 ) then

    test_type = 'ACTIVE'

    test_set(1) = 1
    test_set(2) = 2
    test_set(8) = 1

  else if ( ntest == 3 ) then

    test_type = 'TERMINAL'

    test_set(7) = 1
    test_set(8) = 1

  else if ( ntest == 4 ) then

    test_type = 'INITIAL'

    test_set(4) = 1
    test_set(5) = 1

  else if ( ntest == 5 ) then

    test_type = 'NOREACH'

    test_set(3) = 1

    test_set(2) = 2
    test_set(6) = 2
    test_set(8) = 2

  else if ( ntest == 6 ) then

    test_type = 'REACH'

    test_set(5) = 1

    test_set(6) = 2

    test_set(2) = 3
    test_set(3) = 3

  else if ( ntest == 7 ) then

    test_type = 'SEQUENCE'

    test_set(5) = 1

    test_set(6) = 2

    test_set(2) = 3
    test_set(3) = 3

    test_set(8) = 4

  else if ( ntest == 8 ) then

    test_type = 'ADJACENT'

    test_set(5) = 1

    test_set(6) = 2

    test_set(2) = 3

    test_set(8) = 4

  else if ( ntest == 9 ) then

    test_type = 'NOADJACENT'

    test_set(4) = 1

    test_set(1) = 2
    test_set(5) = 2

    test_set(7) = 3

  else if ( ntest == 10 ) then

    test_type = 'PARTIAL_ORDER'

    test_set(5) = 1

    test_set(6) = 2
    test_set(2) = 2

    test_set(8) = 3

  else

    test_type = 'NONE'

  end if

  return
end
subroutine test_print ( label, maxobj, nobject, test_index, test_set, &
  test_type )
!
!*******************************************************************************
!
!! TEST_PRINT prints out information about a single test.
!
!
!  Discussion:
!
!    The following test types are considered:
!
!      ACTIVE ( set0, set1, set2 )
!        A stimulus was applied, and objects in set1 responded positively,
!        and objects in set2 responded negatively.
!
!      ADJACENT ( set0, set1, set2, set3, ... ) 
!        There is a path, consisting of a single link, from any member
!        of set1 to any member of set2; and from any member of set2
!        to any member of set3, and so on.
!
!      INITIAL ( set0, set1 )
!        Objects in set1 are "initial" objects.  Changes to any object
!        (except itself) will not affect an object in set1.
!
!      NOADJACENT ( set0, set1, set2, ... )
!        There is no direct link from any object in set 1 to any object in
!        set 2, and no direct link from any object in set 2 to any object
!        in set 3, and so on.
!
!      NONE ( )
!        No test was performed.
!
!      NOREACH ( set0, set1, set2, set3, ... )
!        There is definitely no path from any object in set1 to any
!        object in set2, from any object in set2 to any object in set3,
!        and so on.
!
!      PARTIAL_ORDER ( set0, set1, set2, set3, ... )
!        There is a path from any element in set1 to any element in set2,
!        and there is no path from any element in set2 to any element in set1.
!        Similarly, from set2 to set3, but not set3 to set 1 or 2.
!        This implies a partial ordering of the objects in sets 1, 2, 3, ...
!        This is similar to the SEQUENCE test, but stronger.
!
!      REACH ( set0, set1, set2, set3, ... ) 
!        There is a path starting at any element of set1, to any element
!        of set2, to any element of set3, and so on.
!
!      SEQUENCE ( set0, set1, set2, set3, ... )
!        A stimulus was applied.  Items in set1 were activated, THEN
!        items in set2, and so on.  
!
!      TERMINAL ( set0, set1 )
!        Objects in set1 are "terminal" objects.  Changes to an object
!        in set1 will not affect any other objects.
!
!  Modified:
!
!    14 May 1999
!
!  Author:
!
!    John Burkardt
!
!  Parameters:
!
!    Input, character ( len = 3 ) LABEL(MAXOBJ), labels for the objects.
!
!    Input, integer MAXOBJ, the maximum number of objects.
!
!    Input, integer NOBJECT, the number of objects.
!
!    Input, integer TEST_INDEX, the index of the test.  
!
!    Input, integer TEST_SET(MAXOBJ), a partition of the objects.
!
!    Input, character ( len = 15 ) TEST_TYPE, the type of the test.
!
  implicit none
!
  integer maxobj
!
  integer i
  integer ihi
  integer ilo
  character ( len = 3 ) label(maxobj)
  integer nobject
  character ( len = 80 ) string
  integer test_index
  integer test_set(maxobj)
  character ( len = 15 ) test_type
!
  write ( *, * ) ' '
  write ( *, * ) 'Test index = ', test_index
  write ( *, * ) 'Test type = ' // trim ( test_type )

  if ( test_type == 'ACTIVE' ) then

    string = ' '

    do i = 1, nobject
  
      ilo = 3*(i-1) + 1
      ihi = ilo + 2

      if ( test_set(i) == 0 ) then
        string(ilo:ihi) = '  0'
      else if ( test_set(i) == 1 ) then
        string(ilo:ihi) = ' +1'
      else if ( test_set(i) == 2 ) then
        string(ilo:ihi) = ' -1'
      end if

    end do

    write ( *, * )' '
    write ( *, * ) 'Activated objects:'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(a)' ) string(1:3*nobject)

  else if ( test_type == 'ADJACENT' ) then

    write ( *, * )' '
    write ( *, * ) 'One step path from set 1 to 2, 2 to 3, etc::'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(20i3)' ) ( test_set(i), i = 1, nobject )

  else if ( test_type == 'INITIAL' ) then

    string = ' '

    do i = 1, nobject
  
      ilo = 3*(i-1) + 1
      ihi = ilo + 2

      if ( test_set(i) == 0 ) then
        string(ilo:ihi) = '   '
      else if ( test_set(i) == 1 ) then
        string(ilo:ihi) = '  1'
      end if

    end do

    write ( *, * )' '
    write ( *, * ) 'Initial objects:'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(a)' ) string(1:3*nobject)

  else if ( test_type == 'NOADJACENT' ) then

    write ( *, * )' '
    write ( *, * ) 'No direct link from set 1 to 2, 2 to 3, etc::'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(20i3)' ) ( test_set(i), i = 1, nobject )

  else if ( test_type == 'NONE' ) then

  else if ( test_type == 'NOREACH' ) then

    write ( *, * )' '
    write ( *, * ) 'No path from set 1 to 2, 2 to 3, etc::'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(20i3)' ) ( test_set(i), i = 1, nobject )

  else if ( test_type == 'PARTIAL_ORDER' ) then

    write ( *, * )' '
    write ( *, * ) 'Partial ordering, set1 > set2, etc:'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(20i3)' ) ( test_set(i), i = 1, nobject )

  else if ( test_type == 'REACH' ) then

    write ( *, * )' '
    write ( *, * ) 'From any object in set 1'
    write ( *, * ) '  you can reach any object in set 2,'
    write ( *, * ) 'from any object in set 2'
    write ( *, * ) '  you can reach any object in set 3,'
    write ( *, * ) 'and so on.'
    write ( *, * ) ' '
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(20i3)' ) ( test_set(i), i = 1, nobject )

  else if ( test_type == 'SEQUENCE' ) then

    write ( *, * )' '
    write ( *, * ) 'Sequential activation, set1, set2, etc:'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(20i3)' ) ( test_set(i), i = 1, nobject )

  else if ( test_type == 'TERMINAL' ) then

    string = ' '

    do i = 1, nobject
  
      ilo = 3*(i-1) + 1
      ihi = ilo + 2

      if ( test_set(i) == 0 ) then
        string(ilo:ihi) = '   '
      else if ( test_set(i) == 1 ) then
        string(ilo:ihi) = '  1'
      end if

    end do

    write ( *, * )' '
    write ( *, * ) 'Terminal objects:'
    write ( *, '(20i3)' ) ( i, i = 1, nobject )
    write ( *, '(20(2x,a1))' ) ( label(i), i = 1, nobject )
    write ( *, '(a)' ) string(1:3*nobject)

  else

    write ( *, * ) ' '
    write ( *, * ) 'TEST_PRINT - Warning!'
    write ( *, * ) '  Unrecognized test type = ' // trim ( test_type )

  end if

  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