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