      subroutine pvm_fitness (slave, num_jobs, npar, oldph, fitness)
c ---------------------------------------------
c     parallel fitness evaluation using PVM
c ---------------------------------------------
      implicit none

      include '../include/fpvm3.h'

      integer job, info, nhost, msgtype, iwhich, i, looptimer
      integer mytid, dtid, tids(0:128), flag, ntask
      integer ttids(32), ptids(32), htids(32), flags(32)
      integer speed, narch, numt, npar, nspawn, last, wait
      integer num_jobs, ndone, length, par, trial, listen
      integer try, finished(1000), resubmitted(1000)

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

      character*40 hostname
      character*18 host
      character*8 slave, arch
      character*8 aout(32)

      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     enroll this program in PVM
c ---------------------------------------------
      call pvmfmytid( mytid )
      call pvmfconfig( nhost, narch, dtid, host, arch, speed, info )
c ---------------------------------------------
c     run jobs on slave nodes only
c ---------------------------------------------
c      arch = '.'
c      flag = PvmTaskHost+PvmHostCompl
c      nspawn = nhost-1
c     uncomment line below for dual-processor nodes
c      nspawn = 2*(nhost-1)
c ---------------------------------------------
c     run jobs on master and slave nodes
c ---------------------------------------------
      arch = '*'
      flag = PvmDefault
      nspawn = nhost
c     uncomment line below for dual-processor nodes
      nspawn = 2*nhost
      call pvmfspawn( slave, flag, arch, nspawn, tids, numt )
c ---------------------------------------------
c     check for problems spawning slaves
c ---------------------------------------------
      if( numt .lt. nspawn ) then
         write(*,*) 'trouble spawning ',slave
         write(*,*) ' Check tids for error code'
         call shutdown( numt, tids )
      endif
c ---------------------------------------------
c     send an initial job to each node
c ---------------------------------------------
      do job=0,nspawn-1

         trial = job + 1
         do par=1,npar
            data(par) = oldph(par,trial)
         enddo

         call pvmfinitsend( PVMDEFAULT, info )
         call pvmfpack( INTEGER4, trial, 1, 1, info )
         call pvmfpack( INTEGER4, try, 1, 1, info )
         call pvmfpack( INTEGER4, npar, 1, 1, info )
         call pvmfpack( REAL8, data, npar, 1, info ) 
         msgtype  = 1 
         call pvmfsend( tids(job), msgtype, info )
      enddo

      do job=1,num_jobs
c ---------------------------------------------
c     listen for responses
c ---------------------------------------------
 25      msgtype  = 2 
         call pvmfnrecv( -1, msgtype, info )
         listen = listen + 1

         if (info .GT. 0) then
            listen = 0
            wait = 0
c ---------------------------------------------
c     get data from responding node
c ---------------------------------------------
            call pvmfunpack( INTEGER4, trial, 1, 1, info )
            call pvmfunpack( REAL8, result, 1, 1, info )
            call pvmfunpack( INTEGER4, length, 1, 1, info )
            call pvmfunpack( STRING, hostname, length, 1, info )
c ---------------------------------------------
c     re-send jobs that return crash signal
c ---------------------------------------------
            if ((result .eq. 0.0).and.(resubmitted(trial).ne.1)) then
               call sendjob(trial,hostname,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,hostname,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,hostname,npar,2,resubmitted,oldph)
                  wait = 1
                  goto 25
               endif
            enddo
         endif
c ---------------------------------------------
c     return to listen again or move on
c ---------------------------------------------
         if ((info .EQ. 0).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     kill any remaining jobs
c ---------------------------------------------
 199  iwhich = PVMDEFAULT
      call pvmftasks( iwhich, ntask, ttids(1), ptids(1),
     &                htids(1), flags(1), aout(1), info )
      do i=2,ntask
         call pvmftasks( iwhich, ntask, ttids(i), ptids(i),
     &                   htids(i), flags(i), aout(i), info )
         if (aout(i) .EQ. 'ff_slave') then
            call pvmfkill (ttids(i), info)
         endif
      enddo

      call pvmfexit(info) 

      return
      end
c**********************************************************************
      subroutine sendjob(trial,hostname,npar,try,resubmitted,oldph)

      implicit none

      include '../include/fpvm3.h'

      integer tids(0:128), numt, msgtype, par, npar, trial, info, try
      integer resubmitted(1000)

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

      character*40 hostname

      call pvmfspawn( 'ff_slave', 1, hostname, 1, tids, numt )

      if ( numt .lt. 1 ) then
         write(*,*) 'trouble spawning ff_slave'
         write(*,*) ' Check tids for error code'
         call shutdown( numt, tids )
      endif

      do par=1,npar
         data(par) = oldph(par,trial)
      enddo

      call pvmfinitsend( PVMDEFAULT, info )
      call pvmfpack( INTEGER4, trial, 1, 1, info )
      call pvmfpack( INTEGER4, try, 1, 1, info )
      call pvmfpack( INTEGER4, npar, 1, 1, info )
      call pvmfpack( REAL8, data, npar, 1, info )
      msgtype  = 1
      call pvmfsend( tids(0), msgtype, info )

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

      return
      end
c**********************************************************************
      subroutine shutdown( nproc, tids )

      implicit none

      integer nproc, i, info, tids(*)

      do i=0, nproc
         call pvmfkill( tids(i), info )
      enddo

      call pvmfexit( info )

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