V3FIT
ga_fitness_mpi.f
1  SUBROUTINE ga_fitness_mpi (np, fvec, nopt, fcn, nfev, funcval)
2  USE ga_mod
3  USE mpi_params, ONLY: master, myid
4  USE mpi_inc
5  IMPLICIT NONE
6 
7  INTEGER :: np, nopt, nfev
8  REAL(rprec), DIMENSION(nopt) :: fvec
9  REAL(rprec) :: funcval(np)
10  EXTERNAL fcn
11 
12 #if defined(MPI_OPT)
13  INTEGER :: j, iflag, istat
14 
15  INTEGER :: status(MPI_STATUS_size) !mpi stuff
16  INTEGER :: numprocs, i !mpi stuff
17  INTEGER :: numsent, sender, ierr !mpi stuff
18  INTEGER :: anstype, column !mpi stuff
19  REAL(rprec), DIMENSION(nparam) :: x
20 !******************************************
21 !
22 ! mpi setup calls; set barrier so ALL processors get here before starting
23 !
24  CALL mpi_comm_rank( mpi_comm_world, myid, ierr ) !mpi stuff
25  CALL mpi_comm_size( mpi_comm_world, numprocs, ierr ) !mpi stuff
26  CALL mpi_barrier(mpi_comm_world, ierr) !mpi stuff
27 
28 !******************************************
29 !
30 ! ****Master portion of the code****
31 !
32  IF (myid .eq. master) THEN
33  numsent = 0 !numsent is a counter used to track how many
34  !jobs have been sent to workers
35 c
36 c SEND forward difference displacements from master to each
37 c worker process. Tag with these with the column number.
38 c
39  DO j = 1,min(numprocs-1,np)
40  x(:) = parent(:,j)
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'
44  numsent = numsent+1
45  END DO !j = 1,MIN(numprocs-1,n)
46 c
47 c Looping through the columns, collect answers from the workers.
48 c As answers are received, new uncalculated columns are sent
49 c out to these same workers.
50 c
51  DO j = 1,np
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) ! column is tag value
58  IF (anstype .gt. np) stop 'ANSTYPE > NP IN ga_fitness_mpi'
59 
60  funcval(anstype) = -sum(fvec(:nopt)**2)
61  WRITE(6,'(a,1pe10.3,a,i3,a,i3)')' FUNCVAL = ',
62  1 -funcval(anstype),
63  2 ' for iteration ', anstype+nfev,' processor = ', sender
64 
65 c
66 c If more columns are left, THEN sEND another column to the worker(sender)
67 c that just sent in an answer
68 c
69  IF (numsent .lt. np) THEN
70  numsent = numsent+1
71  x(:) = parent(:,numsent)
72 
73  CALL mpi_send(x, nparam, mpi_real8,
74  1 sender, numsent, mpi_comm_world, ierr)
75  IF (ierr .ne. 0)
76  1 stop 'MPI_SEND error(2) in ga_fitness_mpi'
77 
78  ELSE ! Tell worker that there is no more work to DO
79 
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'
83  ENDIF ! IF( myid .eq. master ) THEN
84  END DO ! DO j = 1,n
85 c
86 c ****Worker portion of the code****
87 c Skip this when processor id exceeds work to be done
88 c
89  ELSE IF (myid .le. np) THEN ! i.e., IF( myid .ne. master )
90 c
91 c Otherwise accept the next available column, check the tag,
92 c and IF the tag is non-zero CALL SUBROUTINE fcn.
93 c If the tag is zero, there are no more columns
94 c and worker skips to the END.
95 c
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'
99 
100  column = status(mpi_tag) !!ID of pseudo-processor issuing this message
101  IF (column .eq. 0) THEN
102  GOTO 200
103  ELSE
104  iflag = column
105 c CALL the chisq fcn for the portion of displacement vector which
106 c was just received. Note that WA stores the local fvec_min array
107 
108  CALL fcn(nopt, nparam, x, fvec, iflag, nfev)
109  IF (iflag.ne.0) GOTO 300
110 c
111 c Send this function evaluation back to the master process tagged
112 c with the column number so the master knows where to put it
113 c
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'
117  GOTO 90 !Return to 90 and check IF master process has sent ANY more jobs
118  END IF
119  200 CONTINUE
120  ENDIF ! IF( myid .ne. master )
121 
122 !
123 ! Broadcast the funcval array to ALL processors FROM master
124 !
125  CALL mpi_bcast(funcval, np, mpi_real8, master,
126  1 mpi_comm_world, ierr)
127  IF (ierr .ne. 0) GOTO 100
128 
129  RETURN
130 
131  100 CONTINUE
132  WRITE (6,*) ' MPI_BCAST error in ga_fitness_mpi: IERR=', ierr
133 
134  RETURN
135 
136  300 CONTINUE
137  WRITE (6,*) ' IFLAG = ', iflag, ' in ga_fitness_mpi CALL to fcn'
138  stop
139 
140 #endif
141  END SUBROUTINE ga_fitness_mpi
mpi_inc
Umbrella module avoid multiple inlcudes of the mpif.h header.
Definition: mpi_inc.f:11