lgados.for

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

      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