Vorige Pagina About the Author

' Constructs 9 x 9 Magic Squares with Overlapping Subsquares (Distinct Prime Numbers, Partial Symmetric)
' - Reads Anti Symmetric Magic Square, Calculates Complementary Magic Square (5 x 5)
' - Generates additional Prime Number Pan Magic Squares (4 x 4)

' Tested with Office 2007 under Windows 7

Sub Priem4f1()

    Dim a1(1944), a(81), b1(43300), b(43300), c(16)
    Dim a4(16), b5(25), c5(25), d4(16)              'Sub Squares

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

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

'   Generate Squares

    Sheets("Klad1").Select
    
    t1 = Timer

For j100 = 2 To 35

'   Start Reading Data
    
    Rcrd1a = Sheets("NonSym5").Cells(j100, 28).Value
    MC5 = Sheets("NonSym5").Cells(j100, 26).Value

'   Read Prime Numbers From Sheet Sht1

    s1 = 2 * Sheets(Sht1).Cells(Rcrd1a, 1).Value  'MC4
    s2 = 9 * s1 / 4                               'MC9
    Cntr5 = Sheets(Sht1).Cells(Rcrd1a, 6).Value   'Center
    nVar = Sheets(Sht1).Cells(Rcrd1a, 9).Value
    
    m1 = 1: m2 = nVar
    
    For i1 = m1 To m2
        a1(i1) = Sheets(Sht1).Cells(Rcrd1a, i1 + 9).Value
    Next i1
    
    Erase b1
    For i1 = m1 To m2
        b1(a1(i1)) = a1(i1)
    Next i1

'   Read Prime Numbers used for 2 x PM5

    For i1 = 1 To 25
        a(i1) = Sheets("NonSym5").Cells(j100, i1).Value
    Next i1
    GoSub 750   'Fill c5()
    GoSub 700   'Fill b5()

    GoSub 950   'Remove used primes from available primes
    
    Erase a     'Clear Scratch Area
    
'   Generate Prime Number Pan Magic Squares (4 x 4)
    
For j16 = m1 To m2                                          'a(16)
    If b1(a1(j16)) = 0 Then GoTo 160
    If b(a1(j16)) = 0 Then b(a1(j16)) = a1(j16): c(16) = a1(j16) Else GoTo 160
    a(16) = a1(j16)
    
For j15 = m1 To m2                                          'a(15)
    If b1(a1(j15)) = 0 Then GoTo 150
    If b(a1(j15)) = 0 Then b(a1(j15)) = a1(j15): c(15) = a1(j15) Else GoTo 150
    a(15) = a1(j15)
    
For j14 = m1 To m2                                          'a(14)
    If b1(a1(j14)) = 0 Then GoTo 140
    If b(a1(j14)) = 0 Then b(a1(j14)) = a1(j14): c(14) = a1(j14) Else GoTo 140
    a(14) = a1(j14)
    
    a(13) = s1 - a(14) - a(15) - a(16)
    If a(13) < a1(m1) Or a(13) > a1(m2) Then GoTo 130
    If b1(a(13)) = 0 Then GoTo 130
    If b(a(13)) = 0 Then b(a(13)) = a(13): c(13) = a(13) Else GoTo 130
    
