' Searches for Simple Magic Squares of order 3
' Consecutive Big Primes
' Tested with Office 2007 under Windows 7
Sub Priem3a()
Dim a1(400), a11(9), a(9), b1(1000), b(1000), c(9)
Dim Txt1 As String
y = MsgBox("Locked", vbCritical, "Routine Priem3a")
End
n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
t1 = Timer
' Read Prime Numbers From sheet "Primes"
Sheets("Klad1").Select
i10 = 0: nMax = 1000000
For j10 = 1 To nMax 'Rows 'Primes1': j10 = 18 To nMax (a1() > 1000)
For j20 = 1 To 10 'Columns
i10 = i10 + 1
Txt1 = Sheets("Primes").Cells(j10, j20).Value
l10 = Len(Txt1)
Txt2 = Mid(Txt1, l10 - 2) 'Last 3 Characters
a1(i10) = CInt(Txt2)
If i10 > 1 Then
If a1(i10) < a1(i10 - 1) Then
a20 = a1(i10): m2 = i10 - 1
For j30 = 1 To m2 - 8
i4 = 0
s3 = 0
For j40 = j30 To j30 + 8
i4 = i4 + 1
a11(i4) = a1(j40)
s3 = s3 + a11(i4)
40 Next j40
s1 = s3 / 3: If CInt(s1) <> s1 Then GoTo 30
a5 = s1 / 3: If CInt(a5) <> a5 Then GoTo 30
Pr3 = 2 * a5
If a11(1) + a11(9) <> Pr3 Then GoTo 30
If a11(2) + a11(8) <> Pr3 Then GoTo 30
If a11(3) + a11(7) <> Pr3 Then GoTo 30
If a11(4) + a11(6) <> Pr3 Then GoTo 30
n9 = n9 + 1: GoSub 640
30 Next j30
a1(1) = a20: i10 = 1
End If
End If
20 Next j20
10 Next j10
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine Priem3")
End
' Print results (selected numbers)
640 Cells(n9, 9).Select
For i1 = 1 To 9
Cells(n9, i1).Value = a11(i1) ''a(i1)
Next i1
Cells(n9, 10).Value = s1
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 4: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 4
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = s1
i3 = 0
For i1 = 1 To 3
For i2 = 1 To 3
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' Exclude solutions with identical numbers
800 fl1 = 1
For j1 = 1 To 9
a2 = a(j1)
For j2 = (1 + j1) To 9
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
End Sub
