subroutine APPLY_OPERATORS(POPULATION, PARENT_RANK_ARRAY, CHILD_POPULATION, & INTERVAL_ARRAY) ! ! Subroutine APPLY_OPERATORS applies the genetic operators in ! this package to a population, and returns a child population. ! ! The subroutine employs a loop, which iterates until the child ! population is full of unique individuals. ! Within the loop, two parents are selected at ! random, using PARENT_RANK_ARRAY and INTERVAL_ARRAY; crossover ! is applied to these parents, yielding two new children; then, ! the MUTATION, ADDITION, DELETION, INTRA_PLY_SWAP, and ! PERMUTATION operators are applied to each of these children. ! A child is added to the child subpopulation if it is unique ! w.r.t the parent subpopulation and the other children in the ! child subpopulation. ! ! ! On input: ! ! POPULATION is the parent population from which the new child ! population is created. ! ! PARENT_RANK_ARRAY is an array holding the rank of each ! individual in each parent subpopulation. It is expected that ! the nth rank array entry for any subpopulation will give the ! position in the subpopulation of the individual of rank n. ! There is a unique rank for each member of a subpopulation. ! ! For example, ! If PARENT_RANK_ARRAY(3,1) is equal to 7, then the seventh ! individual in the parent subpopulation (subpopulation 3 in ! this example) has the highest rank (best fitness). ! ! ! INTERVAL_ARRAY is an array of intervals used to randomly ! choose parents from a subpopulation. The real values in this ! array specify intervals corresponding to the desired ! probability that a given ranked parent will be chosen. ! ! For example, ! If a subpopulation has size 3, and the entries in the ! interval array are (x,y,z), then if uniform random variable q ! has a value less than or equal to x, the first individual in the ! parent subpopulation is chosen. If q has a value in the interval ! (x,y], then the second individual in the parent ! subpopulation is chosen, and if q has a value in the interval ! (y,z], the third individual in the parent subpopulation is ! chosen. ! ! ! On output: ! ! CHILD_POPULATION contains a unique set of children resulting ! from applying the genetic operators in this package. ! ! ! Other functions (f) and subroutines (s) called in this ! subroutine: ! ! 1) CREATE_CHILD (f) ! 2) CROSSOVER (s) ! 3) MUTATION (s) ! 4) ADDITION (s) ! 5) DELETION (s) ! 6) PERMUTATION (s) ! 7) INTRA_PLY_SWAP (s) ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type (popltn), intent(in) :: population integer, intent(in) :: parent_rank_array(population_size, & subpopulation_size) type (popltn), intent(inout) :: child_population real (KIND=R8), intent(in) :: interval_array(subpopulation_size) !Local variables type (individual) :: child_1, child_2, last_reject, parent_1, parent_2 integer :: child_subpop_size, i, index1, index2, j, m, & q,subpop integer :: counter, iteration_count logical :: unique, unique1, unique2 real :: rnd popLoop: do subpop = 1,population_size child_subpop_size = 0 iteration_count = 0 unique1 = .TRUE. unique2 = .TRUE. child_1 = child_population%subpopulation_array(subpop)% & individual_array(1) child_2 = child_population%subpopulation_array(subpop)% & individual_array(2) uniqueloop: do !Iterate through until child population is full. iteration_count = iteration_count+1 !Select parents. select: do ! Until different parents have been chosen. call random_number(rnd) Iloop: do I = 1, subpopulation_size if (rnd <= interval_array(I)) then index1 = parent_rank_array(subpop, I) exit end if end do Iloop call random_number(rnd) do I = 1, subpopulation_size if (rnd <= interval_array(I)) then index2 = parent_rank_array(subpop, I) exit end if end do if (index1 /= index2) exit end do select parent_2 = population%subpopulation_array(subpop)%individual_array(index2) parent_1 = population%subpopulation_array(subpop)%individual_array(index1) !Select parent section is complete. call crossover(parent_1, parent_2,child_1,child_2) call mutation(child_1) call deletion(child_1) call addition(child_1) call intra_ply_swap(child_1) call permutation(child_1) ! Check for the uniqueness of child 1 vs. childpopulation ! and population. unique1 = .TRUE. child1: do Q=1, child_subpop_size ! Compare CHILD_1 to all preceding child individuals. if (child_1 & == (child_population%subpopulation_array(subpop)%individual_array(Q)))& unique1 = .FALSE. end do child1 pop1: do Q=1, subpopulation_size ! Compare CHILD_1 to all preceding parent individuals. if (child_1== & (population%subpopulation_array(subpop)%individual_array(Q))) then unique1 = .FALSE. exit end if end do pop1 ! Check to see if child population is full. If so, exit. call mutation(child_2) call deletion(child_2) call addition(child_2) call intra_ply_swap(child_2) call permutation(child_2) ! Compare CHILD_2 to all preceding child individuals. unique2= .TRUE. child2: do Q=1, child_subpop_size ! compare to all preceeding if (child_2 == & (child_population%subpopulation_array(subpop)%individual_array(Q)))& unique2 = .FALSE. end do child2 pop2: do Q=1, subpopulation_size ! Compare CHILD_2 to all preceding parent individuals. if (child_2== & (population%subpopulation_array(subpop)%individual_array(Q))) then unique2 = .FALSE. exit end if end do pop2 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (unique1 .and. unique2) then child_subpop_size = child_subpop_size + 2 if (child_subpop_size >= subpopulation_size) then exit end if child_1 = child_population%subpopulation_array(subpop)% & individual_array(child_subpop_size+1) if (child_subpop_size <= subpopulation_size-2) then child_2 = child_population%subpopulation_array(subpop)% & individual_array(child_subpop_size+2) else child_2 = create_child() end if else if (unique1 .and. .not.(unique2)) then child_subpop_size = child_subpop_size + 1 if (child_subpop_size >= subpopulation_size) then exit end if child_1 = child_population%subpopulation_array(subpop)% & individual_array(child_subpop_size+1) if (child_subpop_size <= subpopulation_size-2) then child_2 = child_population%subpopulation_array(subpop)% & individual_array(child_subpop_size+2) else child_2 = create_child() end if else if (.not.(unique1) .and. unique2) then !***************************************************************************** ! child_subpop_size = child_subpop_size + 1 ! if (child_subpop_size >= subpopulation_size) then ! exit ! end if ! child_2 = child_population%subpopulation_array(subpop)% & ! individual_array(child_subpop_size+1) !***************************************************************************** else if (.not.(unique1) .and. .not.(unique2)) then ! do nothing, no unique children end if !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! if (child_subpop_size >= subpopulation_size) exit if (iteration_count >= subpopulation_size*2000) then write(*,*) 'STOPPED--UNABLE TO FIND UNIQUE CHILD POPULATION' stop end if end do uniqueloop end do popLoop end subroutine APPLY_OPERATORS !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine CROSSOVER (PARENT_1, PARENT_2, CHILD_1, CHILD_2) ! ! Subroutine CROSSOVER creates the genetic coding for two child ! individuals, by crossing over genetic information between two ! parents. A uniformly distributed random number is generated. ! Crossover is applied if the random number is smaller than the ! probability of applying crossover. ! ! If crossover is applied, parents (chosen previously) are used ! for mating. Children are created by combining portions of each ! parent's genetic string. The procedure for splitting apart each ! parent is dependent on the type of crossover used and the ! makeup of each genetic string. Uniformly distributed random ! numbers are generated to determine the locations where ! the parent strings are cut before recombination. ! ! Uniform crossover is applied to geometry chromosomes. For geometry ! crossover, a normal variable is generated. The new geometry digit is ! determined with ! NEW_DIGIT = MU + SIGMA * RND ! where RND is the normal variate, ! MU is the average of the two parent geometry digits, and ! SIGMA is one-half the distance between the two parent geometry digits. ! NEW_DIGIT is clamped at the upper and lower bounds for the given geometry ! genes, defined in INDIVIDUAL_ATTRIBUTES. ! ! This subroutine can perform nine different types of crossover on ! laminate chromosomes (orientation and material type). ! ! Note: An empty gene is one that is present in the genetic string, ! but does not contain any physical information about the ! structure. ! ! The local variable current_cross_type, indicating the type of crossover, is ! set to one of the following parameter (1-5) values : ! ! 1) ONE_POINT_NO_EMPTY is 1-point crossover for genetic strings ! which do not contain empty genes. The crossover point may ! fall anywhere in the parent strings. The left piece of parent ! #1 and the right piece of parent #2 are combined to form ! child #1. The left piece from parent #2 and right piece from ! parent #1 are combined to form child #2. ! ! 2) ONE_POINT_EMPTY_THICK is 1-point crossover for genetic ! strings which contain empty genes. The crossover point is ! restricted to fall within the parent string that has the ! fewest number of empty genes. For example, if string length ! is 10, parent #1 has 3 empty genes, and parent #2 has 4 empty ! genes, The crossover point may fall within locations 1 ! through 7. The left piece of parent #1 and the right piece of ! parent #2 are combined to form child #1. The left piece from ! parent #2 and the right piece from parent #1 are combined to ! form child #2. ! ! 3) TWO_POINT_NO_EMPTY is 2-point crossover for genetic strings ! which do not contain empty genes. Both crossover points may ! fall anywhere in the parent strings, but must be unique from ! one another. The left and right pieces from parent #1 and the ! middle piece from parent #2 are combined to form child # 1. ! The left and right pieces from parent #2 and the middle piece ! from parent #1 are combined to form child #2. ! ! 4) TWO_POINT_EMPTY_THICK is 2-point crossover for genetic ! strings which contain empty genes. The crossover points must ! be unique and are restricted to fall within the parent string ! that has the fewest number of empty genes. For example, if ! ! string length is 10, parent #1 has 3 empty genes, and parent ! #2 has 4 empty genes, both crossover point may fall within ! locations 1 through 7. The left and right pieces from parent ! #1 and the middle piece from parent #2 are combined to form ! child # 1. The left and right pieces from parent #2 and the ! middle piece from parent #1 are combined to form child #2. ! ! 5) UNIFORM_CROSSOVER is crossover may be applied to any genetic ! string, but only operates on non-empty genes. A uniformly ! distributed random number, i, between 0 and 1 is generated ! for each corresponding pair of non-empty genes in the parent ! strings. If i falls within [0,0.5), the gene from parent #1 ! is passed to child #1, and the gene from parent #2 is passed ! to child #2. If i falls within [0.5,1.), the gene from parent ! #2 is passed to child #2, and the gene from parent #2 is ! passed to child #1. ! ! ! If crossover is not applied, the parent strings are copied into ! the child strings. ! ! ! On input: ! ! PARENT_1 is the first parent individual to use for crossing ! over. ! ! PARENT_2 is the second parent individual to use for crossing ! over. ! ! On output: ! ! CHILD_1 is the first child individual resulting from crossover. ! ! CHILD_2 is the second child individual resulting from crossover. ! ! ! Internal variables: ! ! CROSS_POINT_1 stores the location of the first crossover ! point. ! ! CROSS_POINT_2 stores the location of the second crossover point ! (2-point crossover only). ! ! CURRENT_CROSS_TYPE defines the current type of crossover that ! is being implemented. ! ! CURRENT_LAM_SIZE stores the length of the string that crossover ! is currently being applied to. ! ! PACK_FLAG determines whether a string will be packed to ensure ! that empty genes are placed towards the outer edge of the ! string. ! ! PARENT_NUMBER_1 stores the address of the first parent ! individual in the parent subpopulation. ! ! PARENT_NUMBER_2 stores the address of the second parent ! individual in the parent subpopulation. ! ! RND is a uniformly distributed random number. ! ! SIZE_PARENT_1 stores the number of genes in the first parent. ! ! SIZE_PARENT_2 stores the number of genes in the second parent. ! ! THICK_VALUE stores the number of genes in the parent with the ! greatest number. ! ! THIN_VALUE stores the number of genes in the parent with the ! smallest number. ! ! ! Loop variables: ! ! I,J,K,L,M,N,COUNTER ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type (individual), intent(in) :: parent_1, parent_2 type(individual), intent(inout) :: child_1, child_2 !Local variables. real :: rnd real (KIND=R8) :: digit_1, digit_2, lb, mu, new_digit, sigma, ub real (KIND=R8) :: c1,c2,p1,p2 integer :: counter, i, j, k, l, m, n integer :: cross_point_1, cross_point_2, & size_parent_1, size_parent_2, temp integer :: thin_value, thick_value integer :: current_cross_type integer :: current_lam_size integer :: Q integer :: temp1 logical :: current_empty_plies logical :: pack_flag ! Define the different crossover types. integer, parameter :: ONE_POINT_NO_EMPTY = 1, & ONE_POINT_EMPTY_THICK = 2, & TWO_POINT_NO_EMPTY = 3, & TWO_POINT_EMPTY_THICK = 4, & UNIFORM_CROSSOVER = 5, & DEFAULT_CROSS_TYPE = 5 ! It is useful to group the crossover types. ! Each of the two groups (one point and two point) has its own ! unique code for crossing over. integer, dimension(2) :: one_point_cross_types = (/ONE_POINT_NO_EMPTY, & ONE_POINT_EMPTY_THICK/) integer, dimension(2) :: two_point_cross_types = (/TWO_POINT_NO_EMPTY, & TWO_POINT_EMPTY_THICK/) counter = 0 Lam: do i = 1, individual_attributes%individual_size_lam call random_number(rnd) pack_flag=.FALSE. size_parent_1 = size( pack(parent_1%laminate_array(i)% & ply_array, mask = parent_1%laminate_array(i) & %ply_array%orientation .ne. 0) ) size_parent_2 = size( pack(parent_2%laminate_array(i)% & ply_array, mask = parent_2%laminate_array(i) & %ply_array%orientation .ne. 0) ) !Determine which parent contains more genes. if (size_parent_1 > size_parent_2) then thick_value = size_parent_1 thin_value = size_parent_2 else thick_value = size_parent_2 thin_value = size_parent_1 end if current_cross_type = individual_attributes%laminate_definition_array(i) & %crossover_type !write(*,*)'current_cross_type =', current_cross_type if (current_cross_type == 0) current_cross_type = DEFAULT_CROSS_TYPE current_empty_plies = individual_attributes%laminate_definition_array(i) & %empty_plies current_lam_size = individual_attributes%laminate_definition_array(i)% & laminate_size !!!!!!!!!!!!!!!!!!!!!!!!!!! !Begin one point crossover. ! select case (current_cross_type) case (1:2) if (rnd < individual_attributes%laminate_definition_array(i)% & prob_crossover) then call random_number(rnd) select case (current_cross_type) case (ONE_POINT_NO_EMPTY) cross_point_1 = ceiling(rnd*(current_lam_size - 1)) case (ONE_POINT_EMPTY_THICK) cross_point_1 = ceiling(rnd*(thick_value-1)) pack_flag = .TRUE. end select !Copy appropriate segments into the children. child_1%laminate_array(i)%ply_array & (1:cross_point_1) = & parent_1%laminate_array(i)%ply_array & (1:cross_point_1) child_1%laminate_array(i)%ply_array & (cross_point_1+1:current_lam_size) = & parent_2%laminate_array(i)%ply_array & (cross_point_1+1:current_lam_size) child_2%laminate_array(i)%ply_array & (1:cross_point_1) = & parent_2%laminate_array(i)%ply_array & (1:cross_point_1) child_2%laminate_array(i)%ply_array & (cross_point_1+1:current_lam_size) = & parent_1%laminate_array(i)%ply_array & (cross_point_1+1:current_lam_size) else ! No crossover occurs; clone parent's laminates into children. child_1%laminate_array(i)%ply_array(1:current_lam_size) & = parent_1%laminate_array(i)%ply_array(1:current_lam_size) child_2%laminate_array(i)%ply_array(1:current_lam_size) & = parent_2%laminate_array(i)%ply_array(1:current_lam_size) end if !End one point crossover !Begin two point crossover case (3:4) if (rnd < individual_attributes%laminate_definition_array(i)% & prob_crossover) then call random_number(rnd) select case (current_cross_type) case (TWO_POINT_NO_EMPTY) cross_point_1 = ceiling(rnd*(current_lam_size - 1)) call random_number(rnd) cross_point_2 = ceiling(rnd*(current_lam_size - 1)) !Ensure different crossover point if(cross_point_1.eq.cross_point_2) then do while(cross_point_1.ne.cross_point_2) call random_number(rnd) cross_point_2 = ceiling(rnd*(current_lam_size - 1)) end do end if case (TWO_POINT_EMPTY_THICK) cross_point_1 = ceiling(rnd*(thick_value-1)) call random_number(rnd) cross_point_2 = ceiling(rnd*(thick_value-1)) pack_flag = .TRUE. !Ensure different crossover point if(cross_point_1.eq.cross_point_2) then do while(cross_point_1.eq.cross_point_2) call random_number(rnd) cross_point_2 = ceiling(rnd*(thick_value - 1)) end do end if end select !Ensure cross_point_1 lies ahead of cross_point_2 if(cross_point_1.gt.cross_point_2) then temp1 = cross_point_1 cross_point_1 = cross_point_2 cross_point_2 = temp1 end if !Copy appropriate segments into the children. child_1%laminate_array(i)%ply_array & (1:cross_point_1) = & parent_1%laminate_array(i)%ply_array & (1:cross_point_1) child_1%laminate_array(i)%ply_array & (cross_point_1+1:cross_point_2) = & parent_2%laminate_array(i)%ply_array & (cross_point_1+1:cross_point_2) child_1%laminate_array(i)%ply_array & (cross_point_2+1:current_lam_size) = & parent_1%laminate_array(i)%ply_array & (cross_point_2+1:current_lam_size) child_2%laminate_array(i)%ply_array & (1:cross_point_1) = & parent_2%laminate_array(i)%ply_array & (1:cross_point_1) child_2%laminate_array(i)%ply_array & (cross_point_1+1:cross_point_2) = & parent_1%laminate_array(i)%ply_array & (cross_point_1+1:cross_point_2) child_2%laminate_array(i)%ply_array & (cross_point_2+1:current_lam_size) = & parent_2%laminate_array(i)%ply_array & (cross_point_2+1:current_lam_size) else ! No crossover occurs; clone parent's laminates into children. child_1%laminate_array(i)%ply_array(1:current_lam_size) & = parent_1%laminate_array(i)%ply_array(1:current_lam_size) child_2%laminate_array(i)%ply_array(1:current_lam_size) & = parent_2%laminate_array(i)%ply_array(1:current_lam_size) end if !End of two point crossover case default stop 'Error in crossover. Wrong input for crossover type' !End crossover selection. end select if(pack_flag) then !Eliminate empty genes from the children if necessary. child_1%laminate_array(i)%ply_array(1:) = & pack (child_1%laminate_array(i)%ply_array, mask = & child_1%laminate_array(i)%ply_array%orientation .ne. 0, & vector = (empty_individual%laminate_array(i)%ply_array) ) child_2%laminate_array(i)%ply_array(1:) = & pack (child_2%laminate_array(i)%ply_array, mask = & child_2%laminate_array(i)%ply_array%orientation .ne. 0, & vector = (empty_individual%laminate_array(i)%ply_array) ) end if end do Lam !Apply one point geometry crossover [SAR] Geom:DO i = 1, individual_attributes%individual_size_geom CALL random_number(rnd) IF (rnd < individual_attributes%geometry_definition_array(i) & %prob_crossover) THEN DO j=1,individual_attributes%geometry_definition_array(i)% & geom_chromo_size ub=individual_attributes%geometry_definition_array(i)% & upper_bounds_array(j) lb=individual_attributes%geometry_definition_array(i)% & lower_bounds_array(j) p1=parent_1%geometry_array(i)%geometry_gene_array(j)%digit p2=parent_2%geometry_array(i)%geometry_gene_array(j)%digit mu= (p1+p2)/2._R8 sig=abs(p2-p1)/2._R8 rnd=RNOR() c1=mu+sig*rnd c1 = MIN(MAX(c1,lb), ub) rnd=RNOR() c2=mu+sig*rnd c2 = MIN(MAX(c2,lb), ub) child_1%geometry_array(i)%geometry_gene_array(j)%digit=c1 child_2%geometry_array(i)%geometry_gene_array(j)%digit=c2 END DO END IF END DO Geom return end subroutine CROSSOVER !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MUTATION(CHILD) ! ! Subroutine MUTATION provides a means for introducing new ! information into a genetic string, by randomly altering genes. ! ! Mutation is only applied to non-empty genes in the string. ! A uniformly distributed random number is generated. Mutation is ! applied if the random number is smaller than the probability of ! applying mutation. ! ! One point mutation is applied to each geometry chromosome. A uniform ! random variable yields a number between the upper and lower geometry ! bounds for the geometry mutation. ! ! This subroutine can perform two different types of mutation on laminate ! chromosomes. ! ! 1) UNIFORM mutation selects a random number which is compared to ! the probability of applying mutation for each gene in each ! string. If mutation is applied, another random number is ! generated to determine the new value of the mutated gene. ! ! ! 2) ONE_POINT mutation selects a random number which is compared ! to the probability of applying mutation for a gene string. If ! mutation is applied, additional random numbers are generated ! to determine which gene in the string will be mutated, and ! the new value of the mutated gene. ! ! ! On input: ! ! CHILD stores the genetic code for a child individual before ! mutation is applied. ! ! ! On output: ! ! CHILD stores the genetic code for a child individual after ! mutation is applied. ! ! ! Internal variables: ! ! CURRENT_MUTATION_TYPE defines the current type of mutation that ! is being implemented. ! ! CURRENT_LAM_SIZE stores the length of the string that mutation ! is currently being applied to. ! ! RND is a uniformly distributed random number. ! ! ! Loop variables: ! ! I,J ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type(individual), intent(inout) :: child !Local variables. real :: rnd real (KIND=R8) :: lb, new_digit, temp_digit, ub integer :: counter, i, j integer :: current_mutation_type, current_lam_size integer :: temp_orient, temp_material ! Define the different mutation types. integer, parameter :: UNIFORM = 1, & ONE_POINT = 2 Lam:do i = 1, individual_attributes%individual_size_lam call random_number(rnd) current_mutation_type = individual_attributes% & laminate_definition_array(i)%mutation_type if(individual_attributes%laminate_definition_array(i)%empty_plies) & then current_lam_size =size( & pack (child%laminate_array(i)%ply_array, mask = & child%laminate_array(i)%ply_array%orientation .ne. 0)) else current_lam_size = individual_attributes% & laminate_definition_array(i)%laminate_size end if select case (current_mutation_type) case (UNIFORM) Unif: do j = 1, current_lam_size call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_mut_orientation) then temp_orient = child%laminate_array(i)%ply_array(j)% & orientation do call random_number(rnd) !Choose a new orientation. child%laminate_array(i)%ply_array(j)%orientation= & individual_attributes%laminate_definition_array(i)% & orientation_array(ceiling(rnd*individual_attributes%& laminate_definition_array(i)%num_poss_orientations)) if (child%laminate_array(i)%ply_array(j)%orientation /= & temp_orient) exit end do end if call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_mut_material) then temp_material = child%laminate_array(i)%ply_array(j)% & material counter=0 do counter = counter + 1 call random_number(rnd) !Choose a new material. child%laminate_array(i)%ply_array(j)%material= & individual_attributes%laminate_definition_array(i)% & material_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_materials)) if ((child%laminate_array(i)%ply_array(j)%material /= & temp_material) .or. counter == 200) exit end do end if end do Unif case (ONE_POINT) call random_number(rnd) !write(*,*) rnd,current_lam_size ! added by seresta j = ceiling(rnd*current_lam_size) call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_mut_orientation) then temp_orient = child%laminate_array(i)%ply_array(j)% & orientation counter = 0 do counter = counter + 1 call random_number(rnd) !Make sure to choose a unique orientation. child%laminate_array(i)%ply_array(j)%orientation & =individual_attributes%laminate_definition_array(i)% & orientation_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_poss_orientations)) if ((child%laminate_array(i)%ply_array(j)%orientation /= & temp_orient) .or. counter == 200) exit end do end if if(j.eq.0) then ! added by seresta write(*,*)'....', rnd stop endif call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_mut_material) then temp_material = child%laminate_array(i)%ply_array(j)% & material counter = 0 do counter = counter + 1 call random_number(rnd) !Make sure to choose a unique material. child%laminate_array(i)%ply_array(j)%material & =individual_attributes%laminate_definition_array(i)% & material_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_materials)) if ((child%laminate_array(i)%ply_array(j)%material /= & temp_material) .or. counter == 200) exit end do end if case default ! The default mutation is ONE_POINT. call random_number(rnd) j = ceiling(rnd*current_lam_size) call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_mut_orientation) then temp_orient = child%laminate_array(i)%ply_array(j)% & orientation counter = 0 do counter = counter + 1 call random_number(rnd) child%laminate_array(i)%ply_array(j)%orientation & =individual_attributes%laminate_definition_array(i)% & orientation_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_poss_orientations)) if ((child%laminate_array(i)%ply_array(j)%orientation /= & temp_orient) .or. counter == 200) exit end do end if call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_mut_material) then temp_material = child%laminate_array(i)%ply_array(j)% & material counter = 0 do counter = counter + 1 call random_number(rnd) child%laminate_array(i)%ply_array(j)%material & =individual_attributes%laminate_definition_array(i)% & material_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_materials)) if ((child%laminate_array(i)%ply_array(j)%material /= & temp_material) .or. counter == 200) exit end do end if end select end do Lam !Apply one point geometry mutation. Geom:do i = 1, individual_attributes%individual_size_geom call random_number(rnd) current_lam_size = individual_attributes%geometry_definition_array(i)%& geom_chromo_size j = ceiling(rnd*current_lam_size) call random_number(rnd) if (rnd < individual_attributes%geometry_definition_array(i) & %prob_mutation) then temp_digit=child%geometry_array(i)%geometry_gene_array(j)%digit counter = 0 do counter = counter + 1 ub=individual_attributes%geometry_definition_array(i)% & upper_bounds_array(j) lb=individual_attributes%geometry_definition_array(i)% & lower_bounds_array(j) call random_number(rnd) new_digit = min(ub, lb) + rnd*abs(ub-lb) if (temp_digit /= new_digit .or. ub==lb .or. counter==200) then child%geometry_array(i)%geometry_gene_array(j)% & digit = new_digit exit end if end do end if end do Geom return end subroutine MUTATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine DELETION(CHILD) ! ! Subroutine DELETION provides a means of reducing the number of ! genes in a string. Deletion is only applied to laminates which ! allow empty plies, as defined in the variable ! INDIVIDUAL_ATTRIBUTES. ! ! A Uniformly distributed random number is generated for each ! string in a child individual. Deletion is applied if the random ! number is smaller than the probability of applying deletion. If ! deletion is applied, a gene is chosen at random and is converted ! to an empty gene. ! ! ! On input: ! ! CHILD stores the genetic code for a child individual before ! deletion is applied. ! ! ! On output: ! ! CHILD stores the genetic code for a child individual after ! deletion is applied. ! ! ! Internal variables: ! ! CURRENT_LAM_SIZE stores the length of the string that deletion ! is currently being applied to. ! ! J stores the location of the gene to be deleted. ! ! RND is a uniformly distributed random number. ! ! ! Loop variable: ! ! I ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type(individual), intent(inout) :: child !Local variables. real :: rnd integer :: i, j integer :: current_lam_size Lam:do i = 1, individual_attributes%individual_size_lam if(individual_attributes%laminate_definition_array(i)%empty_plies) then !Check if empty plies are allowed in the current laminate. current_lam_size =size( & pack (child%laminate_array(i)%ply_array, mask = & child%laminate_array(i)%ply_array%orientation .ne. 0)) else cycle ! Don't delete if empty plies are not allowed in ! the current laminate. end if if (current_lam_size <= 2) then cycle ! Don't delete if there are two or less plies in ! the current laminate. end if call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_ply_deletion) then call random_number(rnd) j = ceiling(rnd*current_lam_size) ! Make the designated ply empty. child%laminate_array(i)%ply_array(j)%orientation & = 0 child%laminate_array(i)%ply_array(j)%material & = 0 child%laminate_array(i)%ply_array(1:) = & pack (child%laminate_array(i)%ply_array, mask = & child%laminate_array(i)%ply_array%orientation .ne. 0, & vector = (empty_individual%laminate_array(i)%ply_array) ) end if ! End deletion end do Lam return end subroutine DELETION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine ADDITION(CHILD) ! ! Subroutine ADDITION provides a means of increasing the number of ! genes in a string. This operator is only applied to laminates ! which allow empty plies, as specified in the variable ! INDIVIDUAL_ATTRIBUTES. ! ! A Uniformly distributed random number is generated for each ! string in a child individual. Addition is applied if the random ! number is smaller than the probability of applying addition. If ! addition is applied, a gene is chosen at random and is converted ! to an empty gene. ! ! ! On input: ! ! CHILD stores the genetic code for a child individual before ! deletion is applied. ! ! ! On output: ! ! CHILD stores the genetic code for a child individual after ! deletion is applied. ! ! ! Internal variables: ! ! CURRENT_LAM_SIZE stores the length of the string that deletion ! is currently being applied to. ! ! J stores the location of the gene to be added. ! ! RND is a uniformly distributed random number. ! ! ! Loop variable: ! ! I ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type(individual), intent(inout) :: child !Local variables: real :: rnd integer :: i, j integer :: current_lam_size Lam:do i = 1, individual_attributes%individual_size_lam if(individual_attributes%laminate_definition_array(i)%empty_plies) & then current_lam_size =size( & pack (child%laminate_array(i)%ply_array, mask = & child%laminate_array(i)%ply_array%orientation .ne. 0)) else cycle ! Do not add a gene if the current laminate is of fixed size. end if if (current_lam_size == individual_attributes% & laminate_definition_array(i)%laminate_size) then cycle ! Do not add a gene if the current laminate is full. end if call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i)% & prob_ply_addition) then call random_number(rnd) j = ceiling(rnd*current_lam_size) child%laminate_array(i)%ply_array(j+1:current_lam_size+1)= & child%laminate_array(i)%ply_array(j:current_lam_size) ! Add a gene. child%laminate_array(i)%ply_array(j)%orientation & =individual_attributes%laminate_definition_array(i)% & orientation_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_poss_orientations)) child%laminate_array(i)%ply_array(j)%material & =individual_attributes%laminate_definition_array(i)% & material_array(ceiling(rnd*individual_attributes% & laminate_definition_array(i)%num_materials)) else end if end do Lam return end subroutine ADDITION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine INTRA_PLY_SWAP(CHILD) ! ! Subroutine INTRA_PLY_SWAP provides a means of relaying ! information from one part of a string to another, by randomly ! swapping genes. ! ! A Uniformly distributed random number is generated for each ! string in a child individual. Intra-ply swap is applied if the ! random number is smaller than the probability of applying intra- ! ply swap. If intra-ply swap is applied, the positions of two ! genes in a string are chosen at random and swapped (the values ! of the genes must be unique). ! ! ! On input: ! ! CHILD stores the genetic code for a child individual before ! intra-ply swap is applied. ! ! ! On output: ! ! CHILD stores the genetic code for a child individual after ! intra-ply swap is applied. ! ! ! Internal variables: ! ! CURRENT_LAM_SIZE stores the length of the string that ! intra-ply swap is currently being applied to. ! ! J stores the string position of the first gene to be swapped. ! ! K stores the string position of the second gene to be swapped. ! ! RND is a uniformly distributed random number. ! ! SWAP_1 stores the value of the first gene to be swapped. ! ! SWAP_2 stores the value of the second gene to be swapped. ! ! ! Loop variable: ! ! I ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type(individual), intent(inout) :: child !Local variables. real :: rnd integer :: counter, i, j, k integer :: current_lam_size integer :: swap_1, swap_2 Lam:do i = 1, individual_attributes%individual_size_lam if(individual_attributes%laminate_definition_array(i)%empty_plies) then current_lam_size = size( & pack(child%laminate_array(i)%ply_array, mask = & child%laminate_array(i)%ply_array%orientation .ne. 0) ) else current_lam_size = individual_attributes% & laminate_definition_array(i)%laminate_size end if call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_intra_ply_swap) then call random_number(rnd) j = ceiling(rnd*current_lam_size) swap_1 = child%laminate_array(i)%ply_array(j)%orientation counter = 0 do !Only swap genes which are not identical. counter = counter + 1 call random_number(rnd) k = ceiling(rnd*current_lam_size) if(j /= k) then swap_2 = child%laminate_array(i)%ply_array(k)%orientation if(swap_1 /= swap_2 .or. counter >= 200) exit end if end do !Swap the designated genes. child%laminate_array(i)%ply_array(j)%orientation = swap_2 child%laminate_array(i)%ply_array(k)%orientation = swap_1 swap_1 = child%laminate_array(i)%ply_array(j)%material swap_2 = child%laminate_array(i)%ply_array(k)%material child%laminate_array(i)%ply_array(j)%material = swap_2 child%laminate_array(i)%ply_array(k)%material = swap_1 end if end do Lam return end subroutine INTRA_PLY_SWAP !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine PERMUTATION(CHILD) ! ! Subroutine PERMUTATION provides a means of relaying information ! from one part of a string to another by randomly reordering ! sequence of genes. ! ! A Uniformly distributed random number is generated for each ! string in a child individual. Permutation is applied if the ! random number is smaller than the probability of applying ! permutation. If permutaion is applied, the positions of two ! genes in a string are chosen at random. The substring of genes ! defined between and including the two randomly selected ! locations is then inverted ! (e.g., [1,2,3,4] -> [4,3,2,1]). ! ! ! On input: ! ! CHILD stores the genetic code for a child individual before ! permutation is applied. ! ! ! On output: ! ! CHILD stores the genetic code for a child individual after ! permutation is applied. ! ! ! Internal variables: ! ! CURRENT_LAM_SIZE stores the length of the string that ! permutation is currently being applied to. ! ! J stores the string position of the left end of the permutation ! string. ! ! K stores the string position of the right end of the permutation ! string. ! ! PERMUTATION_ARRAY stores the gene values in the permutation ! string. ! ! RND is a uniformly distributed random number. ! ! STRING_LENGTH stores the number of genes in the permutation ! string. ! ! ! Loop variable: ! ! I ! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! use GENERIC_GA type(individual), intent(inout) :: child !Local variables. real :: rnd integer :: i, j, k, temp integer :: current_lam_size, string_length integer, dimension(:), allocatable :: permutation_array Lam: do i = 1, individual_attributes%individual_size_lam allocate(permutation_array(2*individual_attributes% & laminate_definition_array(i)%laminate_size)) if(individual_attributes%laminate_definition_array(i)%empty_plies) then current_lam_size = size( & pack(child%laminate_array(i)%ply_array, mask = & child%laminate_array(i)%ply_array%orientation .ne. 0) ) else current_lam_size = individual_attributes% & laminate_definition_array(i)%laminate_size end if call random_number(rnd) if (rnd < individual_attributes%laminate_definition_array(i) & %prob_permutation) then call random_number(rnd) j = ceiling(rnd*current_lam_size) do call random_number(rnd) k = ceiling(rnd*current_lam_size) if(j /= k) exit end do if (j > k) then !Ensure that k > j. temp = j j = k k = temp end if string_length = k - j + 1 permutation_array(1:string_length) = & child%laminate_array(i)%ply_array(j:k)%orientation permutation_array(string_length+1:2*string_length) = & child%laminate_array(i)%ply_array(j:k)%material child%laminate_array(i)%ply_array(j:k)%orientation = & permutation_array(string_length:1:-1) child%laminate_array(i)%ply_array(j:k)%material = & permutation_array(2*string_length:string_length+1:-1) end if deallocate(permutation_array) end do Lam return end subroutine PERMUTATION !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! real function RNOR() ! ! integer :: iseed real :: vni !***begin prologue rnor !***date written 810915 (yymmdd) !***revision date 870419 (yymmdd) !***category no. l6a14 !***keywords random numbers, normal deviates !***author kahaner, david, scientific computing division, nbs ! marsaglia, george, supercomputer res. inst., florida st. u. ! !***purpose generates normal random numbers, with mean zero and ! unit standard deviation, often denoted n(0,1). !***description ! ! rnor generates normal random numbers with zero mean and ! unit standard deviation, often denoted n(0,1). ! from the book, "numerical methods and software" by ! d. kahaner, c. moler, s. nash ! prentice hall, 1988 ! use ! first time.... ! z = rstart(iseed) ! here iseed is any n o n - z e r o integer. ! this causes initialization of the program. ! rstart returns a real (single precision) echo of iseed. ! ! subsequent times... ! z = rnor() ! causes the next real (single precision) random number ! to be returned as z. ! !..................................................................... ! typical usage ! ! real rstart,rnor,z ! integer iseed,i ! iseed = 305 ! z = rstart(iseed) ! do 1 i = 1,10 ! z = rnor() ! write(*,*) z ! 1 continue ! end ! ! !***references marsaglia & tsang, "a fast, easily implemented ! method for sampling from decreasing or ! symmetric unimodal density functions", to be ! published in siam j sisc 1983. !***routines called (none) !***end prologue rnor real aa,b,c,c1,c2,pc,x,y,xn,v(65),rstart,u(17),s,t,un integer j,ia,ib,ic,ii,jj,id,iii,jjj save u,ii,jj ! data aa,b,c/12.37586,.4878992,12.67706/ data c1,c2,pc,xn/.9689279,1.301198,.1958303e-1,2.776994/ data v/ .3409450, .4573146, .5397793, .6062427, .6631691 & , .7136975, .7596125, .8020356, .8417227, .8792102, .9148948 & , .9490791, .9820005, 1.0138492, 1.0447810, 1.0749254, 1.1043917 & ,1.1332738, 1.1616530, 1.1896010, 1.2171815, 1.2444516, 1.2714635 & ,1.2982650, 1.3249008, 1.3514125, 1.3778399, 1.4042211, 1.4305929 & ,1.4569915, 1.4834526, 1.5100121, 1.5367061, 1.5635712, 1.5906454 & ,1.6179680, 1.6455802, 1.6735255, 1.7018503, 1.7306045, 1.7598422 & ,1.7896223, 1.8200099, 1.8510770, 1.8829044, 1.9155830, 1.9492166 & ,1.9839239, 2.0198430, 2.0571356, 2.0959930, 2.1366450, 2.1793713 & ,2.2245175, 2.2725185, 2.3239338, 2.3795007, 2.4402218, 2.5075117 & ,2.5834658, 2.6713916, 2.7769943, 2.7769943, 2.7769943, 2.7769943/ ! load data array in case user forgets to initialize. ! this array is the result of calling uni 100000 times ! with seed 305. data u/ & 0.8668672834288, 0.3697986366357, 0.8008968294805, & 0.4173889774680, 0.8254561579836, 0.9640965269077, & 0.4508667414265, 0.6451309529668, 0.1645456024730, & 0.2787901807898, 0.06761531340295, 0.9663226330820, & 0.01963343943798, 0.02947398211399, 0.1636231515294, & 0.3976343250467, 0.2631008574685/ ! data ii,jj / 17, 5 / ! !***first executable statement rnor ! ! fast part... ! ! ! basic generator is fibonacci ! un = u(ii)-u(jj) if(un.lt.0.0) un = un+1. u(ii) = un ! u(ii) and un are uniform on [0,1) ! vni is uniform on [-1,1) vni = un + un -1. ii = ii-1 if(ii.eq.0)ii = 17 jj = jj-1 if(jj.eq.0)jj = 17 ! int(un(ii)*128) in range [0,127], j is in range [1,64] j = mod(int(u(ii)*128),64)+1 ! pick sign as vni is positive or negative rnor = vni*v(j+1) if(abs(rnor).le.v(j))return ! ! slow part; aa is a*f(0) x = (abs(rnor)-v(j))/(v(j+1)-v(j)) ! y is uniform on [0,1) y = u(ii)-u(jj) if(y.lt.0.0) y = y+1. u(ii) = y ii = ii-1 if(ii.eq.0)ii = 17 jj = jj-1 if(jj.eq.0)jj = 17 ! s = x+y if(s.gt.c2)go to 11 if(s.le.c1)return if(y.gt.c-aa*exp(-.5*(b-b*x)**2))go to 11 if(exp(-.5*v(j+1)**2)+y*pc/v(j+1).le.exp(-.5*rnor**2))return ! ! tail part; .3601016 is 1./xn ! y is uniform on [0,1) 22 y = u(ii)-u(jj) if(y.le.0.0) y = y+1. u(ii) = y ii = ii-1 if(ii.eq.0)ii = 17 jj = jj-1 if(jj.eq.0)jj = 17 ! x = 0.3601016*log(y) ! y is uniform on [0,1) y = u(ii)-u(jj) if(y.le.0.0) y = y+1. u(ii) = y ii = ii-1 if(ii.eq.0)ii = 17 jj = jj-1 if(jj.eq.0)jj = 17 if( -2.*log(y).le.x**2 )go to 22 rnor = sign(xn-x,rnor) return 11 rnor = sign(b-b*x,rnor) return ! ! ! fill entry rstart(iseed) if(iseed.ne.0) then ! ! set up ... ! generate random bit pattern in array based on given seed ! ii = 17 jj = 5 ia = mod(abs(iseed),32707) ib = 1111 ic = 1947 do iii = 1,17 s = 0.0 t = .50 ! do for each of the bits of mantissa of word ! loop over 64 bits, enough for all known machines ! in single precision do jjj = 1,64 id = ic-ia if(id.ge.0)goto 4 id = id+32707 s = s+t 4 ia = ib ib = ic ic = id t = .5*t end do u(iii) = s end do endif ! return floating echo of iseed rstart=iseed return end function ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!