adjust.bas

三角形闭合差计算程序

Attribute VB_Name = "Adjust"
 Dim c(g_MaxPotNum * (g_MaxPotNum + 1) / 2) As Double
 Dim w(g_MaxPotNum) As Double
 Dim b4(g_MaxPotNum, 2) As Integer
 Dim a4(g_MaxPotNum, 2) As Double
 Dim l4(g_MaxPotNum) As Double
 Dim v4(g_MaxPotNum) As Double
 Dim ph(g_MaxPotNum) As Double
 Dim pdh(g_MaxPotNum) As Double
  Dim Mz(g_MaxPotNum) As Double
  Dim T2(g_MaxPotNum) As Double
  Dim T3(g_MaxPotNum) As Double
  Dim Wa(g_MaxPotNum) As Double
 Dim arecord As Recordset
 Dim uw As Double
 Dim mh As Double
 Dim red As Integer
 Dim pvv As Double
 Dim pll As Double
 Dim i As Integer
 Dim ka As Double
 Dim J As Integer
 Dim k As Integer
 Dim di As Integer
 Dim dj As Integer
 Dim dk As Integer
 Dim llll As Integer
 Dim n As Integer
 Dim ed As Integer
 Dim dd As Integer
 Dim np As Integer
 Dim m5 As Integer
 Dim zt As Integer
 Public Sub Lev_Adjust()
    ed = g_Ed
    dd = g_Dd
    g_PotNum = g_Ed + g_Dd
    np = 1
    n = ed + dd
    m5 = g_ObsNum
    ka = 3#
    mh = g_Mh
    pvv = 0#
    For i = 1 To m5
      pdh(i) = g_StaNum(i)
    Next i
    For i = 1 To n * (n + 1) / 2
       c(i) = 0#
    Next i
    For i = 1 To n
        w(i) = 0#
    Next i
    Call InvsObs
    Call COHZ
    Call obnorh
    zt = ed
    For i = 1 To n - zt
         w(i) = w(zt + i)
    Next i
    For i = 1 To (n - zt) * (n - zt + 1) / 2
        c(i) = c(zt * n - (zt - 1) * zt / 2 + i)
    Next
    n = n - zt
    Call INVSQR1
    zt = ed
    red = m5 - n
    If g_Net = 0 Then
      uw = mh
    End If
    n = n + zt
    MM = zt * n - zt * (zt - 1) / 2
    For i = n * (n + 1) / 2 To MM + 1 Step -1
      c(i) = c(i - MM)
    Next i
    For i = 1 To MM
      c(i) = 0#
    Next i
    For i = n To ed + 1 Step -1
      w(i) = w(i - ed)
    Next i
    For i = 1 To ed
      w(i) = 0#
    Next i
    Call ADJXYZ
    Call BARDSNO
    
End Sub

Sub InvsObs()
    Dim Inf As Integer
    Dim zt As Integer
    Dim strTemp As String
    Inf = 0
    zt = 0
    For i = 1 To g_ObsNum
      For J = 1 To g_PotNum
        If (Trim(g_StaPotName(i)) = Trim(g_PotName(J))) Then
           g_H1(i) = J
           zt = zt + 1
        End If
        If (Trim(g_EndPotName(i)) = Trim(g_PotName(J))) Then
           g_H2(i) = J
           zt = zt + 1
        End If
      Next J
      If (zt = 2) Then
        zt = 0
      Else
        strTemp = "第" & i & "个观测值的起点名：" & g_StaPotName(i) & "或终点名：" & g_EndPotName(i) & "输入有误！"
        MsgBox strTemp, , "提示信息！"
        Inf = 1
        Exit Sub
      End If
    Next i
    If (g_Ih = 1) Then
       For i = 1 To g_ObsNum
        g_H(i) = g_H(i) / 2#
       Next i
    End If
    
End Sub
Sub COHZ()
   zt = 0
   For i = 1 To dd
       g_Z0(ed + i) = 20000#
   Next i
