A Genetic Algorithm by Dave Thomas
A Genetic Algorithm by Dave Thomas
C evolution of solution
C TO FINDING BEST GRID OF ROADS TO CONNECT N CITIES (FIXED
POINTS)
C DEDICATED TO DAVID BERLINSKI
C Copyright 2001 By Dave Thomas, NMSR new G.A. STARTED 3-13-99
FORTRAN 01-31-2001
INCLUDE
'DARWING2.CMN'
INCLUDE 'DSEED.CMN'
C COMMERCIAL STANDARD GRAPHICS
PACKAGE INCLUDE FILES...
include 'graphapi.fi'
include 'graph.fi'
REAL*4 SCRMIN, OVRALL
CHARACTER*8 ROOT
CHARACTER*14 OUTFIL, BSTFIL, INFILE
INTEGER*2 IGEN, INODE, KILGEN, SUMGEN, IOVRALL,
NDNATOT
WRITE (*,*) ' ENTER INPUT
(GEOMETRY) FILE NAME: '
READ (*,'(A14)') INFILE
WRITE (*,*) ' ENTER
8-CHAR OUTPUT-FILE ROOT NAME: '
READ (*,'(A8)') ROOT
OUTFIL = ROOT // '.OUT'
BSTFIL = ROOT // '.BST'
OPEN
(17,FILE=OUTFIL,FORM='FORMATTED',STATUS='UNKNOWN')
OPEN
(18,FILE=BSTFIL,FORM='FORMATTED',STATUS='UNKNOWN')
OPEN
(16,FILE=INFILE,FORM='FORMATTED',STATUS='OLD')
READ (16,*) SEED
WRITE (17,*)'SEED=',SEED
READ (16,*) NGEN
WRITE (17,*)'NGEN=',NGEN
READ (16,*) KILGEN
WRITE (17,*)'KILGEN=',KILGEN
READ (16,*) NORG
WRITE (17,*)'NORG=',NORG
READ (16,*) NFIX
WRITE (17,*)'NFIX=',NFIX
READ (16,*) NVMX
WRITE (17,*)'NVMX=',NVMX
NTOT = NFIX + NVMX ! Total # Points
WRITE (17,*)'NTOT=',NTOT
NMUTE = NORG/10
WRITE (17,*)'NMUTE=',NMUTE
READ (16,*) AFACTOR
WRITE (17,*)'AFACTOR=',AFACTOR
READ (16,*) BFACTOR
WRITE (17,*)'BFACTOR=',BFACTOR
| WRITE (FMTPTS,55) 6*NVMX
55 FORMAT('(A',I2,')')
WRITE (FMTMAP,65) NTOT*(NTOT-1)/2
65 FORMAT('(A',I2,')')
NDNATOT = 2 + 6*NVMX + NTOT*(NTOT-1)/2
IF (NDNATOT.LT.100) THEN
WRITE (FMTTOT,65) NDNATOT
ELSE
WRITE (FMTTOT,75) NDNATOT
END IF
75 FORMAT('(A',I3,')')
WRITE (17,*) 'FORMAT SPECS: FMTPTS, FMTMAP, FMTTOT:'
WRITE (17,*) FMTPTS, FMTMAP, FMTTOT
DO 20 INODE=1, NFIX
READ (16,15) XP(INODE), YP(INODE)
15 FORMAT(I3,1X,I3)
WRITE (17,*) 'I,XP(I), YP(I)=',INODE, XP(INODE),
YP(INODE)
20 CONTINUE
CLOSE (16)
C Generate the NP Organisms
DO 100 IORG = 1, NORG
CALL CREATE(IORG)
C WRITE (*,*) 'AFTER INITIAL CREATE! # = ',IORG
CALL CONNECT(IORG)
C WRITE (*,*) 'AFTER INITIAL CONNECT!'
CALL FITNESS(IORG)
C WRITE (*,*) 'AFTER INITIAL FITNESS!'
IF (.NOT.COK) FTNSS(IORG) = AFACTOR
IF (IORG.EQ.2*NORG) THEN ! change 2*NORG to 1 for GENETIC ENGINEERING (SEEDING)
C
C PENGUIN
C + '02333530667530350405390474FFFFTFFF FFFFTFF FFTFFF FFTFF TTFF
FFF FF F'
C +
'02333530667530350405390474FFFFTFFFFFFFTFFFFTFFFFFTFFTTFFFFFFFF'
C DUBYA
C + '01500387667530350405390474FTFFTFFF FTFTFFF FFTFFF FFFFF TFFF
FFF FF F'
C +
'01500387667530350405390474FTFFTFFFFTFTFFFFFTFFFFFFFFTFFFFFFFFF'
C DOG
C + '01540600667530350405390474FFFFTFFF FTFFFFF FTFFFF FTFFF TFFF
FFF FF F'
C +
'01540600667530350405390474FFFFTFFFFTFFFFFFTFFFFFTFFFTFFFFFFFFF'
C UN-COMMENT NEXT TWO LINES TO
TRY OUT GENETIC SEEDING WITH SPECIFIED DNA ("DOG" SHOWN)
C ORG(1)=
C +
'01540600667530350405390474FFFFTFFFFTFFFFFFTFFFFFTFFFTFFFFFFFFF'
CALL XCRIBE(1)
CALL CONNECT(1)
CALL FITNESS(1)
IF (.NOT.COK) FTNSS(1) = AFACTOR
WRITE (17,*) 'GENETIC ENGINEERED ORGANISM # ', 1
WRITE (17,*) 'dna: ', ORG(1)
WRITE (17,*) 'fitness= ',FTNSS(1),', COK= ',COK
WRITE (*,*) 'ORGANISM # ', 1
WRITE (*,*) 'dna: ', ORG(1)
WRITE (*,*) 'fitness= ',FTNSS(1),', COK= ',COK
END IF
IF (IORG.LE.10)
THEN
WRITE (17,*) 'ORGANISM # ', IORG
WRITE (17,*) 'dna: ', ORG(IORG)
WRITE (17,*) 'fitness= ',FTNSS(IORG),', COK= ',COK
C WRITE (*,*) 'ORGANISM # ', IORG
C WRITE (*,*) 'dna:', ORG(IORG)
C WRITE (*,*) 'fitness= ',FTNSS(IORG),', COK= ',COK
END IF
100 CONTINUE
SUMGEN = 0
OVRALL = 9.99E9
IOVRALL = 0
CALL SAVEGEN(ROOT,SUMGEN)
call _setvideomode(
_VRES16COLOR )
c call _setvideomode( _MAXRESMODE )
call _setwindow(.TRUE.,-100.0,-100.0,1100.0,1100.0)
call _setcharsize_w(20.0,20.0)
DO 500 IGEN = 1, NGEN !
FOR EACH GENERATION
CALL SORTUP
C WRITE (*,*) 'AFTER SORTUP...IGEN=',IGEN
IF (FTNSS(1).LT.OVRALL) THEN
OVRALL = FTNSS(1)
IOVRALL = IGEN
END IF
DO 140 IORG=1, 1
CALL XCRIBE(IORG)
CALL ORGSHOW(IORG)
IF (IORG.LE.1) THEN
C WRITE (17,*) 'AFTER SORT: '
C WRITE (17,*) 'ORGANISM # ', IORG
C WRITE (17,*) 'dna: ', ORG(IORG)
C WRITE (17,*) 'fitness= ',FTNSS(IORG),', COK=
',COK
C WRITE (*,*) 'AFTER SORT: '
C WRITE (*,*) 'ORGANISM # ', IORG
C WRITE (*,*) 'dna:', ORG(IORG)
C WRITE (*,*) 'fitness= ',FTNSS(IORG),', COK= ',COK
END IF
140 CONTINUE
BESTLEN(IGEN)=FTNSS(1)
IF (I2MOD(IGEN,KILGEN).EQ.0) THEN
SUMGEN = SUMGEN + 1
CALL SAVEGEN(ROOT,SUMGEN)
DO 150 IORG = 1, NORG ! re-set population
CALL CREATE(IORG)
CALL CONNECT(IORG)
CALL FITNESS(IORG)
IF (.NOT.COK) FTNSS(IORG) = AFACTOR
150 CONTINUE
CALL SORTUP
BESTLEN(IGEN)=FTNSS(1)
END IF
WRITE (18,*) ORG(1) !
FILENAME$ & ".BST"
C write (17,*) '****************************'
C WRITE (17,*)'IGEN=', IGEN
C WRITE (17,*)'ORG(1)=', ORG(1)
C WRITE (17,*)'FTNSS(1)=', FTNSS(1)
C write (*,*) '****************************'
C WRITE (17,*)'IGEN, FITNESS,OVRALL,IOVRALL=',
C + IGEN, FTNSS(1),OVRALL,IOVRALL
WRITE (17,*)'ORG(1)=', ORG(1)
WRITE (17,160) IGEN, FTNSS(1),OVRALL,IOVRALL
c WRITE (*,160) IGEN, FTNSS(1),OVRALL,IOVRALL
160 FORMAT(I6,',',F11.3,',',F11.3,',',I6)
c WRITE (*,*)'ORG(1)=', ORG(1)
SCRMIN = 9.99E9
DO 200 IORG = 1,
NORG
CALL XCRIBE(IORG)
C WRITE (*,*) 'PRE-SCREW...AFTER XCRIBE! # = ',IORG
CALL CONNECT(IORG)
C WRITE (*,*) 'AFTER CONNECT! '
CALL FITNESS(IORG)
C WRITE (*,*) 'AFTER FITNESS! '
IF (.NOT.COK) FTNSS(IORG) = AFACTOR
SCRMIN = MIN(SCRMIN,FTNSS(IORG))
200 CONTINUE
C WRITE(17,*)
'MINSCORE=',SCRMIN
C WRITE (17,*)'HALFSCORE=',FTNSS(NORG/2)
C WRITE(*,*) 'MINSCORE=',SCRMIN
C WRITE (*,*)'HALFSCORE=',FTNSS(NORG/2)
CALL SCREW ! comment this line out for no sex,
selection...re Bracht
C WRITE (*,*) 'AFTER SCREW! '
DO 300 IMUTE = 1,
NMUTE ! # MUTATIONS PER GENERATION
IORG = INT(URAND(SEED)*FLOAT(NORG-1)) + 2 ! ALL OF 'EM
except #1
C WRITE (*,*) 'MUTATION # ',IMUTE,',IORG=',IORG
DO 250 JMUTE = 1, 3 ! MUTATIONS PER ORGANISM
CALL MUTATE(IORG)
250 CONTINUE
300 CONTINUE
C WRITE (*,*) 'AFTER
MUTATE! '
SCRMIN = 9.99E9
DO 400 IORG = 1,
NORG
CALL XCRIBE(IORG)
C WRITE (*,*) 'POST-SCREW/MUTE...AFTER XCRIBE! # =
',IORG
C WRITE (*,*) ORG(IORG)
CALL CONNECT(IORG)
C WRITE (*,*) 'AFTER CONNECT! '
CALL FITNESS(IORG)
C WRITE (*,*) 'AFTER FITNESS! '
IF (.NOT.COK) FTNSS(IORG) = AFACTOR
SCRMIN = MIN(SCRMIN,FTNSS(IORG))
400 CONTINUE
C WRITE
(17,*)'SCRMIN=', SCRMIN
C WRITE
(17,*)'----------------------------------------'
500 CONTINUE
call _setvideomode(
_DEFAULTMODE )
CLOSE (17)
CLOSE (18)
STOP
END
C ***********************************************************************
SUBROUTINE
CH22I2(STRG,VAL)
C CHARACTER*2 STRG => INTEGER*2 VAL
CHARACTER*2 STRG
INTEGER*2 I, K, M, VAL
VAL = 0
DO 100 I=1, 2
K = ICHAR(STRG(I:I))
IF (K.GE.48.AND.K.LE.57) THEN ! IF 0 TO 9....
M = K - 48
VAL = 10*VAL + M
END IF
100 CONTINUE
RETURN
END
C
***********************************************************************
SUBROUTINE
CH32I2(STRG,VAL)
C CHARACTER*3 STRG => INTEGER*2 VAL
CHARACTER*3 STRG
INTEGER*2 I, K, M, VAL
VAL = 0
DO 100 I=1, 3
K = ICHAR(STRG(I:I))
IF (K.GE.48.AND.K.LE.57) THEN ! IF 0 TO 9....
M = K - 48
VAL = 10*VAL + M
END IF
100 CONTINUE
RETURN
END
C
***********************************************************************
SUBROUTINE
I22CH2(VAL,STRG)
C INTEGER*2 VAL => CHARACTER*2 STRG
CHARACTER*2 STRG
INTEGER*2 I, K, M, VAL
IF
(VAL.GE.0.AND.VAL.LT.10) THEN
WRITE (STRG,10) VAL
10 FORMAT('0',I1)
ELSEIF (VAL.GE.10.AND.VAL.LT.100) THEN
WRITE (STRG,20) VAL
20 FORMAT(I2)
ELSE
WRITE (*,*) 'I22CH2 ERROR...VAL = ',VAL
read (*,'(a2)') STRG
STOP
END IF
RETURN
END
C
***********************************************************************
SUBROUTINE
I22CH3(VAL,STRG)
C INTEGER*2 VAL => CHARACTER*3 STRG
CHARACTER*3 STRG
INTEGER*2 I, K, M, VAL
IF
(VAL.GE.0.AND.VAL.LT.10) THEN
WRITE (STRG,10) VAL
10 FORMAT('0',I1)
ELSEIF (VAL.GE.10.AND.VAL.LT.100) THEN
WRITE (STRG,20) VAL
20 FORMAT(I2)
ELSEIF (VAL.GE.100.AND.VAL.LT.1000) THEN
WRITE (STRG,30) VAL
30 FORMAT(I3)
ELSE
WRITE (*,*) 'I22CH3 ERROR...VAL = ',VAL
read (*,'(a3)') STRG
STOP
END IF
RETURN
END
C
***********************************************************************
SUBROUTINE
XCRIBE(IORG)
C TRANSCRIBE DNA TO POINT DATA
INCLUDE 'DARWING2.CMN'
character*2 STRG
INTEGER*2 J, K, M, IX, IY, IC, LT
TMPORG = ORG(IORG)
C WRITE (*,*) 'IN XCRIBE...IORG = ', IORG
C WRITE (*,*) TMPORG
WRITE (C2TEMP,'(A2)') TMPORG(1:2)
CALL CH22I2(C2TEMP,NPV)
NPV = MIN(NPV,NVMX)
C WRITE (*,*) 'NPV=', NPV
DO 100 J = 1 , NPV
IX = 3+6*(J-1)
IY = 6+6*(J-1)
WRITE (CTEMP,'(A3)') TMPORG(IX:IX+2)
CALL CH32I2(CTEMP,XP(J+NFIX))
WRITE (CTEMP,'(A3)') TMPORG(IY:IY+2)
CALL CH32I2(CTEMP,YP(J+NFIX))
C WRITE (*,*) 'J,X,Y='
C WRITE (*,*) J+NFIX, XP(J+NFIX), YP(J+NFIX)
IF
(XP(J+NFIX).LT.0.OR.XP(J+NFIX).GT.1000) THEN
WRITE (*,*)
'XCRIBE...IORG,XP(J+NFIX)=',IORG,XP(J+NFIX),'?'
WRITE (*,*) TMPORG
read (*,'(a2)') STRG
STOP
END IF
IF
(YP(J+NFIX).LT.0.OR.YP(J+NFIX).GT.1000) THEN
WRITE (*,*)
'XCRIBE...IORG,YP(J+NFIX)=',IORG,YP(J+NFIX),'?'
WRITE (*,*) TMPORG
read (*,'(a2)') STRG
STOP
END IF
100 CONTINUE
C EXTRACT CONNECT DATA INTO
CMAP
IC = 3 + 6*NVMX ! INDEX PAST NP, XY POSITIONS...
LT = 2 + 6*NVMX + NTOT*(NTOT-1)/2
WRITE (CMAP,FMTMAP) TMPORG(IC:LT)
C WRITE (*,*) 'CMAP=',CMAP
C WRITE (*,*) 'CMAP(1:1)=',CMAP(1:1)
C WRITE (*,*) 'CMAP(2:2)=',CMAP(2:2)
C WRITE (*,*) 'CMAP(3:3)=',CMAP(3:3)
M = 0
DO 300 J=1, NTOT-1
C WRITE (*,*) ' '
DO 200 K=J+1, NTOT
M = M + 1
IF (CMAP(M:M).EQ.'T') THEN
CN(J,K) = .TRUE.
CN(K,J) = .TRUE.
ELSEIF (CMAP(M:M).EQ.'F') THEN
CN(J,K) = .FALSE.
CN(K,J) = .FALSE.
ELSE
write (*,*)
'xcribe...j,k,m,CMAP(M:M)=',j,k,m,CMAP(M:M)
WRITE (*,*) 'IN XCRIBE...IORG = ', IORG
WRITE (*,*) TMPORG
WRITE (*,*) 'cmap = ',CMAP
read (*,'(a2)') STRG
STOP
END IF
C WRITE (*,220)
CN(J,K)
220 FORMAT(L1,\)
200 CONTINUE
300 CONTINUE
RETURN
END
!
*******************************************************************
SUBROUTINE
MUTATE(IORG)
INCLUDE 'DARWING2.CMN'
INCLUDE 'DSEED.CMN'
CHARACTER*1 C1
CHARACTER*2 PAD2, CPAD2, STRG
CHARACTER*1 INVERT
INTEGER*2 L1A, L1B, L2A, L2B, L3A, L3B, L, NEW
C RANDOM MUTATION # OF VARIABLE
POINTS
C PRINT "PRE-M:";ORG(IORG)
TMPORG = ORG(IORG)
RNDVAL = URAND(SEED)
C IF (IORG.GE.470.AND.IORG.LE.480) THEN
C WRITE (*,*) 'IN MUTATE..BEFORE, FOR # ',IORG,',
RND=',RNDVAL
C WRITE (*,*) TMPORG
C END IF
IF (RNDVAL.LT.0.25) THEN
! <1/4, NPV AREA
NEW = INT(URAND(SEED)*FLOAT(NVMX-1))+2 ! MINIMUM 2 VARIABLE
POINTS
IF (NEW.LT.2.OR.NEW.GT.NVMX) THEN
WRITE (*,*) 'MUTATE...NEW NPV=',NEW,'?'
read (*,'(a2)') STRG
STOP
END IF
CPAD2 = PAD2(NEW)
TMPORG(1:2) = CPAD2
C IF (IORG.GE.470.AND.IORG.LE.480) THEN
C WRITE (*,*) 'MUTE_NPV...NEW,CPAD2=', NEW, ',', CPAD2
C END IF
ELSEIF (RNDVAL.LT.0.50)
THEN ! <1/2, POINT X,Y AREA
L2A = 3
L2B = 2+NVMX*6
L = INT(URAND(SEED)*FLOAT(L2B-L2A+1))+3 ! WHERE IN STRAND TO
STRIKE!
NEW = INT(URAND(SEED)*10.0) ! 0 - 9
C IF (IORG.GE.470.AND.IORG.LE.480) THEN
C WRITE (*,*) 'MUTE_XY...L,NEW=',L,NEW
C END IF
IF
(NEW.LT.0.OR.NEW.GT.9) THEN
WRITE (*,*) 'MUTATE...NEW XY DIGIT=',NEW,'?'
read (*,'(a2)') STRG
STOP
END IF
WRITE (C1,'(I1)')
NEW
TMPORG(L:L) = C1
ELSEIF (RNDVAL.LT.1.00) THEN ! <1, CONNECTION MAP AREA
L3A = 3 + 6*NVMX
L3B = 2 + NVMX*6 + NTOT*(NTOT-1)/2
C L3B - L3A = NTOT*(NTOT-1)/2 - 1
C INPUT X$
L = INT(URAND(SEED)*FLOAT(L3B-L3A+1))+L3A
C PRINT "MUTATE...L3A.L3B,L=",L3A;L3B;L
C1 = TMPORG(L:L)
TMPORG(L:L) = INVERT(C1)
IF (TMPORG(L:L).NE.'T'.AND.TMPORG(L:L).NE.'F') THEN
WRITE (*,*) 'MUTATE...TMPORG(',L,')= ',TMPORG(L:L),'
?'
read (*,'(a2)') STRG
STOP
END IF
C IF
(IORG.GE.470.AND.IORG.LE.480) THEN
C WRITE (*,*) 'MUTE_CON...L,C1=', L, C1
C END IF
END IF
C IF
(IORG.GE.470.AND.IORG.LE.480) THEN
C WRITE (*,*) 'IN MUTATE..AFTER, FOR # ',IORG
C WRITE (*,*) TMPORG
C END IF
ORG(IORG) = TMPORG
RETURN
END
!
*******************************************************************
SUBROUTINE SCREW ! SIMPLE
CROSSOVER
INCLUDE 'DARWING2.CMN'
INCLUDE 'DSEED.CMN'
CHARACTER*104 ORG2(MXORGS), EMPTY, ORGT1, ORGT2
CHARACTER*1 ANS
REAL*4 F, FITSUM, L1, L2
INTEGER*2 LT, IORG, IC, IDNA, MORG, IBOY,IGIRL
C WRITE (*,*) 'READY TO
SCREW.'
C READ(*,'(A1)') ANS
DO 10 IC = 1, 104
EMPTY(IC:IC)=' '
10 CONTINUE
C SEX BETWEEN ADAPTED
ORGANISMS
C PICK WHICH ORG'S GET TO SCREW...
F = 2 ! FACTOR,
>1...
CALL GETNORM(L1,L2,FITSUM)
LT = 2 + 6*NVMX + NTOT*(NTOT-1)/2 ! TOTAL
C WRITE (*,*) 'LT=',LT
DO 100 IORG = 1, NORG
ORG2(IORG) = ORG(IORG)
ORG(IORG) = EMPTY
100 CONTINUE
C WRITE
(17,*)''"SCREW"
ORG(1) = ORG2(1) ! ELITE!
DO 200 MORG = 2, NORG
C PICK A BOY
CALL GETONE(IBOY,L1,L2,FITSUM)
C PICK A GIRL
CALL GETONE(IGIRL,L1,L2,FITSUM)
RNDVAL = URAND(SEED)
IDNA = INT(RNDVAL*(LT-2))+3 ! SKIP NPV SECTION
C WRITE (*,*)
'IBOY,IGIRL,MORG,IDNA=',IBOY,IGIRL,MORG,IDNA
ORGT1 = ORG2(IBOY)
ORGT2 = ORG2(IGIRL)
IF (RNDVAL.LT.0.5) THEN ! CROSSOVER #1
ORG(MORG) = ORGT1(1:IDNA) // ORGT2(IDNA+1:LT)
ELSE ! CROSSOVER # 2
ORG(MORG) = ORGT2(1:IDNA) // ORGT1(IDNA+1:LT)
END IF
C IF
(MORG.GE.470.AND.MORG.LE.480) THEN
C WRITE (*,*) 'IN SCREW...BOY,GIRL,IDNA,OFFSPRING:'
C WRITE (*,*) IBOY,IGIRL,IDNA,MORG
C WRITE (*,*)
'....F....1....F....2....F....3....F....4',
C + '....F....5....F....6....F....7'
C WRITE (*,*) ORG2(IBOY)
C WRITE (*,*) ORG2(IGIRL)
C WRITE (*,*) ORG(MORG)
C READ(*,'(A1)') ANS
C END IF
200 CONTINUE
RETURN
END
!
*******************************************************************
SUBROUTINE
CREATE(IORG)
INCLUDE 'DARWING2.CMN'
INCLUDE 'DSEED.CMN'
CHARACTER*104 EMPTY, ORGT1, ORGT2
CHARACTER*1 CT
CHARACTER*2 PAD2, CPAD2
CHARACTER*3 PAD3, CPAD3
CHARACTER*2 NPVARB, STRG
INTEGER*2 IORG, IC, IDNA, XPP, YPP, LORGT1, LORGT2,
LTEMP
DO 10 IC = 1, 104
EMPTY(IC:IC)=' '
10 CONTINUE
ORG(IORG) = EMPTY
ORGT1 = EMPTY
ORGT2 = EMPTY
RNDVAL = URAND(SEED)
NPV = INT(RNDVAL*FLOAT(NVMX-1))+2 ! MINIMUM 2 VARIABLE
POINTS
NPV = NVMX !!! OVERRIDE - JUST SET TO MAX (5)
!!!!!!
IF
(NPV.LT.2.OR.NPV.GT.NVMX) THEN
WRITE (*,*) 'CREATE...NEW NPV=',NPV,'?'
read (*,'(a2)') STRG
STOP
END IF
C write (*,*) 'npv = ',
npv
NPVARB = PAD2(NPV)
C write (*,*) 'npvarb = ', npvarb
DO 100 J = 1, NVMX ! FOR
EACH POSSIBLE VARIABLE POINT
RNDVAL = URAND(SEED)
XPP = 200+INT(RNDVAL*600.) ! X-LOCATION
XP(J+NFIX) = XPP
RNDVAL = URAND(SEED)
YPP = 400+INT(RNDVAL*200.) ! X-LOCATION
YP(J+NFIX) = YPP
C write (*,*) 'j,xpp,ypp=',j,xpp,ypp
IF (J.EQ.1) THEN
ORGT1 = PAD3(XPP) // PAD3(YPP)
ELSE
LTEMP = 6*(J-1)
ORGT1 = ORGT1(1:LTEMP) // PAD3(XPP) // PAD3(YPP)
END IF
C NOTE JUNK DNA FOR J
> NP
C write (*,*) 'orgt1=',orgt1
100 CONTINUE
LORGT1 = 6*NVMX
LTEMP = 0
DO 300 J = 1 , NTOT-1 ! FOR EACH POSSIBLE POINT
DO 200 K = J+1, NTOT ! FOR EACH OTHER POINT (POSSIBLE
CONNECTION...)
RNDVAL = URAND(SEED)
IF (RNDVAL.LE.0.5)
THEN ! RANDOM T OR F
CT = 'T'
ELSE
CT = 'F'
END IF
IF
(J.EQ.1.AND.K.EQ.2) THEN
ORGT2 = CT
LTEMP = 1
ELSE
ORGT2 = ORGT2(1:LTEMP) // CT
LTEMP = LTEMP + 1
END IF
IF (CT.EQ.'T')
THEN
CN(J,K) = .TRUE.
CN(K,J) = .TRUE.
ELSE
CN(J,K) = .FALSE.
CN(K,J) = .FALSE.
END IF
200 CONTINUE
300 CONTINUE
C write (*,*)
'npvarb=',npvarb
C write (*,*) 'orgt1=',orgt1
C write (*,*) 'orgt2=',orgt2
LORGT2 = NTOT*(NTOT-1)/2
ORG(IORG)= NPVARB // ORGT1(1:LORGT1) // ORGT2(1:LORGT2)
C WRITE (*,*) 'ORG(',IORG,')=',ORG(IORG)
RETURN
END
C
*******************************************************************
SUBROUTINE
CONNECT(IORG)
C ORGANISM LEVEL
INCLUDE 'DARWING2.CMN'
INTEGER*2 LIST(20), NEWLIST(20), I, J, NNEW, ILST, NLST
LOGICAL GOT(20), COKTMP ! used for finding
connectivity
NLST = 1
LIST(1) = 1
DO 100 I=1, 20
GOT(I) = .FALSE.
100 CONTINUE
GOT(1)=.TRUE.
NNEW = 0
200 CONTINUE ! DO
DO 400 ILST = 1, NLST
J = LIST(ILST)
GOT(J) = .TRUE.
C WRITE
(*,*)'CONNECT...ILST,NLST,J,GOT(J)=',ILST,NLST,J,GOT(J)
DO 300 K = 1, NFIX+NPV
IF (CN(J,K).AND.(.NOT.GOT(K))) THEN
GOT(K) = .TRUE.
NNEW = NNEW + 1
NEWLIST(NNEW) = K
END IF
300 CONTINUE
400 CONTINUE
C WRITE (*,*)'AFTER 400...NNEW,NEWLIST(NNEW)=',NNEW,NEWLIST(NNEW)
IF (NNEW.EQ.0) THEN
COKTMP = .TRUE.
DO 500 IFIX = 1, NFIX
IF (.NOT.GOT(IFIX)) COKTMP = .FALSE.
500 CONTINUE
COK = COKTMP
GOTO 999 ! EXIT DO
END IF
DO 600 ILST = 1, NNEW
LIST(ILST) = NEWLIST(ILST)
NEWLIST(ILST) = 0
600 CONTINUE
NLST = NNEW
NNEW = 0
GOTO 200
999 CONTINUE ! LOOP
C WRITE (*,*) 'IN
CONNECT...COK=',COK
RETURN
END
!
**************************************************************************
CHARACTER*2 FUNCTION
PAD2(N)
INTEGER*2 N
CHARACTER*2 CTEMP
N = ABS(N)
IF (N.LT.10) THEN
WRITE (CTEMP,100) 0, N
100 FORMAT(I1,I1)
ELSEIF (N.LT.100) THEN
WRITE (CTEMP,200) N
200 FORMAT(I2)
ELSE
WRITE (*,*) 'OOOPS. N TOO LARGE.'
CTEMP = ' '
END IF
C WRITE (*,*) 'CTEMP = ', CTEMP
PAD2 = CTEMP
RETURN
END
!
***************************************************************************
CHARACTER*3 FUNCTION
PAD3(N)
INTEGER*2 N
CHARACTER*3 CTEMP
N = ABS(N)
IF (N.LT.10) THEN
WRITE (CTEMP,100) 0, 0, N
100 FORMAT(I1,I1,I1)
ELSEIF (N.LT.100) THEN
WRITE (CTEMP,200) 0, N
200 FORMAT(I1,I2)
ELSEIF (N.LT.1000) THEN
WRITE (CTEMP,300) N
300 FORMAT(I3)
ELSE
WRITE (*,*) 'OOOPS. N TOO LARGE.'
CTEMP = ' '
END IF
C WRITE (*,*) 'CTEMP = ',
CTEMP
PAD3 = CTEMP
RETURN
END
C
***************************************************************************
CHARACTER*1 FUNCTION
TORF()
INCLUDE 'DSEED.CMN'
RNDVAL = URAND(SEED)
IF (RNDVAL.LT.0.5)
THEN
TORF='F'
ELSE
TORF='T'
END IF
RETURN
END
!
**************************************************************************
CHARACTER*1 FUNCTION
INVERT(CT)
CHARACTER*1 CT
IF (CT.EQ.'T') THEN
CT='F'
ELSEIF (CT.EQ.'F') THEN
CT='T'
ELSE
CT='*'
END IF
INVERT = CT
RETURN
END
!
**************************************************************************
SUBROUTINE SORTUP
INCLUDE 'DARWING2.CMN'
INTEGER*2 IORG, JORG, ISMALLEST
REAL*4 RTEMP
C SMALLEST TO LARGEST
C POPULATION LEVEL
C SLAVE ARRAYS JUST ALONG FOR THE RIDE, NOT SORTED ITSELF
C this version sorts FTNSS array from smallest up to largest
C print "NORG = ";NORG
DO 200 IORG = 1,
NORG-1
ISMALLEST = IORG
DO 100 JORG= IORG+1, NORG
IF (FTNSS(JORG).LT.FTNSS(ISMALLEST)) THEN ! test for
smallitude
ISMALLEST = JORG
END IF
100 CONTINUE
IF (ISMALLEST.GT.IORG) THEN
RTEMP =
FTNSS(IORG)
FTNSS(IORG) = FTNSS(ISMALLEST)
FTNSS(ISMALLEST) = RTEMP
TMPORG =
ORG(IORG)
ORG(IORG) = ORG(ISMALLEST)
ORG(ISMALLEST) = TMPORG
END IF
200 CONTINUE
RETURN
END
C
*************************************************************************
SUBROUTINE
SAVEGEN(ROOT,SUMGEN)
INCLUDE 'DARWING2.CMN'
CHARACTER*8 ROOT
CHARACTER*14 GENFIL
CHARACTER*3 PAD3
CHARACTER*2 PAD2
INTEGER*2 SUMGEN
GENFIL = ROOT // '.' //
PAD3(SUMGEN)
OPEN (19,FILE=GENFIL,FORM='FORMATTED',STATUS='UNKNOWN')
DO 100 IORG = 1, NORG
WRITE (19,*) ORG(IORG)
100 CONTINUE
CLOSE (19)
RETURN
END
C
******************************************************************************
SUBROUTINE
FITNESS(IORG)
INCLUDE 'DARWING2.CMN'
REAL*4 WLGTH, DR2, LGTHJK, DX, DY
INTEGER*2 NUMSEG, NUMSHORT, M, I, J, K
CHARACTER*1 ANS
WLGTH = 0.0
NUMSEG = 0
NUMSHORT = 0
DO 100 J = 1,
NFIX+NPV-1
C WRITE (*,*) 'J,X,Y=',J,XP(J),YP(J)
DO 200 K = J+1,
NFIX+NPV
C WRITE (*,*) 'K,X,Y=',K,XP(K),YP(K)
C WRITE (*,*) 'CN(J,K)=',CN(J,K)
M = NTOT*(J-1)+K
IF (CN(J,K)) THEN
DX = XP(K)-XP(J)
DY = YP(K)-YP(J)
DR2 = DX*DX + DY*DY
C WRITE (*,*) 'J,DX,DY,DR2='
C WRITE (*,*) J,DX,DY,DR2
LGTHJK = SQRT(DR2) ! LENGTH OF THIS SEGMENT (J TO
K)
C write (*,*) 'LGTHJK = ', LGTHJK
WLGTH=WLGTH + LGTHJK ! RUNNING LENGTH
NUMSEG=NUMSEG+1 ! RUNNING # SEGMENTS TOTAL
END IF
200 CONTINUE
100 CONTINUE
C WRITE (*,*)
'WLGTH=',WLGTH
FTNSS(IORG)=WLGTH
C read (*,'(a1)') ANS
RETURN
END
C
*****************************************************************
SUBROUTINE
GETONE(IORG,L1,L2,FITSUM) ! SELECT BOY OR GIRL, BASED ON FITNESS
INCLUDE 'DARWING2.CMN'
INCLUDE 'DSEED.CMN'
REAL*4 FITSUM, NORM, L1, L2, X, Z, PARTSUM
INTEGER*2 IORG, JORG
character*2 STRG
IF (L1.EQ.L2) THEN
WRITE (*,*) 'DIVVY BY ZERO IN GETONE!'
read (*,'(a2)') STRG
STOP
END IF
NORM =
(NORG*L2-FITSUM)/(L2-L1) ! SMALL BETTER THEN LARGE
RNDVAL = URAND(SEED)
X = (RNDVAL**BFACTOR)*NORM ! STRONG FACTOR; BFACTOR<1 TO
SKEW LOW; TRY 1.5
PARTSUM = 0
IORG = 0
DO 100 JORG = NORG, 1,
-1
IF (FTNSS(JORG).LT.AFACTOR/2.0) THEN
Z = (L2-FTNSS(JORG))/(L2-L1) ! SMALL BETTER THEN
LARGE
PARTSUM = PARTSUM + Z
C PRINT
"L1;L2;FITSUM;X;NORM;JORG;Z;PARTSUM=";L1;L2;FITSUM;X;NORM;JORG;Z;PARTSUM
IF (PARTSUM.GE.X) THEN ! SMALL BETTER THEN LARGE
IORG = JORG
RETURN
END IF
END IF
100 CONTINUE
IORG = MAX(IORG,1) !
DESPERATION IF NO VALID RETURN ABOVE
RETURN
END
C
*******************************************************************
SUBROUTINE
GETNORM(L1,L2,FITSUM) ! GENERATE NORMALIZATION FACTORS
INCLUDE 'DARWING2.CMN'
INCLUDE 'DSEED.CMN'
REAL*4 FITSUM, NORM, L1, L2, X, Z, PARTSUM
INTEGER*2 IORG, JORG
character*2 STRG
C WRITE (*,*) 'IN
GETNORM.'
L1 = 999999999.0
L2 = 0.0
FITSUM = 0.0
DO 100 IORG = 1, NORG !
FOR EACH NEW ORGANISM...
L1 = MIN(FTNSS(IORG), L1)
IF (FTNSS(IORG).LT.AFACTOR/2.0) THEN
L2 = MAX(FTNSS(IORG), L2)
FITSUM = FITSUM + FTNSS(IORG)
END IF
100 CONTINUE
C WRITE (*,*) 'MIN,MAX
LENGTHS = ', L1, L2
C WRITE (*,*) 'SUM OF LENGTHS = ', FITSUM
IF (L1.EQ.L2) THEN
WRITE (*,*) 'L1=L2 IN GETNORM!'
read (*,'(a2)') STRG
STOP
END IF
RETURN
END
C
*******************************************************************
SUBROUTINE ORGSHOW(IORG)
! PLOT THE ORGANISMS
INCLUDE 'DARWING2.CMN'
include 'graphapi.fi'
include 'graph.fi'
REAL*8 XT1, YT1, XT2, YT2, XT3, YT3, H
INTEGER*2 J, K, IORG
CHARACTER*104 TEXT
H = 10.0
CALL _clearscreen(_GCLEARSCREEN)
write (text,*) 'gen #', IGEN
call _grtext_w(-90.0,1000.0,text)
write (text,FMTTOT) ORG(IORG)
call _grtext_w(-90.0, 950.0,text)
write (text,*) FTNSS(IORG)
call _grtext_w(-90.0, 900.0,text)
DO 200 J = 1, NFIX + NPV
XT1 = DBLE(XP(J))
YT1 = DBLE(YP(J))
call _setcolor(12)
call _ellipse_w(_GBORDER,XT1-H,YT1-H,XT1+H,YT1+H)
write (text,'(I3)') J
call _grtext_w(XT1,YT1,text)
DO 100 K = 1, NFIX + NPV
XT2 = DBLE(XP(K))
YT2 = DBLE(YP(K))
IF (CN(J, K)) THEN
call _setcolor(11)
call _moveto_w( XT1, YT1 )
call _lineto_w( XT2, YT2 )
call _ellipse_w(_GBORDER,XT1-H,YT1-H,XT1+H,YT1+H)
call _ellipse_w(_GBORDER,XT2-H,YT2-H,XT2+H,YT2+H)
END IF
100 CONTINUE
200 CONTINUE
RETURN
END
C
*******************************************************************
C CONTENTS OF FILE
'DARWING2.CMN'
PARAMETER (MXORGS=8000)
PARAMETER (MXGENS=5000)
PARAMETER (MXPNTS=20)
CHARACTER*104 ORG, TMPORG
CHARACTER*70 CMAP
CHARACTER*6 FMTPTS, FMTMAP, FMTTOT
CHARACTER*3 CTEMP
CHARACTER*2 C2TEMP
LOGICAL CN, COK
REAL*4 FTNSS, BESTLEN, AFACTOR, BFACTOR
INTEGER*2 NGEN, NORG, NFIX, NVMX, NTOT, NMUTE, XP, YP,
NPV
COMMON /GENPUL/
ORG(MXORGS), CN(MXPNTS,MXPNTS), FTNSS(MXORGS),
+ XP(MXPNTS), YP(MXPNTS), BESTLEN(MXGENS),
COK,
+ AFACTOR, BFACTOR, NGEN, NORG, NFIX, NVMX,
NTOT,
+ NMUTE, NPV, FMTPTS, FMTMAP, FMTTOT
C *******************************************************************
C CONTENTS OF FILE
'DSEED.CMN'
INTEGER*4 SEED
REAL*4 RNDVAL
COMMON /DSEED/ SEED
C *******************************************************************
C CONTENTS
OF INPUT (GEOMETRY) FILE '4NODE.DAT'
1052835 ! SEED; 1048577 ! 2^20+1
OVER-RIDE
5000 ! NGEN = # GENERATIONS
1000 ! RESTART # FOR NEW
GENERATIONS
1000 ! NORG= # of organisms ***
EVEN ***
4 ! NFIX = # of Fixed Points
(cities)
5 ! NVMX= MAX # of Variable
Points (connecting hubs)
100000.0 ! AFACTOR = MAX LENGTH
FACTOR
1.50 ! BFACTOR= GROWTH FACTOR
!!!!!
200,400 ! XP(1), YP(1)
800,400 ! XP(2), YP(2)
200,600 ! XP(3), YP(3)
800,600 ! XP(4), YP(4)
C *******************************************************************
C CONTENTS OF INPUT (GEOMETRY)
FILE '5NODE.DAT'
1048577 ! SEED; 1048577 ! 2^20+1
OVER-RIDE
20000 ! NGEN = # GENERATIONS
1000 ! RESTART # FOR NEW
GENERATIONS
2000 ! NORG= # of organisms ***
EVEN ***
5 ! NFIX = # of Fixed Points
(cities)
4 ! NVMX= MAX # of Variable
Points (connecting hubs)
100000.0 ! AFACTOR = MAX LENGTH
FACTOR
1.50 ! BFACTOR= GROWTH FACTOR
!!!!!
350,300 ! XP(1), YP(1)
650,300 ! XP(2), YP(2)
200,560 ! XP(3), YP(3)
800,560 ! XP(4), YP(4)
500,733 ! XP(5), YP(5)
More Info: Dave Thomas : nmsrdaveATswcp.com (Help fight SPAM! Please replace the AT with an @)