www.pudn.com > DataCollectionSystem.rar > modFangan3.bas, change:2003-07-22,size:9176b


Attribute VB_Name = "fanganthree" 
Option Explicit 
 
Public Sub trans7(x() As Double, y() As Double, z() As Double, X1() As Double, Y1() As Double, z1() As Double, N As Integer) 
Dim C As Integer 
Dim atemp(1000) As Double 
Dim btemp(1000) As Double 
Dim a(1000, 9) As Double 
Dim b(9, 1000) As Double 
Dim i As Integer, j As Integer, k As Integer 
Dim L(8) As Double 
Dim f(9, 9) As Double 
Dim Q(9, 9) As Double 
 
 
 
For i = 1 To N 
    For j = 1 To 6 
        a(3 * (i - 1) + 1, j) = 0 
        a(3 * (i - 1) + 2, j) = 0 
        a(3 * (i - 1) + 3, j) = 0 
    Next j 
      a(3 * (i - 1) + 1, 1) = 1 
      a(3 * (i - 1) + 2, 2) = 1 
      a(3 * (i - 1) + 3, 3) = 1 
Next i 
 
For i = 1 To N 
    a(3 * (i - 1) + 1, 5) = -z1(i) 
    a(3 * (i - 1) + 1, 6) = Y1(i) 
    a(3 * (i - 1) + 2, 4) = z1(i) 
    a(3 * (i - 1) + 2, 6) = -X1(i) 
    a(3 * (i - 1) + 3, 4) = -Y1(i) 
    a(3 * (i - 1) + 3, 5) = X1(i) 
    a(3 * (i - 1) + 1, 7) = X1(i) 
    a(3 * (i - 1) + 2, 7) = Y1(i) 
    a(3 * (i - 1) + 3, 7) = z1(i) 
    a(3 * (i - 1) + 1, 8) = x(i) - X1(i) 
    a(3 * (i - 1) + 2, 8) = y(i) - Y1(i) 
    a(3 * (i - 1) + 3, 8) = z(i) - z1(i) 
Next i 
 
'转置 
For i = 1 To 7 
    For j = 1 To 3 * N 
        b(i, j) = a(j, i) 
    Next j 
Next i 
 
 
 
   
'n阵 
For i = 1 To 7 
    For j = 1 To 7 
        f(i, j) = 0 
        For k = 1 To 3 * N 
            f(i, j) = f(i, j) + b(i, k) * a(k, j) 
        Next k 
    Next j 
Next i 
 
'atpl 
For i = 1 To 7 
    L(i) = 0 
    For j = 1 To 3 * N 
        L(i) = L(i) + b(i, j) * a(j, 8) 
    Next j 
Next i 
 
'求逆阵 
 
k = 0 
For i = 1 To 7 
    For j = 1 To i 
        k = k + 1 
        atemp(k) = f(i, j) 
    Next j 
Next i 
 
Dim Ier As Long 
Call INVERS(atemp(), L(), 3, 7, Ier) 
 
If Ier <> 0 Then 
    Call MYINVERS(7, f, Q) 
'求参数 
    For i = 1 To 7 
        canshu(i) = 0 
        For j = 1 To 7 
            canshu(i) = canshu(i) + Q(i, j) * L(j) 
        Next j 
    Next i 
    Open App.Path + "\DataFiles\Invers.txt" For Append As #33 
    Write #33, "false" 
    Close #33 
Else 
    For i = 1 To 7 
        canshu(i) = L(i) 
    Next i 
    Open App.Path + "\DataFiles\Invers.txt" For Append As #33 
    Write #33, "true" 
    Close #33 
End If 
 
For i = 1 To 3 
    xresult(i) = canshu(1) + canshu(6) * Y1(i) - canshu(5) * z1(i) + (1 + canshu(7)) * X1(i) 
    yresult(i) = canshu(2) - canshu(6) * X1(i) + canshu(4) * z1(i) + (1 + canshu(7)) * Y1(i) 
    zresult(i) = canshu(3) + canshu(5) * X1(i) - canshu(4) * Y1(i) + (1 + canshu(7)) * z1(i) 
