' Generates Prime Number Composed Magic Squares of Order 9
' Tested with Office 2007 under Windows 7
Sub PriemF9()
Dim a1(1944), a13(169), a(25), b1(43300), b(43300), c(25)
Dim a2(16), c2(16) 'Scratch Areas
Dim a4(16), b4(16), d4(16), e4(16), c5(25), g5(25) 'Sub Squares
Dim a8 As Long
y = MsgBox("Locked", vbCritical, "Routine PriemF9")
End
n2 = 0: n3 = 0: k1 = 1: k2 = 1: n9 = 0: n10 = 0
Sht1 = "Pairs7"
' Generate Squares
Sheets("Klad1").Select
t1 = Timer
For j100 = 380 To 632
' Start Reading Data M5c/M5g
Rcrd1a = Sheets("M5c").Cells(j100, 27).Value
MC5c = Sheets("M5c").Cells(j100, 26).Value
Rcrd1b = Sheets("M5g").Cells(j100, 27).Value
MC5g = Sheets("M5g").Cells(j100, 26).Value
If Rcrd1a <> Rcrd1b Or MC5c <> MC5g Then
y = MsgBox("Conflict in Data", vbCritical, "Read M5c/g")
End
End If
' Read Prime Numbers From Sheet Sht1
Pr4 = Sheets(Sht1).Cells(Rcrd1a, 1).Value 'Pairsum
s1 = 2 * Pr4 'PM4
s13 = 13 * s1 / 4 'M13
s7 = 7 * s1 / 4 'M7
nVar = Sheets(Sht1).Cells(Rcrd1a, 9).Value
If nVar < 169 Then GoTo 1000
m1 = 1: m2 = nVar
For i1 = m1 To m2
a1(i1) = Sheets(Sht1).Cells(Rcrd1a, i1 + 9).Value
Next i1
If a1(1) = 1 Then m1 = m1 + 1: m2 = m2 - 1
Erase b1
For i1 = m1 To m2
b1(a1(i1)) = a1(i1)
Next i1
' Read Prime Numbers used for M5c/M5g
For i1 = 1 To 25
a(i1) = Sheets("M5c").Cells(j100, i1).Value
Next i1
GoSub 700 'Fill c5()
For i1 = 1 To 25
a(i1) = Sheets("M5g").Cells(j100, i1).Value
Next i1
GoSub 750 'Fill g5()
GoSub 600 'Compose Main Square based on c5() and g(5)
s72 = a13(83) + a13(97) + a13(111)
GoSub 950 'Remove used primes from available primes
Erase a 'Clear Scratch Area
' Determine Diagonal 7 x 7
t11 = Timer 'Time Out
For jj10 = m1 To m2
If b1(a1(jj10)) = 0 Then GoTo 100
If b(a1(jj10)) = 0 Then b(a1(jj10)) = a1(jj10): c(10) = a1(jj10) Else GoTo 100
a(10) = a1(jj10)
a(14) = Pr4 - a(10): If b(a(14)) = 0 Then b(a(14)) = a(14): c(14) = a(14) Else GoTo 140
For jj11 = m1 To m2
If b1(a1(jj11)) = 0 Then GoTo 110
If b(a1(jj11)) = 0 Then b(a1(jj11)) = a1(jj11): c(11) = a1(jj11) Else GoTo 110
a(11) = a1(jj11)
t12 = Timer: t13 = t12 - t11 'Time Out
If t13 > 60 Then Erase b, c: t11 = Timer: GoTo 100 'Time Out, Try Next jj10
a(15) = Pr4 - a(11): If b(a(15)) = 0 Then b(a(15)) = a(15): c(15) = a(15) Else GoTo 150
For jj12 = m1 To m2
If b1(a1(jj12)) = 0 Then GoTo 120
If b(a1(jj12)) = 0 Then b(a1(jj12)) = a1(jj12): c(12) = a1(jj12) Else GoTo 120
a(12) = a1(jj12)
a(16) = Pr4 - a(12): If b(a(16)) = 0 Then b(a(16)) = a(16): c(16) = a(16) Else GoTo 160
a(13) = (s7 - s72) - a(12) - a(11) - a(10)
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
a(17) = Pr4 - a(13): If b(a(17)) = 0 Then b(a(17)) = a(17): c(17) = a(17) Else GoTo 170
' Assign Results
a13(55) = a(10): a13(56) = a(14)
a13(68) = a(15): a13(69) = a(11)
a13(125) = a(12): a13(126) = a(17)
a13(138) = a(16): a13(139) = a(13)
' Generate 4 x 4 Squares
a2(12) = a13(69): a2(11) = a13(68)
a2(16) = a13(56): a2(15) = a13(55)
GoSub 2000: 'Determine Square b4()
If fl1 = 0 Then GoTo 165
a2(12) = a13(125): a2(11) = a13(138)
a2(16) = a13(126): a2(15) = a13(139)
GoSub 2000: 'Determine Square d4()
If fl1 = 0 Then n10 = 0: GoTo 165
GoSub 850: If fl1 = 0 Then GoTo 165 'Back Check Identical Numbers a13()
'' n9 = n9 + 1: GoSub 650 'Print Square a13()
n9 = n9 + 1: GoSub 660 'Print Lines a13()
Erase b, c: n10 = 0: GoTo 1000 'Print Only First Solution
165 b(c(17)) = 0: c(17) = 0
170 b(c(13)) = 0: c(13) = 0
130 b(c(16)) = 0: c(16) = 0
160 b(c(12)) = 0: c(12) = 0
120 Next jj12
b(c(15)) = 0: c(15) = 0
150 b(c(11)) = 0: c(11) = 0
110 Next jj11
b(c(14)) = 0: c(14) = 0
140 b(c(10)) = 0: c(10) = 0
100 Next jj10
n10 = 0
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine PriemF9")
End
' Generate Prime Number Magic Border Squares (4 x 4)
2000 fl1 = 1
' a2(16), a2(15)
For j14 = m1 To m2 'a2(14)
If b1(a1(j14)) = 0 Then GoTo 2140
If b(a1(j14)) = 0 Then b(a1(j14)) = a1(j14): c2(14) = a1(j14) Else GoTo 2140
a2(14) = a1(j14)
a2(13) = s1 / 2 - a2(14)
If a2(13) < a1(m1) Or a2(13) > a1(m2) Then GoTo 2130
If b1(a2(13)) = 0 Then GoTo 2130
If b(a2(13)) = 0 Then b(a2(13)) = a2(13): c2(13) = a2(13) Else GoTo 2130
' a2(12), a2(11)
For j10 = m1 To m2 'a2(10)
If b1(a1(j10)) = 0 Then GoTo 2100
If b(a1(j10)) = 0 Then b(a1(j10)) = a1(j10): c2(10) = a1(j10) Else GoTo 2100
a2(10) = a1(j10)
a2(9) = s1 / 2 - a2(10):
If a2(9) < a1(m1) Or a2(9) > a1(m2) Then GoTo 2090:
If b1(a2(9)) = 0 Then GoTo 2090
If b(a2(9)) = 0 Then b(a2(9)) = a2(9): c2(9) = a2(9) Else GoTo 2090
a2(8) = (s1 + a2(10) - a2(12) - a2(14) - a2(16)) / 2:
a8 = a2(8)
If CLng(a8) <> a8 Then GoTo 2080
If a2(8) < a1(m1) Or a2(8) > a1(m2) Then GoTo 2080:
If b1(a2(8)) = 0 Then GoTo 2080
If b(a2(8)) = 0 Then b(a2(8)) = a2(8): c2(8) = a2(8) Else GoTo 2080
a2(7) = s1 / 2 - a2(8):
If a2(7) < a1(m1) Or a2(7) > a1(m2) Then GoTo 2070:
If b1(a2(7)) = 0 Then GoTo 2070
If b(a2(7)) = 0 Then b(a2(7)) = a2(7): c2(7) = a2(7) Else GoTo 2070
a2(6) = s1 / 2 - a2(7) - a2(10) + a2(12):
If a2(6) < a1(m1) Or a2(6) > a1(m2) Then GoTo 2060:
If b1(a2(6)) = 0 Then GoTo 2060
If b(a2(6)) = 0 Then b(a2(6)) = a2(6): c2(6) = a2(6) Else GoTo 2060
a2(5) = s1 / 2 - a2(6):
If a2(5) < a1(m1) Or a2(5) > a1(m2) Then GoTo 2050:
If b1(a2(5)) = 0 Then GoTo 2050
If b(a2(5)) = 0 Then b(a2(5)) = a2(5): c2(5) = a2(5) Else GoTo 2050
a2(4) = s1 / 2 - a2(5) - a2(12) + a2(14):
If a2(4) < a1(m1) Or a2(4) > a1(m2) Then GoTo 2040:
If b1(a2(4)) = 0 Then GoTo 2040
If b(a2(4)) = 0 Then b(a2(4)) = a2(4): c2(4) = a2(4) Else GoTo 2040
a2(3) = s1 / 2 - a2(4):
If a2(3) < a1(m1) Or a2(3) > a1(m2) Then GoTo 2030:
If b1(a2(3)) = 0 Then GoTo 2030
If b(a2(3)) = 0 Then b(a2(3)) = a2(3): c2(3) = a2(3) Else GoTo 2030
a2(2) = s1 - a2(4) - a2(10) - a2(12):
If a2(2) < a1(m1) Or a2(2) > a1(m2) Then GoTo 2020:
If b1(a2(2)) = 0 Then GoTo 2020
If b(a2(2)) = 0 Then b(a2(2)) = a2(2): c2(2) = a2(2) Else GoTo 2020
a2(1) = s1 / 2 - a2(2):
If a2(1) < a1(m1) Or a2(1) > a1(m2) Then GoTo 2010:
If b1(a2(1)) = 0 Then GoTo 2010
If b(a2(1)) = 0 Then b(a2(1)) = a2(1): c2(1) = a2(1) Else GoTo 2010
n10 = n10 + 1
Select Case n10
Case 1:
For i1 = 1 To 16: b4(i1) = a2(i1): Next i1
GoSub 610 'Add to Main Square (b4)
Case 2:
For i1 = 1 To 16: d4(i1) = a2(i1): Next i1
GoSub 620 'Add to Main Square (d4)
End Select
Return
2005 b(c2(1)) = 0: c2(1) = 0
2010 b(c2(2)) = 0: c2(2) = 0
2020 b(c2(3)) = 0: c2(3) = 0
2030 b(c2(4)) = 0: c2(4) = 0
2040 b(c2(5)) = 0: c2(5) = 0
2050 b(c2(6)) = 0: c2(6) = 0
2060 b(c2(7)) = 0: c2(7) = 0
2070 b(c2(8)) = 0: c2(8) = 0
2080 b(c2(9)) = 0: c2(9) = 0
2090 b(c2(10)) = 0: c2(10) = 0
2100 Next j10
b(c2(13)) = 0: c2(13) = 0
2130 b(c2(14)) = 0: c2(14) = 0
2140 Next j14
fl1 = 0
Return
' Compose Main Square based on g5() and c5()
600 Erase a13
a13(105) = g5(1): a13(106) = g5(2): a13(107) = g5(3): a13(108) = g5(4): a13(109) = g5(5):
a13(118) = g5(6): a13(119) = g5(7): a13(120) = g5(8): a13(121) = g5(9): a13(122) = g5(10):
a13(131) = g5(11): a13(132) = g5(12): a13(133) = g5(13): a13(134) = g5(14): a13(135) = g5(15):
a13(144) = g5(16): a13(145) = g5(17): a13(146) = g5(18): a13(147) = g5(19): a13(148) = g5(20):
a13(157) = g5(21): a13(158) = g5(22): a13(159) = g5(23): a13(160) = g5(24): a13(161) = g5(25):
a13(57) = c5(1): a13(58) = c5(2): a13(59) = c5(3): a13(60) = c5(4): a13(61) = c5(5):
a13(70) = c5(6): a13(71) = c5(7): a13(72) = c5(8): a13(73) = c5(9): a13(74) = c5(10):
a13(83) = c5(11): a13(84) = c5(12): a13(85) = c5(13): a13(86) = c5(14): a13(87) = c5(15):
a13(96) = c5(16): a13(97) = c5(17): a13(98) = c5(18): a13(99) = c5(19): a13(100) = c5(20):
a13(109) = c5(21): a13(110) = c5(22): a13(111) = c5(23): a13(112) = c5(24): a13(113) = c5(25):
Return
' Add to Main Square (b4)
610
a13(53) = b4(13): a13(54) = b4(14): a13(55) = b4(15): a13(56) = b4(16):
a13(66) = b4(9): a13(67) = b4(10): a13(68) = b4(11): a13(69) = b4(12):
a13(79) = b4(5): a13(80) = b4(6): a13(81) = b4(7): a13(82) = b4(8):
a13(92) = b4(1): a13(93) = b4(2): a13(94) = b4(3): a13(95) = b4(4):
Return
' Add to Main Square (d4)
620
a13(123) = d4(4): a13(124) = d4(8): a13(125) = d4(12): a13(126) = d4(16):
a13(136) = d4(3): a13(137) = d4(7): a13(138) = d4(11): a13(139) = d4(15):
a13(149) = d4(2): a13(150) = d4(6): a13(151) = d4(10): a13(152) = d4(14):
a13(162) = d4(1): a13(163) = d4(5): a13(164) = d4(9): a13(165) = d4(13):
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 3 Then
n2 = 1: k1 = k1 + 14: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 14
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = "MC = " + CStr(s13)
i3 = 0
For i1 = 1 To 13
For i2 = 1 To 13
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a13(i3)
Next i2
Next i1
Return
' Print results (selected numbers)
660 For i1 = 1 To 169
Cells(n9, i1).Value = a13(i1)
Next i1
Cells(n9, 170).Value = s13 'Magic Constant 13 x 13
Cells(n9, 171).Select
Cells(n9, 171).Value = Rcrd1a 'Record Nr
Return
' Transform Ultra Magic Squares into c5()
700 c5(1) = a(18): c5(2) = a(19): c5(3) = a(20): c5(4) = a(16): c5(5) = a(17):
c5(6) = a(23): c5(7) = a(24): c5(8) = a(25): c5(9) = a(21): c5(10) = a(22):
c5(11) = a(3): c5(12) = a(4): c5(13) = a(5): c5(14) = a(1): c5(15) = a(2):
c5(16) = a(8): c5(17) = a(9): c5(18) = a(10): c5(19) = a(6): c5(20) = a(7):
c5(21) = a(13): c5(22) = a(14): c5(23) = a(15): c5(24) = a(11): c5(25) = a(12):
Return
750 For i1 = 1 To 25
g5(i1) = a(i1)
Next i1
Return
' Exclude solutions with identical numbers (M13)
850 fl1 = 1
For j1 = 1 To 169
a20 = a13(j1): If a20 = 0 Then GoTo 860
For j2 = (1 + j1) To 169
If a20 = a13(j2) Then fl1 = 0: Return
Next j2
860 Next j1
Return
' Remove used primes from available primes M5c/M5g
950 For i1 = 1 To 25
b1(c5(i1)) = 0: b1(g5(i1)) = 0
Next i1
Return
End Sub
