-
Notifications
You must be signed in to change notification settings - Fork 2
/
ga_14oct10.f
475 lines (396 loc) · 12.1 KB
/
ga_14oct10.f
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
c CC BY-SA 4.0
c At 10:38 P.M. on March 3, 1953, in a one-story brick building at the end of
c Olden Lane in Princeton, New Jersey, Italian Norweigian mathemathical biologist
c Nils Aall Barriceli inoculate a 5 kilobytes digital universe with random
c numbers generated by drawing cards from a shuffled deck. " A serie of numerical
c experiments are being made with the aim of verifying the posibility of an
c evolution similar to that of living organisms taking place in an artificial
c created universe". he announced.
c Turing's Cathedral. The origins of the digital universe. George Dyson.
c Pantheon Books. New York.
c Hender Rivera
c ************** algoritmo genetico *********************
c ************** Genetic Algorithms *********************
c ----------------------------------------------------------------------------80
c implicit double precision (a-h,o-z)
implicit none
integer ipoblacion,ilong_cromo,i,igen,ilong_gen,ib
c poblacion = population
integer igeneracion,is,j,flag(40,2)
c generacion = generation
character*4 codigo(14)
c código = code
character*200 cromo(40),cromo_temporal,padres(2)
c padres = parents
character*200 swap
character*50 expre_algebra,parser
real*8 fitnes(40),sum_fitnes,tot_fitnes,inc_fitnes
real*8 xr,rebanada
c rebanada = slice
real*8 evaluar,comparacion
c evaluar = assess, comparacion = comparison
real*8 dec,mut,crossover_rate
real*8 target_number,fit_tot
integer*4 iran,indice(2)
parameter (target_number=23.)
c ipoblacion debe ser un numero par
c ipoblacion need to be an even number
parameter (ipoblacion=40,ilong_cromo=200,ilong_gen=4)
crossover_rate=0.7
mut=0.001
c Random seed
c semilla aleatoria
iran=12572
c iran=17572
open(unit=36,file='fitnes.dat')
open(unit=37,file='fitnes2.dat')
c Codificacion de los digitos y simbolos.
c Digits and symbols coding.
codigo(1) = '0000' !cero, zero
codigo(2) = '0001' !uno, one
codigo(3) = '0010' !dos, two
codigo(4) = '0011' !tres, three
codigo(5) = '0100' !cuatro, four
codigo(6) = '0101' !cinco, five
codigo(7) = '0110' !seis, six
codigo(8) = '0111' !siete, seven
codigo(9) = '1000' !ocho, eight
codigo(10) = '1001' !nueve, nine
codigo(11) = '1010' ! +
codigo(12) = '1011' ! -
codigo(13) = '1100' ! *
codigo(14) = '1101' ! /
c inicio de los cromosomas
c chromosomes initial setting
do i=1,ipoblacion
cromo(i)=''
indice(i)=0
enddo
c Se genera la poblacion aleatoria
c Generate the random population
do i=1,ipoblacion
do j=1,50 ! 1 hasta la longitud del cromosoma/4, 1 up to chromosome size over 4
call rnd001(xr,iran,14)
igen=xr+1
cromo(i)(j*4-3:j*4) = codigo(igen)
enddo
enddo
c ********* inicio del ciclo de evolucion ************
c ********* Evolution cicle start *********************
222 continue
do i=1,40
cromo_temporal=cromo(i)
expre_algebra=parser(cromo_temporal)
comparacion=evaluar(expre_algebra)
if (target_number.ne.comparacion) then
fitnes(i)=1.d0/abs((target_number-comparacion))
else
fitnes(i)=1.d0
endif
enddo
c do i=1,40
c if (flag(i,2).eq.1) then
c write(6,*) igeneracion,fitnes(i),evaluar(parser(cromo(i))),
c + parser(cromo(i))
c enddo
c endif
write(36,*)
+ igeneracion,(evaluar(parser(cromo(i))),i=1,40)
c write(6,*)
c + igeneracion,(cromo(i),(parser(cromo(i))),fitnes(i),i=1,1)
c Rullete
c The parents are taken from the first generation among the best
c fitted individuals.
c Ruleta
c Se escojen los padres a partir de la primera generacion
c entre los individuos que mejor se adaptan
indice(1)=0
indice(2)=0
555 call rnd001(xr,iran,40)
is=xr+1
call rnd001(xr,iran,1)
if (xr.lt.fitnes(is).and.fitnes(is).ne.1.) then
indice(1)=is
padres(1)=cromo(indice(1))
else
goto 555
endif
777 call rnd001(xr,iran,40)
is=xr+1
call rnd001(xr,iran,1)
if (xr.lt.fitnes(is).and.fitnes(is).ne.1.and.indice(1).ne.is)
+ then
indice(2)=is
padres(2)=cromo(indice(2))
else
goto 777
endif
c Crossover
swap=''
call rnd001(xr,iran,1)
if(xr.lt.crossover_rate) then
call rnd001(xr,iran,50)
igen=xr+1
swap=padres(1)(igen*4-3:200)
padres(1)(igen*4-3:200)=padres(2)(igen*4-3:200)
padres(2)(igen*4-3:200)=swap
endif
c Mutation
c Mutacion
do ib=1,2
do i=1,200
call rnd001(xr,iran,1)
if(xr.lt.mut) then
if(padres(ib)(i:i).eq.'1') then
padres(ib)(i:i)='0'
else
padres(ib)(i:i)='1'
endif
endif
enddo
enddo
c The parents are replaced by their offsprings.
c Se sustituyen los padre por hijos
do i=1,2
cromo(indice(i))=padres(i)
enddo
igeneracion=igeneracion+1
c Checkout if the majority of individuals in the population has converge.
c Verifica si la mayoria de individuos de la poblacion han convergido
fit_tot=0
do i=1,40
cromo_temporal=cromo(i)
expre_algebra=parser(cromo_temporal)
comparacion=evaluar(expre_algebra)
fit_tot=fit_tot+abs(comparacion)
enddo
write(37,*) igeneracion,fit_tot
if(fit_tot.le.1000) goto 333
goto 222
c 444 format(1x,i2,5(f9.3,1x))
c 22 format(1x,i6,1x,3(a200,1x))
c 20 format(1x,i6,1x,40(f9.3,1x))
c 33 format(1x,i6,1x,f9.3)
c---------------fin del programa -------------
c--------------- End of the program -----------
333 continue
stop
end
c --------- funciones y subrutinas --------------------
c --------- Subroutine and functions ------------------
c ------- Decimal function 2 -------------------
c ------------- funcion decimal 2 ----------------
function dec2(temp)
implicit none
integer bin,k
real decimal,dec2
character*200 cromo_temporal
character*4 temp
decimal=0.
do k=1,4
c bin=ichar(cromo_temporal(201-k:201-k))
bin=ichar(temp(5-k:5-k))
if (bin.eq.49) then
bin=1
else
bin=0
endif
decimal=decimal+(real(bin)*(((2.**real(k-1)))))
c write(*,*) 'stop'
enddo
dec2=decimal
end
c ------ Function for assess the parser that coding the individual.
c ------ Funcion de calculo del parser que codifica el sujeto --------
function parser(cromo_temporal)
implicit none
character*200 cromo_temporal
character*200 expresion
character*50 expresion_algebra,parser
character*1 algebra
character*4 temp
real dec,dec2,decimal,bufer
integer i,icontador_deescojidos,k
c write(*,*) 'cromo_temporal ',cromo_temporal
expresion=''
expresion_algebra=''
bufer=999999
i=0
k=0
icontador_deescojidos=0
100 continue
i=i+1
if (i.gt.50) goto 999
temp=cromo_temporal(i*4-3:i*4)
decimal=dec2(temp)
c si / precede a 0 '/0'
if(bufer.eq.13.and.decimal.eq.0.) then
goto 100
endif
c si no es operador o numero
if(decimal.ge.14) then
goto 100
endif
if(decimal.gt.9.and.icontador_deescojidos.eq.0) then
goto 100
endif
c Search until finds the first number.
c busca hasta que encuentra el primer numero.
if(icontador_deescojidos.eq.0.and.decimal.le.9) then
bufer=decimal
icontador_deescojidos=icontador_deescojidos+1
k=icontador_deescojidos
expresion(k*4-3:k*4)=temp
expresion_algebra(k:k)=algebra(temp)
goto 100
endif
c An operator preceded for a number 5/
c un operador antecedido de numero 5/
if(decimal.gt.9.and.decimal.lt.14.and.bufer.le.9)
+ then
bufer=decimal
icontador_deescojidos=icontador_deescojidos+1
k=icontador_deescojidos
expresion(k*4-3:k*4)=temp
expresion_algebra(k:k)=algebra(temp)
goto 100
endif
c A number preceded fot a operator /4
c un numero antecedido de operador /4
if(decimal.le.9.and.bufer.gt.9.and.bufer.lt.14) then
bufer=decimal
icontador_deescojidos=icontador_deescojidos+1
k=icontador_deescojidos
expresion(k*4-3:k*4)=temp
expresion_algebra(k:k)=algebra(temp)
goto 100
endif
c A number preceded for a number
c un numero antecedido de numero
if(decimal.le.9.and.bufer.le.9) then
goto 100
endif
c An operator preceded of an operator
c un operador antecedido de operador
if(decimal.gt.9.and.bufer.lt.14.and.bufer.gt.9) then
goto 100
endif
if(i.eq.50.and.decimal.gt.9) goto 999
999 continue
if(bufer.gt.9) then
expresion_algebra(k:k)=''
endif
parser=expresion_algebra
end
c ----------- Evaluation of algebraic expresión ------------------
c------------ funcion que evalua la expresion algebraica --------
function evaluar(expre_algebra)
implicit none
character*50 expre_algebra
real evaluar,evaluar2
character*1 parser_temporal,c
integer i,k,selector,bufer(50)
do i=1,50
selector=ichar(expre_algebra(i:i))
select case (selector)
case (48)
bufer(i)=0
case (49)
bufer(i)=1
case (50)
bufer(i)=2
case (51)
bufer(i)=3
case (52)
bufer(i)=4
case (53)
bufer(i)=5
case (54)
bufer(i)=6
case (55)
bufer(i)=7
case (56)
bufer(i)=8
case (57)
bufer(i)=9
case (43)
bufer(i)=10
case (45)
bufer(i)=11
case (42)
bufer(i)=12
case (47)
bufer(i)=13
case default
bufer(i)=0
end select
enddo
evaluar2=bufer(1)
do i=2,49,2
select case (bufer(i))
case(10)
evaluar2=evaluar2+bufer(i+1)
case(11)
evaluar2=evaluar2-bufer(i+1)
case(12)
evaluar2=evaluar2*bufer(i+1)
case(13)
evaluar2=evaluar2/bufer(i+1)
case default
evaluar2=evaluar2
end select
enddo
evaluar=evaluar2
end
c **************** funciones llamadas por funciones **********
c **************** function called by functions **************
function algebra(temp)
implicit none
character*4 temp
character*1 algebra
real decimal,dec2
integer selector
decimal=dec2(temp)
selector=decimal
select case (selector)
case (0)
algebra='0'
case (1)
algebra='1'
case (2)
algebra='2'
case (3)
algebra='3'
case (4)
algebra='4'
case (5)
algebra='5'
case (6)
algebra='6'
case (7)
algebra='7'
case (8)
algebra='8'
case (9)
algebra='9'
case (10)
algebra='+'
case (11)
algebra='-'
case (12)
algebra='*'
case (13)
algebra='/'
case default
stop
end select
end
c Función random
subroutine rnd001(xi,i,ifin)
integer*4 i,ifin
real*8 xi
i=i*54891
xi=i*2.328306e-10+0.5D00
xi=xi*ifin
return
end