以下、付録です。
λの繰り返し計算のプログラムリストは以下の通りです。
Sub Topology_optimization_2_lambda_search() Dim co As Integer, ro As Integer, i As Integer, idx As Integer, k As Integer Dim generation_num As Integer Dim lambda_init As Double, g_Vo As Double, a As Double, zero As Double Dim ss As String zero = 0.000000001 generation_num = Cells(4, 1) ne = Cells(4, 5) If generation_num = 1 Then Range("R11:T1010").Select Selection.ClearContents lambda_init = Cells(4, 17) Cells(11, 19) = lambda_init Else i = Cells(6, 11) lambda_init = Cells(i + 10, 19) Range("R11:T1010").Select Selection.ClearContents Cells(11, 19) = lambda_init End If Range("U12:V1010").Select Selection.ClearContents i = 0 Do i = i + 1: Cells(6, 11) = i Range("T8").Select Selection.Copy ro = 10 + i Range(Cells(ro, 20), Cells(ro, 20)).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("U11:V11").Select Selection.Copy Range(Cells(ro, 21), Cells(ro, 21)).Select ActiveSheet.Paste Cells(ro, 18) = i If (i = 1) And (Abs(Cells(ro, 20)) < zero) Then ss = "Finished lambda serch" idx = MsgBox(ss, 0, "Lambda serch") GoTo Density_plot_a a = 1# ElseIf i = 1 Then a = 1# Else a = Cells(ro, 20) * Cells(ro - 1, 20) End If If a <= 0# Then Exit Do If i > 100 Then MsgBox "Failed to search for lambda .", 16, "Error in Topology_optimization_2_lambda_serch()" Exit Sub End If Range(Cells(ro, 22), Cells(ro, 22)).Select Selection.Copy Range(Cells(ro + 1, 19), Cells(ro + 1, 19)).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Loop k = 0 Do i = i + 1: k = k + 1: Cells(6, 11) = i ro = 10 + i Cells(ro, 18) = i 'Range("U11:V11").Select 'Selection.Copy 'Range(Cells(ro, 21), Cells(ro, 21)).Select 'ActiveSheet.Paste Range(Cells(ro - 2, 19), Cells(ro - 1, 20)).Select Selection.Copy Range("AD11").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("AD16").Select Selection.Copy Range(Cells(ro, 19), Cells(ro, 19)).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Range("T8").Select Selection.Copy Range(Cells(ro, 20), Cells(ro, 20)).Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False If Abs(Cells(ro, 20) - Cells(ro - 1, 20)) < zero Then ss = "Finished lambda serch" idx = MsgBox(ss, 0, "Lambda serch") Exit Do End If idx = 0 g_Vo = Cells(8, 20) If (g_Vo < 0.01) And (k > 20) Then ss = "Continue lambda serch?" & vbCrLf ss = ss & "Recommend to finish lambda serch." & vbCrLf & vbCrLf ss = ss & "Volume error is " & Format(g_Vo * 100, "0.000") & "%" idx = MsgBox(ss, 4, "Lambda serch") ElseIf k > 20 Then ss = "Continue lambda serch?" & vbCrLf & vbCrLf ss = ss & "Volume error is " & Format(g_Vo * 100, "0.000") & "%" idx = MsgBox(ss, 4, "Lambda serch") Else k = k End If If idx = 7 Then Exit Do Loop Density_plot_a: Topology_optimization_Density_plot (1) Cells(4, 3) = "2 Finished lambda serch." ActiveSheet.Shapes.Range(Array("TextBox 6")).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.0500000007 .Transparency = 0 .Solid End With ActiveSheet.Shapes.Range(Array("TextBox 2")).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.0500000007 .Transparency = 0 .Solid End With ActiveSheet.Shapes.Range(Array("TextBox 3")).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.ObjectThemeColor = msoThemeColorBackground1 .ForeColor.TintAndShade = 0 .ForeColor.Brightness = -0.0500000007 .Transparency = 0 .Solid End With ActiveSheet.Shapes.Range(Array("TextBox 4")).Select With Selection.ShapeRange.Fill .Visible = msoTrue .ForeColor.RGB = RGB(255, 153, 153) .Transparency = 0 .Solid End With Range("A1").Select End Sub
Copyright © ITmedia, Inc. All Rights Reserved.