vba遗传算法之非一致性突变

http://www.docin.com/p-959323141-f4.html

 1 Sub 非一致性变异()
 2 Dim totalGenerate As Integer, currentGenerate As Integer, ak As Double, bk As Double, vk As Double, vk1 As Double, vk2 As Double, i As Integer
 3 Dim p As Integer, mytemp As Double
 4 totalGenerate = 100: ak = 1#: bk = 2#: vk = 1.5: p = 2
 5 Randomize
 6 mytemp1 = Rnd
 7 mytemp2 = Rnd
 8 dety1 = (bk - vk)
 9 For currentGenerate = 1 To totalGenerate
10 vk = 1.5
11 vk1 = vk + (bk - vk) * (1 - mytemp1 ^ (1 - currentGenerate / totalGenerate) ^ (p))
12  Cells(currentGenerate, 9) = vk1
13  vk2 = vk + (vk - ak) * (1 - mytemp2 ^ ((1 - currentGenerate / totalGenerate) ^ (p)))
14   Cells(currentGenerate, 10) = vk2
15  If Rnd < 0.5 Then
16   vk = vk1
17   Else
18   vk = vk2
19   End If
20   Cells(currentGenerate, 11) = vk
21   Cells(currentGenerate, 12) = ak
22   Cells(currentGenerate, 13) = bk
23 
24 Next currentGenerate
25 
26 End Sub

p=2：

比如定模型参数时，参数范围为[1,3],初始值为1.5，要突变这个1.5可以用以下代码：

 1 Sub 非一致性变异()
 2 Dim totalGenerate As Integer, currentGenerate As Integer, ak As Double, bk As Double, vk As Double, vk1 As Double, vk2 As Double, i As Integer
 3 Dim p As Integer, mytemp As Double
 4 totalGenerate = 100: ak = 1: bk = 3: vk = 1.5: p = 5
 5 Randomize
 6 mytemp1 = Rnd
 7 mytemp2 = Rnd
 8 dety1 = (bk - vk)
 9 For currentGenerate = 1 To totalGenerate
10 vk = 1.5
11 vk1 = vk + (bk - vk) * (1 - mytemp1 ^ (1 - currentGenerate / totalGenerate) ^ (p))
12  Cells(currentGenerate, 9) = vk1
13  vk2 = vk - (vk - ak) * (1 - mytemp1 ^ ((1 - currentGenerate / totalGenerate) ^ (p)))
14   Cells(currentGenerate, 10) = vk2
15  If Rnd < 0.5 Then
16   vk = vk1
17   Else
18   vk = vk2
19   End If
20   Cells(currentGenerate, 11) = vk
21   Cells(currentGenerate, 12) = ak
22   Cells(currentGenerate, 13) = bk
23   
24 'Cells(currentGenerate, 15) = vk + Sgn(0.5 - Rnd) * (bk - vk) * (1 - mytemp1 ^ (1 - currentGenerate / totalGenerate) ^ (p)) 'Round(2 * (0.5 - Rnd()), 0)
25 
26 Next currentGenerate
27 
28 End Sub