initpop.bas

电力自动化专业领域的一个重要内容

Attribute VB_Name = "Module1"
Option Explicit
Public kd(1 To 8) As Integer
Type PP
kdchrom(1 To 192) As Integer
kjP(1 To 192) As Integer
fitness As Double
AA(0 To 23, 1 To 8) As Integer
AP(0 To 23, 1 To 8) As Double
parent1 As Integer
parent2 As Integer
End Type
Public oldpop(1 To 50) As PP
Public newpop(1 To 50) As PP
Public fh(23) As Double
Public A() As Double
Public A2() As Double
Public C() As Double
Public C2() As Double
Public C3() As Double
Public B() As Double
Public P() As Double
Public JX() As Double
Public fvalue As Double
Public fvalue2 As Double
Public Jmax As Integer
Public Imin As Integer
Public Cmax As Double
Public sumfitness As Double
Public jrand As Integer
Public oldrand(1 To 192) As Double
Public ncross As Double
Public nmutation As Double
Public jcross As Integer
Public min As Double
Public minpp As Integer
Public max As Double
Public maxpp As Integer
Public gen As Integer
Public maxgen As Integer
Sub report(gen As Integer)
Dim i As Integer
Dim j As Integer
Dim N As Integer
Open "E:\wyl\结果gj2.txt" For Output As #1
For N = 1 To 50
For i = 0 To 23
For j = 1 To 8
Print #1, newpop(N).AA(i, j);
Next j
Print #1,
Next i
Print #1,
For i = 0 To 23
For j = 1 To 8
Print #1, newpop(N).AP(i, j);
Next j
Print #1,
Next i
Print #1,
Print #1, newpop(N).fitness
Next N
Print #1,
Print #1, sumfitness
Close #1
End Sub
Sub generation()
Dim j As Integer
Dim mate1 As Integer
Dim mate2 As Integer
Dim p2 As PP
p2 = oldpop(1)
j = 1
Do While (j < 50)
mate1 = selectit()
mate2 = selectit()
Call crossover(oldpop(mate1).AA(), oldpop(mate2).AA(), j)
Call Pallocate(newpop(j).AA(), newpop(j).AP())
newpop(j).fitness = objfun(newpop(j).AA(), newpop(j).AP())
newpop(j).parent1 = mate1
newpop(j).parent2 = mate2
Call Pallocate(newpop(j + 1).AA(), newpop(j + 1).AP())
newpop(j + 1).fitness = objfun(newpop(j + 1).AA(), newpop(j + 1).AP())
newpop(j + 1).parent1 = mate1
newpop(j + 1).parent2 = mate2
j = j + 2
Loop
newpop(1) = p2
Call linear(newpop())
End Sub

Function mutation(ch As Integer) As Integer
Dim mutate As Integer
Dim j As Integer
Dim pmutation As Double
pmutation = 0.001
mutate = flip(pmutation)
If (mutate) Then
nmutation = nmutation + 1
If (ch) Then
ch = 0
Else
ch = 1
End If
If (ch) Then
mutation = 1
Else
mutation = 0
End If
Else
mutation = ch
End If
End Function
Function mutation2(ch As Integer) As Integer
Dim mutate As Integer
Dim j As Integer
Dim pmutation As Double
pmutation = 0.02 - (0.02 - 0.0005) / (maxgen) * (gen - 1)
mutate = flip(pmutation)
If (mutate) Then
nmutation = nmutation + 1
If (ch) Then
ch = 0
Else
ch = 1
End If
If (ch) Then
mutation2 = 1
Else
mutation2 = 0
End If
Else
mutation2 = ch
End If
End Function
Function flip(probility As Double) As Integer
Dim ppp As Double
ppp = Rnd(1000)
If ppp <= probility Then
flip = 1
Else
flip = 0
End If

End Function

