Vorige Pagina About the Author

' Reduces equations describing Magic Squares of order 4

' Tested with Office 2007 under Windows 7

Sub Algorithm4()

y = MsgBox("Locked", vbCritical, "Routine Algoritm4")
End

'   lost een stelsel vergelijkingen op en schrijft het oplossings algoritme

    Dim a(16, 17)

'   1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1
'   0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 1
'   0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0, 0, 0, 0, 1
'   0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 1
'   1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1
'   0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 1
'   0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 1
'   0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 0, 0, 0, 1, 1
'   1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1
'   0, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 1
'   0, 0, 1, 0, 0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 1
'   0, 0, 0, 1, 1, 0, 0, 0, 0, 1, 0, 0, 0, 0, 1, 0, 1
'   0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 1
'   0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 1
'   0, 1, 0, 0, 1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 1
'   1, 0, 0, 0, 0, 0, 0, 1, 0, 0, 1, 0, 0, 1, 0, 0, 1

    Sheets("Matrix4").Select

    k10 = 16: k20 = 17

    For j1 = 1 To k10
        For j2 = 1 To k20
            a(j1, j2) = Cells(j1, j2).Value
        Next j2
    Next j1

'   A*x=c

'   De aangevulde matrix is:

'   A(a11,a12,a13,a14, ... c1)
'   A(a21,a22,a23,a24, ... c2)
'   A(a31,a32,a33,a34, ... c3)
'     ...

    k = 1: k1 = 16: k2 = 16: n1 = 0
   
    For j1 = 1 To k1

        GoSub 100                            'check op factoren
   
        n1 = n1 + 17: GoSub 500
        Cells(n1, 1).Select: Cells(n1, 1).Value = "Na check op factoren"
   
'       zoek een element >< 0 in kolom j1
   
        a1 = 0: J = k
        For j2 = k To k2
            If a(j2, j1) <> 0 Then a1 = Abs(a(j2, j1)): J = j2: GoTo 5
        Next j2

'       zoek de kleinste (absoluut) in kolom j1

5       For j2 = k To k2
            If a(j2, j1) <> 0 And a1 > Abs(a(j2, j1)) Then a1 = Abs(a(j2, j1)): J = j2
        Next j2

        For j2 = 1 To k2                     'vegen
            If a1 = 0 Then GoTo 10           'rij met alleen maar nullen
            If a(j2, j1) = 0 Then GoTo 10
            If j2 = J Then GoTo 10

            a1 = a(j, j1): a2 = a(j2, j1): n = a2 / a1
            If Abs(n) >= 1 And n = Int(n) Then
               For j3 = 1 To k1 + 1
                   a(j2, j3) = a(j2, j3) - n * (a(j, j3))
                   If Abs(a(j2, j3)) < 0.000001 Then a(j2, j3) = 0
               Next j3
            Else                             'voorkom breuken
               For j3 = 1 To k1 + 1
                   a(j2, j3) = a1 * a(j2, j3) - a2 * (a(j, j3))
                   If Abs(a(j2, j3)) < 0.000001 Then a(j2, j3) = 0
               Next j3
            End If
10      Next j2
             
        n1 = n1 + 17: GoSub 500
        Cells(n1, 1).Select: Cells(n1, 1).Value = "Na Vegen"
      
        For j2 = 1 To k1 + 1
            a1 = a(J, j2)                    'Swap a(j, j2) , a(k, j2)
            a(J, j2) = a(k, j2)
            a(k, j2) = a1
        Next j2
        k = k + 1
       
        n1 = n1 + 17: GoSub 500
        Cells(n1, 1).Select: Cells(n1, 1).Value = "Na verwisselen (Indien nodig)"
       
    Next j1

    GoSub 1000                               'normeren
    GoSub 1050                               'comprimeren

    n1 = n1 + 17: GoSub 500
    Cells(n1, 1).Select: Cells(n1, 1).Value = "Resultaten"

    GoSub 700                                'schrijf algoritme

    End

'   check op factoren

