calculate.bas

三角形闭合差计算程序

Attribute VB_Name = "calculate"
 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