Sub crossover(parents1() As Integer, parents2() As Integer, k5 As Integer)
Dim i As Integer
Dim j As Integer
Dim N As Integer
Dim J1 As Integer
Dim pcross As Double
pcross = 0.8
If (flip(pcross)) Then
jcross = Int(Rnd(700) * 23)
ncross = ncross + 1
Else
jcross = 23
End If
If (jcross <> 23) Then
For i = 4 To 7
For j = 0 To jcross - 1
newpop(k5).AA(j, i) = mutation(parents1(j, i))
newpop(k5 + 1).AA(j, i) = mutation(parents2(j, i))
Next j
For j = jcross To 23
newpop(k5).AA(j, i) = mutation(parents2(j, i))
newpop(k5 + 1).AA(j, i) = mutation(parents1(j, i))
Next j
Next i
Else
For i = 5 To 7
For j = 0 To 23
newpop(k5).AA(j, i) = mutation(parents1(j, i))
newpop(k5 + 1).AA(j, i) = mutation(parents2(j, i))
Next j
Next i
End If
For i = 1 To 4
For j = 0 To 23
newpop(k5).AA(j, i) = parents1(j, i)
newpop(k5 + 1).AA(j, i) = parents2(j, i)
Next j
Next i
For i = 8 To 8
For j = 0 To 23
newpop(k5).AA(j, i) = parents1(j, i)
newpop(k5 + 1).AA(j, i) = parents2(j, i)
Next j
Next i

End Sub
Sub linear(ttpop() As PP)
Dim i As Integer
Dim j As Integer
Dim tt As PP
For i = 1 To 49
For j = i + 1 To 50
If (ttpop(i).fitness >= ttpop(j).fitness) Then GoTo 130
tt = ttpop(j)
ttpop(j) = ttpop(i)
ttpop(i) = tt
130: Next j
Next i
End Sub
Function select1() As Integer
Dim bias As Single
Dim index As Integer
bias = 2#
index = 50 * (bias - Sqr(bias * bias - 4 * (bias - 1) * Rnd(900))) / 2# / (bias - 1)
select1 = index
If (select1 = 0) Then
select1 = 1
End If
End Function


Function selectit() As Integer
Dim rand1 As Double
Dim partsum As Double
Dim j As Integer
partsum = 0
j = 1
rand1 = Rnd(500) * sumfitness
Do While ((partsum < rand1) And (j < 50))
partsum = partsum + oldpop(j).fitness
j = j + 1
Loop
selectit = j - 1
End Function

Sub statistics(pop() As PP)
Dim j As Integer
sumfitness = pop(1).fitness
min = pop(1).fitness
max = pop(1).fitness
maxpp = 1
minpp = 1
For j = 2 To 50
sumfitness = sumfitness + pop(j).fitness
If (pop(j).fitness > max) Then
max = pop(j).fitness
maxpp = j
End If

If (pop(j).fitness < min) Then
min = pop(j).fitness
minpp = j
End If

Next j
End Sub
Function objfun(CA() As Integer, CP() As Double) As Double
Dim PP(0 To 23) As Double
Dim i As Integer
Dim j As Integer
Dim profit As Double
Dim allprofit As Double
Dim qicost As Double
Dim ygcost As Double
Dim tingcost As Double
Dim initP(1 To 8) As Integer
Dim S(1 To 8) As Double
Dim SD(1 To 8) As Double
Dim PMAX(1 To 8) As Double
Dim allpmax As Double
Dim PSAVE(0 To 23) As Integer
Dim FP As Double
Dim gongcost As Double
Dim F(1 To 8, 1 To 3) As Double
Dim DP(1 To 8) As Integer
Dim ttP(0 To 24, 1 To 8) As Double
Dim fh(0 To 23) As Double
Dim pw(0 To 23) As Double



DP(1) = 150: DP(2) = 150: DP(3) = 150: DP(4) = 150
DP(5) = 50: DP(6) = 30: DP(7) = 30: DP(8) = 30
initP(1) = 350: initP(2) = 345: initP(3) = 450: initP(4) = 300: initP(5) = 150

FP = 98
Open "E:\wyl\电价.txt" For Input As #2
For i = 0 To 23
Input #2, PP(i)
Next i
Close #2

Open "E:\wyl\负荷.txt" For Input As #2
For i = 0 To 23
Input #2, fh(i)
Next i
Close #2


Open "E:\wyl\启动煤耗.txt" For Input As #2
For i = 1 To 8
Input #2, S(i)
Next i
Close #2
Open "E:\wyl\停机煤耗.txt" For Input As #2
For i = 1 To 8
Input #2, SD(i)
Next i
Close #2

