ความคิดเห็นที่ 6
นี่เป็นตัวอย่าง code QR decomposition ที่ผมพัฒนาขึ้นครับ
Sub QRCompute(N As Integer, P As Integer)
Const MaxP As Integer = 15
Const MaxN As Integer = 70
Dim orig_MatrixV(1 To MaxN, 1 To MaxP) As Double
Dim MatrixV(1 To MaxP, 1 To MaxN, 1 To MaxP) As Double
Dim MatrixR(1 To MaxN, 1 To MaxP) As Double
Dim MatrixR1(1 To MaxP, 1 To MaxP) As Double
Dim MatrixR1_Inverse(1 To MaxP, 1 To MaxP) As Double
Dim Iden(1 To MaxN, 1 To MaxN) As Double
Dim v(1 To MaxP, 1 To MaxN) As Double
Dim v2(1 To MaxP, 1 To MaxN) As Double
Dim sum_v2(1 To MaxP) As Double
Dim e(1 To MaxP, 1 To MaxN) As Double
Dim size_v(1 To MaxP) As Double
Dim v_num(1 To MaxP, 1 To MaxN) As Double
Dim v_num2(1 To MaxP, 1 To MaxN) As Double
Dim sum_v_num2(1 To MaxP) As Double
Dim size_v_num(1 To MaxP) As Double
Dim u(1 To MaxP, 1 To MaxN) As Double
Dim Hu(1 To MaxP, 1 To MaxN, 1 To MaxN) As Double
Dim SE(1 To MaxP) As Double
Dim CI_95(1 To MaxP) As Double
Dim CI_99(1 To MaxP) As Double
Application.ScreenUpdating = False
Sheets("Summary").Select
RSS_MS = Cells(19, 6)
DOF_MS = N - P
S_Square = RSS_MS / DOF_MS
Sheets("Convention").Select
For j = 1 To P
For i = 1 To N
orig_MatrixV(i, j) = Cells(5 + i, 5 + j)
MatrixV(1, i, j) = orig_MatrixV(i, j)
Next i
Next j
Sheets("GraphGen").Select
Cells.Clear
For i = 1 To N
For j = 1 To N
If i = j Then
Iden(i, j) = 1
Else
Iden(i, j) = 0
End If
Next j
Next i
For j = 1 To P
sum_v2(j) = 0
For i = 1 To N
If j = 1 Then
v(j, i) = MatrixV(j, i, j)
Else
If i < j Then
v(j, i) = 0
Else
v(j, i) = MatrixV(j, i, j)
End If
End If
v2(j, i) = v(j, i) ^ 2
sum_v2(j) = sum_v2(j) + v2(j, i)
If i = j Then
e(j, i) = 1
Else
e(j, i) = 0
End If
If i = N Then
size_v(j) = (sum_v2(j)) ^ (1 / 2)
End If
Next i
sum_v_num2(j) = 0
For i = 1 To N
v_num(j, i) = v(j, i) - size_v(j) * e(j, i)
v_num2(j, i) = v_num(j, i) ^ 2
sum_v_num2(j) = sum_v_num2(j) + v_num2(j, i)
If i = N Then
size_v_num(j) = (sum_v_num2(j)) ^ (1 / 2)
End If
Next i
For i = 1 To N
u(j, i) = v_num(j, i) / size_v_num(j)
Next i
For i = 1 To N
Cells(1, i) = u(j, i)
Cells(1 + i, 1) = u(j, i)
Next i
Range(Cells(N + 2, 1), Cells(2 * N + 1, N)).FormulaArray = _
"=-2*mmult($a$2:" & Cells(1 + N, 1).Address & ",$a$1:" & Cells(1, N).Address & ")"
For i = 1 To N
For k = 1 To N
Cells(2 * N + 1 + i, k) = Iden(i, k)
Next k
Next i
For i = 1 To N
For k = 1 To N
Cells(3 * N + 1 + i, k) = Cells(N + 1 + i, k) + Cells(2 * N + 1 + i, k)
Hu(j, i, k) = Cells(3 * N + 1 + i, k)
Next k
Next i
Cells.Clear
For i = 1 To N
For k = 1 To N
Cells(i, k) = Hu(j, i, k)
Next k
Next i
For k = 1 To P
For i = 1 To N
Cells(i + N, k) = MatrixV(j, i, k)
Next i
Next k
Range(Cells(2 * N + 1, 1), Cells(3 * N, P)).FormulaArray = _
"=mmult($a$1:" & Cells(N, N).Address & ",$a$" & N + 1 & ":" & Cells(2 * N, P).Address & ")"
If j <> P Then
For k = 1 To P
For i = 1 To N
MatrixV(j + 1, i, k) = Cells(2 * N + i, k)
Next i
Next k
Else
For k = 1 To P
For i = 1 To N
MatrixR(i, k) = Cells(2 * N + i, k)
Next i
Next k
For k = 1 To P
For i = 1 To P
MatrixR1(i, k) = Cells(2 * N + i, k)
Next i
Next k
End If
Cells.Clear
Next j
For i = 1 To P
For k = 1 To P
Cells(i, k) = MatrixR1(i, k)
Next k
Next i
Range(Cells(P + 1, 1), Cells(2 * P, P)).FormulaArray _
= "=minverse($a$1:" & Cells(P, P).Address & ")"
For i = 1 To P
Sum = 0
For k = 1 To P
MatrixR1_Inverse(i, k) = Cells(P + i, k)
Sum = Sum + MatrixR1_Inverse(i, k) ^ 2
Next k
SE(i) = (S_Square * Sum) ^ (1 / 2)
Next i
Cells.Clear
Cells(1, 1) = "=tinv(" & 0.05 & "," & DOF_MS & ")"
TDist95 = Cells(1, 1)
Cells(1, 1) = "=tinv(" & 0.01 & "," & DOF_MS & ")"
TDist99 = Cells(1, 1)
For i = 1 To P
CI_95(i) = SE(i) * TDist95
CI_99(i) = SE(i) * TDist99
Next i
Cells.Clear
Sheets("Summary").Select
For i = 1 To P
Cells(21 + i, 6) = Cells(2 + i, 6)
Cells(21 + i, 7) = SE(i)
Cells(21 + i, 8) = CI_95(i)
Cells(21 + i, 9) = Cells(21 + i, 6) - CI_95(i)
Cells(21 + i, 10) = Cells(21 + i, 6) + CI_95(i)
Cells(21 + i, 11) = CI_99(i)
Cells(21 + i, 12) = Cells(21 + i, 6) - CI_99(i)
Cells(21 + i, 13) = Cells(21 + i, 6) + CI_99(i)
Next i
Range(Cells(22, 6), Cells(39, 13)).NumberFormat = "0.0000E+00"
For i = 1 To 15
For j = 6 To 13
If Cells(21 + i, j) = "" Then
Cells(21 + i, j).Interior.ColorIndex = 48
Else
Cells(21 + i, j).Interior.ColorIndex = xlNone
End If
Next j
Next i
End Sub
จากคุณ :
Practical x 2  
- [
16 ธ.ค. 49 21:59:45
]
|
|
|
