ga170.f90

Genetic Algorithmn FORTRAN source code. Good start for knowing and studying

SUBROUTINE evalout(iiskip, iiend, ibest, fbar, best)
!
!  This subroutine evaluates the population, assigns fitness,
!  establishes the best individual, and outputs information.

INTEGER, INTENT(IN)     :: iiskip
INTEGER, INTENT(IN)     :: iiend
INTEGER, INTENT(OUT)    :: ibest(nchrmax)
REAL (dp), INTENT(OUT)  :: fbar
REAL (dp), INTENT(OUT)  :: best

INTERFACE
  SUBROUTINE func(j, funcval)
    USE GA_commons
    IMPLICIT NONE
    INTEGER, INTENT(IN)     :: j
    REAL (dp), INTENT(OUT)  :: funcval
  END SUBROUTINE func
END INTERFACE

!
INTEGER    :: j, jend, jstart, k, kk, n
REAL (dp)  :: fitsum, funcval, paramsm(nparmax), paramav(nparmax)
!
fitsum = 0.0D0
best = -1.0D10
paramsm(1:nparam) = 0.0D0
jstart = 1
jend = npopsiz
IF (iiskip /= 0) jstart = iiskip
IF (iiend /= 0) jend = iiend
DO  j = jstart, jend
  CALL decode(j, parent, iparent)
  IF (iiskip /= 0 .AND. iiend /= 0 .AND. iiskip == iiend) WRITE (6,5000)  &
      j, (iparent(k,j),k = 1,nchrome), (parent(kk,j),kk = 1,nparam ), 0.0
!
!  Call function evaluator, write out individual and fitness, and add
!  to the summation for later averaging.
  CALL func(j, funcval)
  fitness(j) = funcval
  WRITE (24,5000) j, (iparent(k,j),k = 1,nchrome), (parent(kk,j),  &
                  kk = 1,nparam), fitness(j)
  fitsum = fitsum + fitness(j)
  DO  n = 1, nparam
    paramsm(n) = paramsm(n) + parent(n,j)
  END DO
!
!  Check to see if fitness of individual j is the best fitness.
  IF (fitness(j) > best) THEN
    best = fitness(j)
    DO  k = 1, nchrome
      ibest(k) = iparent(k,j)
    END DO
  END IF
END DO
!
!  Compute parameter and fitness averages.
fbar = fitsum / DBLE(npopsiz)
DO  n = 1, nparam
  paramav(n) = paramsm(n) / DBLE(npopsiz)
END DO
!
!  Write output information
IF (npopsiz == 1) THEN
  WRITE (24,5000) 1, (iparent(k,1),k = 1,nchrome), (parent(k,1),k  &
                  = 1,nparam), fitness(1)
  WRITE (24,*) ' Average Values:'
  WRITE (24,5300) (parent(k,1),k = 1,nparam), fbar
ELSE
  WRITE (24,5300) (paramav(k),k = 1,nparam), fbar
END IF
WRITE (6,5100) fbar
WRITE (24,5100) fbar
WRITE (6,5200) best
WRITE (24,5200) best
!
RETURN

5000 FORMAT (i3, ' ', 30I1, 2(' ', f7.4), ' ', f8.5)
5100 FORMAT (' Average Function Value of Generation=', f8.5)
5200 FORMAT (' Maximum Function Value              =', f8.5/)
5300 FORMAT (/' Average Values:', t34, 2(' ', f7.4), ' ', f8.5/)
END SUBROUTINE evalout
!#######################################################################

SUBROUTINE niche()
!
!  Implement "niching" through Goldberg's multidimensional phenotypic
!  sharing scheme with a triangular sharing function.  To find the
!  multidimensional distance from the best individual, normalize all
!  parameter differences.
!
!
!   Variable definitions:
!
!  alpha   = power law exponent for sharing function; typically = 1.0
!  del     = normalized multidimensional distance between ii and all
!            other members of the population
!            (equals the square root of del2)
!  del2    = sum of the squares of the normalized multidimensional
!            distance between member ii and all other members of
!            the population
!  nniche  = number of niched parameters
!  sigshar = normalized distance to be compared with del; in some sense,
!            1/sigshar can be viewed as the number of regions over which
!            the sharing function should focus, e.g. with sigshar=0.1,
!            the sharing function will try to clump in ten distinct
!            regions of the phase space.  A value of sigshar on the
!            order of 0.1 seems to work best.
!  share   = sharing function between individual ii and j
!  sumshar = sum of the sharing functions for individual ii
!
!      alpha=1.0

REAL (dp)  :: del, del2, share, sigshar, sumshar
INTEGER    :: ii, j, jj, k, nniche

sigshar = 0.1D0
nniche = 0
DO  jj = 1, nparam
  nniche = nniche + nichflg(jj)
END DO
IF (nniche == 0) THEN
  WRITE (6,5000)
  WRITE (24,5000)
  CLOSE (24)
  STOP