Open "E:\wyl\煤耗特性数据文件.txt" For Input As #2
For i = 1 To 8
For j = 1 To 3
Input #2, F(i, j)
Next j
Next i
Close #2

Open "E:\wyl\出力上限.txt" For Input As #2
For i = 1 To 8
Input #2, PMAX(i)
Next i
Close #2

Open "E:\wyl\备用容量.txt" For Input As #2
For i = 0 To 23
Input #2, PSAVE(i)
Next i
Close #2

allprofit = 0
For i = 0 To 23
For j = 1 To 8
allprofit = allprofit + 1000 / 60 * PP(i) * CA(i, j) * CP(i, j)
Next j
Next i
qicost = 0
For i = 1 To 8
For j = 1 To 23
qicost = qicost + CA(j, i) * (1 - CA(j - 1, i)) * 800
Next j
Next i
gongcost = 0
For j = 1 To 8
For i = 0 To 23
gongcost = gongcost + (F(j, 1) * CP(i, j) * CP(i, j) + F(j, 2) * CP(i, j) + F(j, 3)) * CA(i, j)
Next i
Next j
tingcost = 0
For i = 1 To 8
For j = 1 To 23
tingcost = tingcost + CA(j - 1, i) * (1 - CA(j, i)) * 600
Next j
Next i
profit = allprofit - qicost - gongcost - tingcost
For i = 0 To 23
allpmax = 0
For j = 1 To 8
If CA(i, j) = 1 Then
allpmax = allpmax + PMAX(j)
End If
Next j
If ((allpmax - fh(i)) < PSAVE(i)) Then
profit = profit - 1000
End If
Next i
For i = 5 To 7
For j = 1 To 22
If (CA(j, i) = 1) And (CA(j - 1, i) = 0) And (CA(j + 1, i) = 0) Then
profit = profit - 500
End If
Next j
If (CA(0, i) = 1) And (CA(1, i) = 0) Then
profit = profit - 500
End If

If (CA(23, i) = 1) And (CA(22, i) = 0) Then
profit = profit - 500
End If
Next i
For i = 1 To 24
For j = 1 To 8
ttP(i, j) = CP(i - 1, j)
Next j
Next i
For i = 1 To 8
ttP(0, i) = initP(i)
Next i


For i = 1 To 8
For j = 0 To 23
If ttP(j, i) - ttP(j + 1, i) > DP(i) Then
profit = profit - 1000
End If
Next j
Next i
For i = 0 To 23
pw(i) = 0
For j = 1 To 8
pw(i) = pw(i) + CP(i, j)
Next j
If (pw(i) <> fh(i)) Then
profit = profit - 1000
End If
Next i


objfun = profit
End Function

'生成初始群体

Sub initpop()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim N As Integer
Dim kjnum As Integer
Dim m As Integer
Dim allB(1 To 8) As Double
Dim allBx(1 To 8) As Double
Dim allP(1 To 8) As Double
Dim BP(1 To 8) As Double
Dim ZB() As Double
Dim ZP() As Double
Dim ZB1() As Double
Dim ZP1() As Double
Dim kjnum1 As Integer
Dim sumallBx As Double
Dim nm As Double
Dim initP(1 To 8) As Integer
Dim initkj(1 To 8) As Integer
Dim allBU(1 To 8) As Integer
Dim allBD(1 To 8) As Integer
Dim UP(1 To 8) As Integer

initP(1) = 350: initP(2) = 345: initP(3) = 450: initP(4) = 300: initP(5) = 150
initkj(1) = 1: initkj(2) = 1: initkj(3) = 1: initkj(4) = 1: initkj(5) = 1
UP(1) = 150: UP(2) = 150: UP(3) = 150: UP(4) = 150: UP(5) = 50: UP(6) = 30: UP(7) = 30: UP(8) = 30
allBU(1) = 350: allBU(2) = 345: allBU(3) = 450
allBU(4) = 450: allBU(5) = 200: allBU(6) = 91
allBU(7) = 90:  allBU(8) = 80

