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 D.A.Coley@exeter.ac.uk

*     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
          
      RETURN 
      END
      
      SUBROUTINE FindUNKNO(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,STRING,
     + UNKNO,RANGE)
*     Decode the strings to real numbers.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER PSIZE,TSLENG,NUNKNO,SUBLEN,UNKNOW
      INTEGER INTEGS(PSIZE, NUNKNO)
      INTEGER STRING(PSIZE, TSLENG) 
      REAL UNKNO(PSIZE,NUNKNO)  
      REAL RANGE(2, NUNKNO)

*     First decode the strings to sets of decimal integers.      
      CALL FindINTEGS(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,STRING)
      
*     Now convert these integers to reals.
      DO 1 INDIV = 1 , PSIZE
        DO 2 UNKNOW = 1 , NUNKNO
          UNKNO(INDIV, UNKNOW) = RANGE(1, UNKNOW) + 
     +    INTEGS(INDIV, UNKNOW)* 
     +    (RANGE(2, UNKNOW) - RANGE(1, UNKNOW)) / (2**SUBLEN - 1)
2       CONTINUE
1     CONTINUE
         
      RETURN 
      END
      
            
      SUBROUTINE InitialPopulation(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,
     +  STRING,UNKNO,RANGE)
*     Create the initial random population.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER BIT,PSIZE,TSLENG,NUNKNO,SUBLEN
      INTEGER STRING(PSIZE, TSLENG) 
           
      DO 1 INDIV = 1 , PSIZE
      
        DO 2 BIT = 1 , TSLENG
          IF (RND().GT.0.5) THEN
            STRING(INDIV, BIT) = 1
          ELSE
            STRING(INDIV, BIT) = 0
          ENDIF
2        CONTINUE
              
1     CONTINUE
 
*     Decode strings to real numbers.    
      CALL FindUNKNO(PSIZE,TSLENG,NUNKNO,SUBLEN,INTEGS,STRING,UNKNO,
     + RANGE)
      
      RETURN 
      END
      
      SUBROUTINE Mutate(PSIZE,TSLENG,NSTRIN,MP)
*     Visit each bit of each string very occasionally flipping a "1" to a "0" or visa versa.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER PSIZE,TSLENG,BIT
      INTEGER NSTRIN(PSIZE,TSLENG) 
      write(*,*)'mutate',MP
      DO 1 INDIV = 1, PSIZE
        DO 2 BIT = 1, TSLENG         
*         Throw a random number and see if it is less than or equal to the mutation probability.
          IF (RND().LE.MP) THEN                 
*           Mutate.
            IF (NSTRIN(INDIV, BIT).EQ.1) THEN
                    NSTRIN(INDIV, BIT) = 0
            ELSE
                    NSTRIN(INDIV, BIT) = 1
            ENDIF      
          ENDIF                       
2       CONTINUE      
1     CONTINUE
                   
      RETURN 
      END
      
      SUBROUTINE NoCrossover(MATE1,MATE2,NEWIND,PSIZE,TSLENG,STRING,
     + NSTRIN)
*     Pass the selected strings to the temporary population without applying crossover.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER MATE1,MATE2,NEWIND,PSIZE,TSLENG,BIT
      INTEGER STRING(PSIZE, TSLENG)
      INTEGER NSTRIN(PSIZE, TSLENG) 
      write(*,*)'NOCROSS'
      DO 1 BIT = 1 , TSLENG
        NSTRIN(NEWIND, BIT) = STRING(MATE1, BIT)
        NSTRIN(NEWIND + 1, BIT) = STRING(MATE2, BIT)
*        WRITE(*,*)NEWIND,MATE1,MATE2,BIT
1     CONTINUE
      
      RETURN 
      END
      
      SUBROUTINE OpenFiles
*     Open result files. See Chapter 2 for a description of their contents.     
      OPEN (1, FILE='LGADOS.RES') 
      OPEN (2, FILE='LGADOS.ALL')
      OPEN (99, FILE='C:\SHIT.DAT')	
      
      RETURN 
      END
      
      SUBROUTINE PrintGeneration (GENER,MEANF,FITIND,PSIZE,TSLENG,
     + NUNKNO,STRING,UNKNO,FIT)
*     Print results to the screen and the files.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER GENER,FITIND,PSIZE,TSLENG,NUNKNO
      REAL UNKNO(PSIZE,NUNKNO), FIT(PSIZE)
      INTEGER STRING(PSIZE, TSLENG)
       
*     Screen.      
      WRITE (*,*) GENER, FIT(FITIND), MEANF 
*     File LGADOS.RES.
      WRITE (1,*) GENER, ',', FIT(FITIND), ',', MEANF
      
      DO 1 UNKNOW = 1 , NUNKNO
*       Screen.
*       WRITE (*,*) UNKNO(FITIND, UNKNOW)
*       File LGADOS.RES
*       WRITE (1,*)  ','; UNKNO(FITIND, UNKNOW);
1     CONTINUE

*     Carriage return.      
*      WRITE (*,*)
*     Carriage return.
*     WRITE (1,*) 
      
      DO 2 INDIV = 1 , PSIZE
*      File LGADOS.ALL
*        WRITE (,) #2, GENER; ','; FIT(INDIV); ',';
*     
        DO 3 UNKNOW = 1 , NUNKNO
