11-m.frm

VB语言编写,圆柱形螺旋弹簧质量最小的优化设计,使用复合形法优化

VERSION 5.00
Begin VB.Form Form1 
   Caption         =   "圆柱形螺旋弹簧的优化设计"
   ClientHeight    =   10470
   ClientLeft      =   60
   ClientTop       =   465
   ClientWidth     =   9885
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   7.5
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   10470
   ScaleWidth      =   9885
   StartUpPosition =   3  '窗口缺省
   Begin VB.CommandButton Command1 
      Caption         =   "Command1"
      Height          =   495
      Left            =   7680
      TabIndex        =   0
      Top             =   8400
      Width           =   1215
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Function f(x1 As Single, x2 As Single, x3 As Single) As Single                         '定义目标函数
f = 0.0000192457 * (x2 + 2) * x1 * x1 * x3
End Function

Private Function gx(x1 As Single, x2 As Single, x3 As Single) As Boolean                        '定义约束函数
   gx = 163 * x1 ^ (-2.86) * x3 ^ (0.86) - 350 <= 0 And 10 - 0.004 * (1 / x1) ^ 4 * x2 * x3 ^ 3 <= 0 _
        And (x2 + 1.5) * x1 + 0.0044 * x1 ^ (-4) * x2 * x3 ^ 3 - 3.7 * x3 <= 0 _
        And 375 - 356000 * x1 * 1 / x2 * x3 ^ (-2) <= 0 And 4 - 1 / x1 * x3 <= 0 _
        And x1 >= 1 And x1 <= 4 And x2 >= 4.5 And x2 <= 50 And x3 >= 10 And x3 <= 30
End Function
Private Sub Command1_Click()
  Dim i As Integer, j As Integer, n As Integer, q As Integer, w As Integer
Dim x(1 To 6, 1 To 3) As Single                                                               'x为顶点
Dim y(1 To 6) As Single, z(1 To 6) As Single                                                  'y存放目标函数值
Dim xh(1 To 6, 1 To 3), xg(1 To 6, 1 To 3), xl(1 To 6, 1 To 3) As Single                     'xh劣点，xg次劣点,xl最好点
Dim h, g, l As Integer
Dim xf(1 To 1, 1 To 3) As Single, xc(1 To 1, 1 To 3) As Single, x0(1 To 1, 1 To 3) As Single, xr(1 To 1, 1 To 3) As Single 'xc所有点中心点，x0除劣点中心点，xr反射点
Dim a(1 To 3) As Single, b(1 To 3) As Single
Dim e, a0 As Single, t As Single, sum, sum1, sum2, delta As Single, yc, yr As Single
Dim m, P, k As Single, x1, x2, x3 As Single                                                     'e收敛精度

e = 0.000001

a(1) = 1: a(2) = 4.5: a(3) = 10
b(1) = 4: b(2) = 50: b(3) = 30


P:

                                                                                   '随机生成一个初始点
Do
x(1, 1) = a(1) + Rnd * (b(1) - a(1))
x(1, 2) = a(2) + Rnd * (b(2) - a(2))
x(1, 3) = a(3) + Rnd * (b(3) - a(3))
   If gx(x(1, 1), x(1, 2), x(1, 3)) Then
        Exit Do
   End If
Loop
 'Form1.Print x(1, 1), x(1, 2), x(1, 3)




                                                                         '随机生成初始点


For i = 2 To 6
x(i, 1) = a(1) + Rnd * (b(1) - a(1))
x(i, 2) = a(2) + Rnd * (b(2) - a(2))
x(i, 3) = a(3) + Rnd * (b(3) - a(3))
Next i

q = 1
For i = 2 To 6
   If gx(x(i, 1), x(i, 2), x(i, 3)) Then
        q = q + 1
        m = x(i, 1): x(i, 1) = x(q, 1): x(q, 1) = m
        P = x(i, 2): x(i, 2) = x(q, 2): x(q, 2) = P
        k = x(i, 3): x(i, 3) = x(q, 3): x(q, 3) = k
        'Form1.Print x(i, 1), x(i, 2), x(i, 3)
   End If
Next i

