lgados.for

An Introduction to Genetic Algorithms for Scientists and Engineers By David Coley, World Scientific

      PROGRAM LGADOS
      
*     -----------------------------------------------------------------------
*     LGADOS.FOR - A FORTRAN version of the LGA Genetic Algorithm.
      
*     For Distribution with the book "An Introduction to Genetic Algorithms for
*     Scientists and Engineers", World Scientific 1998.
      
*     David A. Coley
*     Complex Systems Group
*     Physics Building
*     University of Exeter
*     Exeter
*     EX4 4QL
*     UK
*     email [e-mail]

*     Before using this software please check for updates and corrections at
*     http://www.ex.ac.uk/cee/ga 

*     Version = 17th July 1998

*     The random number sub routine is rather poor and should be replaced by a 
*     library call to a better routine if at all possible

*     To try and ensure the two versions read as closely as possible,
*     this code has been converted from the BASIC version with the minimum
*     number of alterations. If FORTRAN had been the starting point the
*     form of the code would be somewhat different and the scope of the 
*     variables more sensible.
      
*     -----------------------------------------------------------------------
      
*     ------- SET ALL THE IMPORTANT FIXED PARAMETERS. -------
      
*     These should be set by the user.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER GENER,PSIZE,NUNKNO,SUBLEN,TSLENG,MAXG,NEWIND,MATE1,
     + MATE2,FITIND

*     Set the random number generator to so it produces a different set of numbers
*     each time LGADOS is run by changing the value of ISEED in RND().
	
*     Must be even.	
      PARAMETER(PSIZE = 4)
      PARAMETER(NUNKNO = 2)
*     All sub-strings have the same length.
      PARAMETER(SUBLEN =6)
      PARAMETER(TSLENG = NUNKNO*SUBLEN)
      PARAMETER(MAXG = 4)
      PARAMETER(CP = 0.6 )
      PARAMETER(MP = 1/12.)
      CHARACTER*3 ELITE
      PARAMETER(ELITE = 'on ')
      PARAMETER(SCALEC = 2)
  
*     ------DECLARE ALL SHARED (IE. GLOBAL) VARIABLES----------
      
*     The arrays that hold the individuals within the current population.
      REAL UNKNO(PSIZE,NUNKNO), FIT(PSIZE)
      INTEGER INTEGS(PSIZE, NUNKNO)
      INTEGER STRING(PSIZE, TSLENG)
 
*     The new population.
      INTEGER NSTRIN(PSIZE, TSLENG) 
      
*     The array that defines the range of the unknowns.
      REAL RANGE(2, NUNKNO) 
      
*     The best individual in the past GENER. Used if ELITE is on.
      INTEGER ESTRIN(TSLENG) 
      INTEGER EINTEG(NUNKNO) 
      REAL EliteFIT 
      REAL EUNKNO(NUNKNO)
     
*     -----------------------------------------------------------------       
      
*     Define the range of each unknown. These should also be set by the user.   
      CALL DefineRange(RANGE,NUNKNO) 
           
*     Open files used to store results
      CALL OPENFILES
    
*     ------- START OF THE GENETIC ALGORITHM -------
      
*     ------- CREATE AN INITIAL POPULATION, GENERATION 1 ------
      
      GENER = 1

*     Build a population of strings at random.
      CALL InitialPopulation(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,
     +  STRING,UNKNO,RANGE)

*     Find the fitness of each member of the population. 
      CALL FindFIT(PSIZE,UNKNO,NUNKNO,FIT) 

*     Find the mean fitness and the fittest individual. 
      CALL Statistics(MEANF,SUMFIT,FITIND,PSIZE,FIT,INTEGS,
     + STRING,ESTRIN,EINTEG,EUNKNO,NUNKNO,TSLENG,UNKNO,ELITE,EFIT)
 
*     Print generation to file. 
      CALL PrintGeneration(GENER,MEANF,FITIND,PSIZE,TSLENG,
     + NUNKNO,STRING,UNKNO,FIT)
     
