1 SUBROUTINE ga_fitness_mpi (np, fvec, nopt, fcn, nfev, funcval)
3 USE mpi_params,
ONLY: master, myid
7 INTEGER :: np, nopt, nfev
8 REAL(rprec),
DIMENSION(nopt) :: fvec
9 REAL(rprec) :: funcval(np)
13 INTEGER :: j, iflag, istat
15 INTEGER :: status(MPI_STATUS_size)
16 INTEGER :: numprocs, i
17 INTEGER :: numsent, sender, ierr
18 INTEGER :: anstype, column
19 REAL(rprec),
DIMENSION(nparam) :: x
24 CALL mpi_comm_rank( mpi_comm_world, myid, ierr )
25 CALL mpi_comm_size( mpi_comm_world, numprocs, ierr )
26 CALL mpi_barrier(mpi_comm_world, ierr)
32 IF (myid .eq. master)
THEN
39 DO j = 1,min(numprocs-1,np)
41 CALL mpi_send(x, nparam, mpi_real8, j,
42 1 j, mpi_comm_world, ierr)
43 IF (ierr .ne. 0) stop
'MPI_SEND error(1) in ga_fitness_mpi'
52 CALL mpi_recv(fvec, nopt, mpi_real8,
53 1 mpi_any_source, mpi_any_tag,
54 2 mpi_comm_world, status, ierr)
55 IF (ierr .ne. 0) stop
'MPI_RECV error(1) in ga_fitness_mpi'
56 sender = status(mpi_source)
57 anstype = status(mpi_tag)
58 IF (anstype .gt. np) stop
'ANSTYPE > NP IN ga_fitness_mpi'
60 funcval(anstype) = -sum(fvec(:nopt)**2)
61 WRITE(6,
'(a,1pe10.3,a,i3,a,i3)')
' FUNCVAL = ',
63 2
' for iteration ', anstype+nfev,
' processor = ', sender
69 IF (numsent .lt. np)
THEN
71 x(:) = parent(:,numsent)
73 CALL mpi_send(x, nparam, mpi_real8,
74 1 sender, numsent, mpi_comm_world, ierr)
76 1 stop
'MPI_SEND error(2) in ga_fitness_mpi'
80 CALL mpi_send(mpi_bottom, 0, mpi_real8,
81 1 sender, 0, mpi_comm_world, ierr)
82 IF (ierr .ne. 0)stop
'MPI_end error(3) in ga_fitness_mpi'
89 ELSE IF (myid .le. np)
THEN
96 90
CALL mpi_recv(x, nparam, mpi_real8, master,
97 1 mpi_any_tag, mpi_comm_world, status, ierr)
98 IF (ierr .ne. 0) stop
'MPI_RECV error(2) in ga_fitness_mpi'
100 column = status(mpi_tag)
101 IF (column .eq. 0)
THEN
108 CALL fcn(nopt, nparam, x, fvec, iflag, nfev)
109 IF (iflag.ne.0)
GOTO 300
114 CALL mpi_send(fvec, nopt, mpi_real8, master,
115 1 column, mpi_comm_world, ierr)
116 IF (ierr .ne. 0) stop
'MPI_SEND error(4) in ga_fitness_mpi'
125 CALL mpi_bcast(funcval, np, mpi_real8, master,
126 1 mpi_comm_world, ierr)
127 IF (ierr .ne. 0)
GOTO 100
132 WRITE (6,*)
' MPI_BCAST error in ga_fitness_mpi: IERR=', ierr
137 WRITE (6,*)
' IFLAG = ', iflag,
' in ga_fitness_mpi CALL to fcn'
141 END SUBROUTINE ga_fitness_mpi