100 For j20 = k To k2
        i = 1: a1 = 0
        For j10 = 1 To k1 + 1       'zoek een element >< 0
            If a(j20, j10) <> 0 Then a1 = Abs(a(j20, j10)): i = j10: GoTo 105
        Next j10
        If a1 = 0 Then GoTo 110     'rij met alleen maar nullen
105     For j10 = 1 To k1 + 1       'zoek het kleinste element >< 0
            If a(j20, j10) <> 0 And a1 > Abs(a(j20, j10)) Then a1 = Abs(a(j20, j10)): i = j10
        Next j10
        fl = 1
        For j10 = 1 To k1 + 1
            a2 = a(j20, j10) / a(j20, i)
            If a2 <> Int(a2) Then fl = 0
        Next j10
        If fl = 0 Then GoTo 110
        For j10 = 1 To k1 + 1
            a(j20, j10) = a(j20, j10) / a1
        Next j10
110 Next j20
    Return
   
500 For j10 = 1 To k10
        For j20 = 1 To k20
'            a(j10, j20) = Round(a(j10, j20), 3)      'Correction floating point error
            Cells(n1 + j10, j20).Value = a(j10, j20)
        Next j20
    Next j10
    Return

'   Schrijf algoritme

700 Open "C:\Users\jos\WebSite\Entertainment\Descriptions\Excel\Vierkanten\alg.txt" For Output As #1
    Print #1, "'": Print #1, "' bepaal mogelijke oplossingen": Print #1, "'"
    For j10 = k10 To 1 Step -1
    fl = 0
    For j20 = 1 To k20
        If a(j10, j20) <> 0 Then fl = 1: j30 = j20: GoTo 702  'te bepalen variabele
    Next j20
702 If fl = 0 Then GoTo 710
       prstr1$ = "a(" + Str$(j30) + ")="
       s1 = a(j10, k20)
       If s1 <> 0 Then
          If Abs(s1) <> 1 Then
            prstr1$ = prstr1$ + Str$(s1) + "*s1"
          ElseIf s1 > 0 Then
            prstr1$ = prstr1$ + "s1"
          ElseIf s1 < 0 Then
            prstr1$ = prstr1$ + "-s1"
          End If
       End If
    For j20 = j30 + 1 To k20 - 1
       a1 = a(j10, j20)
       If a1 <> 0 Then
          a10$ = Str$(a1)
          If a1 > 0 Then
            prstr1$ = prstr1$ + "-"
          Else
            prstr1$ = prstr1$ + "+": a10$ = Mid$(a10$, 2)
          End If
          If Abs(a1) <> 1 Then
            prstr1$ = prstr1$ + a10$ + "*a(" + Str$(j20) + ")"
          Else
            prstr1$ = prstr1$ + "a(" + Str$(j20) + ")"
          End If
       End If
705 Next j20
    Print #1, prstr1$
710 Next j10
    Print #1, "RETURN"
    Return
    
'    normeren

1000 For j10 = 1 To k10
     fl = 0
     For j20 = 1 To k20
        If a(j10, j20) <> 0 Then
           fl = 1: a1 = a(j10, j20)
           For j30 = 1 To k20
               a(j10, j30) = a(j10, j30) / a1
           Next j30
        End If
        If fl = 1 Then Exit For
     Next j20
     Next j10

     Return

'    comprimeren

1050 k1 = 0
     For j10 = 1 To k10
         fl1 = 0
         While (fl1 = 0 And j10 < k10 - k1)            
                For j20 = 1 To k20
                    If a(j10, j20) <> 0 Then fl1 = 1
                Next j20
            
                If fl1 = 0 Then
                   k1 = k1 + 1
                   For j30 = j10 To k10 - 1
                       For j20 = 1 To k20
                           a(j30, j20) = a(j30 + 1, j20)
                       Next j20
                   Next j30
                   For j20 = 1 To k20: a(k10, j20) = 0: Next j20
                End If        
         Wend
     Next j10

     Return

End Sub

Vorige Pagina About the Author