shuizhunwangpingchavb.txt

这是一款精密水准网平差的VB源代码

Option Base 1
Dim x() As Double
Dim nIs() As Integer, nJs() As Integer
Dim Vtp() As Double
Private Sub Command1_Click()
   g = NBBni
   Dim zwc As Double
   ReDim x(Wz)
   ReDim Vtp(Cd)
   ReDim zwc1(Yz + Wz)
   ReDim V(Cd)
   Dim i As Integer, j As Integer
   For i = 1 To Wz
    For j = 1 To Wz
     x(i) = x(i) + NBB_1(i, j) * W(j)
    Next j
   Next i
   For i = 1 To Wz
   Dh1(i + Yz).Dgc = x(i) / 1000 + JsDh1(i + Yz).Dgc
   Next i
   
   '精度评定
   For i = 1 To Wz
    For j = 1 To Cd
      V(j) = V(j) + Wc(j, i + Yz) * x(i)
    Next j
   Next i
   For i = 1 To Cd
    V(i) = V(i) - L(i)
   Next i
   
   For i = 1 To Cd
    For j = 1 To Cd
      Vtp(j) = Vtp(j) + V(j) * P(i, j)
    Next j
   Next i
   For i = 1 To Cd
    Vtpv = Vtpv + Vtp(i) * V(i)
   Next i
   zwc = Sqr(Vtpv / (Cd - Wz))
   For i = 1 To Wz
     zwc1(i + Yz) = zwc * Sqr(NBB_1(i, i))
   Next i
    Open "result.txt" For Output As #2
     Print #2, "点号"; Space(10); "高程(m)"; Space(7); "中误差(mm)"
       For i = Yz + 1 To Yz + Wz
          Print #2, i, FormatNumber(Dh1(i).Dgc, 4), FormatNumber(zwc1(i), 4)
        Next i
  n = MsgBox("结果已经保存在与平查数据相同的位置", , "提示")
  If n = vbOK Then
        Unload Me
 End If
End Sub

Private Sub dakai_Click()
   If Yz = 0 Or Wz = 0 Or Cd = 0 Then
   g = MsgBox("请输入参数", , "提示")
   Else
   Dim path As String   '读取文件
   ReDim Dh1(Yz + Wz)
   ReDim Hc1(Cd)
   ReDim JsDh1(Yz + Wz)
   Dim i As Integer
   CommonDialog1.ShowOpen
   path = CommonDialog1.FileName
   Open path For Input As #1
   For i = 1 To Yz
     Input #1, a, b
     JsDh1(i).Dp = a: JsDh1(i).Dgc = b
     JsDh1(i).Bs = True
   Next i
   For i = 1 To Cd
     Input #1, a, c, b, e
     Hc1(i).Sp = a: Hc1(i).Ep = c: Hc1(i).Gc = b: Hc1(i).Cj = e
   Next i
   For i = Yz + 1 To Wz + Yz
     JsDh1(i).Bs = False
   Next i
   End If
