Fortran

Demo Fortran90 Genetic Algorithm Code

NOTE: The following is what I wrote during my Doctorate and has not been modified since. Please treat as such!!
To copy the code you can right click in the text area.

The code is written in Fortran 90. All undeclared variables are real unless the variable name begins with the letters I-N in which case the are integers. The routine for setting the random seed is specific to the ftn90 compiler for pc’s by NAG/Salford software, otherwise it should work on any Fortran 90 compiler. In the code anything following a ‘!’ is a comment.

The following code is included as a demonstration of a genetic algorithm optimisation procedure. The subroutine CALCSUITABILITY determines the 'performance' of each candidate solution on which the tournament selection procedure is based in the subroutine BREED. In this particular example the more identical adjacent bits in the string the better the suitability. Each bit can have values of 0,1,2 or 3

F90 Code

PROGRAM Genetic
!!coded in Fortran 90 by Philip Brierley

!! declare arrays !!
INTEGER,ALLOCATABLE :: PARENT(:,:),SUITABILITY(:)
INTEGER :: STRINGSIZE,POPSIZE,GENERATIONS,CONTESTANTS
COMMON STRINGSIZE,POPSIZE

!! set up some user defined parameters !!
GENERATIONS=1000	!number of generations before stopping
POPSIZE=20		!number of strings in each generation
STRINGSIZE=30		!number of bits in each string
CONTESTANTS=3		!no of contestants in tournament selection
PROB_MUT=0.01		!mutation probability
PROB_CROSS=0.8		!crossover probability

!! set the array dimensions !!
ALLOCATE(PARENT(POPSIZE,STRINGSIZE))
ALLOCATE(SUITABILITY(POPSIZE))		!'fitness' of each parent

!these calls will be compiler specific
CALL CLEAR_SCREEN@
CALL DATE_TIME_SEED@

!! generate an initial population !!
DO I=1,POPSIZE
DO J=1,STRINGSIZE
PARENT(I,J)=NINT(RANDOM()*3)		!create a string of 0's, 1's, 2's and 3's
ENDDO
ENDDO

!! start the process !!
DO I=1,GENERATIONS

!! suitability of each individual string !!
CALL CALCSUITABILITY(PARENT,SUITABILITY)

!! print status	worst,best,average !!
PRINT *,I, MINVAL(SUITABILITY), MAXVAL(SUITABILITY), SUM(SUITABILITY)/POPSIZE

!! create new generation !!
CALL BREED(SUITABILITY,PARENT,PROB_CROSS,PROB_MUT,CONTESTANTS)

ENDDO !(I)

!! this is the end !!

STOP
END

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE CALCSUITABILITY(PARENT,SUITABILITY)

INTEGER::  STRINGSIZE,POPSIZE
INTEGER :: PARENT(POPSIZE,STRINGSIZE),SUITABILITY(POPSIZE)

COMMON STRINGSIZE,POPSIZE

SUITABILITY=0

DO I=1,POPSIZE
DO J=1,STRINGSIZE-1
	IF (PARENT(I,J)==PARENT(I,J+1)) THEN
	SUITABILITY(I)=SUITABILITY(I)+1	! based on adjacent bits being the same
	ENDIF
ENDDO !(J)
ENDDO !(I)

END SUBROUTINE CALCSUITABILITY

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE BREED(SUITABILITY,PARENT,PROB_CROSS,PROB_MUT,CONTESTANTS)

INTEGER :: POPSIZE,STRINGSIZE,CONTESTANTS
INTEGER :: PARENT(POPSIZE,STRINGSIZE)
INTEGER :: SON(POPSIZE,STRINGSIZE)		!next generation
INTEGER :: POTENTIAL_DAD(CONTESTANTS)		!potential parents
INTEGER :: DAD(2,STRINGSIZE)			!array for 2 chosen parents
INTEGER :: SUITABILITY(POPSIZE)

COMMON STRINGSIZE,POPSIZE

DO I=1,POPSIZE		!each mating results in only 1 offspring

!! choose two parents !!
	DO J=1,2
		DO K=1,CONTESTANTS			!randomly select contestants
		POTENTIAL_DAD(K)=NINT(RANDOM()*(POPSIZE-1))+1
		ENDDO  !(K)

DAD(J,:)=PARENT(POTENTIAL_DAD(1),:)	!first assumes the throne
		IWINNER=SUITABILITY(POTENTIAL_DAD(1))

DO M=2,CONTESTANTS			!tournament begins
		IF (SUITABILITY(POTENTIAL_DAD(M))>IWINNER) THEN
		DAD(J,:)=PARENT(POTENTIAL_DAD(M),:)
		IWINNER=SUITABILITY(POTENTIAL_DAD(M))
		ENDIF
		ENDDO !(M)

ENDDO	 !(J)					!two parents chosen

!! create an offspring !!
	IF (RANDOM()<PROB_CROSS) THEN			!probability of crossover
		ICROSSPOS=NINT(RANDOM()*(STRINGSIZE-2))+1
		SON(I,1:ICROSSPOS)=DAD(1,1:ICROSSPOS)
		SON(I,ICROSSPOS+1:STRINGSIZE)=DAD(2,ICROSSPOS+1:STRINGSIZE)
	ELSE
		SON(I,:)=DAD(1,:)		!one parent replicates into next generation
	ENDIF

!!mutate the offspring !!
	DO N=1,STRINGSIZE
		IF (RANDOM()<PROB_MUT) THEN	!probability of mutation
		SON(I,N)=NINT(RANDOM()*3)	!mutate
		ENDIF
	ENDDO !(N)

ENDDO !(I)

PARENT=SON					!the offspring become the next generation

END SUBROUTINE BREED