      subroutine mpi_fitness (num_jobs, npar, oldph, fitness)
c ---------------------------------------------
c     parallel fitness evaluation using MPI
c ---------------------------------------------
      implicit none

      include '/usr/lib/mpich/include/mpif.h'
      
      integer looptimer, listen, wait, ndone, job, num_jobs
      integer finished(1024), resubmitted(1024), try
      integer nproc, ierr, nspawn, msgtype, trial, slave
      integer par, npar, last, status(MPI_STATUS_SIZE)

      double precision data(32), result
      real oldph(32,1024), fitness(1024)

      logical receiving

      parameter(looptimer=10000000)

c ---------------------------------------------
c     initialize book-keeping variables
c ---------------------------------------------
      listen = 0
      wait = 0
      ndone = 0
      do job=1,num_jobs
         finished(job) = 0
         resubmitted(job) = 0
      enddo
      try = 1
c ---------------------------------------------
c     determine number of processors
c ---------------------------------------------
      call mpi_comm_size( MPI_COMM_WORLD, nproc, ierr )

c ---------------------------------------------
c     run jobs on slave nodes only
c ---------------------------------------------
      nspawn = nproc - 1

c ---------------------------------------------
c     send an initial job to each node
c ---------------------------------------------
      msgtype = 1 
      do job=1,nspawn
         trial = job
         slave = job

         do par=1,npar
            data(par) = INT((100*oldph(par,trial))+0.5)/100.
         enddo

         call mpi_send( trial, 1, MPI_INTEGER, slave,
     +                  msgtype, MPI_COMM_WORLD, ierr )
         call mpi_send( try, 1, MPI_INTEGER, slave,
     +                  msgtype, MPI_COMM_WORLD, ierr )
         call mpi_send( npar, 1, MPI_INTEGER, slave,
     +                  msgtype, MPI_COMM_WORLD, ierr )
         call mpi_send( data, npar, MPI_DOUBLE_PRECISION, slave,
     +                  msgtype, MPI_COMM_WORLD, ierr )
      enddo

      do job=1,num_jobs
c ---------------------------------------------
c     listen for responses
c ---------------------------------------------
 25      msgtype  = 2 
         call mpi_iprobe( MPI_ANY_SOURCE, msgtype, MPI_COMM_WORLD,
     +                    receiving, status, ierr )
         listen = listen + 1

         if (receiving) then
            listen = 0
            wait = 0
c ---------------------------------------------
c     get data from responding node
c ---------------------------------------------
            call mpi_recv( slave, 1, MPI_INTEGER, MPI_ANY_SOURCE,
     +                     msgtype, MPI_COMM_WORLD, status, ierr )
            call mpi_recv( trial, 1, MPI_INTEGER, slave,
     +                     msgtype, MPI_COMM_WORLD, status, ierr )
            call mpi_recv( result, 1, MPI_DOUBLE_PRECISION, slave,
     +                     msgtype, MPI_COMM_WORLD, status, ierr )

c ---------------------------------------------
c     re-send jobs that return crash signal
c ---------------------------------------------
            if ((result .eq. 0.0).and.(resubmitted(trial).ne.1)) then
               call sendjob(trial,slave,npar,2,resubmitted,oldph)
               goto 25
            endif

            fitness(trial) = result
            finished(trial) = 1
            ndone = ndone + 1

c ---------------------------------------------
c     send new job to responding node
c ---------------------------------------------
 140        if (ndone .LE. (num_jobs-nspawn)) then
               trial = job + nspawn
               call sendjob(trial,slave,npar,1,resubmitted,oldph)
            endif
            goto 100
         endif
c ---------------------------------------------
c     re-submit crashed jobs to free nodes
c ---------------------------------------------
         if (ndone .GT.(num_jobs-nspawn)) then
            last = ndone-nspawn
            if (ndone .GE.(num_jobs-5)) last=ndone
            do trial=1,last
               if ((finished(trial).NE.1).AND.
     &         (resubmitted(trial).NE.1).AND.(wait.NE.1)) then
                  call sendjob(trial,slave,npar,2,resubmitted,oldph)
                  wait = 1
                  goto 25
               endif
            enddo
         endif
c ---------------------------------------------
c     return to listen again or move on
c ---------------------------------------------
         if ((.NOT. receiving).AND.(listen .LT. looptimer)) goto 25

         do trial=1,num_jobs
            if ((finished(trial) .NE. 1).AND.
     &          (resubmitted(trial) .EQ. 1)) then
               fitness(trial) = 0.0
               finished(trial) = 1
               ndone = ndone + 1
            endif
         enddo
         goto 199
 100     continue
      enddo
c ---------------------------------------------
c     ready for next generation of jobs
c ---------------------------------------------
 199  return
      end
c**********************************************************************
      subroutine sendjob(trial,slave,npar,try,resubmitted,oldph)

      implicit none

      include '/usr/lib/mpich/include/mpif.h'

      integer trial, slave, par, npar, try, ierr
      integer resubmitted(1024), msgtype

      double precision data(32)
      real oldph(32,1024)

      do par=1,npar
         data(par) = INT((100*oldph(par,trial))+0.5)/100.
      enddo

      msgtype = 1
      call mpi_send( trial, 1, MPI_INTEGER, slave,
     +               msgtype, MPI_COMM_WORLD, ierr )
      call mpi_send( try, 1, MPI_INTEGER, slave,
     +               msgtype, MPI_COMM_WORLD, ierr )
      call mpi_send( npar, 1, MPI_INTEGER, slave,
     +               msgtype, MPI_COMM_WORLD, ierr )
      call mpi_send( data, npar, MPI_DOUBLE_PRECISION, slave,
     +               msgtype, MPI_COMM_WORLD, ierr )

      if (try .EQ. 2) resubmitted(trial) = 1

      return
      end
c**********************************************************************