End Sub

 Private Function jsjsgc()  '计算点的近似高程
 Dim kk As Integer, i As Integer, j As Integer
 kk = 0
 For i = 1 To Cd
   For j = 1 To Cd
    If JsDh1(Hc1(j).Sp).Bs = True And JsDh1(Hc1(j).Ep).Bs = False Then
      JsDh1(Hc1(j).Ep).Dgc = JsDh1(Hc1(j).Sp).Dgc + Hc1(j).Gc
      JsDh1(Hc1(j).Ep).Bs = True
      kk = kk + 1
    ElseIf JsDh1(Hc1(j).Sp).Bs = False And JsDh1(Hc1(j).Ep).Bs = True Then
      JsDh1(Hc1(j).Sp).Dgc = JsDh1(Hc1(j).Ep).Dgc - Hc1(j).Gc
      JsDh1(Hc1(j).Sp).Bs = True
      kk = kk + 1
    End If
   Next j
   If kk >= Wz Then Exit For
 Next i
 End Function
 Private Function jsxsjz() '计算误差方程的系数矩阵
   Dim i As Integer
   ReDim Wc(Cd, Wz + Yz)
   ReDim L(Cd)
   a = jsjsgc
   For i = 1 To Cd
    If Hc1(i).Sp > Yz Then
     Wc(i, Hc1(i).Sp) = -1
    End If
    If Hc1(i).Ep > Yz Then
     Wc(i, Hc1(i).Ep) = 1
    End If
    L(i) = (Hc1(i).Gc - JsDh1(Hc1(i).Ep).Dgc + JsDh1(Hc1(i).Sp).Dgc) * 1000
   Next i
 End Function
 Private Function Qz() '计算权阵 以10km的观测高差为单位权观测
   ReDim P(Cd, Cd)
   For i = 1 To Cd
    P(i, i) = 10 / Hc1(i).Cj
   Next i
 End Function
 Private Function NBBandW()     '计算NBB及W
   h = jsxsjz()
   z = Qz()
   ReDim NBB(Wz, Wz)
   ReDim Nbb1(Wz, Cd)
   ReDim W(Cd)
   Dim ii As Integer, j As Integer, i As Integer
        For i = 1 To Wz
         For j = 1 To Cd
          For ii = 1 To Cd
           Nbb1(i, j) = Nbb1(i, j) + Wc(ii, i + Yz) * P(ii, j)
          Next ii
         Next j
        Next i
        
        For i = 1 To Wz
         For j = 1 To Wz
          For ii = 1 To Cd
           NBB(i, j) = NBB(i, j) + Nbb1(i, ii) * Wc(ii, j + Yz)
           Next ii
         Next j
        Next i
        For i = 1 To Wz
         For j = 1 To Wz
           m = NBB(i, j)
         Next j
        Next i
        For i = 1 To Wz
          For j = 1 To Cd
           W(i) = W(i) + Nbb1(i, j) * L(j)
          Next j
        Next i
 End Function
 Private Function NBBni() '求逆阵
   ReDim nIs(Wz)
   ReDim nJs(Wz)
   ReDim NBB_1(Wz, Wz)
   Dim i As Integer, j As Integer, k As Integer
   Dim D As Double, pii As Double
  g = NBBandW
  ' 全选主元，消元
  For k = 1 To Wz
    D = 0#
    For i = k To Wz
        For j = k To Wz
            pii = Abs(NBB(i, j))
            If (pii > D) Then
                D = pii
                nIs(k) = i
                nJs(k) = j
            End If
        Next j
    Next i
    
    ' 求解失败
   'If (D + 1# = 1#) Then
       ' NBBni = False
       ' Exit Function
   ' End If

    If (nIs(k) <> k) Then
        For j = 1 To Wz
            pii = NBB(k, j)
            NBB(k, j) = NBB(nIs(k), j)
            NBB(nIs(k), j) = pii
        Next j
    End If

    If (nJs(k) <> k) Then
        For i = 1 To Wz
            pii = NBB(i, k)
            NBB(i, k) = NBB(i, nJs(k))
            NBB(i, nJs(k)) = pii
        Next i
    End If

    NBB(k, k) = 1# / NBB(k, k)
    For j = 1 To Wz
        If (j <> k) Then NBB(k, j) = NBB(k, j) * NBB(k, k)
    Next j
    For i = 1 To Wz
        If (i <> k) Then
            For j = 1 To Wz
                If (j <> k) Then NBB(i, j) = NBB(i, j) - NBB(i, k) * NBB(k, j)
            Next j
        End If
    Next i
    For i = 1 To Wz
        If (i <> k) Then NBB(i, k) = -NBB(i, k) * NBB(k, k)
    Next i
 Next k

' 调整恢复行列次序
For k = Wz To 1 Step -1
    If (nJs(k) <> k) Then
      For j = 1 To Wz
          pii = NBB(k, j)
          NBB(k, j) = NBB(nJs(k), j)
          NBB(nJs(k), j) = pii
      Next j
    End If
    If (nIs(k) <> k) Then
      For i = 1 To Wz
          pii = NBB(i, k)
          NBB(i, k) = NBB(i, nIs(k))
          NBB(i, nIs(k)) = pii
      Next i
    End If
Next k
    For i = 1 To Wz
     For j = 1 To Wz
      NBB_1(i, j) = NBB(i, j)
     Next j
    Next i
End Function


Private Sub shuru_Click()
  Form2.Show
End Sub