' Generates Prime Number Composed Magic Squares of Order 13 (Partly Completed)
' Adds Magic Border Squares of Order 4 (A and E)
' Tested with Office 2007 under Windows 7
Sub PriemJ13()
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 PriemJ13")
End
n2 = 0: n3 = 0: k1 = 1: k2 = 1: n9 = 0: n10 = 0
ShtNm1 = "Pairs7"
ShtNm2 = "M13"
' Generate Squares
Sheets("Klad1").Select
t1 = Timer
For j100 = 9 To 91
Cells(k1, 1).Select: Cells(k1, 1).Value = j100
' Start Reading Data M13
Rcrd1a = Sheets(ShtNm2).Cells(j100, 171).Value
' Read Prime Numbers From Sheet Sht1
Pr4 = Sheets(ShtNm1).Cells(Rcrd1a, 1).Value 'Pairsum
s1 = 2 * Pr4 'PM4
s13 = 13 * s1 / 4 'M13
nVar = Sheets(ShtNm1).Cells(Rcrd1a, 9).Value
If nVar < 169 Then GoTo 1000
m1 = 1: m2 = nVar
Erase b1
For j1 = 1 To nVar
x = Sheets(ShtNm1).Cells(Rcrd1a, 9 + j1).Value
b1(x) = x
Next j1
pMax = Sheets(ShtNm1).Cells(Rcrd1a, 9 + nVar).Value
' Read Partly Completed Square 13 x 13
For i1 = 1 To 169
a13(i1) = Sheets(ShtNm2).Cells(j100, i1).Value
Next i1
GoSub 950 'Remove used primes from available primes
' Restore available pairs in a1()
n10 = 0
For j1 = 1 To pMax
If b1(j1) <> 0 Then
n10 = n10 + 1
a1(n10) = b1(j1)
End If
Next j1
m1 = 1: m2 = n10: n10 = 0
If a1(1) = 1 Then m1 = 2: m2 = m2 - 1
Erase a 'Clear Scratch Area
' Determine Diagonal 11 x 11
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) = s1 - 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(3) = a(10): a13(4) = a(14)
a13(16) = a(15): a13(17) = a(11)
a13(129) = a(12): a13(130) = a(17)
a13(142) = a(16): a13(143) = a(13)
' Generate 4 x 4 Squares
a2(12) = a13(17): a2(11) = a13(16)
a2(16) = a13(4): a2(15) = a13(3)
GoSub 2000: 'Determine Square a4()
If fl1 = 0 Then GoTo 165
a2(12) = a13(129): a2(11) = a13(142)
a2(16) = a13(130): a2(15) = a13(143)
GoSub 2000: 'Determine Square e4()
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 PriemJ13")
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: a4(i1) = a2(i1): Next i1
GoSub 610 'Add to Main Square (a4)
Case 2:
For i1 = 1 To 16: e4(i1) = a2(i1): Next i1
GoSub 620 'Add to Main Square (e4)
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
' Add to Main Square (a4)
610
a13(1) = a4(13): a13(2) = a4(14): a13(3) = a4(15): a13(4) = a4(16):
a13(14) = a4(9): a13(15) = a4(10): a13(16) = a4(11): a13(17) = a4(12):
a13(27) = a4(5): a13(28) = a4(6): a13(29) = a4(7): a13(30) = a4(8):
a13(40) = a4(1): a13(41) = a4(2): a13(42) = a4(3): a13(43) = a4(4):
Return
' Add to Main Square (e4)
620
a13(127) = e4(4): a13(128) = e4(8): a13(129) = e4(12): a13(130) = e4(16):
a13(140) = e4(3): a13(141) = e4(7): a13(142) = e4(11): a13(143) = e4(15):
a13(153) = e4(2): a13(154) = e4(6): a13(155) = e4(10): a13(156) = e4(14):
a13(166) = e4(1): a13(167) = e4(5): a13(168) = e4(9): a13(169) = e4(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).Select
Cells(n9, 170).Value = s13 'Magic Constant 13 x 13
Cells(n9, 171).Value = Rcrd1a 'Record Nr
Return
' Exclude solutions with identical numbers
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
950 For i1 = 1 To 169
b1(a13(i1)) = 0
Next i1
Return
End Sub