Do
    x1 = 0: x2 = 0: x3 = 0
  For i = 1 To q
    x1 = x1 + x(i, 1)
    x2 = x2 + x(i, 2)
    x3 = x3 + x(i, 3)
  Next i

    xf(1, 1) = x1 / q
    xf(1, 2) = x2 / q
    xf(1, 3) = x3 / q
  
  
  If gx(xf(1, 1), xf(1, 2), xf(1, 3)) Then                                         '靠拢
          q = q + 1
        Do
         x(q, 1) = xf(1, 1) + 0.5 * (x(q, 1) - xf(1, 1))
         x(q, 2) = xf(1, 2) + 0.5 * (x(q, 2) - xf(1, 2))
         x(q, 3) = xf(1, 3) + 0.5 * (x(q, 3) - xf(1, 3))
           
        Loop Until gx(x(q, 1), x(q, 2), x(q, 3))
    Else
        For j = 1 To 3                                                             '收缩区间
        If x(1, j) > xf(1, j) Then
           a(j) = xf(1, j)
           b(j) = x(1, j)
           Else
           a(j) = x(1, j)
           b(j) = xf(1, j)
         End If
         Next j
        GoTo P
         
End If
  
Loop Until q >= 6


Form1.Print "#########################################################################"


For i = 1 To 6
   
        Form1.Print i, x(i, 1), x(i, 2), x(i, 3)
   
Next i









Form1.Print "#########################################################################"




Do
w = w + 1
For j = 1 To 3                                                                         '6个顶点中心点
sum = 0
    For i = 1 To 6
        sum = sum + x(i, j)
    Next i
 xc(1, j) = sum / 6
  'Form1.Print xc(1, j)
Next j
  yc = f(xc(1, 1), xc(1, 2), xc(1, 3))                                                 '中心点函数值
  
For i = 1 To 6                                                                         '各顶点函数值
   y(i) = f(x(i, 1), x(i, 2), x(i, 3))
   z(i) = f(x(i, 1), x(i, 2), x(i, 3))
  ' Form1.Print y(i)
Next i
 
For j = 6 To 2 Step -1                                                                 '各顶点函数值小 -〉大排序
    For i = 1 To j - 1
        If z(i) > z(i + 1) Then
          t = z(i)
          z(i) = z(i + 1)
          z(i + 1) = t
        End If
    Next i
Next j
    h = 0: g = 0: l = 0
For i = 1 To 6
    If y(i) = z(6) Then h = i                                                        'h最劣点，g次劣点,l最好点 序号
    If y(i) = z(5) Then g = i
    If y(i) = z(1) Then l = i
Next i
    
 sum1 = 0
For i = 1 To 6
sum1 = sum1 + (y(i) - yc) ^ 2                                                        'delta 判断准则
Next i
delta = (sum1 / 6) ^ 0.5
If delta <= e Then Exit Do




For j = 1 To 3                                                                        '除最劣点中心点x0
sum1 = 0
    For i = 1 To 6
      sum1 = sum1 + x(i, j)
    Next i
    sum1 = sum1 - x(h, j)
    x0(1, j) = sum1 / 5
   'Form1.Print x0(1, j)
Next j

If Not gx(x0(1, 1), x0(1, 2), x0(1, 3)) Then
        For i = 1 To 3
           If x(l, i) <= x0(l, i) Then
           a(i) = x(l, i)
           b(i) = x0(1, i)
           Else
           a(i) = x0(l, i)
           b(i) = x(1, i)
           End If
        Next i
        GoTo P                                                                          '判断x0是否可行，否则退回p处
        
End If




Do
a0 = 1.3
k:

For i = 1 To 3                                                                          '反射点
   xr(1, i) = x0(1, i) + a0 * (x0(1, i) - x(h, i))
   'Form1.Print xr(1, i)
Next i
If Not gx(xr(1, 1), xr(1, 2), xr(1, 3)) Then
    a0 = a0 / 2
    GoTo k
Else
     If f(xr(1, 1), xr(1, 2), xr(1, 3)) < f(x(h, 1), x(h, 2), x(h, 3)) Then
        Exit Do
     Else
         If Not (a0 <= 0.00001) Then
           a0 = a0 / 2
           
         Else
           For i = 1 To 3
               x(h, i) = x(g, i)                                                           '次劣点代最劣点
           Next i
         End If
    End If
End If

Loop



For i = 1 To 3
    x(h, i) = xr(1, i)                                                                      '反射点代最劣点
Next i

    
Loop



If gx(1.596886, 11.79351, 11.30099) Then
 
Form1.Print "---------------------+++++++++++++++++++++++++++++----------", w
End If





For i = 1 To 6
   
        Form1.Print i, x(i, 1), x(i, 2), x(i, 3)
   
Next i

Form1.Print z(1)





End Sub