*     If linear fitness scaling is on then scale population prior to selection.	 
      CALL Scaling(SCALEC,FITIND,SUMFIT,MEANF,FIT,PSIZE)  
      
*     ------- LOOP OVER ALL THE GENERATIONS -------
      
      DO 1 GENER = 2 , MAXG

*     Loop over the population choosing pairs of mates. 
        DO 2 NEWIND = 1 , PSIZE, 2 
     
          CALL Selection(MATE1,SUMFIT,PSIZE,FIT)
     
          CALL Selection(MATE2,SUMFIT,PSIZE,FIT)
          WRITE(*,*)MATE1,MATE2                                                   
*     Pass individuals to the temporary population either with or without performing crossover.
          IF (RND().LE.CP) THEN 
            CALL CrossOver(MATE1, MATE2, NEWIND,TSLENG,NSTRIN,PSIZE,
     + STRING)
          ELSE
            CALL NoCrossover(MATE1,MATE2,NEWIND,PSIZE,TSLENG,STRING,
     + NSTRIN)
          ENDIF
      
2        CONTINUE

*     Mutate the temporary population.
        CALL Mutate(PSIZE,TSLENG,NSTRIN,MP) 

*     Replace the old population completely by the new one.
        CALL Replace(PSIZE,TSLENG,STRING,NSTRIN)
 
*     De-code the new population to integers then real numbers.
        CALL FindUNKNO(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,STRING,
     + UNKNO,RANGE) 

*       Find the fitness of each member of the population.
        CALL FINDFIT(PSIZE,UNKNO,NUNKNO,FIT)
 
*       Find the mean fitness and the fittest individual.
        CALL Statistics(MEANF,SUMFIT,FITIND,PSIZE,FIT,INTEGS,
     +  STRING,ESTRIN,EINTEG,EUNKNO,NUNKNO,TSLENG,UNKNO,ELITE,EFIT)
 
*       Print results to file.        
        CALL PrintGeneration(GENER,MEANF,FITIND,PSIZE,TSLENG,
     +  NUNKNO,STRING,UNKNO,FIT) 

*     If linear fitness scaling is "on " then scale population prior to selection.
        CALL Scaling(SCALEC,FITIND,SUMFIT,MEANF,FIT,PSIZE)
        
1     CONTINUE
      
*     Close all files    
      CLOSE (1)
      CLOSE (2)
      CLOSE (3) 

      END
      
      SUBROUTINE CrossOver (MATE1, MATE2, NEWIND,TSLENG,NSTRIN,PSIZE,
     + STRING)
      
*     Perform single point crossover.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER BIT,CSITE,NEWIND,TSLENG,PSIZE,MATE1,MATE2
      INTEGER STRING(PSIZE,TSLENG)
      INTEGER NSTRIN(PSIZE,TSLENG)
      write(*,*)'CROSS'
*     Pick the cross-site at random. 
      CSITE = (TSLENG - 1)* RND() + 1

*     Swap bits to the left of the cross-site.
      DO 1 BIT =1 , CSITE
        NSTRIN(NEWIND, BIT) = STRING(MATE1, BIT)
        NSTRIN(NEWIND + 1, BIT) = STRING(MATE2, BIT)
1     CONTINUE

*     Swap bits to the right of the cross-site.
      DO 2 BIT = CSITE + 1 , TSLENG
        NSTRIN(NEWIND, BIT) = STRING(MATE2, BIT)
        NSTRIN(NEWIND + 1, BIT) = STRING(MATE1, BIT)
2     CONTINUE
      
      RETURN 
      END
      
          
            
      SUBROUTINE DefineRange(RANGE,NUNKNO)
*     Defines the upper and lower bounds of each unknown.
*     Add other ranges using the same format if more than two unknowns in the problem.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER UNKNOW,NUNKNO
      REAL RANGE(2,NUNKNO)

*     The first unknown.      
      UNKNOW = 1
