ぽｔ - プログラム倉庫

Function lx(s As Single, th, tl As Single, tr As Single) As Single
Dim ls As Single
Dim w1 As Single
Dim w2 As Single
w1 = (1 - tl) * th(s)
w2 = w1 ^ (0.5)
ls = (w2 - tr) / (w1 + w2)
If ls < 0 Then ls = 0
lx = ls
End Function
Function cx(s As Single, th, tl As Single, tr As Single) As Single
Dim ls As Single
ls = lx(s, th, tl, tr)
If ls < 0 Then ls = 0
cx = (1 - tl) * th(s) * ls + tr
End Function

Function tls(th) As Single
Dim maxw As Single
Dim tl As Single
Dim tr As Single
Dim tp As Single
Dim w1 As Single
Dim n As Single
maxw = -9999
For n = 1 To 600
tl = 0.001 * n
tr = trs(th, tl)
w1 = wel(th, tl, tr)
If w1 > maxw Then tp = tl
If w1 > maxw Then maxw = w1
Next
tls = tp
End Function

Function trs(th, tl As Single) As Single
Dim tr1 As Single
Dim tr2 As Single
Dim tr3 As Single
Dim b1 As Single
Dim b2 As Single
Dim t As Single
tr1 = 0
tr2 = 0.1
t = 0
Do Until t > 100
b1 = bud(th, tl, tr1)
b2 = bud(th, tl, tr2)
tr3 = tr2 - b2 * (tr2 - tr1) / (b2 - b1)
tr1 = tr2
tr2 = tr3
If (tr1 - tr2) ^ 2 < 10 ^ (-5) Then t = 1000
t = t + 1
Loop
trs = tr2
End Function
Function wel(th, tl As Single, tr As Single) As Single
Dim w1 As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
w1 = 0
For s = 1 To 300
ls = lx(s, th, tl, tr)
cs = cx(s, th, tl, tr)
w1 = w1 - 1 / cs - 1 / (1 - ls)
Next
wel = w1
End Function
Function bud(th, tl As Single, tr As Single) As Single
Dim w1 As Single
Dim s As Single
Dim ls As Single
Dim cs As Single
Dim ys As Single
ys = 0
cs = 0
For s = 1 To 300
ls = lx(s, th, tl, tr)
If ls < 0 Then ls = 0
ys = ys + th(s) * ls
cs = cs + cx(s, th, tl, tr)
Next
bud = ys - cs
End Function
Private Sub Command1_Click()
Dim th(1 To 300) As Single
Dim s As Single
Dim tl As Single
Dim tr As Single
Dim cs(1 To 300) As Single
Dim ys(1 To 300) As Single
Dim w1 As Single
Open "c:/p1.txt" For Input As #1
Do Until EOF(1)
Input #1, a1, a2
s = a1
th(s) = a2
Loop
Close #1
tl = tls(th)
tr = trs(th, tl)
Debug.Print tl, tr
For s = 1 To 300
ys(s) = th(s) * lx(s, th, tl, tr)
cs(s) = cx(s, th, tl, tr)
Next
Open "c:/p2.txt" For Output As #2
For s = 1 To 300
Write #2, s, cs(s), ys(s)
Next
Close #2
End Sub