' Generates Pan Magic Squares of order 4 for integers 1 thru 16
' Tested with Office 2007 under Windows 7
Sub MgcSqr4()
Dim c(2500, 4), a1(4), a(16), s(16), i1(3, 16)
'
' Possible solution for integers 0 thru 15 : 16 * (0 + 15) / (2 * 4) = 30
'
' Possible solution for integers 1 thru 16 : 16 * (1 + 16) / (2 * 4) = 34
' (Same diagrams, value elements + 1)
n1 = 0: n2 = 0: n9 = 0
m1 = 1: m2 = 16: s1 = 34
For j1 = m1 To m2 '2064 results
For j2 = m1 To m2
If j2 = j1 Then GoTo 120
For j3 = m1 To m2
If j3 = j2 Or j3 = j1 Then GoTo 110
For j4 = m1 To m2
If j4 = j3 Or j4 = j2 Or j4 = j1 Then GoTo 100
s2 = j1 + j2 + j3 + j4
If s2 = s1 Then
n1 = n1 + 1
c(n1, 1) = j1: c(n1, 2) = j2: c(n1, 3) = j3: c(n1, 4) = j4
'Cells(n1, 1).Value = j1: Cells(n1, 2).Value = j2
'Cells(n1, 3).Value = j3: Cells(n1, 4).Value = j4
End If
100 Next j4
110 Next j3
120 Next j2
130 Next j1
End
' kies element
t1 = Timer
For j6 = 1 To n1
For j1 = 1 To 4: a1(j1) = c(j6, j1): Next j1
GoSub 500 'genereer en bereken oplossingen
Next j6
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr4")
End
' kies vier elementen
500 For j2 = 1 To 4: a(j2 + 12) = a1(j2): Next j2
For j1 = m1 To m2
If j1 = a(13) Or j1 = a(14) Or j1 = a(15) Or j1 = a(16) Then GoTo 510
a(12) = j1
GoSub 700 'bereken overige mogelijke oplossingen
GoSub 600 'check of gegenereerde oplossingen goed zijn
If fl1 = 0 Then GoTo 510
GoSub 800 'eliminatie routine
If fl1 = 1 Then
n9 = n9 + 1
' GoSub 640 'Print results (selected numbers)
GoSub 650 'Print results (squares)
End If
510 Next j1
Return
' Check gegenereerde combinaties
' a (1) , a(2) , a(3) , a(4)
' a (5) , a(6) , a(7) , a(8)
' a (9) , a(10), a(11), a(12)
' a (13), a(14), a(15), a(16)
600 fl1 = 1
s(1) = a(1) + a(2) + a(3) + a(4): If s1 <> s(1) Then fl1 = 0: Return
s(2) = a(5) + a(6) + a(7) + a(8): If s1 <> s(2) Then fl1 = 0: Return
s(3) = a(9) + a(10) + a(11) + a(12): If s1 <> s(3) Then fl1 = 0: Return
s(4) = a(13) + a(14) + a(15) + a(16): If s1 <> s(4) Then fl1 = 0: Return
s(5) = a(1) + a(5) + a(9) + a(13): If s1 <> s(5) Then fl1 = 0: Return
s(6) = a(2) + a(6) + a(10) + a(14): If s1 <> s(6) Then fl1 = 0: Return
s(7) = a(3) + a(7) + a(11) + a(15): If s1 <> s(7) Then fl1 = 0: Return
s(8) = a(4) + a(8) + a(12) + a(16): If s1 <> s(8) Then fl1 = 0: Return
s(9) = a(1) + a(6) + a(11) + a(16): If s1 <> s(9) Then fl1 = 0: Return
s(10) = a(2) + a(7) + a(12) + a(13): If s1 <> s(10) Then fl1 = 0: Return
s(11) = a(3) + a(8) + a(9) + a(14): If s1 <> s(11) Then fl1 = 0: Return
s(12) = a(4) + a(5) + a(10) + a(15): If s1 <> s(12) Then fl1 = 0: Return
s(13) = a(4) + a(7) + a(10) + a(13): If s1 <> s(13) Then fl1 = 0: Return
s(14) = a(3) + a(6) + a(9) + a(16): If s1 <> s(14) Then fl1 = 0: Return
s(15) = a(2) + a(5) + a(12) + a(15): If s1 <> s(15) Then fl1 = 0: Return
s(16) = a(1) + a(8) + a(11) + a(14): If s1 <> s(16) Then fl1 = 0: Return
Return
' Print results (selected numbers)
640 For i1 = 1 To 16
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 5: k2 = 0
Else
If n9 > 1 Then k2 = k2 + 5
End If
Cells(k1 + 1, k2 + 1).Select
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
' bereken mogelijke oplossingen
700 a(13) = s1 - a(14) - a(15) - a(16)
a(11) = s1 - a(12) - a(15) - a(16)
a(10) = a(12) - a(14) + a(16)
a(9) = -a(12) + a(14) + a(15)
a(8) = 0.5 * s1 - a(14)
a(7) = -0.5 * s1 + a(14) + a(15) + a(16)
a(6) = 0.5 * s1 - a(16)
a(5) = 0.5 * s1 - a(15)
a(4) = 0.5 * s1 - a(12) + a(14) - a(16)
a(3) = 0.5 * s1 + a(12) - a(14) - a(15)
a(2) = 0.5 * s1 - a(12)
a(1) = -0.5 * s1 + a(12) + a(15) + a(16)
Return
' Eliminatie routine
800 fl1 = 1
For j10 = 1 To 16 'sluit < m1, > m2 en gebroken getallen uit
If a(j10) < m1 Or a(j10) > m2 Or Int(a(j10)) <> a(j10) Then fl1 = 0: GoTo 850
a2 = a(j10)
For j20 = (1 + j10) To 16
If a2 = a(j20) Then fl1 = 0: GoTo 850 'sluit gelijke getallen uit
Next j20
Next j10
850 Return
End Sub
