ga170.f90

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

    iparent(n,j) = itemp
  END DO
  temp = fitness(iother)
  fitness(iother) = fitness(j)
  fitness(j) = temp
END DO
!
RETURN
END SUBROUTINE shuffle
!#######################################################################

SUBROUTINE decode(i, array, iarray)
!
!  This routine decodes a binary string to a real number.
!

INTEGER, INTENT(IN)     :: i
REAL (dp), INTENT(OUT)  :: array(nparmax,indmax)
INTEGER, INTENT(IN)     :: iarray(nchrmax,indmax)

INTEGER  :: iparam, j, k, l, m
!
l = 1
DO  k = 1, nparam
  iparam = 0
  m = l
  DO  j = m, m + ig2(k) - 1
    l = l + 1
    iparam = iparam + iarray(j,i) * (2**(m+ig2(k)-1-j))
  END DO
  array(k,i) = g0(k) + g1(k) * iparam
END DO
!
RETURN
END SUBROUTINE decode
!#######################################################################

SUBROUTINE code(j, k, array, iarray)
!
!  This routine codes a parameter into a binary string.
!

INTEGER, INTENT(IN)        :: j
INTEGER, INTENT(IN)        :: k
REAL (dp), INTENT(IN OUT)  :: array(nparmax,indmax)
INTEGER, INTENT(OUT)       :: iarray(nchrmax,indmax)

INTEGER  :: i, iparam, istart, m

!
!  First, establish the beginning location of the parameter string of interest.

istart = 1
DO  i = 1, k - 1
  istart = istart + ig2(i)
END DO
!
!  Find the equivalent coded parameter value, and back out the binary
!  string by factors of two.
m = ig2(k) - 1
IF (g1(k) == 0.0D0) RETURN
iparam = NINT((array(k,j)-g0(k))/g1(k))
DO  i = istart, istart + ig2(k) - 1
  iarray(i,j) = 0
  IF (iparam+1 > 2**m) THEN
    iarray(i,j) = 1
    iparam = iparam - 2 ** m
  END IF
  m = m - 1
END DO
!     write(3,*)array(k,j),iparam,(iarray(i,j),i=istart,istart+ig2(k)-1)
!
RETURN
END SUBROUTINE code
!#######################################################################
!

SUBROUTINE possibl(array, iarray)
!
!  This subroutine determines whether or not all parameters are within
!  the specified range of possibility.  If not, the parameter is
!  randomly reassigned within the range.  This subroutine is only
!  necessary when the number of possibilities per parameter is not
!  optimized to be 2**n, i.e. if npossum < ig2sum.
!

REAL (dp), INTENT(OUT)   :: array(nparmax,indmax)
INTEGER, INTENT(IN OUT)  :: iarray(nchrmax,indmax)

INTEGER    :: i, irand, j, n2ig2j
REAL (dp)  :: rand
!
DO  i = 1, npopsiz
  CALL decode(i, array, iarray)
  DO  j = 1, nparam
    n2ig2j = 2 ** ig2(j)
    IF (nposibl(j) /= n2ig2j .AND. array(j,i) > parmax(j)) THEN
      idum = 1
      CALL ran3(idum, rand)
      irand = INT(DBLE(nposibl(j))*rand)
      array(j,i) = g0(j) + irand * g1(j)
      CALL code(i, j, array, iarray)
      IF (nowrite == 0) WRITE (6,5000) i, j
      IF (nowrite == 0) WRITE (24,5000) i, j
    END IF
  END DO
END DO
!
!
RETURN
5000 FORMAT ('*** Parameter adjustment to individual     ',i4,  &
    ', parameter  ',i3,' ***')
END SUBROUTINE possibl
!#######################################################################

SUBROUTINE restart(i, istart, kount)
!
!  This subroutine writes restart information to the ga.restart file.
!

INTEGER, INTENT(IN)   :: i
INTEGER, INTENT(IN)   :: istart
INTEGER, INTENT(OUT)  :: kount

INTEGER  :: j, l

kount = kount + 1
IF (i == maxgen+istart-1 .OR. kount == kountmx) THEN
  OPEN (UNIT=25, FILE='ga.res', STATUS='OLD')
  REWIND (25)
  WRITE (25,*) i + 1, npopsiz
  DO  j = 1, npopsiz
    WRITE (25,5000) j, (iparent(l,j),l = 1,nchrome)
  END DO
  CLOSE (25)
  kount = 0
END IF
!
!
RETURN
5000 FORMAT (i5, '   ', 30I2)
END SUBROUTINE restart
!#######################################################################

