| Hi Ned,
yes I looked into the examples in the DXML manual. They require 2 seed
input values while the code I am working on uses ran which calls for one seed.
Attached is the parallel loop and one of the functions "ga_select"
called within the parallel loop that uses ran().
I appreciate your help very much
/Joseph
------------------------------------------------------------------
subroutine ga_generation (ierr)
c
c include global values
c
include 'kfdimdef.inc'
include 'kfgadef.inc'
c
c define variables
c
integer*4 ierr
c
integer*4 individuenzahl, mate1, mate2, ieqmate, inuk, j
integer ga_select
real oldfitness(DIM_MAXPOP)
real ga_objfunc
logical*1 chromosom(DIM_CHROM)
c
c
do j = 1, popsize
oldfitness(j) = fitness(j)
end do
c
c
do inuk = 1, lchrom
newpop(inuk,1) = oldpop(inuk,best)
newpop(inuk,2) = oldpop(inuk,secondbest)
end do
fitness(1) = oldfitness(best)
fitness(2) = oldfitness(secondbest)
individuenzahl = 3
c
c
c$par parallel do
c$par& always dynamic(1)
c$par& local(individuenzahl,mate1,mate2,ieqmate,inuk,chromosom)
c$par& shared(popsize,sumfitness,oldfitness,ierr,lchrom,newpop)
c$par& shared(fitness)
c$par new /ga_i_private/
do individuenzahl = 3, popsize-1, 2
c
c
mate1 = ga_select (popsize, sumfitness, oldfitness, iseed) ! cu
mate2 = ga_select (popsize, sumfitness, oldfitness, iseed) ! cu
ieqmate = 1
do while (mate1 .eq. mate2)
ieqmate = ieqmate + 1
if (ieqmate .ge. DIM_MAXPOP) then
ierr = -1 ! nicht genug Individuen im mating-pool
c$par pdone
end if
mate2 = ga_select (popsize, sumfitness, oldfitness, iseed) ! cu
enddo
c
c Crossover (incl. Mutation)
c
call ga_crossover (mate1, mate2, individuenzahl)
c
c
do inuk = 1, lchrom
chromosom(inuk) = newpop(inuk,individuenzahl)
end do
call ga_decode (lchrom, chromosom)
fitness(individuenzahl) = ga_objfunc()
c
do inuk = 1, lchrom
chromosom(inuk) = newpop(inuk,individuenzahl+1)
end do
call ga_decode (lchrom, chromosom)
fitness(individuenzahl+1) = ga_objfunc()
c
end do
c
return
end
c
c Filename: kfgadef.inc
c Author: I. Martin
c Date: V1.0 10-jun-1996
c Description: global values needed for the genetic algorithm
c
c -----
c
c parameter statements dimensions
c
integer*4 DIM_MAXGEN, DIM_MAXPOP, DIM_CHROM
parameter (DIM_MAXGEN = 100000) ! no. of generations
parameter (DIM_MAXPOP = 4000) ! no. of chromosomes in the
1 ! population
parameter (DIM_CHROM = DIM_FP*8) ! chromosome length
c
c define variables in common blocks
c
integer*4 ncross, nmutation, maxgen, popsize, lchrom, best,
cu 1 secondbest
1 secondbest, iseed ! cu
real*4 pcross, pmutation
real fitness(DIM_MAXPOP), maxfitness, secfitness,
1 minfitness, sumfitness, avgfitness,
1 chisq_sav(0:DIM_MAXGEN)
logical*1 oldpop(DIM_CHROM,DIM_MAXPOP),
1 newpop(DIM_CHROM,DIM_MAXPOP)
c
c common blocks
c
common /ga_i/ ncross, nmutation, maxgen, popsize, lchrom, best,
cu 1 secondbest, oldpop, newpop
1 secondbest, oldpop, newpop ! cu
common /ga_i_private/ iseed
c$par instance parallel /ga_i_private/
common /ga_r/ pcross, pmutation, fitness, maxfitness, secfitness,
1 minfitness, sumfitness, avgfitness, chisq_sav
c -----
integer function ga_select (popsize, sumfitness, fitness, iseed) ! cu
c
c
integer*4 popsize, iseed ! cu
real sumfitness, fitness(popsize)
c
integer*4 j
real partfitsum, rand
real*4 ran ! cu
c
c
c
j = 1
partfitsum = fitness(j)
rand = ran(iseed) * sumfitness ! Zufallswert auf dem Rouletterad ! cu
do while (partfitsum .lt. rand .and. j .lt. popsize)
j = j + 1
partfitsum = partfitsum + fitness(j)
end do
ga_select = j
c
return
end
|
| Here is one way to use the new routines for this problem, without too much
rewriting of code.
--Ned A.
subroutine ga_generation (ierr)
...old declarations...
cc new variables
integer*4 is1a, is1b, is2a, is2b, is3a, is3b, p2skip
...old code...
...code changes
is1a=1234 ! arbitrary, start seeda for stream 1
is1b=9876 ! arbitrary, start seedb for stream 1
p2skip = log(2.0*popsize+1.0)/log(2.0)
cc 2**p2skip is big enough so we can get 3 independent streams of RN's
call ranl_skip2(p2skip,is1a,is1b,is2a,is2b) ! for stream 2
call ranl_skip2(p2skip,is2a,is2b,is3a,is3b) ! for stream 3
cc these seeds get fed to ga_select (and then ranl)
c
c$par parallel do
c$par& always dynamic(1)
c$par& local(individuenzahl,mate1,mate2,ieqmate,inuk,chromosom)
c$par& shared(popsize,sumfitness,oldfitness,ierr,lchrom,newpop)
c$par& shared(fitness)
c$par new /ga_i_private/
do individuenzahl = 3, popsize-1, 2
c
c
c ...code changes in 3 calls to ga_select to pass seeds
mate1 = ga_select (popsize, sumfitness, oldfitness, is1a,is1b)! cu
mate2 = ga_select (popsize, sumfitness, oldfitness, is2a,is2b)! cu
ieqmate = 1
do while (mate1 .eq. mate2)
ieqmate = ieqmate + 1
if (ieqmate .ge. DIM_MAXPOP) then
ierr = -1 ! nicht genug Individuen im mating-pool
c$par pdone
end if
mate2 = ga_select (popsize, sumfitness, oldfitness, is3a,is3b)! cu
enddo
c
c Crossover (incl. Mutation)
cc ...
return
end
------------------------
cc ...replace iseed by isa,isb here and call ranl not ran:
integer function ga_select (popsize, sumfitness, fitness, isa,isb) ! cu
c
c
integer*4 popsize, isa,isb ! cu
real sumfitness, fitness(popsize)
c
integer*4 j
real partfitsum, rand
real*4 ran ! cu
c
c
c
j = 1
partfitsum = fitness(j)
call ranl(isa,isb,rand,1) * sumfitness ! Zufallswert auf dem Rouletterad ! cu
do while (partfitsum .lt. rand .and. j .lt. popsize)
j = j + 1
partfitsum = partfitsum + fitness(j)
end do
ga_select = j
c
return
end
|