Vorige Pagina About the Author

' Constructs 9 x 9 Primme Number Associated Magic Squares based on:
' One Magic Center Square, four Semi Magic Anti Symmetric Corner - and four Semi Magic Anti Symmetric Border Squares

' Tested with Office 2007 under Windows 7

Sub Priem3d3()

    Dim a1(1944), a9(81), a(9), b1(43300), b(43300), c(16), a2(9), b2(43300), c2(16), a3(81)

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

    n2 = 0: n3 = 0: k1 = 1: k2 = 1: n9 = 0: n10 = 0
    Sht1 = "Pairs3"

'   Generate Squares

    Sheets("Klad1").Select
    
    t1 = Timer

For j100 = 493 To 846 ''2410
    
    If j100 = 505 Or j100 = 562 Then GoTo 1000
    
    GoSub 2010                    'Read Prime Numbers From Sheet Sht1
    
    If nVar < 81 Then GoTo 1000

'   Determine Center Square

For j9 = m1 To m2                                                     'a(9)
If b(a1(j9)) = 0 Then b(a1(j9)) = a1(j9): c(9) = a1(j9) Else GoTo 160
a(9) = a1(j9)

For j8 = m1 To m2                                                     'a(8)
If b(a1(j8)) = 0 Then b(a1(j8)) = a1(j8): c(8) = a1(j8) Else GoTo 120
a(8) = a1(j8)

    a(7) = s1 - a(8) - a(9):
    If a(7) < a1(m1) Or a(7) > a1(m2) Then GoTo 110:
    If b1(a(7)) = 0 Then GoTo 110
    
    a(6) = 4 * s1 / 3 - a(8) - 2 * a(9):
    If a(6) < a1(m1) Or a(6) > a1(m2) Then GoTo 110:
    If b1(a(6)) = 0 Then GoTo 110
    
    a(5) = s1 / 3:
    If a(5) < a1(m1) Or a(5) > a1(m2) Then GoTo 110:
    If b1(a(5)) = 0 Then GoTo 110
    
    a(4) = -2 * s1 / 3 + 1 * a(8) + 2 * a(9):
    If a(4) < a1(m1) Or a(4) > a1(m2) Then GoTo 110:
    If b1(a(4)) = 0 Then GoTo 110
    
    a(3) = -s1 / 3 + 1 * a(8) + 1 * a(9):
    If a(3) < a1(m1) Or a(3) > a1(m2) Then GoTo 110:
    If b1(a(3)) = 0 Then GoTo 110
    
    a(2) = 2 * s1 / 3 - a(8):
    If a(2) < a1(m1) Or a(2) > a1(m2) Then GoTo 110:
    If b1(a(2)) = 0 Then GoTo 110
    
    a(1) = 2 * s1 / 3 - a(9):
    If a(1) < a1(m1) Or a(1) > a1(m2) Then GoTo 110:
    If b1(a(1)) = 0 Then GoTo 110

'                         Exclude solutions with identical numbers a()

                          GoSub 800: If fl1 = 0 Then GoTo 110
                          
                          GoSub 700                           'Assign Center Square
                          GoSub 900                           'Remove used primes a() from available primes b1()
                          
                          GoSub 2000                          'Determine 4 Corner Squares
                          If n10 < 2 Then GoTo 70

                          GoSub 3000                          'Determine 4 Border Squares
  
                          If n10 >= 4 Then n10 = 0: n3 = 0: Erase b, c: GoTo 1000
                          
70                        GoSub 905                           'Reassign    primes a() to   available primes b1()

110 b(c(8)) = 0: c(8) = 0
120 Next j8
    
    b(c(9)) = 0: c(9) = 0
160 Next j9
     
     n10 = 0
     
1000 Next j100

   t2 = Timer
    
   t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
   y = MsgBox(t10, 0, "Routine Priem3d3")

End

'    Determine 4 Corner Squares

