実践！ 密度法によるトポロジー最適化に挑戦してみよう：フリーFEMソフトとExcelマクロで形状最適化（7）（5/6 ページ）

[高橋良一／ＲＴデザインラボ 代表，MONOist]

付録（プログラムリスト）

　以下、付録です。

λの繰り返し計算のプログラムリスト

　λの繰り返し計算のプログラムリストは以下の通りです。

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

プログラム1