LL:
   For k = 1 To m5
     i = g_H1(k)
     J = g_H2(k)
    If (g_Z0(i) < 10000# And g_Z0(J) > 10000#) Then
        g_Z0(J) = g_Z0(i) + g_H(k)
        zt = zt + 1
    End If
    If (g_Z0(i) > 10000# And g_Z0(J) < 10000#) Then
        g_Z0(i) = g_Z0(J) - g_H(k)
        zt = zt + 1
    End If
  Next k
  If zt < dd Then GoTo LL
 End Sub

Sub obnorh()
    Dim jj(2) As Integer
    Dim z(g_MaxPotNum) As Double
    Dim t As Double
    zt = 2
    For i = 1 To m5
      z(n + 1) = (g_Z0(g_H2(i)) - g_Z0(g_H1(i)) - g_H(i)) * 1000#
      l4(i) = z(n + 1)
      jj(1) = g_H1(i)
      jj(2) = g_H2(i)
      z(jj(1)) = -1
      z(jj(2)) = 1
      If (g_H1(i) > g_H2(i)) Then
        k = jj(1)
        jj(1) = jj(2)
        jj(2) = k
      End If
      For J = 1 To zt
        a4(i, J) = z(jj(J))
        b4(i, J) = jj(J)
      Next J
      ph(i) = 1 / pdh(i)
      For J = 1 To zt
        di = (jj(J) - 1) * (n - jj(J) / 2#)
        For k = J To zt
          t = ph(i) * z(jj(J)) * z(jj(k))
          c(di + jj(k)) = c(di + jj(k)) + t
        Next k
        w(jj(J)) = w(jj(J)) + ph(i) * z(jj(J)) * z(n + 1)
      Next J
      pll = pll + ph(i) * z(n + 1) ^ 2
    Next i
End Sub


Sub INVSQR1()
    Dim ss As Double
    For i = 1 To n
      di = (i - 1) * (n - i / 2#)
      For J = i To n
        ss = c(di + J)
        For k = 1 To i - 1
          dk = (k - 1) * (n - k / 2#)
          ss = ss - c(dk + i) * c(dk + J) / c(dk + k)
        Next k
        If (J = i) Then
          c(di + J) = 1 / ss
        Else
          c(di + J) = ss * c(di + i)
        End If
      Next J
    Next i
    For i = 1 To n - 1
      di = (i - 1) * (n - i / 2#)
      For J = i + 1 To n
        ss = -c(di + J)
        For k = i + 1 To J - 1
          dk = (k - 1) * (n - k / 2#)
          ss = ss - c(di + k) * c(dk + J)
        Next k
        c(di + J) = ss
      Next J
    Next i
    For i = 1 To n - 1
      di = (i - 1) * (n - i / 2#)
      For J = i To n
        dj = (J - 1) * (n - J / 2#)
        If (i = J) Then
          ss = c(di + J)
        Else
         ss = c(di + J) * c(dj + J)
        End If
        For k = J + 1 To n
          dk = (k - 1) * (n - k / 2#)
          ss = ss + c(di + k) * c(dj + k) * c(dk + k)
        Next k
        c(di + J) = ss
      Next J
    Next i
End Sub


Sub ADJXYZ()

       Dim llll As Integer
       Dim i As Integer
       zt = 2
       For i = 1 To n
          g_DZ(i) = 0#
          di = (i - 1) * (n - i / 2#)
          For J = 1 To n
            dj = (J - 1) * (n - J / 2#)
            If (J < i) Then
              g_DZ(i) = g_DZ(i) - c(dj + i) * w(J)
            Else
              g_DZ(i) = g_DZ(i) - c(di + J) * w(J)
            End If
          Next J
        Next i
        For i = 1 To m5
          v4(i) = l4(i)
          For J = 1 To zt
            v4(i) = v4(i) + a4(i, J) * g_DZ(b4(i, J))
          Next J
          pvv = pvv + v4(i) ^ 2 * ph(i)
       Next i
       If g_Net = 1 Then
          If red > 0 Then
             uw = Sqr(Abs(pvv) / red)
          Else
             uw = mh
          End If
        End If
        For i = 1 To g_PotNum
            J = (i - 1) * (n - i / 2#)
            Mz(i) = 0#
            If (i > ed) Then
              MZ1 = Sqr(Abs(c(i + J)))
              Mz(i) = uw * MZ1
            End If
            g_Z(i) = g_Z0(i) + g_DZ(i) / 1000#
        Next i
        Set arecord = g_d_Base.OpenRecordset("高程成果表", dbOpenTable)
        With arecord
            ic = .RecordCount
            If .RecordCount > 0 Then
              .MoveFirst
              For i = 1 To ic
                   .Delete
                   If i < ic Then
                      .MoveFirst
                  End If
              Next i
            End If
            For i = 1 To g_PotNum
                .AddNew
                .Fields(0) = i
                .Fields(1) = g_PotName(i)
                .Fields(2) = Format(g_Z(i), "#0.0000")
                .Fields(3) = Format(Mz(i), "#0.00")
                .Update
              Next i
            .Close
        End With
        Set arecord = g_d_Base.OpenRecordset("基本信息表", dbOpenTable)
        With arecord
                .Edit
                .Fields(15) = uw
                .Update
                .Close
        End With
        End Sub


        Sub BARDSNO()
        Dim z(g_MaxPotNum) As Double
        Dim t As Double
        zt = 2
        For i = 1 To m5
          z(i) = 0#
          For J = 1 To zt
            t = 0#
            dj = (b4(i, J) - 1) * (n - b4(i, J) / 2#)
            For k = 1 To zt
              dk = (b4(i, k) - 1) * (n - b4(i, k) / 2#)
              If (b4(i, k) >= b4(i, J)) Then
                t = t + a4(i, k) * c(dj + b4(i, k))
              Else
                t = t + a4(i, k) * c(dk + b4(i, J))
              End If
            Next k
            z(i) = z(i) + t * a4(i, J)
          Next J
        Next i
        For i = 1 To m5
          pdh(i) = ph(i) * (1# / ph(i) - z(i))
          pq = pdh(i) + pq
        Next i
        For i = 1 To m5
           If (pdh(i) < 0.00000001) Then
            Wa(i) = 0
          Else
            t = Sqr(pdh(i) / ph(i)) * uw
            Wa(i) = v4(i) / t
          End If
          T2(i) = g_H(i) + v4(i) / 1000#
          T3(i) = uw * Sqr(z(i))
         Next i
        Set arecord = g_d_Base.OpenRecordset("观测成果表", dbOpenTable)
        With arecord
            ic = .RecordCount
            If .RecordCount > 0 Then
              .MoveFirst
              For i = 1 To ic
                   .Delete
                   If i < ic Then
                      .MoveFirst
                  End If
              Next i
            End If
            For i = 1 To g_ObsNum
                .AddNew
                .Fields(0) = i
                .Fields(1) = g_StaPotName(i)
                .Fields(2) = g_EndPotName(i)
                .Fields(3) = Format(g_H(i), "#0.0000")
                .Fields(4) = Format(v4(i), "#0.00")
                .Fields(5) = Format(T2(i), "#0.0000")
                .Fields(6) = Format(T3(i), "#0.00")
                .Fields(7) = Format(pdh(i), "#0.00")
                .Fields(8) = Format(Wa(i), "#0.00")
                .Update
               Next i
            .Close
        End With
End Sub