For j12 = m1 To m2                                          'a(12)
    If b1(a1(j12)) = 0 Then GoTo 120
    If b(a1(j12)) = 0 Then b(a1(j12)) = a1(j12): c(12) = a1(j12) Else GoTo 120
    a(12) = a1(j12)
    
    a(11) = s1 - a(12) - a(15) - a(16)
    If a(11) < a1(m1) Or a(11) > a1(m2) Then GoTo 70
    If b1(a(11)) = 0 Then GoTo 70
    
    a(10) = a(12) - a(14) + a(16)
    If a(10) < a1(m1) Or a(10) > a1(m2) Then GoTo 70
    If b1(a(10)) = 0 Then GoTo 70
    
    a(9) = -a(12) + a(14) + a(15)
    If a(9) < a1(m1) Or a(9) > a1(m2) Then GoTo 70
    If b1(a(9)) = 0 Then GoTo 70
    
    a(8) = 0.5 * s1 - a(14)
    If a(8) < a1(m1) Or a(8) > a1(m2) Then GoTo 70
    If b1(a(8)) = 0 Then GoTo 70
    
    a(7) = -0.5 * s1 + a(14) + a(15) + a(16)
    If a(7) < a1(m1) Or a(7) > a1(m2) Then GoTo 70:
    If b1(a(7)) = 0 Then GoTo 70
    
    a(6) = 0.5 * s1 - a(16)
    If a(6) < a1(m1) Or a(6) > a1(m2) Then GoTo 70:
    If b1(a(6)) = 0 Then GoTo 70
    
    a(5) = 0.5 * s1 - a(15)
    If a(5) < a1(m1) Or a(5) > a1(m2) Then GoTo 70:
    If b1(a(5)) = 0 Then GoTo 70
    
    a(4) = 0.5 * s1 - a(12) + a(14) - a(16)
    If a(4) < a1(m1) Or a(4) > a1(m2) Then GoTo 70:
    If b1(a(4)) = 0 Then GoTo 70
    
    a(3) = 0.5 * s1 + a(12) - a(14) - a(15)
    If a(3) < a1(m1) Or a(3) > a1(m2) Then GoTo 70:
    If b1(a(3)) = 0 Then GoTo 70
    
    a(2) = 0.5 * s1 - a(12)
    If a(2) < a1(m1) Or a(2) > a1(m2) Then GoTo 70:
    If b1(a(2)) = 0 Then GoTo 70
    
    a(1) = -0.5 * s1 + a(12) + a(15) + a(16)
    If a(1) < a1(m1) Or a(1) > a1(m2) Then GoTo 70:
    If b1(a(1)) = 0 Then GoTo 70
    
'                 Exclude solutions with identical numbers (PM4)
    
                  n8 = 16: GoSub 800: If fl1 = 0 Then GoTo 70
    
                  n10 = n10 + 1
                  Select Case n10
                              
                         Case 1
                                For i1 = 1 To 16: a4(i1) = a(i1): Next i1
                                GoSub 900                                  'Remove used primes from available primes
                                Erase b, c: GoTo 160
                         Case 2
                                For i1 = 1 To 16: d4(i1) = a(i1): Next i1
                                GoSub 600                                  'Compose Main Square
                                n8 = 81: GoSub 800                         'Double Check Identical Integers
                                If fl1 = 1 Then
                                    n9 = n9 + 1: GoSub 650                 'Print Composed Squares
                                End If
                  End Select
                  If n10 = 2 Then n10 = 0: Erase b, c: GoTo 10             'Only two squares required
   
70  b(c(12)) = 0: c(12) = 0
120 Next j12

    b(c(13)) = 0: c(13) = 0
130 b(c(14)) = 0: c(14) = 0
140 Next j14
    b(c(15)) = 0: c(15) = 0
150 Next j15
    b(c(16)) = 0: c(16) = 0
160 Next j16

    n10 = 0
10  Next j100

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

End

'   Compose Main Square

