adjust.bas

本程序是计算三角网闭合差的程序,包括建表,数据库数据输入等完整过程

Attribute VB_Name = "Caculation"
Dim Zt As Integer
Dim Zt1 As Integer
Dim a As Integer
Dim I As Integer
Dim J As Integer
Dim K As Integer
Dim L As Integer
Dim Ic As Integer
Dim Aij As Integer
Dim Aik As Double
Dim Aji As Double
Dim Ajk As Double
Dim Aki As Double
Dim Akj As Double
Dim Aijk As Double
Dim Ajik As Double
Dim Akij As Double
Dim arecord As Recordset
Dim t As Double
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 uw As Double
Dim mh As Double
Dim red As Integer
Dim pvv As Double
Dim pll As Double
Dim ka As Double
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
 
Sub CaculateTrangleClosureError()
Call TakeValue
For a = 1 To g_ObsNum
    Call GW(g_Dir(a))
Next a
Zt = 0
For I = 1 To g_PotNum - 2
    For J = I + 1 To g_PotNum - 1
        For K = J + 1 To g_PotNum
        Zt1 = 0
            For L = 1 To g_ObsNum
                If g_PotName(I) = g_StaPotName(L) And g_PotName(J) = g_EndPotName(L) Then
                Zt1 = Zt1 + 1
                Aij = g_Dir(L)
                End If
                If g_PotName(I) = g_StaPotName(L) And g_PotName(K) = g_EndPotName(L) Then
                Zt1 = Zt1 + 1
                Aik = g_Dir(L)
                End If
                If g_PotName(J) = g_StaPotName(L) And g_PotName(I) = g_EndPotName(L) Then
                Zt1 = Zt1 + 1
                Aji = g_Dir(L)
                End If
                If g_PotName(J) = g_StaPotName(L) And g_PotName(K) = g_EndPotName(L) Then
                Zt1 = Zt1 + 1
                Ajk = g_Dir(L)
                End If
                If g_PotName(K) = g_StaPotName(L) And g_PotName(I) = g_EndPotName(L) Then
                Zt1 = Zt1 + 1
                Aki = g_Dir(L)
                End If
                If g_PotName(K) = g_StaPotName(L) And g_PotName(J) = g_EndPotName(L) Then
                Zt1 = Zt1 + 1
                Akj = g_Dir(L)
                End If
            Next L
            If Zt1 = 6 Then
                 Zt = Zt + 1
                 g_PotName1(Zt) = g_PotName(I)
                 g_PotName2(Zt) = g_PotName(J)
                 g_PotName3(Zt) = g_PotName(K)
                 Aijk = Aik - Aij
                 If Aijk < 0.000000000000001 Then Aijk = Abs(Aijk)
                 If Aijk > g_Pi Then Aijk = 2 * g_Pi - Aijk
                 Ajik = Ajk - Aji
                 If Ajik < 0.000000000000001 Then Ajik = Abs(Ajik)
                 If Ajik > g_Pi Then Ajik = 2 * g_Pi - Ajik
                 Akij = Akj - Aki
                 If Akij < 0.000000000000001 Then Akij = Abs(Akij)
                 If Akij > g_Pi Then Akij = 2 * g_Pi - Akij
                 g_W(Zt) = (Aijk + Ajik + Akij - g_Pi) * g_P
                 End If
                 
        Next K
    Next J
Next I
t = 0
For I = 1 To Zt
    t = t + g_W(I) * g_W(I)
 
Next I
g_MD = Sqr(t / Zt / 6)

    
 Set arecord = g_d_Base.OpenRecordset("基本信息表", dbOpenTable)
    With arecord
      
        .MoveFirst
        .Edit
        .Fields(10) = g_MD
        .Update
        .Close
        
      
    End With
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 Zt
                .AddNew
                .Fields(0) = I
                .Fields(1) = g_PotName1(I)
                .Fields(2) = g_PotName2(I)
                .Fields(3) = g_PotName3(I)
                .Fields(4) = g_W(I)
                .Update
               Next I
            .Close
        End With
End Sub
 
 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