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

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

 Sub 非一致性变异()
 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
 Dim p As Integer, mytemp As Double
 totalGenerate = : ak = #: bk = #: vk = 1.5: p =
 Randomize
 mytemp1 = Rnd
 mytemp2 = Rnd
 dety1 = (bk - vk)
 For currentGenerate =  To totalGenerate
 vk = 1.5
 vk1 = vk + (bk - vk) * ( - mytemp1 ^ ( - currentGenerate / totalGenerate) ^ (p))
  Cells(currentGenerate, ) = vk1
  vk2 = vk + (vk - ak) * ( - mytemp2 ^ (( - currentGenerate / totalGenerate) ^ (p)))
   Cells(currentGenerate, ) = vk2
  If Rnd < 0.5 Then
   vk = vk1
   Else
   vk = vk2
   End If
   Cells(currentGenerate, ) = vk
   Cells(currentGenerate, ) = ak
   Cells(currentGenerate, ) = bk

 Next currentGenerate

 End Sub

p=2：

---

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

 Sub 非一致性变异()
 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
 Dim p As Integer, mytemp As Double
 totalGenerate = : ak = : bk = : vk = 1.5: p =
 Randomize
 mytemp1 = Rnd
 mytemp2 = Rnd
 dety1 = (bk - vk)
 For currentGenerate =  To totalGenerate
 vk = 1.5
 vk1 = vk + (bk - vk) * ( - mytemp1 ^ ( - currentGenerate / totalGenerate) ^ (p))
  Cells(currentGenerate, ) = vk1
  vk2 = vk - (vk - ak) * ( - mytemp1 ^ (( - currentGenerate / totalGenerate) ^ (p)))
   Cells(currentGenerate, ) = vk2
  If Rnd < 0.5 Then
   vk = vk1
   Else
   vk = vk2
   End If
   Cells(currentGenerate, ) = vk
   Cells(currentGenerate, ) = ak
   Cells(currentGenerate, ) = bk

 'Cells(currentGenerate, 15) = vk + Sgn(0.5 - Rnd) * (bk - vk) * (1 - mytemp1 ^ (1 - currentGenerate / totalGenerate) ^ (p)) 'Round(2 * (0.5 - Rnd()), 0)

 Next currentGenerate

 End Sub