2000 Erase b2, c2
    
    For jj9 = m1 To m2                                                     'a2(9)
    If b1(a1(jj9)) = 0 Then GoTo 165
    If b2(a1(jj9)) = 0 Then b2(a1(jj9)) = a1(jj9): c2(9) = a1(jj9) Else GoTo 165
    a2(9) = a1(jj9)
    
    For jj8 = m1 To m2                                                     'a2(8)
    If b1(a1(jj8)) = 0 Then GoTo 125
    If b2(a1(jj8)) = 0 Then b2(a1(jj8)) = a1(jj8): c2(8) = a1(jj8) Else GoTo 125
    a2(8) = a1(jj8)
    
        a2(7) = s1 - a2(8) - a2(9):
        If a2(7) < a1(m1) Or a2(7) > a1(m2) Then GoTo 115:
        If b1(a2(7)) = 0 Then GoTo 115
        
    For jj6 = m1 To m2                                                     'a2(6)
    If b1(a1(jj6)) = 0 Then GoTo 100
    If b2(a1(jj6)) = 0 Then b2(a1(jj6)) = a1(jj6): c2(6) = a1(jj6) Else GoTo 100
    a2(6) = a1(jj6)
    
        a2(5) = -s1 + a2(6) + a2(8) + 2 * a2(9)
        If a2(5) < a1(m1) Or a2(5) > a1(m2) Then GoTo 80:
        If b1(a2(5)) = 0 Then GoTo 80
        
        a2(4) = 2 * s1 - 2 * a2(6) - a2(8) - 2 * a2(9)
        If a2(4) < a1(m1) Or a2(4) > a1(m2) Then GoTo 80:
        If b1(a2(4)) = 0 Then GoTo 80
        
        a2(3) = s1 - a2(6) - a2(9)
        If a2(3) < a1(m1) Or a2(3) > a1(m2) Then GoTo 80:
        If b1(a2(3)) = 0 Then GoTo 80
        
        a2(2) = 2 * s1 - a2(6) - 2 * a2(8) - 2 * a2(9)
        If a2(2) < a1(m1) Or a2(2) > a1(m2) Then GoTo 80:
        If b1(a2(2)) = 0 Then GoTo 80
        
        a2(1) = -2 * s1 + 2 * a2(6) + 2 * a2(8) + 3 * a2(9)
        If a2(1) < a1(m1) Or a2(1) > a1(m2) Then GoTo 80:
        If b1(a2(1)) = 0 Then GoTo 80
    
    '                 Exclude solutions with identical numbers a2()
    
                      GoSub 810: If fl1 = 0 Then GoTo 80
                      GoSub 1900: If fl1 = 0 Then GoTo 80           'Anti Symmetric
                              
                      n10 = n10 + 1
                             
                      If n10 < 2 Then
                             GoSub 750                              'Transform and Assign Corner Squares
                             GoSub 910                              'Remove used primes a2() from available primes b1()
                             Erase b2, c2: GoTo 165
                      Else
                             GoSub 750                              'Transform and Assign Corner Squares
                             GoSub 910                              'Remove used primes a2() from available primes b1()
                      End If
                      If n10 = 2 Then Erase b2, c2: Return          'Only four squares required
       
       
80      b2(c2(6)) = 0: c2(6) = 0
100     Next jj6
       
115     b2(c2(8)) = 0: c2(8) = 0
125     Next jj8
        
        b2(c2(9)) = 0: c2(9) = 0
165     Next jj9

        GoSub 915                                                   'Reassign Primes a3()

        Return

'    Determine 4 Border Squares

3000 Erase b2, c2
    
'    Determine Border Square

For jjj9 = m1 To m2                                                     'a2(9)
If b1(a1(jjj9)) = 0 Then GoTo 155
If b2(a1(jjj9)) = 0 Then b2(a1(jjj9)) = a1(jjj9): c2(9) = a1(jjj9) Else GoTo 155
a2(9) = a1(jjj9)

For jjj8 = m1 To m2                                                     'a2(8)
If b1(a1(jjj8)) = 0 Then GoTo 135
If b2(a1(jjj8)) = 0 Then b2(a1(jjj8)) = a1(jjj8): c2(8) = a1(jjj8) Else GoTo 135
a2(8) = a1(jjj8)

    a2(7) = s1 - a2(8) - a2(9):
    If a2(7) < a1(m1) Or a2(7) > a1(m2) Then GoTo 130:
    If b1(a2(7)) = 0 Then GoTo 130
    
For jjj6 = m1 To m2                                                     'a2(6)
If b1(a1(jjj6)) = 0 Then GoTo 105
If b2(a1(jjj6)) = 0 Then b2(a1(jjj6)) = a1(jjj6): c2(6) = a1(jjj6) Else GoTo 105
a2(6) = a1(jjj6)