END IF
DO  ii = 1, npopsiz
  sumshar = 0.0D0
  DO  j = 1, npopsiz
    del2 = 0.0D0
    DO  k = 1, nparam
      IF (nichflg(k) /= 0) THEN
        del2 = del2 + ((parent(k,j)-parent(k,ii))/pardel(k)) ** 2
      END IF
    END DO
    del = SQRT(del2) / nniche
    IF (del < sigshar) THEN
!               share=1.0 - ((del/sigshar)**alpha)
      share = 1.0D0 - (del/sigshar)
    ELSE
      share = 0.0D0
    END IF
    sumshar = sumshar + share / npopsiz
  END DO
  IF (sumshar /= 0.0D0) fitness(ii) = fitness(ii) / sumshar
END DO
!
!
RETURN
5000 FORMAT (' ERROR: iniche=1 and all values in nichflg array = 0'/  &
             '       Do you want to niche or not?')
END SUBROUTINE niche
!#######################################################################

SUBROUTINE selectn(ipick, j, mate1, mate2)
!
!  Subroutine for selection operator.  Presently, tournament selection
!  is the only option available.
!

INTEGER, INTENT(IN OUT)  :: ipick
INTEGER, INTENT(IN)      :: j
INTEGER, INTENT(IN OUT)  :: mate1
INTEGER, INTENT(IN OUT)  :: mate2

INTEGER  :: n
!
!  If tournament selection is chosen (i.e. itourny=1), then
!  implement "tournament" selection for selection of new population.
IF (itourny == 1) THEN
  CALL select(mate1, ipick)
  CALL select(mate2, ipick)
!        write(3,*) mate1,mate2,fitness(mate1),fitness(mate2)
  DO  n = 1, nchrome
    ichild(n,j) = iparent(n, mate1)
    IF (nchild == 2) ichild(n,j+1) = iparent(n,mate2)
  END DO
END IF
!
RETURN
END SUBROUTINE selectn
!#######################################################################

SUBROUTINE crosovr(ncross, j, mate1, mate2)
!
!  Subroutine for crossover between the randomly selected pair.

INTEGER, INTENT(OUT)     :: ncross
INTEGER, INTENT(IN)      :: j
INTEGER, INTENT(IN OUT)  :: mate1
INTEGER, INTENT(IN OUT)  :: mate2

REAL (dp)  :: rand
INTEGER    :: icross, n
!
IF (iunifrm == 0) THEN
!  Single-point crossover at a random chromosome point.
  idum = 1
  CALL ran3(idum, rand)
  IF (rand > pcross) GO TO 30
  ncross = ncross + 1
  idum = 1
  CALL ran3(idum, rand)
  icross = 2 + INT(DBLE(nchrome-1)*rand)
  DO  n = icross, nchrome
    ichild(n,j) = iparent(n,mate2)
    IF (nchild == 2) ichild(n,j+1) = iparent(n,mate1)
  END DO
ELSE
!  Perform uniform crossover between the randomly selected pair.
  DO  n = 1, nchrome
    idum = 1
    CALL ran3(idum, rand)
    IF (rand <= pcross) THEN
      ncross = ncross + 1
      ichild(n,j) = iparent(n,mate2)
      IF (nchild == 2) ichild(n,j+1) = iparent(n,mate1)
    END IF
  END DO
END IF
!
30 RETURN
END SUBROUTINE crosovr
!#######################################################################

SUBROUTINE mutate()
!

REAL (dp)  :: creep, rand
INTEGER    :: j, k, ncreep, nmutate
!
!  This subroutine performs mutations on the children generation.
!  Perform random jump mutation if a random number is less than pmutate.
!  Perform random creep mutation if a different random number is less
!  than pcreep.
nmutate = 0
ncreep = 0
DO  j = 1, npopsiz
  DO  k = 1, nchrome
!  Jump mutation
    idum = 1
    CALL ran3(idum, rand)
    IF (rand <= pmutate) THEN
      nmutate = nmutate + 1
      IF (ichild(k,j) == 0) THEN
        ichild(k,j) = 1
      ELSE
        ichild(k,j) = 0
      END IF
      IF (nowrite == 0) WRITE (6,5100) j, k
      IF (nowrite == 0) WRITE (24,5100) j, k
    END IF
  END DO

!  Creep mutation (one discrete position away).
  IF (icreep /= 0) THEN
    DO  k = 1, nparam
      idum = 1
      CALL ran3(idum, rand)
      IF (rand <= pcreep) THEN
        CALL decode(j, child, ichild)
        ncreep = ncreep + 1
        creep = 1.0D0
        idum = 1
        CALL ran3(idum, rand)
        IF (rand < 0.5D0) creep = -1.0D0
        child(k,j) = child(k,j) + g1(k) * creep
        IF (child(k,j) > parmax(k)) THEN
          child(k,j) = parmax(k) - 1.0D0 * g1(k)
        ELSE IF (child(k,j) < parmin(k)) THEN
          child(k,j) = parmin(k) + 1.0D0 * g1(k)
        END IF
        CALL code(j, k, child, ichild)
        IF (nowrite == 0) WRITE (6,5200) j, k
        IF (nowrite == 0) WRITE (24,5200) j, k
      END IF
    END DO
  END IF