SUBROUTINE ran3(iidum, rand)
!
!  Returns a uniform random deviate between 0.0 and 1.0.  Set idum to
!  any negative value to initialize or reinitialize the sequence.
!  This function is taken from W.H. Press', "Numerical Recipes" p. 199.
!

INTEGER, INTENT(IN OUT)  :: iidum
REAL (dp), INTENT(OUT)   :: rand

!      implicit real*4(m)
REAL (dp), PARAMETER :: mbig = 4000000., mseed = 1618033., mz = 0.0,  &
                        fac = 1./mbig
!     parameter (mbig=1000000000,mseed=161803398,mz=0,fac=1./mbig)
!
!  According to Knuth, any large mbig, and any smaller (but still large)
!  mseed can be substituted for the above values.
INTEGER, SAVE  :: ma(55)
INTEGER, SAVE  :: iff = 0

INTEGER        :: i, ii, k, mj, mk
INTEGER, SAVE  :: inext, inextp

IF (iidum < 0 .OR. iff == 0) THEN
  iff = 1
  mj = mseed - DBLE(ABS(iidum))
  mj = MOD(mj,INT(mbig))
  ma(55) = mj
  mk = 1
  DO  i = 1, 54
    ii = MOD(21*i,55)
    ma(ii) = mk
    mk = mj - mk
    IF (mk < mz) mk = mk + mbig
    mj = ma(ii)
  END DO
  DO  k = 1, 4
    DO  i = 1, 55
      ma(i) = ma(i) - ma(1+MOD(i+30,55))
      IF (ma(i) < mz) ma(i) = ma(i) + mbig
    END DO
  END DO
  inext = 0
  inextp = 31
  iidum = 1
END IF
inext = inext + 1
IF (inext == 56) inext = 1
inextp = inextp + 1
IF (inextp == 56) inextp = 1
mj = ma(inext) - ma(inextp)
IF (mj < mz) mj = mj + mbig
ma(inext) = mj
rand = mj * fac

RETURN
END SUBROUTINE ran3

END MODULE ga



PROGRAM gafortran
! Driver program

USE GA_commons
USE ga
IMPLICIT NONE
!
INTEGER    :: ibest(nchrmax)
REAL (dp)  :: geni(1000000), genavg(1000000), genmax(1000000)


INTEGER    :: i, ig2sum, ipick, istart, j, kount, mate1, mate2, ncross, npossum
REAL (dp)  :: best, evals, fbar
!
!      call etime(tarray)
!      write(6,*) tarray(1),tarray(2)
!      cpu0=tarray(1)
!
!  Call the input subroutine.
!      TIME0=SECNDS(0.0)
CALL INPUT()
!
!  Perform necessary initialization and read the ga.restart file.
CALL initial(istart, npossum, ig2sum)
!
!  $$$$$ Main generational processing loop. $$$$$
DO  i = istart, maxgen + istart - 1
  WRITE (6,5100) i
  WRITE (24,5100) i
  WRITE (24,5000)
!
!  Evaluate the population, assign fitness, establish the best
!  individual, and write output information.
  CALL evalout(iskip, iend, ibest, fbar, best)
  geni(i)   = i
  genavg(i) = fbar
  genmax(i) = best
  IF (npopsiz == 1 .OR. iskip /= 0) THEN
    CLOSE (24)
    STOP
  END IF
!
!  Implement "niching".
  IF (iniche /= 0) CALL niche()
!
!  Enter selection, crossover and mutation loop.
  ncross = 0
  ipick = npopsiz
  DO  j = 1, npopsiz, nchild
!
!  Perform selection.
    CALL selectn(ipick, j, mate1, mate2)
!
!  Now perform crossover between the randomly selected pair.
    CALL crosovr(ncross, j, mate1, mate2)
  END DO
  WRITE (6,5200) ncross
  WRITE (24,5200) ncross
!
!  Now perform random mutations.  If running micro-GA, skip mutation.
  IF (microga == 0) CALL mutate()
!
!  Write child array back into parent array for new generation.  Check
!  to see if the best parent was replicated.
  CALL newgen(ielite, npossum, ig2sum, ibest)
!
!  Implement micro-GA if enabled.
  IF (microga /= 0) CALL gamicro(i, npossum, ig2sum, ibest)
!
!  Write to restart file.
  CALL restart(i, istart, kount)
END DO
!  $$$$$ End of main generational processing loop. $$$$$
! 999  continue
WRITE (24,5300)
DO  i = istart, maxgen + istart - 1
  evals = npopsiz * geni(i)
  WRITE (24,5400) geni(i), evals, genavg(i), genmax(i)