Next i 
 
 
End Sub 
 
 
Public Sub MYINVERS(b As Integer, a() As Double, Q() As Double) 
Dim i As Integer, j As Integer, k As Integer 
Dim e(7) As Double, C(10, 10) As Double, H(10, 10) As Double 
For i = 1 To b 
e(i) = a(i, i) 
Next i 
    For i = 1 To b 
        For j = 1 To b 
            Q(i, j) = 0 
        Next j 
        Q(i, i) = 1 
    Next i 
 
 
 
 
 
    For k = 1 To b 
        'e = a(k, k) 
                For j = 1 To b 
                    a(k, j) = a(k, j) / e(k): Q(k, j) = Q(k, j) / e(k) 
                Next j 
 
        For i = 1 To b 
            If k = i Then GoTo 99 
                    For j = 1 To b 
                           If j > k Then Let a(i, j) = a(i, j) - a(i, k) * a(k, j) 
                           Q(i, j) = Q(i, j) - a(i, k) * Q(k, j) 
                    Next j 
99:     Next i 
    Next k 
End Sub 
Public Sub INVERS(a, b, ijob, N, Ier) 
Dim ONE As Double, Q As Double, s As Double, SIXTN As Double, t As Double, x As Double, Zero As Double, Eps As Double 
Dim iis As Long, i As Long, j As Long, k As Long, Ip1 As Long 
Dim Isw As Long, Ip As Long, Iq As Long, Ir As Long, Nm1 As Long, ii As Long, Jm1 As Long, jj As Long, Li As Long, Ji As Long, Jl As Long, L As Long, Lj As Long, Iw As Long, Im1 As Long, n1 As Long 
Dim Kk As Long 
Dim Rn As Double 
Dim Itmp 
     
    Zero = 0#: ONE = 1#: SIXTN = 16# 
    Eps = 0.0000000025 
      If (ijob < 1 Or ijob > 4) Then GoTo 115 
      Isw = 0 
      Rn = ONE / (N * SIXTN) 
      Ip = 1 
      Ier = 0 
    For i = 1 To N 
        Itmp = DoEvents 
         Iq = Ip 
         Ir = 1 
         For j = 1 To i 
            x = a(Ip) 
            If (j = 1) Then GoTo 10 
            For k = Iq To Ip1 
               x = x - a(k) * a(Ir) 
               Ir = Ir + 1 
            Next k 
10          If (i <> j) Then GoTo 15 
            Q = a(Ip) + x * Rn 
            If (Q - a(Ip) <= Eps) Then GoTo 120 
      a(Ip) = ONE / Sqr(x) 
      GoTo 20 
15          a(Ip) = x * a(Ir) 
20          Ip1 = Ip 
            Ip = Ip + 1 
            Ir = Ir + 1 
            Next j 
    Next i 
    If (ijob = 4) Then GoTo 9005 
      If (Isw = 0 And ijob <> 1) Then GoTo 75 
35  Nm1 = N - 1 
      If (N = 1) Then GoTo 55 
      ii = 1 
      For i = 1 To Nm1 
    Itmp = DoEvents 
         Ip1 = i + 1 
         Jm1 = i 
         jj = ii 
         For j = Ip1 To N 
            s = Zero 
            Li = ii 
            Ji = jj + i 
            Jl = Ji 
            For L = i To Jm1 
               s = s + a(Li) * a(Jl) 
               Jl = Jl + 1 
               Li = Li + L 
            Next L 
            jj = jj + j 
            a(Ji) = -a(jj) * s 
            Jm1 = j 
        Next j 
         ii = ii + Ip1 
        Next i 
55   ii = 0 
     For i = 1 To N 
    Itmp = DoEvents 
         jj = ii 
         For j = i To N 
            s = Zero 
            Ji = jj + i 
            Li = Ji 
            jj = jj + j 
            Lj = jj 
            For L = j To N 
               s = s + a(Li) * a(Lj) 
               Li = Li + L 
               Lj = Lj + L 
            Next L 
            a(Ji) = s 
        Next j 
         ii = ii + i 
        Next i 
      If (ijob = 1 Or Isw = 1) Then GoTo 9005 
75 Isw = 1 
      Ip = 1 
      Iw = 0 
      Im1 = 0 
      For i = 1 To N 
         t = b(i) 
         If (Iw = 0) Then GoTo 85 
         Ip = Ip + Iw - 1 
         For k = Iw To Im1 
            t = t - a(Ip) * b(k) 
            Ip = Ip + 1 
         Next k 
         GoTo 90 
85    If (t <> Zero) Then Iw = i 
         Ip = Ip + Im1 
