www.pudn.com > DataCollectionSystem.rar > modFangan2.bas, change:2003-05-22,size:7742b


Attribute VB_Name = "fangantwo" 
Option Explicit 
Public qxx(5) As Double, qxy(5) As Double, qxz(5) As Double   '气象改正基准点坐标值 
Public startpt() As Integer 
Public endpt() As Integer 
Public szhenzhi(3) As Double  '首次观测的基准点中最长边即边长的真值 
Public qxjzdh(3) As Double    '气象基准点高差真值 
Public szhenzhi1(3) As Double '后期观测的基准点间的边长 
Public qxjzdh1(3) As Double   '后期观测气象基准点高差值 
Public deltad As Double, c As Double     '距离改正系数,高差改正系数 
'Public xx3(5000) As Double, yy3(5000) As Double, zz3(5000) As Double    '气象改正后的值 
Public cx As Double, cy As Double, cz As Double     'cx1,cy1,cz1测站点坐标 
Public ip As Double, lp As Double   '仪器高,目标高 
 
Public ljz As Double     '基准点限差 
Public lbx As Double    '变形点限差 
Public canshu(9) As Double '七参数 
Public dianshu As Integer  '点数 
 
Public h(5000) As Double   '水平角 
Public V0(5000) As Double  '竖直角 
Public Sj(5000) As Double  '斜距 
 
Public dianhaonew(5000) As String 
Public xx2(1000) As Double 
Public yy2(1000) As Double 
Public zz2(1000) As Double 
 
'Public xxx2(5000) As Double '以后的观测值在首次观测值中的坐标 
'Public yyy2(5000) As Double 
'Public zzz2(5000) As Double '读入此次观测的坐标值 
 
Public dianhao2() As Integer  '基准点点号 
Public dianshu1 As Integer 
 
 
Public xx(5000) As Double '基准点的两套坐标 
Public yy(5000) As Double 
Public zz(5000) As Double 
Public xx1(5000) As Double 
Public yy1(5000) As Double 
Public zz1(5000) As Double 
 
 
Public dianhao4(1000) As Integer '产生变形的点号 
Public max As Double 
Public jj As Integer 
Public kk As Integer  '被删除的点数 
Public xresult(100)  As Double '方案二传出的坐标结果 
Public yresult(100)  As Double 
Public zresult(100)  As Double 
Public deltah As Double     '方位角的改正 
Public kx As Double, ky As Double, kz As Double '比例系数 
 
 
 
 
'选择基准点间最长边 
'所选用的基准点个数 
'选择基准点间最长边 
'所选用的基准点个数 
Public Sub SelectLongDist(xxx() As Double, yyy() As Double, zzz() As Double, m1) 
'startpt(),endpt()选择的用来求气象改正的比例系数的基准点 
'此函数中startpt,endpt为公共变量 
Dim temp() As Double 
Dim j As Integer 
Dim i As Integer 
ReDim temp(m1 + 1, m1 + 1) 
ReDim startpt(m1 + 1), endpt(m1 + 1) 
Dim hh1 As Integer 
Dim k As Integer 
Dim maxl As Double 
maxl = 0 
 
For i = 1 To m1 
    For j = i To m1 
        temp(i, j) = Sqr((xxx(i) - xxx(j)) ^ 2 + (yyy(i) - yyy(j)) ^ 2 + (zzz(i) - zzz(j)) ^ 2) 
    Next j 
Next i 
 
For k = 1 To 3 
    For i = 1 To m1 
        For j = i To m1 
            If k = 2 Or k = 3 Then 
                If i = startpt(1) Then 
                    If j = endpt(1) Then 
                        GoTo tang 
                    End If 
                End If 
            End If 
            If k = 3 Then 
                If i = startpt(2) Then 
                    If j = endpt(2) Then 
                        GoTo tang 
                    End If 
                End If 
            End If 
            If temp(i, j) > maxl Then 
                   ' If Abs(zzz(i) - zzz(j)) > 1 Then 'can be moved 
                        maxl = temp(i, j) 
                        startpt(k) = i: endpt(k) = j 
                   ' End If                  'can be moved 
            End If 
tang: 
        Next j 
    Next i 
 
    maxl = 0 
Next k 
End Sub 
'某一变形点与基准点边长最短的三条 
Public Sub RelevantFixPtMin(xxx() As Double, yyy() As Double, zzz() As Double, x As Double, y As Double, z As Double, m1, ByRef min1() As Integer) 
Dim i As Integer 
Dim j As Integer 
Dim temps As Double 
Dim mintemp As Double 
Dim k2 As Integer 
 
mintemp = 10000 
 
For i = 1 To 3 
    min1(i) = 0 
Next i 
 
For j = 1 To 3 
    For i = 1 To m1 
        If ((i <> min1(1)) And (i <> min1(2)) And (i <> min1(3))) Then 
            temps = Sqr((xxx(i) - x) ^ 2 + (yyy(i) - y) ^ 2 + (zzz(i) - z) ^ 2) 
            If temps < mintemp Then 
                mintemp = temps 
                k2 = i 
            End If 
        End If 
    Next i 
    mintemp = 100000 
    min1(j) = k2 
Next j 
 