END DO
WRITE (6,5000) nmutate, ncreep
WRITE (24,5000) nmutate, ncreep
!
!
RETURN
5000 FORMAT (/'  Number of Jump Mutations  =', i5/  &
              '  Number of Creep Mutations =', i5)
5100 FORMAT ('*** Jump mutation performed on individual  ', i4,  &
             ', chromosome ', i3, ' ***')
5200 FORMAT ('*** Creep mutation performed on individual ', i4,  &
             ', parameter  ', i3, ' ***')
END SUBROUTINE mutate
!#######################################################################

SUBROUTINE newgen(iielite, npossum, ig2sum, ibest)
!
!  Write child array back into parent array for new generation.  Check
!  to see if the best parent was replicated; if not, and if ielite=1,
!  then reproduce the best parent into a random slot.
!

INTEGER, INTENT(IN)  :: iielite
INTEGER, INTENT(IN)  :: npossum
INTEGER, INTENT(IN)  :: ig2sum
INTEGER, INTENT(IN)  :: ibest(nchrmax)

INTEGER    :: irand, j, jelite, kelite, n
REAL (dp)  :: rand
!
IF (npossum < ig2sum) CALL possibl(child, ichild)
kelite = 0
DO  j = 1, npopsiz
  jelite = 0
  DO  n = 1, nchrome
    iparent(n,j) = ichild(n,j)
    IF (iparent(n,j) == ibest(n)) jelite = jelite + 1
    IF (jelite == nchrome) kelite = 1
  END DO
END DO
IF (iielite /= 0 .AND. kelite == 0) THEN
  idum = 1
  CALL ran3(idum, rand)
  irand = 1D0 + INT(DBLE(npopsiz)*rand)
  DO  n = 1, nchrome
    iparent(n,irand) = ibest(n)
  END DO
  WRITE (24,5000) irand
END IF
!
!
RETURN
5000 FORMAT ('  Elitist Reproduction on Individual ', i4)
END SUBROUTINE newgen
!#######################################################################

SUBROUTINE gamicro(i, npossum, ig2sum, ibest)
!
!  Micro-GA implementation subroutine
!

INTEGER, INTENT(IN)  :: i
INTEGER, INTENT(IN)  :: npossum
INTEGER, INTENT(IN)  :: ig2sum
INTEGER, INTENT(IN)  :: ibest(nchrmax)

INTEGER    :: icount, j, n
REAL (dp)  :: diffrac, rand

!
!  First, check for convergence of micro population.
!  If converged, start a new generation with best individual and fill
!  the remainder of the population with new randomly generated parents.
!
!  Count number of different bits from best member in micro-population
icount = 0
DO  j = 1, npopsiz
  DO  n = 1, nchrome
    IF (iparent(n,j) /= ibest(n)) icount = icount + 1
  END DO
END DO
!
!  If icount less than 5% of number of bits, then consider population
!  to be converged.  Restart with best individual and random others.
diffrac = DBLE(icount) / DBLE((npopsiz-1)*nchrome)
IF (diffrac < 0.05D0) THEN
  DO  n = 1, nchrome
    iparent(n,1) = ibest(n)
  END DO
  DO  j = 2, npopsiz
    DO  n = 1, nchrome
      idum = 1
      CALL ran3(idum, rand)
      iparent(n,j) = 1
      IF (rand < 0.5D0) iparent(n,j) = 0
    END DO
  END DO
  IF (npossum < ig2sum) CALL possibl(parent,iparent)
  WRITE (6,5000) i
  WRITE (24,5000) i
END IF
!
!
RETURN
5000 FORMAT (//'%%%%%%%  Restart micro-population at generation', i5,  &
               '  %%%%%%%')
END SUBROUTINE gamicro
!#######################################################################

SUBROUTINE select(mate, ipick)
!
!  This routine selects the better of two possible parents for mating.
!

INTEGER, INTENT(OUT)     :: mate
INTEGER, INTENT(IN OUT)  :: ipick

INTEGER  :: ifirst, isecond
!
IF (ipick+1 > npopsiz) CALL shuffle(ipick)
ifirst = ipick
isecond = ipick + 1
ipick = ipick + 2
IF (fitness(ifirst) > fitness(isecond)) THEN
  mate = ifirst
ELSE
  mate = isecond
END IF
!     write(3,*)'select', ifirst, isecond, fitness(ifirst), fitness(isecond)
!
RETURN
END SUBROUTINE select
!#######################################################################

SUBROUTINE shuffle(ipick)
!
!  This routine shuffles the parent array and its corresponding fitness
!

INTEGER, INTENT(OUT)  :: ipick

INTEGER    :: iother, itemp, j, n
REAL (dp)  :: rand, temp
!
ipick = 1
DO  j = 1, npopsiz - 1
  n = 1
  CALL ran3(n, rand)
  iother = j + 1 + INT(DBLE(npopsiz-j)*rand)
  DO  n = 1, nchrome
    itemp = iparent(n,iother)
    iparent(n,iother) = iparent(n,j)