allBD(1) = 200: allBD(2) = 190: allBD(3) = 250
allBD(4) = 250: allBD(5) = 110: allBD(6) = 53
allBD(7) = 52: allBD(8) = 45
allP(1) = 0.787: allP(2) = 0.794: allP(3) = 0.809
allP(4) = 0.81:  allP(5) = 0.833: allP(6) = 0.889
allP(7) = 0.956: allP(8) = 1.104




Open "E:\wyl\负荷.txt" For Input As #1
For i = 0 To 23
Input #1, fh(i)
Next i
Close #1
For N = 1 To 50
For k = 0 To 23
100: Call random1
For j = 1 To 8
oldpop(N).kdchrom(8 * k + j) = kd(j)
Next j
Next k

For i = 0 To 23
For j = 1 To 8
oldpop(N).AA(i, j) = oldpop(N).kdchrom(8 * i + j)
Next j
Next i
Call Pallocate(oldpop(N).AA(), oldpop(N).AP())

oldpop(N).fitness = objfun(oldpop(N).AA(), oldpop(N).AP())










Open "E:\wyl\初始群体1.txt" For Append As #1
For i = 0 To 23
For j = 1 To 8
Print #1, oldpop(N).AA(i, j);
Next j
Print #1,
Next i
Print #1,
For i = 0 To 23
For j = 1 To 8
Print #1, oldpop(N).AP(i, j);
Next j
Print #1,
Next i
Print #1,
Print #1, oldpop(N).fitness
Close #1
Next N

Call linear(oldpop)

End Sub

'随机数发生器

Sub random1()
Dim i As Integer
For i = 1 To 3
kd(i) = 1
Next i
For i = 4 To 7
kd(i) = Int(Rnd(900) + 0.5)
Next i
kd(8) = 0
End Sub
Sub randomsj()
Dim i As Integer
For i = 1 To 8
kd(i) = Int(Rnd(900) + 0.5)
Next i
End Sub
Sub Pallocate(ss() As Integer, rr() As Double)
Dim i As Integer
Dim j As Integer
Dim N1  As Integer
Dim kjnum As Integer
Dim m As Integer
Dim allB(1 To 8) As Double
Dim allBx(1 To 8) As Double
Dim allP(1 To 8) As Double
Dim BP(1 To 8) As Integer
Dim ZB() As Double
Dim ZP() As Double
Dim ZB1() As Double
Dim ZP1() As Double
Dim kjnum1 As Integer
Dim sumallBx As Double
Dim sumallB As Double
Dim nm As Double
Dim initP(1 To 8) As Integer
Dim initkj(1 To 8) As Integer
Dim allBU(1 To 8) As Integer
Dim allBD(1 To 8) As Integer
Dim UP(1 To 8) As Integer
Dim fhguding As Double
Dim fhguding1 As Double
Dim msj As Integer
Dim ifopen As Integer
Dim k As Integer

Dim gudingP(0 To 23, 1 To 8) As Double
Dim kyss(0 To 23, 1 To 8) As Integer


initP(1) = 350: initP(2) = 345: initP(3) = 450: initP(4) = 300: initP(5) = 150
initkj(1) = 1: initkj(2) = 1: initkj(3) = 1: initkj(4) = 1: initkj(5) = 1
UP(1) = 150: UP(2) = 150: UP(3) = 150: UP(4) = 150: UP(5) = 50: UP(6) = 30: UP(7) = 30: UP(8) = 30

allBU(1) = 350: allBU(2) = 345: allBU(3) = 450
allBU(4) = 450: allBU(5) = 200: allBU(6) = 91
allBU(7) = 90:  allBU(8) = 80

allBD(1) = 200: allBD(2) = 190: allBD(3) = 250
allBD(4) = 250: allBD(5) = 110: allBD(6) = 53
allBD(7) = 52: allBD(8) = 45

allP(1) = 0.787: allP(2) = 0.794: allP(3) = 0.809
allP(4) = 0.81:  allP(5) = 0.833: allP(6) = 0.889
allP(7) = 0.956: allP(8) = 1.104


N1 = 0
For i = 1 To 8
allB(i) = initP(i) + UP(i)
allBx(i) = initP(i) - UP(i)
Next i
For i = 1 To 8
If (allB(i) > allBU(i)) Then