*         File LGADOS.ALL
*          WRITE (,) #2, UNKNO(INDIV, UNKNOW);
3       CONTINUE
       
        DO 4 BIT = 1 , TSLENG
*        File LGADOS.ALL
          WRITE (2,*) STRING(INDIV, BIT)
4       CONTINUE
*       Carriage return  
*        WRITE (2,*)
      
2     CONTINUE
      
      RETURN 
      END
      
      SUBROUTINE Replace(PSIZE,TSLENG,STRING,NSTRIN)
*     Replace the old population with the new one.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER PSIZE,TSLENG,BIT
      INTEGER STRING(PSIZE, TSLENG)
      INTEGER NSTRIN(PSIZE, TSLENG) 
      
      DO 1 INDIV = 1 , PSIZE
        DO 2 BIT = 1 , TSLENG
          STRING(INDIV, BIT) = NSTRIN(INDIV, BIT)
2     CONTINUE
1     CONTINUE

      RETURN 
      END
      
      SUBROUTINE Scaling(SCALEC,FITIND,SUMFIT,MEANF,FIT,PSIZE)      
*     Apply Linear FIT Scaling,
*           scaledfitness = a* fitness + b.
*     Subject to,
*           meanscaledfitness = meanfitness
*     and
*           bestscaledfitness = c* MEANF,
*     where c, the scaling constant, is set by the user.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER FITIND,PSIZE
      REAL FIT(PSIZE)
      INTEGER INDIV

*     If the scaling constant is set to zero, or all individuals have the same
*     fitness, scaling is not applied.
      IF ((SCALEC.NE.0).AND.(FIT(FITIND) - MEANF.GT.0)) THEN
*     Find A and b.
      
      A = (SCALEC - 1)* MEANF / (FIT(FITIND) - MEANF)
      
      B = (1 - a)* MEANF
      
*     Adjust the fitness of all members of the population.
        SUMFIT = 0
        DO 1 INDIV = 1 , PSIZE
          FIT(INDIV) = A* FIT(INDIV) + B
*         Avoid negative values near the end of a run
          IF (FIT(INDIV).LT.0) FIT(INDIV) = 0
*         Adjust the sum of all the fitnesses.
          SUMFIT = SUMFIT + FIT(INDIV)
1       CONTINUE
      
*     Adjust the mean of all the fitnesses.
        MEANF = SUMFIT / PSIZE
      ENDIF
      
      RETURN 
      END
      
      SUBROUTINE Selection(MATE,SUMFIT,PSIZE,FIT)
*     Select a single individual by fitness proportional selection.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER MATE,PSIZE,I
      REAL FIT(PSIZE)
      write(*,*)'SELECT',PSIZE
      SUM = 0
      INDIV = 0
      
      RWHEEL = RND()* SUMFIT
      write(*,*)SUMFIT,RWHEEL
      DO 1 I=1,PSIZE
        INDIV = INDIV + 1
        SUM = SUM + FIT(INDIV)
        WRITE(*,*)SUM,FIT(INDIV),INDIV
      IF (SUM.GE.RWHEEL) GO TO 2
1     CONTINUE
      
2     MATE = INDIV
      
      RETURN 
      END
      
      SUBROUTINE Statistics(MEANF,SUMFIT,FITIND,PSIZE,FIT,INTEGS,
     + STRING,ESTRIN,EINTEG,EUNKNO,NUNKNO,TSLENG,UNKNO,ELITE,EFIT)
*     Calculate the sum of fitness across the population and find the best individual,
*     then apply ELITE if required.
      IMPLICIT REAL (A-H,J-Z)
      INTEGER FITIND,PSIZE,NUNKNO,TSLENG,INDIV
      REAL FIT(PSIZE)
      INTEGER STRING(PSIZE, TSLENG)
      INTEGER ESTRIN(TSLENG) 
      INTEGER EINTEG(NUNKNO) 
      CHARACTER*3 ELITE

      FITIND = 0
      MAXFIT = 0
      
      DO 1 INDIV = 1 , PSIZE
        IF (FIT(INDIV).GT.MAXFIT) THEN
          MAXFIT = FIT(INDIV)
          FITIND = INDIV
        ENDIF
1     CONTINUE
      
      IF (ELITE.EQ.'on ') THEN
        CALL ELITES (FITIND,PSIZE,NUNKNO,TSLENG,UNKNO,FIT,
     + INTEGS,STRING,ESTRIN,EINTEG,EUNKNO,EFIT)
      ENDIF
     
*     Sum the fitness. 
      SUMFIT = 0
      DO 2 INDIV = 1 , PSIZE
        SUMFIT = SUMFIT + FIT(INDIV)
2     CONTINUE
      
*     Find the average fitness of the population.
      MEANF = SUMFIT / PSIZE
      
      RETURN 
      END

      FUNCTION RND()
*     This is a very simple random number generator
*     adapted from "FORTRAN 77" by D.M.Monro.
*     If possible, a better one should be used.
      SAVE NEW,I

*     Change ISEED each time LGADOS is run so that the random number generator produces
*     a different set of numbers.

      ISEED=15625

      IF (I.EQ.0) NEW=ISEED
      I=I+1
      NEW=NEW*ISEED
      NEW=MOD(NEW,16384)
      IF (NEW.LT.0) NEW=16384+NEW

      RND=NEW/16384.

      RETURN
      END