End Sub 
 
 
Public Sub fangan2a(x() As Double, y() As Double, z() As Double, x1() As Double, y1() As Double, z1() As Double) 
'xresult,yresult,zresult为传出的改正后的坐标,为全局函数 
 
Dim xfix(200) As Double 
Dim yfix(200) As Double 
Dim zfix(200) As Double 
Dim min2(3) As Integer 
Dim ConnectFix(100, 100) As Double 
Dim i As Integer, j As Integer 
 
Dim kxtemp As Double, kytemp As Double, kztemp As Double 
Dim xresulttemp As Double, yresulttemp As Double, zresulttemp As Double 
 
For i = 1 To M 
    xfix(i) = x(i) 
    yfix(i) = y(i) 
    zfix(i) = z(i) 
Next i 
 
'求边长最长的三条边的基准点端点号 
Call SelectLongDist(xfix(), yfix(), zfix(), M) 
 
'求和变形点之间距离最小的基准点的点号 
For i = M + 1 To N + M 
    min2(1) = 0: min2(2) = 0: min2(3) = 0 
    Call RelevantFixPtMin(xfix(), yfix(), zfix(), x(i), y(i), z(i), M, min2()) 
    For j = 1 To 3 
        ConnectFix(i, j) = min2(j) 
    Next j 
Next i 
 
'求kx,ky,kz 
For i = 1 To 3 
    kxtemp = kxtemp + (x(startpt(i)) - x(endpt(i))) / (x1(startpt(i)) - x1(endpt(i))) 
    kytemp = kytemp + (y(startpt(i)) - y(endpt(i))) / (y1(startpt(i)) - y1(endpt(i))) 
    kztemp = kztemp + (z(startpt(i)) - z(endpt(i))) / (z1(startpt(i)) - z1(endpt(i))) 
Next i 
kx = kxtemp / 3 
ky = kytemp / 3 
kz = kztemp / 3 
 
'求变形点的坐标 
For i = M + 1 To N + M 
    xresulttemp = 0 
    yresulttemp = 0 
    zresulttemp = 0 
    For j = 1 To 3 
        xresulttemp = xresulttemp + x1(ConnectFix(i, j)) + (x1(i) - x1(ConnectFix(i, j))) * kx 
        yresulttemp = yresulttemp + y1(ConnectFix(i, j)) + (y1(i) - y1(ConnectFix(i, j))) * ky 
        zresulttemp = zresulttemp + z1(ConnectFix(i, j)) + (z1(i) - z1(ConnectFix(i, j))) * kz 
    Next j 
    xresult(i) = xresulttemp / 3 
    yresult(i) = yresulttemp / 3 
    zresult(i) = zresulttemp / 3 
Next i 
 
 
 
 
 
'判断基准点是否被用过 
Dim NotUsedPt(50) As Integer, UsedPt(50) As Integer 
Dim k As Integer, f As Integer, f1 As Integer 
Dim flag As Boolean 
 
'NotUsedPt()求没有用过的基准点 
For i = 1 To M 
    flag = True 
    For j = M + 1 To M + N 
        For k = 1 To 3 
            If i = ConnectFix(j, k) Then 
                flag = False 
                GoTo tang 
            End If 
        Next k 
    Next j 
tang: 
    If flag = True Then 
       f = f + 1 
       NotUsedPt(f) = i 
    End If 
Next i 
'UsedPt()求用过的基准点 
For i = 1 To M 
    flag = True 
    For j = 1 To f 
        If i = NotUsedPt(j) Then 
            flag = False 
            Exit For 
        End If 
    Next j 
    If flag = True Then 
        f1 = f1 + 1 
        UsedPt(f1) = i 
    End If 
Next i 
     
     
'没有用过的基准点的坐标 
For i = 1 To f 
    Call RelevantFixPtMin(xfix(), yfix(), zfix(), x(NotUsedPt(i)), y(NotUsedPt(i)), z(NotUsedPt(i)), M, min2()) 
    For j = 1 To 3 
        ConnectFix(NotUsedPt(i), j) = min2(j) 
    Next j 
Next i 
 
For i = 1 To f 
    xresulttemp = 0 
    yresulttemp = 0 
    zresulttemp = 0 
    For j = 1 To 3 
        xresulttemp = xresulttemp + x1(ConnectFix(NotUsedPt(i), j)) + (x1(NotUsedPt(i)) - x1(ConnectFix(NotUsedPt(i), j))) * kx 
        yresulttemp = yresulttemp + y1(ConnectFix(NotUsedPt(i), j)) + (y1(NotUsedPt(i)) - y1(ConnectFix(NotUsedPt(i), j))) * ky 
        zresulttemp = zresulttemp + z1(ConnectFix(NotUsedPt(i), j)) + (z1(NotUsedPt(i)) - z1(ConnectFix(NotUsedPt(i), j))) * kz 
    Next j 
    xresult(NotUsedPt(i)) = xresulttemp / 3 
    yresult(NotUsedPt(i)) = yresulttemp / 3 
    zresult(NotUsedPt(i)) = zresulttemp / 3 
Next i 
 
 
'用过的基准点的坐标 
For i = 1 To f1 
    xresult(UsedPt(i)) = x1(UsedPt(i)) 
    yresult(UsedPt(i)) = y1(UsedPt(i)) 
    zresult(UsedPt(i)) = z1(UsedPt(i)) 
Next i 
 
 
End Sub