adjust.bas

三角形闭合差计算程序

Attribute VB_Name = "Adjust"
Dim JJ(9) As Long
Dim I As Long
Dim mm As Long
Dim t As Double
Dim Bd As Double
Dim M As Integer
 Sub TwoDim_Adjust()
        Call TakeValue
        g_Sd = g_Ed + g_Dd
        Ka = 3#
        T3 = 0.05
        If (g_Kg = 1) Then
             L0 = 206.2648062
        Else
             L0 = 636.6197724
        End If
        M02(5) = g_Md
        If (g_M11 > 0) Then
               Set arecord = g_d_Base.OpenRecordset("DistanceObservationValueTable", dbOpenTable)
                With arecord
                       If .RecordCount > 0 Then
                           .MoveFirst
                           For I = 1 To .RecordCount
                                E1(I) = .Fields(1)
                                D1(I) = .Fields(2)
                                Sid(I) = .Fields(3)
                                Psk(I) = .Fields(4)
                                If I < .RecordCount Then
                                    .MoveNext
                                End If
                           Next I
                      End If
                End With
                arecord.Close
                For I = 1 To g_M1
                    Call Transe(E1(I), E(I), g_Sd)
                    Call Transe(D1(I), D(I), g_Sd)
                 Next I
        End If
        If (g_M21 = 1) Then
            Set arecord = g_d_Base.OpenRecordset("HorizontalDirectionStationNumberTable", dbOpenTable)
             With arecord
                    If .RecordCount > 0 Then
                        .MoveFirst
                        For I = 1 To .RecordCount
                            Nip(I) = .Fields(1)
                            NI(I) = .Fields(2)
                            If I < .RecordCount Then
                               .MoveNext
                            End If
                        Next I
                   End If
             End With
            arecord.Close
            Set arecord = g_d_Base.OpenRecordset("HorizontalDirectionObservationValueTable", dbOpenTable)
             With arecord
                    If .RecordCount > 0 Then
                        .MoveFirst
                        For I = 1 To .RecordCount
                            G1(I) = .Fields(1)
                            F1(I) = .Fields(2)
                            g_Dir(I) = .Fields(3)
                            If I < .RecordCount Then
                                 .MoveNext
                            End If
                        Next I
                   End If
             End With
            arecord.Close
            For I = 1 To g_M2
                Call Transe(G1(I), G(I), g_Sd)
                Call Transe(F1(I), F(I), g_Sd)
            Next I
            g_Si(1) = 1
            For I = 2 To g_ST
                 g_Si(I) = g_Si(I - 1) + NI(I - 1)
            Next I
            For I = 1 To g_M2
                 Call GW(g_Dir(I), g_Kg)
            Next I
        End If
        N = 2 * g_Sd + g_ST
        If (g_M2 = 0) Then M02(5) = g_Ms + g_Pp
        If (g_Kc = 1) Then
             Set arecord = g_d_Base.OpenRecordset("ApproximateCoordinateTable", dbOpenTable)
                With arecord
                    .MoveFirst
                    For I = 1 To .RecordCount
                          X0(I) = .Fields(1)
                          Y0(I) = .Fields(2)
                          If I < .RecordCount Then
                              .MoveNext
                          End If
                    Next I
                    
                 End With
              arecord.Close
         End If
         If g_Kc = 0 Then
               Set arecord = g_d_Base.OpenRecordset("ApproximateCoordinateTable", dbOpenTable)
                With arecord
                    .MoveFirst
                    For I = 1 To g_Ed
                        X0(I) = .Fields(1)
                        Y0(I) = .Fields(2)
                        If I < g_Ed Then
                             .MoveNext
                        End If
                     Next I
                 End With
                 arecord.Close
                 Set arecord = g_d_Base.OpenRecordset("CalculationRouteTableofApproximateCoordinate", dbOpenTable)
                       With arecord
                              If .RecordCount > 0 Then
                                 .MoveFirst
                                 For I = 1 To .RecordCount
                                     If .Fields(1) <> "" Then AA1(I) = .Fields(1)
                                     If .Fields(2) <> "" Then BB1(I) = .Fields(2)
                                     If .Fields(3) <> "" Then CC1(I) = .Fields(3)
                                     If I < .RecordCount Then
                                        .MoveNext
                                     End If
                                  Next I
                              End If
                           End With
                 arecord.Close
                 For I = 1 To g_Dd
                    Call Transe(AA1(I), AA(I), g_Sd)
                    Call Transe(BB1(I), BB(I), g_Sd)
                    Call Transe(CC1(I), CC(I), g_Sd)
                 Next I
                 If (g_M2 > 0 And g_Net < 4) Then
                     Call CoDir
                  End If
                  If (g_M2 = 0 And g_Net < 4) Then
                     Call CoSid
                  End If
                  If (g_Net = 4 Or g_Net = 5) Then
                      Call CoTra
                  End If
        End If
