ga_fitness_mpi.f

      SUBROUTINE ga_fitness_mpi (np, fvec, nopt, fcn, nfev, funcval)
      USE ga_mod
      USE mpi_params, ONLY: master, myid
      USE mpi_inc
      IMPLICIT NONE
 
      INTEGER :: np, nopt, nfev
      REAL(rprec), DIMENSION(nopt) :: fvec
      REAL(rprec) :: funcval(np)
      EXTERNAL fcn
 
#if defined(MPI_OPT)
      INTEGER :: j, iflag, istat
 
      INTEGER :: status(MPI_STATUS_size)                     !mpi stuff
      INTEGER :: numprocs, i                           !mpi stuff
      INTEGER :: numsent, sender, ierr                       !mpi stuff
      INTEGER :: anstype, column                             !mpi stuff
      REAL(rprec), DIMENSION(nparam) :: x
!******************************************
!
!  mpi setup calls; set barrier so ALL processors get here before starting
!
      CALL mpi_comm_rank( mpi_comm_world, myid, ierr )       !mpi stuff
      CALL mpi_comm_size( mpi_comm_world, numprocs, ierr )   !mpi stuff
      CALL mpi_barrier(mpi_comm_world, ierr)                 !mpi stuff
 
!******************************************
!
!     ****Master portion of the code****
!
      IF (myid .eq. master) THEN
         numsent = 0    !numsent is a counter used to track how many
                        !jobs have been sent to workers
c
c     SEND forward difference displacements from master to each
c           worker process. Tag with these with the column number.
c
         DO j = 1,min(numprocs-1,np)
            x(:) = parent(:,j)
            CALL mpi_send(x, nparam, mpi_real8, j,
     1                  j, mpi_comm_world, ierr)
            IF (ierr .ne. 0) stop 'MPI_SEND error(1) in ga_fitness_mpi'
            numsent = numsent+1
         END DO          !j = 1,MIN(numprocs-1,n)
c
c      Looping through the columns, collect answers from the workers.
c      As answers are received, new uncalculated columns are sent
c      out to these same workers.
c
         DO j = 1,np
            CALL mpi_recv(fvec, nopt, mpi_real8,
     1           mpi_any_source, mpi_any_tag,
     2           mpi_comm_world, status, ierr)
            IF (ierr .ne. 0) stop 'MPI_RECV error(1) in ga_fitness_mpi'
            sender     = status(mpi_source)
            anstype    = status(mpi_tag)       ! column is tag value
            IF (anstype .gt. np) stop 'ANSTYPE > NP IN ga_fitness_mpi'
 
            funcval(anstype) = -sum(fvec(:nopt)**2)
            WRITE(6,'(a,1pe10.3,a,i3,a,i3)')' FUNCVAL = ',
     1       -funcval(anstype),
     2      ' for iteration ', anstype+nfev,' processor = ', sender
 
c
c           If more columns are left, THEN sEND another column to the worker(sender)
c           that just sent in an answer
c
            IF (numsent .lt. np) THEN
               numsent = numsent+1
               x(:) = parent(:,numsent)
 
               CALL mpi_send(x, nparam, mpi_real8,
     1                       sender, numsent, mpi_comm_world, ierr)
               IF (ierr .ne. 0)
     1            stop 'MPI_SEND error(2) in ga_fitness_mpi'
 
            ELSE                ! Tell worker that there is no more work to DO
 
               CALL mpi_send(mpi_bottom, 0, mpi_real8,
     1                       sender, 0, mpi_comm_world, ierr)
               IF (ierr .ne. 0)stop 'MPI_end error(3) in ga_fitness_mpi'
            ENDIF      ! IF( myid .eq. master ) THEN
         END DO     ! DO j = 1,n
c
c     ****Worker portion of the code****
c        Skip this when processor id exceeds work to be done
c
      ELSE IF (myid .le. np) THEN        ! i.e., IF( myid .ne. master )
c
c        Otherwise accept the next available column, check the tag,
c        and IF the tag is non-zero CALL SUBROUTINE fcn.
c        If the tag is zero, there are no more columns
c        and worker skips to the END.
c
 90      CALL mpi_recv(x, nparam, mpi_real8, master,
     1                 mpi_any_tag, mpi_comm_world, status, ierr)
         IF (ierr .ne. 0) stop 'MPI_RECV error(2) in ga_fitness_mpi'
 
         column = status(mpi_tag)                !!ID of pseudo-processor issuing this message
         IF (column .eq. 0) THEN
            GOTO 200
         ELSE
            iflag = column
c           CALL the chisq fcn for the portion of displacement vector which
c           was just received. Note that WA stores the local fvec_min array
 
            CALL fcn(nopt, nparam, x, fvec, iflag, nfev)
            IF (iflag.ne.0) GOTO 300
c
c           Send this function evaluation back to the master process tagged
c           with the column number so the master knows where to put it
c
            CALL mpi_send(fvec, nopt, mpi_real8, master,
     1                    column, mpi_comm_world, ierr)
            IF (ierr .ne. 0) stop 'MPI_SEND error(4) in ga_fitness_mpi'
            GOTO 90    !Return to 90 and check IF master process has sent ANY more jobs
         END IF
 200     CONTINUE
      ENDIF       ! IF( myid .ne. master )
 
!
!     Broadcast the funcval array to ALL processors FROM master
!
      CALL mpi_bcast(funcval, np, mpi_real8, master,
     1     mpi_comm_world, ierr)
      IF (ierr .ne. 0) GOTO 100
 
      RETURN
 
 100  CONTINUE
      WRITE (6,*) ' MPI_BCAST error in ga_fitness_mpi: IERR=', ierr
 
      RETURN
 
 300  CONTINUE
      WRITE (6,*) ' IFLAG = ', iflag, ' in ga_fitness_mpi CALL to fcn'
      stop
 
#endif
      END SUBROUTINE ga_fitness_mpi