吸収 表計算　

Excelで微分方程式に挑戦！ルンゲ・クッタ法によるプログラミング。ホームページプログラミングでのプログラムと全く同じものを使用。sp02a.xls absp1.xls

マクロの部分は以下のよう

Sub A_onClick()

'----
NM = 2
NM = NM - 1
ReDim Y(NM), Y0(NM), YW(NM), YS(NM), YQ(NM), YD(NM)
'---- [a,b]
YA = 0
'----
y1 = Cells(5, 2)
y2 = Cells(6, 2)
x1 = Cells(11, 2)
KYA = Cells(2, 2)
KXA = Cells(3, 2)
M = Cells(1, 2)
D = -1 * (KXA / KYA)
L = Cells(10, 2)
G = Cells(4, 2)
'----
Y0(0) = y1
Y0(1) = x1
YH0 = Cells(12, 2)

YH1 = YH0
X0 = YA

NZ = 0
Lin = NZ + 15
Cells(Lin, 1) = X0
Cells(Lin, 2) = Y0(0)
Cells(Lin, 3) = Y0(1)
Cells(Lin, 4) = M * (D * Y0(1) - Y0(0)) / (D - M)
Cells(Lin, 5) = (D * Y0(1) - Y0(0)) / (D - M)

Do While Y0(0) > y2
NZ = NZ + 1
For NK = 0 To NM
YS(NK) = Y0(NK)
Next
YH = YH1
X = X0
Call Sub1640
For NK = 0 To NM
YQ(NK) = YW(NK)
Next
'1240------
YH = YH1 / 2#
X = X0
Call Sub1640
For NK = 0 To NM
YS(NK) = YW(NK)
Next
X = X0 + YH
Call Sub1640

For NK = 0 To NM
    YD(NK) = (YW(NK) - YQ(NK)) / 15
    E1 = Abs(YD(NK)) / YH1 / YW(NK)
   
Next

'1500-----
X0 = X0 + YH1
For NK = 0 To NM
Y0(NK) = YW(NK) + YD(NK)
Next
Lin = NZ + 15
Cells(Lin, 1) = X0
Cells(Lin, 2) = Y0(0)
Cells(Lin, 3) = Y0(1)
Cells(Lin, 4) = M * (D * Y0(1) - Y0(0)) / (D - M)
Cells(Lin, 5) = (D * Y0(1) - Y0(0)) / (D - M)

Loop

End Sub

Sub Sub1640()
'------Runge-Kutta
For NK = 0 To NM
Y(NK) = YS(NK)
YW(NK) = YS(NK)
Next
For NK = 0 To NM
Call SUB2000
YDD = DYDX * YH
YW(NK) = YW(NK) + YDD / 6#
Y(NK) = YS(NK) + YDD / 2#
Next
X = X + YH / 2#
For NK = 0 To NM
Call SUB2000
YDD = DYDX * YH
YW(NK) = YW(NK) + YDD / 3#
Y(NK) = YS(NK) + YDD / 2#
Next
For NK = 0 To NM
Call SUB2000
YDD = DYDX * YH
YW(NK) = YW(NK) + YDD / 3#
Y(NK) = YS(NK) + YDD
Next
X = X + YH / 2#
For NK = 0 To NM
Call SUB2000
YDD = DYDX * YH
YW(NK) = YW(NK) + YDD / 6#
Next
End Sub

Sub SUB2000()
'---------ﾋﾞﾌﾞﾝ ﾎｳﾃｲｼｷ
Select Case NK
Case 0
' [ DYDX=Y(0)' ]
DYDX = -(KYA / G) * (Y(0) - M * (D * Y(1) - Y(0)) / (D - M))
Case 1
' [ DYDX=Y(1)' ]
DYDX = -(KXA / L) * ((D * Y(1) - Y(0)) / (D - M) - Y(1))
End Select
End Sub