END DO
!      call etime(tarray)
!      write(6,*) tarray(1),tarray(2)
!      cpu1=tarray(1)
!      cpu=(cpu1-cpu0)
!      write(6,1400) cpu,cpu/60.0
!      write(24,1400) cpu,cpu/60.0
CLOSE (24)
!
! 1400 format(2x,'CPU time for all generations=', e12.6, ' sec'/
!     +       2x,'                             ', e12.6, ' min')
!
STOP

5000 FORMAT ('  #      Binary Code                Param1  Param2  Fitness')
5100 FORMAT (//'#################  Generation', i5, '  #################')
5200 FORMAT (/'  Number of Crossovers      =', i5)
5300 FORMAT (//' Summary of Output'/  &
               '  Generation   Evaluations   Avg.Fitness   Best Fitness')
5400 FORMAT (t3, 3(e10.4, '    '), e11.5)

!#######################################################################


CONTAINS


SUBROUTINE INPUT()
!
!  This subroutine inputs information from the ga.inp (gafort.in) file.
!
!
NAMELIST /ga/ irestrt, npopsiz, pmutate, maxgen, idum, pcross,  &
    itourny, ielite, icreep, pcreep, iunifrm, iniche, iskip, iend,  &
    nchild, nparam, parmin, parmax, nposibl, nowrite, nichflg, microga, kountmx
!
kountmx = 5
irestrt = 0
itourny = 0
ielite = 0
iunifrm = 0
iniche = 0
iskip = 0
iend = 0
nchild = 1
nichflg(1:nparam) = 1
microga = 0
!
OPEN (UNIT=24, FILE='ga.out', STATUS='UNKNOWN')
REWIND (24)
OPEN (UNIT=23, FILE='ga.inp', STATUS='OLD')
READ (23, nml=ga)
CLOSE (23)
itourny = 1
!      if (itourny.eq.0) nchild=2
!
!  Check for array sizing errors.
IF (npopsiz > indmax) THEN
  WRITE (6,5000) npopsiz
  WRITE (24,5000) npopsiz
  CLOSE (24)
  STOP
END IF
IF (nparam > nparmax) THEN
  WRITE (6,5100) nparam
  WRITE (24,5100) nparam
  CLOSE (24)
  STOP
END IF
!
!  If using the microga option, reset some input variables
IF (microga /= 0) THEN
  pmutate = 0.0D0
  pcreep = 0.0D0
  itourny = 1
  ielite = 1
  iniche = 0
  nchild = 1
  IF (iunifrm == 0) THEN
    pcross = 1.0D0
  ELSE
    pcross = 0.5D0
  END IF
END IF
!
!
RETURN
5000 FORMAT (' ERROR: npopsiz > indmax.  Set indmax = ', i6)
5100 FORMAT (' ERROR: nparam > nparmax.  Set nparmax = ', i6)
END SUBROUTINE INPUT

END PROGRAM gafortran

!#######################################################################
!

SUBROUTINE func(j, funcval)
!

USE GA_commons
IMPLICIT NONE

INTEGER, INTENT(IN)     :: j
REAL (dp), INTENT(OUT)  :: funcval

!
!      dimension parent2(indmax,nparmax),iparent2(indmax,nchrmax)
!
!  This is an N-dimensional version of the multimodal function with
!  decreasing peaks used by Goldberg and Richardson (1987, see ReadMe
!  file for complete reference).  In N dimensions, this function has
!  (nvalley-1)^nparam peaks, but only one global maximum.  It is a
!  reasonably tough problem for the GA, especially for higher dimensions
!  and larger values of nvalley.
!
INTEGER    :: i, nvalley
REAL (dp)  :: f1, f2, pi

nvalley = 6
pi = 4.0D0 * ATAN(1.d0)
funcval = 1.0D0
DO  i = 1, nparam
  f1 = (SIN(5.1D0*pi*parent(i,j)+0.5D0)) ** nvalley
  f2 = EXP(-4.0D0*LOG(2.0D0)*((parent(i,j)-0.0667D0)**2)/0.64D0)
  funcval = funcval * f1 * f2
END DO
!
!  As mentioned in the ReadMe file, The arrays have been rearranged
!  to enable a more efficient caching of system memory.  If this causes
!  interface problems with existing functions used with previous
!  versions of my code, then you can use some temporary arrays to bridge
!  this version with older versions.  I've named the temporary arrays
!  parent2 and iparent2.  If you want to use these arrays, uncomment the
!  dimension statement above as well as the following do loop lines.
!
!      do 11 i=1,nparam
!         parent2(j,i)=parent(i,j)
! 11   continue
!      do 12 k=1,nchrome
!         iparent2(j,k)=iparent(k,j)
! 12   continue
!
RETURN
END SUBROUTINE func
!#######################################################################