*     The lower bound.
      RANGE(1,UNKNOW) = 0
*     The upper bound. 
      RANGE(2,UNKNOW) = 1 

*     The second unknown.      
      UNKNOW = 2
      RANGE(1,UNKNOW) = 0
      RANGE(2,UNKNOW) = 3.14159
       
      RETURN 
      END
      
      SUBROUTINE ELITES (FITIND,PSIZE,NUNKNO,TSLENG,UNKNO,FIT,
     + INTEGS,STRING,ESTRIN,EINTEG,EUNKNO,EFIT)
*     Applies ELITE by replacing a randomly chosen individual by the elite member
*     from the previous population if the new max fitness is less then the previous value.
      IMPLICIT REAL (A-H,J-Z) 
      INTEGER BIT,FITIND,PSIZE,NUNKNO,TSLENG,UNKNOW     
      REAL UNKNO(PSIZE,NUNKNO), FIT(PSIZE)
      INTEGER INTEGS(PSIZE, NUNKNO)
      INTEGER STRING(PSIZE, TSLENG)
      INTEGER ESTRIN(TSLENG) 
      INTEGER EINTEG(NUNKNO) 
      REAL EUNKNO(NUNKNO)
      write(*,*)'ELITE'     
      IF (FIT(FITIND).LT.EFIT) THEN

*     Chosen individual to be replaced.
        INDIV = INT(PSIZE* RND() + 1)
      
        DO 1 BIT = 1 , TSLENG
          STRING(INDIV, BIT) = ESTRIN(BIT)
1       CONTINUE
      
        FIT(INDIV) = EFIT
      
        DO 2 UNKNOW = 1 , NUNKNO
          INTEGS(INDIV, UNKNOW) = EINTEG(UNKNOW)
          UNKNO(INDIV, UNKNOW) = EUNKNO(UNKNOW)
2       CONTINUE
      
        FITIND = INDIV
      
      ENDIF
      
      DO 3 BIT = 1 , TSLENG
              ESTRIN(BIT) = STRING(FITIND, BIT)
3     CONTINUE
      
      EFIT = FIT(FITIND)
                            
      DO 4 UNKNOW = 1 , NUNKNO
        EINTEG(UNKNOW) = INTEGS(FITIND, UNKNOW)
        EUNKNO(UNKNOW) = UNKNO(FITIND, UNKNOW)
4     CONTINUE
      
      RETURN 
      END
      
      SUBROUTINE FindFIT(PSIZE,UNKNO,NUNKNO,FIT)
*     The problem at hand is used to assign a positive (or zero) fitness to each individual in turn.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER PSIZE,NUNKNO      
      REAL UNKNO(PSIZE,NUNKNO)
      REAL FIT(PSIZE)
      
*     The problem is f = x^2 + sin(y).
      DO 1 INDIV = 1 , PSIZE
        FIT(INDIV) = UNKNO(INDIV, 1)**2 + SIN(UNKNO(INDIV, 2))
1     CONTINUE
         
      RETURN 
      END
      
      SUBROUTINE FindINTEGS(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,STRING)
*     Decode the strings to sets of decimal integers.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER PSIZE,TSLENG,NUNKNO,SUBLEN,BIT,SBIT 
      INTEGER INTEGS(PSIZE, NUNKNO)
      INTEGER STRING(PSIZE, TSLENG)      
      INTEGER BIT
      
      DO 1 INDIV = 1 , PSIZE      
        BIT = TSLENG + 1
        DO 2 UNKNOW = NUNKNO , 1 ,-1      
          INTEGS(INDIV, UNKNOW) = 0
          DO 3 SBIT = 1 , SUBLEN      
            BIT = BIT - 1
            IF (STRING(INDIV, BIT).EQ.1) THEN
              INTEGS(INDIV, UNKNOW) = INTEGS(INDIV, UNKNOW) +
     +        2**(SBIT - 1)
            ENDIF      
3         CONTINUE     
2       CONTINUE      
1     CONTINUE