90       b(i) = t * a(Ip) 
         Ip = Ip + 1 
         Im1 = i 
       Next i 
      n1 = N + 1 
      For i = 1 To N 
    Itmp = DoEvents 
         ii = n1 - i 
         Ip = Ip - 1 
         iis = Ip 
         Iq = ii + 1 
         t = b(ii) 
         If (N < Iq) Then GoTo 105 
         Kk = N 
         For k = Iq To N 
            t = t - a(iis) * b(Kk) 
            Kk = Kk - 1 
            iis = iis - Kk 
         Next k 
105      b(ii) = t * a(iis) 
            Next i 
      If (ijob = 3) Then GoTo 35 
      GoTo 9005 
115 Ier = 129 
       
      GoTo 9005 
120 Ier = 130 
      If (ijob = 4) Then GoTo 9005 
 
9005 
End Sub 
 
Public Sub trans_7c(x() As Double, y() As Double, z() As Double, X1() As Double, Y1() As Double, z1() As Double, N As Integer) 
Dim a(1000, 9) As Double 
Dim b(9, 1000) As Double 
Dim i As Integer, j As Integer, k As Integer 
Dim L(8) As Double 
Dim f(9, 9) As Double 
 
For i = 1 To N 
    For j = 1 To 6 
        a(3 * (i - 1) + 1, j) = 0 
        a(3 * (i - 1) + 2, j) = 0 
        a(3 * (i - 1) + 3, j) = 0 
    Next j 
      a(3 * (i - 1) + 1, 1) = 1 
      a(3 * (i - 1) + 2, 2) = 1 
      a(3 * (i - 1) + 3, 3) = 1 
Next i 
 
For i = 1 To N 
    a(3 * (i - 1) + 1, 5) = -z1(i) 
    a(3 * (i - 1) + 1, 6) = Y1(i) 
    a(3 * (i - 1) + 2, 4) = z1(i) 
    a(3 * (i - 1) + 2, 6) = -X1(i) 
    a(3 * (i - 1) + 3, 4) = -Y1(i) 
    a(3 * (i - 1) + 3, 5) = X1(i) 
    a(3 * (i - 1) + 1, 7) = X1(i) 
    a(3 * (i - 1) + 2, 7) = Y1(i) 
    a(3 * (i - 1) + 3, 7) = z1(i) 
    a(3 * (i - 1) + 1, 8) = x(i) - X1(i) 
    a(3 * (i - 1) + 2, 8) = y(i) - Y1(i) 
    a(3 * (i - 1) + 3, 8) = z(i) - z1(i) 
Next i 
 
'转置 
For i = 1 To 7 
    For j = 1 To 3 * N 
        b(i, j) = a(j, i) 
    Next j 
Next i 
 
'n阵 
For i = 1 To 7 
    For j = 1 To 7 
        f(i, j) = 0 
        For k = 1 To 3 * N 
            f(i, j) = f(i, j) + b(i, k) * a(k, j) 
        Next k 
    Next j 
Next i 
 
'atpl 
For i = 1 To 7 
    L(i) = 0 
    For j = 1 To 3 * N 
        L(i) = L(i) + b(i, j) * a(j, 8) 
    Next j 
Next i 
 
'求逆阵 
 
    Call MyInversB(7, f, L()) 
'求参数 
    For i = 1 To 7 
        canshu(i) = L(i) 
    Next i 
     
End Sub 
 
 
Sub MyInversB(M As Integer, a() As Double, b() As Double) 
Dim k As Integer, j As Integer, i As Integer, io As Integer 
Dim C As Double, t As Double 
 
 
For k = 1 To M 
    C = 0 
    For i = k To M 
        If Abs(a(i, k)) < Abs(C) Then 
            GoTo 3050 
        End If 
        C = a(i, k) 
        io = i 
3050: 
    Next i 
    If io = k Then 
        GoTo 3100 
    End If 
    For j = k To M 
        t = a(k, j) 
        a(k, j) = a(io, j) 
        a(io, j) = t 
    Next j 
    t = b(k): b(k) = b(io): b(io) = t 
3100: 
    C = 1 / C 
    For j = k + 1 To M 
        a(k, j) = C * a(k, j) 
        For i = k + 1 To M 
            a(i, j) = a(i, j) - a(i, k) * a(k, j) 
        Next i 
    Next j 
     
    b(k) = C * b(k) 
    For i = k + 1 To M 
        b(i) = b(i) - b(k) * a(i, k) 
    Next i 
Next k 
 
For i = M - 1 To 1 Step -1 
    For j = i + 1 To M 
        b(i) = b(i) - a(i, j) * b(j) 
    Next j 
Next i 
 
End Sub