L:
        For I = 1 To N * (N + 1) \ 2
              C(I) = 0#
        Next I
        For I = 1 To N
              W(I) = 0#
        Next I
        Pll = 0#
        If (g_M1 > 0) Then
            Call ObNorS
        End If
        If (g_M2 > 0) Then
            Call ObNorD
        End If
        Call InvSqr1
        M = g_M1 + g_M2 + g_M4 + g_M5 - N
        If (YU = 0) Then
            Call AdjXYZ
        End If
        If (g_Net = 5) Then
             UW = M02(5)
        End If
        If (YU = 1) Then
            UW = M02(5)
        End If
        Zt = 2 * g_Ed
        Zt1 = Zt
        N = N + Zt1
        mm = Zt1 * N - Zt1 * (Zt1 - 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
        Call AdjXyz1
        If (g_Co > 0) Then
                 Set arecord = g_d_Base.OpenRecordset("RelativeEllipsePointNameTable", dbOpenTable)
                    With arecord
                          If .RecordCount > 0 Then
                             .MoveFirst
                             For I = 1 To .RecordCount
                                 If .Fields(1) <> "" Then RT1(I) = .Fields(1)
                                 If .Fields(2) <> "" Then TT1(I) = .Fields(2)
                                 If I < .RecordCount Then
                                    .MoveNext
                                 End If
                             Next I
                          End If
                     End With
                 arecord.Close
                 For I = 1 To g_Co
                      Call Transe(RT1(I), RT(I), g_Sd)
                      Call Transe(TT1(I), TT(I), g_Sd)
                 Next I
         End If
         Call ELLIPODE
         Call BardSno
End Sub

Sub CoSid()
    Dim Sa As Double
    Dim Sb As Double
    Dim Sc As Double
    Dim Ss As Double
    Dim Ta As Double
    Dim Tb As Double
    Dim R As Double
    Dim Zt1 As Long
    Dim ZT2 As Long
          For I = 1 To g_Dd
              Sc = Sqr((X0(AA(I)) - X0(BB(I))) ^ 2 + (Y0(AA(I)) - Y0(BB(I))) ^ 2)
              Zt1 = 0
              ZT2 = 0
              For j = 1 To g_M1
                    If Zt1 = 1 Then GoTo L
                    If (E(j) = BB(I) And D(j) = CC(I)) Or (D(j) = BB(I) And E(j) = CC(I)) Then
                        Sa = Sid(j)
                        Zt1 = Zt1 + 1
                    End If
L:
                    If ZT2 = 1 Then GoTo LL
                    If (E(j) = AA(I) And D(j) = CC(I)) Or (D(j) = AA(I) And E(j) = CC(I)) Then
                        Sb = Sid(j)
                         ZT2 = ZT2 + 1
                    End If
LL:
                     If Zt1 = 1 And ZT2 = 1 Then GoTo lll
               Next j
lll:
              Ss = (Sa + Sb + Sc) / 2#
              Sa = Ss - Sa
              Sb = Ss - Sb
              Sc = Ss - Sc
              R = Sqr(Sa / Ss * Sb * Sc)
              Ta = Tan(2# * Atn(R / Sa))
              Tb = Tan(2# * Atn(R / Sb))
              Sa = Ta * Tb
              Ss = Ta + Tb
              X0(CC(I)) = (X0(AA(I)) * Ta + X0(BB(I)) * Tb + (Y0(BB(I)) - Y0(AA(I))) * Sa) / Ss
              Y0(CC(I)) = (Y0(AA(I)) * Ta + Y0(BB(I)) * Tb + (X0(AA(I)) - X0(BB(I))) * Sa) / Ss
         Next I
End Sub
       
Sub CoDir()
      Dim ab As Double
      Dim At As Double
      Dim Ba As Double
      Dim Bc As Double
      Dim Ta As Double
      Dim Tb As Double
      Dim Zt As Double
        For I = 1 To g_Dd
               Zt = 0
               For j = 1 To g_M2
                    If G(j) = AA(I) And F(j) = CC(I) Then
                        At = g_Dir(j)
                        Zt = Zt + 1
                    End If
                    If G(j) = AA(I) And F(j) = BB(I) Then
                        ab = g_Dir(j)
                        Zt = Zt + 1
                    End If
                    If G(j) = BB(I) And F(j) = AA(I) Then
                        Ba = g_Dir(j)
                        Zt = Zt + 1
                    End If
                    If G(j) = BB(I) And F(j) = CC(I) Then
                        Bc = g_Dir(j)
                        Zt = Zt + 1
                    End If
                    If (Zt = 4) Then GoTo L
               Next j
L:
              Ta = ab - At
               If Ta < 0# Then Ta = Ta + 2# * g_Pi
               Tb = Bc - Ba
               If Tb < 0# Then Tb = Tb + 2# * g_Pi
               Ta = Tan(Ta)
               Tb = Tan(Tb)
               ab = Ta * Tb
               Ba = Ta + Tb
               X0(CC(I)) = (X0(AA(I)) * Ta + X0(BB(I)) * Tb + (Y0(BB(I)) - Y0(AA(I))) * ab) / Ba
               Y0(CC(I)) = (Y0(AA(I)) * Ta + Y0(BB(I)) * Tb + (X0(AA(I)) - X0(BB(I))) * ab) / Ba
        Next I
End Sub
   
Sub CoTra()
   Dim TD As Double
   Dim Sbc As Double
   Dim Sa As Double
   Dim Sb As Double
   Dim Sc As Double
   Dim Ba As Double
   Dim Bc As Double
   Dim Zt As Long
       For I = 1 To g_Dd
               Sa = X0(BB(I)) - X0(AA(I))
               Sb = Y0(BB(I)) - Y0(AA(I))
               Call ALFA(Sa, Sb, Sc)
               For j = 1 To g_M1
                   If (E(j) = BB(I) And D(j) = CC(I)) Or (D(j) = BB(I) And E(j) = CC(I)) Then
                        Sbc = Sid(j)
                        GoTo L
                   End If
               Next j
L:
              Zt = 0
               For j = 1 To g_M2
                    If G(j) = BB(I) And F(j) = AA(I) Then
                        Ba = g_Dir(j)
                        Zt = Zt + 1
                    End If
                    If G(j) = BB(I) And F(j) = CC(I) Then
                        Bc = g_Dir(j)
                        Zt = Zt + 1
                    End If
                    If (Zt = 2) Then GoTo LL
               Next j
LL:
              TD = Bc - Ba
               If TD < 0.0000000001 Then TD = TD + 2# * g_Pi
               TD = TD + Sc + g_Pi