' Constructs Prime Number Magic Squares of order 8 (Big Primes)
' Tested with Office 365 under Windows 11
Sub Priem8b()
Dim a(64), b(64), c(64)
y = MsgBox("Locked", vbCritical, "Routine Priem8b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
For j1 = 2 To 9
' Read Magic Lines
For j2 = 1 To 8: a(j2) = Sheets("Att1772").Cells(j1, j2).Value: Next j2
For j2 = 1 To 8: b(j2) = Sheets("Att1772").Cells(j1, j2 + 9).Value: Next j2
s1 = Sheets("Att1772").Cells(j1, 21).Value
' Construct squares a() and b()
a(9) = a(5): a(10) = a(6): a(11) = a(7): a(12) = a(8): a(13) = a(1): a(14) = a(2):
a(15) = a(3): a(16) = a(4):
a(17) = a(4): a(18) = a(3): a(19) = a(2): a(20) = a(1): a(21) = a(8): a(22) = a(7):
a(23) = a(6): a(24) = a(5):
a(25) = a(8): a(26) = a(7): a(27) = a(6): a(28) = a(5): a(29) = a(4): a(30) = a(3):
a(31) = a(2): a(32) = a(1):
a(33) = a(7): a(34) = a(8): a(35) = a(5): a(36) = a(6): a(37) = a(3): a(38) = a(4):
a(39) = a(1): a(40) = a(2):
a(41) = a(3): a(42) = a(4): a(43) = a(1): a(44) = a(2): a(45) = a(7): a(46) = a(8):
a(47) = a(5): a(48) = a(6):
a(49) = a(6): a(50) = a(5): a(51) = a(8): a(52) = a(7): a(53) = a(2): a(54) = a(1):
a(55) = a(4): a(56) = a(3):
a(57) = a(2): a(58) = a(1): a(59) = a(4): a(60) = a(3): a(61) = a(6): a(62) = a(5):
a(63) = a(8): a(64) = a(7):
b(9) = b(3): b(10) = b(4): b(11) = b(1): b(12) = b(2): b(13) = b(7): b(14) = b(8):
b(15) = b(5): b(16) = b(6):
b(17) = b(5): b(18) = b(6): b(19) = b(7): b(20) = b(8): b(21) = b(1): b(22) = b(2):
b(23) = b(3): b(24) = b(4):
b(25) = b(7): b(26) = b(8): b(27) = b(5): b(28) = b(6): b(29) = b(3): b(30) = b(4):
b(31) = b(1): b(32) = b(2):
b(33) = b(6): b(34) = b(5): b(35) = b(8): b(36) = b(7): b(37) = b(2): b(38) = b(1):
b(39) = b(4): b(40) = b(3):
b(41) = b(8): b(42) = b(7): b(43) = b(6): b(44) = b(5): b(45) = b(4): b(46) = b(3):
b(47) = b(2): b(48) = b(1):
b(49) = b(2): b(50) = b(1): b(51) = b(4): b(52) = b(3): b(53) = b(6): b(54) = b(5):
b(55) = b(8): b(56) = b(7):
b(57) = b(4): b(58) = b(3): b(59) = b(2): b(60) = b(1): b(61) = b(8): b(62) = b(7):
b(63) = b(6): b(64) = b(5):
' Calculate Square c()
For j2 = 1 To 64
c(j2) = 1000 * a(j2) + b(j2)
Next j2
' Print results
GoSub 800: If fl1 = 0 Then GoTo 70
'' n9 = n9 + 1: GoSub 640 'Lines
n9 = n9 + 1: GoSub 650 'Squares
70 Next j1
End
' Print results (selected numbers)
640 For i1 = 1 To 64
Cells(n9, i1).Value = c(i1)
Next i1
Cells(n9, 65).Select
Cells(n9, 65).Value = s1
n10 = Sheets("Att1772").Cells(j1, 21).Value
Cells(n9, 66).Value = n10
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 2 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = "MC = " + CStr(s1)
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers
800 fl1 = 1
For j10 = 1 To 64
c2 = c(j10)
For j20 = (1 + j10) To 64
If c2 = c(j20) Then fl1 = 0: Return
Next j20
Next j10
Return
End Sub