600 a(1) = a4(1):   a(2) = a4(2):   a(3) = a4(3):   a(4) = a4(4):   a(5) = b5(1):   a(6) = b5(2):   a(7) = b5(3):   a(8) = b5(4):   a(9) = b5(5):
    a(10) = a4(5):  a(11) = a4(6):  a(12) = a4(7):  a(13) = a4(8):  a(14) = b5(6):  a(15) = b5(7):  a(16) = b5(8):  a(17) = b5(9):  a(18) = b5(10):
    a(19) = a4(9):  a(20) = a4(10): a(21) = a4(11): a(22) = a4(12): a(23) = b5(11): a(24) = b5(12): a(25) = b5(13): a(26) = b5(14): a(27) = b5(15):
    a(28) = a4(13): a(29) = a4(14): a(30) = a4(15): a(31) = a4(16): a(32) = b5(16): a(33) = b5(17): a(34) = b5(18): a(35) = b5(19): a(36) = b5(20):
    a(37) = c5(1):  a(38) = c5(2):  a(39) = c5(3):  a(40) = c5(4):  a(41) = b5(21): a(42) = b5(22): a(43) = b5(23): a(44) = b5(24): a(45) = b5(25):
    a(46) = c5(6):  a(47) = c5(7):  a(48) = c5(8):  a(49) = c5(9):  a(50) = c5(10): a(51) = d4(1):  a(52) = d4(2):  a(53) = d4(3):  a(54) = d4(4):
    a(55) = c5(11): a(56) = c5(12): a(57) = c5(13): a(58) = c5(14): a(59) = c5(15): a(60) = d4(5):  a(61) = d4(6):  a(62) = d4(7):  a(63) = d4(8):
    a(64) = c5(16): a(65) = c5(17): a(66) = c5(18): a(67) = c5(19): a(68) = c5(20): a(69) = d4(9):  a(70) = d4(10): a(71) = d4(11): a(72) = d4(12):
    a(73) = c5(21): a(74) = c5(22): a(75) = c5(23): a(76) = c5(24): a(77) = c5(25): a(78) = d4(13): a(79) = d4(14): a(80) = d4(15): a(81) = d4(16):
    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 = a(i3)
        Next i2
    Next i1

    Return
   
'   Transform Non Symmetric Magic Square into c5() and b5()

700 b5(1) = 2 * Cntr5 - c5(25): b5(2) = 2 * Cntr5 - c5(24):  b5(3) = 2 * Cntr5 - c5(23): b5(4) = 2 * Cntr5 - c5(22):  b5(5) = 2 * Cntr5 - c5(21):
    b5(6) = 2 * Cntr5 - c5(20): b5(7) = 2 * Cntr5 - c5(19):  b5(8) = 2 * Cntr5 - c5(18): b5(9) = 2 * Cntr5 - c5(17):  b5(10) = 2 * Cntr5 - c5(16):
    b5(11) = 2 * Cntr5 - c5(15):b5(12) = 2 * Cntr5 - c5(14): b5(13) = 2 * Cntr5 - c5(13):b5(14) = 2 * Cntr5 - c5(12): b5(15) = 2 * Cntr5 - c5(11):
    b5(16) = 2 * Cntr5 - c5(10):b5(17) = 2 * Cntr5 - c5(9):  b5(18) = 2 * Cntr5 - c5(8): b5(19) = 2 * Cntr5 - c5(7):  b5(20) = 2 * Cntr5 - c5(6):
    b5(21) = 2 * Cntr5 - c5(5): b5(22) = 2 * Cntr5 - c5(4):  b5(23) = 2 * Cntr5 - c5(3): b5(24) = 2 * Cntr5 - c5(2):  b5(25) = 2 * Cntr5 - c5(1):
    Return

750 c5(1) = a(21):  c5(2) = a(22):  c5(3) = a(23):  c5(4) = a(24):  c5(5) = a(25):
    c5(6) = a(16):  c5(7) = a(17):  c5(8) = a(18):  c5(9) = a(19):  c5(10) = a(20):
    c5(11) = a(11): c5(12) = a(12): c5(13) = a(13): c5(14) = a(14): c5(15) = a(15):
    c5(16) = a(6):  c5(17) = a(7):  c5(18) = a(8):  c5(19) = a(9):  c5(20) = a(10):
    c5(21) = a(1):  c5(22) = a(2):  c5(23) = a(3):  c5(24) = a(4):  c5(25) = a(5):
    Return
    
'   Exclude solutions with identical numbers

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

'   Remove used primes from available primes (PM4)

900 For i1 = 1 To 16
        b1(a(i1)) = 0
    Next i1
    Return
   
'   Remove used primes from available primes (2 x PM5)

950 For i1 = 1 To 25
        b1(b5(i1)) = 0: b1(c5(i1)) = 0
    Next i1
    Return
   
End Sub

Vorige Pagina About the Author