For jjj5 = m1 To m2                                                     'a2(5)
If b1(a1(jjj5)) = 0 Then GoTo 95
If b2(a1(jjj5)) = 0 Then b2(a1(jjj5)) = a1(jjj5): c2(5) = a1(jjj5) Else GoTo 95
a2(5) = a1(jjj5)
    
    a2(4) = s1 - a2(5) - a2(6)
    If a2(4) < a1(m1) Or a2(4) > a1(m2) Then GoTo 85:
    If b1(a2(4)) = 0 Then GoTo 85
    
    a2(3) = -a2(6) + a2(7) + a2(8)
    If a2(3) < a1(m1) Or a2(3) > a1(m2) Then GoTo 85:
    If b1(a2(3)) = 0 Then GoTo 85
    
    a2(2) = s1 - a2(5) - a2(8)
    If a2(2) < a1(m1) Or a2(2) > a1(m2) Then GoTo 85:
    If b1(a2(2)) = 0 Then GoTo 85
    
    a2(1) = a2(5) + a2(6) - a2(7)
    If a2(1) < a1(m1) Or a2(1) > a1(m2) Then GoTo 85:
    If b1(a2(1)) = 0 Then GoTo 85

'                     Exclude solutions with identical numbers

                      GoSub 810: If fl1 = 0 Then GoTo 85
                      GoSub 1900: If fl1 = 0 Then GoTo 85           'Anti Symmetric
                          
                      n10 = n10 + 1
                   
                      If n10 < 4 Then
                             GoSub 750                              'Transform and Assign Border Squares
                             GoSub 910                              'Remove used primes a2() from available primes b1()
                             Erase b2, c2: GoTo 155
                      Else
                             GoSub 750                              'Transform and Assign Border Squares
                             GoSub 850                              'Double Check Identical Integers
                             If fl1 = 1 Then
                                    n9 = n9 + 1: GoSub 650          'Print Composed Squares
                             End If
                      End If
                      If n10 = 4 Then Erase b2, c2: Return          'Only eight squares required

85  b2(c2(5)) = 0: c2(5) = 0
95  Next jjj5
   
    b2(c2(6)) = 0: c2(6) = 0
105 Next jjj6
   
130 b2(c2(8)) = 0: c2(8) = 0
135 Next jjj8
    
    b2(c2(9)) = 0: c2(9) = 0
155 Next jjj9

     GoSub 915                                                   'Reassign Primes a3()

     Return

'   Print results (squares)

650  n2 = n2 + 1
     If n2 = 3 Then
         n2 = 1: k1 = k1 + 10: k2 = 1
     Else
         If n9 > 1 Then k2 = k2 + 10
     End If

     Cells(k1, k2 + 1).Select
     Cells(k1, k2 + 1).Font.Color = -4165632
     Cells(k1, k2 + 1).Value = "MC = " + CStr(s2)
    
     i3 = 0
     For i1 = 1 To 9
         For i2 = 1 To 9
             i3 = i3 + 1
             Cells(k1 + i1, k2 + i2).Value = a9(i3)
         Next i2
     Next i1

     Return

'    Assign Center Square

700  a9(31) = a(1):  a9(32) = a(2):  a9(33) = a(3):
     a9(40) = a(4):  a9(41) = a(5):  a9(42) = a(6):
     a9(49) = a(7):  a9(50) = a(8):  a9(51) = a(9):
     
     Return

'    Transform and Assign Corner and Border Squares

750  Select Case n10

        Case 1: 'Left Top
                
                a9(1) = a2(3):  a9(2) = a2(2):   a9(3) = a2(1):
                a9(10) = a2(6):  a9(11) = a2(5):  a9(12) = a2(4):
                a9(19) = a2(9):  a9(20) = a2(8):  a9(21) = a2(7):
                
                'Right Bottom
        
                a9(61) = Pr3 - a9(21): a9(62) = Pr3 - a9(20): a9(63) = Pr3 - a9(19):
                a9(70) = Pr3 - a9(12): a9(71) = Pr3 - a9(11): a9(72) = Pr3 - a9(10):
                a9(79) = Pr3 - a9(3):  a9(80) = Pr3 - a9(2):  a9(81) = Pr3 - a9(1):
                
        Case 2: 'Right Top
        
                a9(7) = a2(1):   a9(8) = a2(2):   a9(9) = a2(3):
                a9(16) = a2(4):  a9(17) = a2(5):  a9(18) = a2(6):
                a9(25) = a2(7):  a9(26) = a2(8):  a9(27) = a2(9):

                'Left Bottom
        
                a9(55) = Pr3 - a9(27): a9(56) = Pr3 - a9(26): a9(57) = Pr3 - a9(25):
                a9(64) = Pr3 - a9(18): a9(65) = Pr3 - a9(17): a9(66) = Pr3 - a9(16):
                a9(73) = Pr3 - a9(9):  a9(74) = Pr3 - a9(8):  a9(75) = Pr3 - a9(7):

