V3FIT
ga_evalout.f90
1  SUBROUTINE ga_evalout(fbar, best, fcn, nopt, fvec, nfev, &
2  num_processors, iflag, myid)
3 !#######################################################################
4 !
5 ! this subroutine evaluates the population, assigns fitness,
6 !c establishes the best individual, and outputs information.
7  USE ga_mod
8  USE mpi_params, ONLY: master
9  IMPLICIT NONE
10  EXTERNAL fcn
11 #if !defined(MPI_OPT)
12  EXTERNAL ga_fitness_parallel
13 #endif
14  INTEGER :: nopt, n, j, k, kk, iflag, myid
15  REAL(rprec), DIMENSION(nopt) :: fvec
16  REAL(rprec), DIMENSION(nparmax) :: paramsm,paramav
17  INTEGER :: nfev, num_processors
18  REAL(rprec) :: fitsum, funcval, fbar, best
19  INTEGER :: jstart, jend, istat, jstat
20  LOGICAL :: ldiag_opt
21 
22  SAVE
23 
24  fitsum = 0
25  best=-1.0e30_dp
26 
27  ldiag_opt = .false.
28 
29  IF (myid .eq. master) WRITE(6,*) 'in ga_evalout',num_processors
30  WRITE(6,*) fbar,best,nopt,nfev,iflag
31 ! ,iflag
32 ! fbar,best,nopt,nfev,num_processors,iflag
33 
34  DO 29 n=1,nparam
35  paramsm(n)=0
36  29 CONTINUE
37  jstart=1
38  jend=npopsiz
39  IF(iskip.ne.0) jstart=iskip
40  IF(iend.ne.0) jend=iend
41 
42  DO j=jstart,jend
43 
44  CALL ga_decode(j,parent,iparent)
45 
46 ! IF(iskip.ne.0 .and. iend.ne.0 .and. iskip.eq.iend) THEN
47 ! IF(lscreen) THEN
48 ! IF(nchrome .le. 120) THEN
49 ! WRITE(6,1075) j,(iparent(k,j),k=1,nchrome)
50 ! ELSE
51 ! WRITE(6,1075) j,(iparent(k,j),k=1,120)
52 ! WRITE(6,1077) (iparent(k,j),k=121,nchrome)
53 ! END IF
54 ! WRITE(6,1076) (parent(kk,j),kk=1,nparam),0.0
55 ! END IF
56 ! END IF
57  IF(ldiag_opt .and. myid.eq.master) THEN
58  IF(nchrome .le. 120) THEN
59  WRITE(iunit_ga_out,1075) j,(iparent(k,j),k=1,nchrome)
60  ELSE
61  WRITE(iunit_ga_out,1075) j,(iparent(k,j),k=1,120)
62  WRITE(iunit_ga_out,1077) (iparent(k,j),k=121,nchrome)
63  END IF
64  WRITE(iunit_ga_out,1076) (parent(kk,j),kk=1,nparam)
65  END IF
66 
67  END DO
68 #if defined(MPI_OPT)
69  CALL ga_fitness_mpi (jend-jstart+1, f_obj, num_obj, &
70  fcn, nfev, fitness)
71 #else
72  IF (myid .eq. master) WRITE(6,'(1x,i4,a,i4,a)') jend-jstart+1, &
73  ' processes started on ',num_processors, ' processors'
74 
75 ! flush out buffer before multiprocessing
76  CALL flush(6)
77  CALL flush(iunit_ga_out)
78 
79  CALL multiprocess(jend-jstart+1, num_processors, &
80  ga_fitness_parallel, fcn )
81 #endif
82  nfev=nfev+jend-jstart+1
83  nfit_eval=nfev
84 
85 ! Clean up...
86  iflag=-100
87  CALL fcn(nopt, npopsiz, parent(1,jbest), fvec, iflag, nfev)
88 #if !defined(MPI_OPT)
89  DO j=jstart, jend
90 !
91 ! Call function evaluator, Write out individual and fitness, and add
92 ! to the summation for later averaging.
93 ! iflag=j
94 ! funcval = ga_evaluate(fcn, nopt, fvec, nparam, parent(1,j),
95 ! 1 iflag, nfev)
96 
97  READ(j+1000, iostat=istat) jstat, iflag
98  IF( jstat .ne. j ) THEN
99  WRITE(6,*) "wrong INDEX READ in evalout"
100  iflag=-14
101  EXIT
102  END IF
103 
104  READ(j+1000, iostat=istat) funcval
105  fitness(j)=funcval
106  CLOSE(j+1000, status='delete')
107  END DO
108 #endif
109  DO 30 j = jstart, jend
110  fitsum=fitsum+fitness(j)
111  DO 22 n=1,nparam
112  paramsm(n)=paramsm(n)+parent(n,j)
113  22 CONTINUE
114 
115 ! Check to see IF fitness of individual j is the best fitness.
116  IF (fitness(j).gt.best) THEN
117  best=fitness(j)
118  jbest=j
119  DO 24 k=1,nchrome
120  ibest(k)=iparent(k,j)
121  24 CONTINUE
122  END IF
123  30 CONTINUE
124 
125 ! compute parameter and fitness averages.
126  fbar=fitsum/npopsiz
127  DO 23 n=1,nparam
128  paramav(n)=paramsm(n)/npopsiz
129  23 CONTINUE
130 
131 
132 ! write output information
133  IF (myid.eq.master) THEN
134  IF (ldiag_opt) THEN
135  IF (npopsiz.eq.1) THEN
136  IF(nchrome .le. 120) THEN
137  WRITE(iunit_ga_out,1075) 1,(iparent(k,1),k=1,nchrome)
138  ELSE
139  WRITE(iunit_ga_out,1075) 1,(iparent(k,1),k=1,120)
140  WRITE(iunit_ga_out,1077) (iparent(k,j),k=121,nchrome)
141  END IF
142  WRITE(iunit_ga_out,1076) (parent(k,1),k=1,nparam)
143  WRITE(iunit_ga_out,1078) fitness(1)
144  WRITE(iunit_ga_out,*) ' Average Values:'
145  WRITE(iunit_ga_out,1275) (parent(k,1),k=1,nparam)
146  WRITE(iunit_ga_out,1276) fbar
147  ELSE
148  WRITE(iunit_ga_out,1275) (paramav(k),k=1,nparam)
149  WRITE(iunit_ga_out,1276) (fitness(j),j=1,npopsiz)
150  END IF
151  END IF
152  WRITE(6,1100) fbar
153  WRITE(iunit_ga_out,1100) fbar
154  WRITE(6,1200) best
155  WRITE(iunit_ga_out,1200) best
156  END IF
157 
158  1075 FORMAT(i3,1x,(120i1))
159  1077 FORMAT(3x,1x,(120i1))
160  1076 FORMAT(3x,1x,10(1x,e10.4))
161  1078 FORMAT(10x,e12.5)
162  1100 FORMAT(1x,'Average Function Value of Generation=',e12.5)
163  1200 FORMAT(1x,'Maximum Function Value =',e12.5/)
164  1275 FORMAT(/' Average Values:',18x,10(1x,e10.4))
165  1276 FORMAT(10x,10e12.5)
166 
167  END SUBROUTINE ga_evalout