'               Remaing Squares (Clock Wise)
                
        Case 3: 'Mid Top
        
                a9(4) = a2(1):   a9(5) = a2(2):   a9(6) = a2(3):
                a9(13) = a2(4):  a9(14) = a2(5):  a9(15) = a2(6):
                a9(22) = a2(7):  a9(23) = a2(8):  a9(24) = a2(9):
       
                'Mid Bottom
                
                a9(58) = Pr3 - a9(24): a9(59) = Pr3 - a9(23): a9(60) = Pr3 - a9(22):
                a9(67) = Pr3 - a9(15): a9(68) = Pr3 - a9(14): a9(69) = Pr3 - a9(13):
                a9(76) = Pr3 - a9(6):  a9(77) = Pr3 - a9(5):  a9(78) = Pr3 - a9(4):
       
        Case 4: 'Mid Left
        
                a9(28) = a2(1):  a9(29) = a2(2):  a9(30) = a2(3):
                a9(37) = a2(4):  a9(38) = a2(5):  a9(39) = a2(6):
                a9(46) = a2(7):  a9(47) = a2(8):  a9(48) = a2(9):
        
                'Mid Right
                
                a9(34) = Pr3 - a9(48): a9(35) = Pr3 - a9(47): a9(36) = Pr3 - a9(46):
                a9(43) = Pr3 - a9(39): a9(44) = Pr3 - a9(38): a9(45) = Pr3 - a9(37):
                a9(52) = Pr3 - a9(30): a9(53) = Pr3 - a9(29): a9(54) = Pr3 - a9(28):
                
     End Select
     
     Return

'    Exclude solutions with identical numbers a()

800  fl1 = 1
     For j1 = 1 To 9
        a20 = a(j1)
        For j2 = (1 + j1) To 9
            If a20 = a(j2) Then fl1 = 0: Return
        Next j2
     Next j1
     Return

'    Exclude solutions with identical numbers a2()

810  fl1 = 1
     For j1 = 1 To 9
        a20 = a2(j1)
        For j2 = (1 + j1) To 9
            If a20 = a2(j2) Then fl1 = 0: Return
        Next j2
     Next j1
     Return

'    Exclude solutions with identical numbers a9()

850  fl1 = 1
     For j1 = 1 To 81
        a20 = a9(j1)
        For j2 = (1 + j1) To 81
            If a20 = a9(j2) Then fl1 = 0: Return
        Next j2
     Next j1
     Return

'    Remove used primes a() from available primes b1()

900  For i1 = 1 To 9
         b1(a(i1)) = 0
     Next i1
     Return
     
'    Reassign   primes a()  to   available primes b1()
     
905  For i1 = 1 To 9
         b1(a(i1)) = a(i1)
     Next i1
     Return

'    Remove used primes a2() and complements from available primes b1()
'    Store  used primes a2() and complements temporarely in a3()

910  For i1 = 1 To 9
         b1(a2(i1)) = 0: b1(Pr3 - a2(i1)) = 0
         n3 = n3 + 1: a3(n3) = a2(i1)
     Next i1
     For i1 = 1 To 9
        n3 = n3 + 1: a3(n3) = Pr3 - a2(i1)
     Next i1
     Return

'    Reassign   primes a3()  to   available primes b1()
     
915  For i1 = 1 To n3
         b1(a3(i1)) = a3(i1)
     Next i1
     Erase a3: n3 = 0: n10 = 0
     Return
     
'   Check Pairs

1900 fl1 = 1: n25 = 0
     For j1 = 1 To 9
        a20 = Pr3 - a2(j1)          'Complement
        For j2 = (1 + j1) To 9
             If a20 = a2(j2) Then fl1 = 0: Return
         Next j2
     Next j1
     Return
     
'    Read Prime Numbers From Sheet Sht1

2010 Cntr3 = Sheets(Sht1).Cells(j100, 4).Value  'Center Element
     s1 = 3 * Cntr3                             'MC3
     s2 = 3 * s1                                'MC9
     nVar = Sheets(Sht1).Cells(j100, 5).Value
     Pr3 = Sheets(Sht1).Cells(j100, 1).Value    'Pair Sum
     nSemi3 = Sheets(Sht1).Cells(j100, 6).Value 'Expected Nmbr Semi Magic Squares
    
     m1 = 1: m2 = nVar
    
     For i1 = m1 To m2
         a1(i1) = Sheets(Sht1).Cells(j100, i1 + 6).Value
     Next i1
     If a1(1) = 1 Then m1 = 2
    
     Erase b1
     For i1 = m1 To m2
         b1(a1(i1)) = a1(i1)
     Next i1
   
     Return

End Sub

Vorige Pagina About the Author