' Searches for 4 x 4 Magic Squares of Squares
' Tested with Office 2007 under Windows 7
Sub SqrSqr4a()
Dim a(16)
y = MsgBox("Locked", vbCritical, "Routine SqrsSqrs4a")
End
n1 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 87
m3 = m1 ^ 2: m4 = m2 ^ 2
sMin = 2823
sMax = 9775
Sheets("Klad1").Select
t1 = Timer
For j100 = sMin To sMax 'Magic sum
n10 = 0: s1 = j100
Cells(k1 + 1, 1).Value = j100
For j16 = m1 To m2 'a(16) = 9
Cells(k1 + 2, 1).Value = j16
a(16) = j16 ^ 2
For j15 = m1 To m2 'a(15) = 44
Cells(k1 + 3, 1).Value = j15
a(15) = j15 ^ 2
i10 = 15: GoSub 850: If fl1 = 0 Then GoTo 150
For j14 = m1 To m2 'a(14) = 27
a(14) = j14 ^ 2
i10 = 14: GoSub 850: If fl1 = 0 Then GoTo 140
a(13) = s1 - a(14) - a(15) - a(16)
If a(13) < m3 Or a(13) > m4 Then GoTo 140
i10 = 13: GoSub 850: If fl1 = 0 Then GoTo 140
a2 = Sqr(a(13)): If Int(a2) <> a2 Then GoTo 140
For j12 = m1 To m2 'a(12) = 42
a(12) = j12 ^ 2
i10 = 12: GoSub 850: If fl1 = 0 Then GoTo 120
For j11 = m1 To m2 'a(11) = 13
a(11) = j11 ^ 2
i10 = 11: GoSub 850: If fl1 = 0 Then GoTo 110
For j10 = m1 To m2 'a(10) = 36
a(10) = j10 ^ 2
i10 = 10: GoSub 850: If fl1 = 0 Then GoTo 100
a(9) = s1 - a(10) - a(11) - a(12)
If a(9) < m3 Or a(9) > m4 Then GoTo 100
i10 = 9: GoSub 850: If fl1 = 0 Then GoTo 100
a2 = Sqr(a(9)): If Int(a2) <> a2 Then GoTo 100
For j8 = m1 To m2 'a(8) = 32
a(8) = j8 ^ 2
a(7) = a(8) - a(10) + a(12) - a(13) + a(16)
If a(7) < m3 Or a(7) > m4 Then GoTo 80
a2 = Sqr(a(7)): If Int(a2) <> a2 Then GoTo 80
a(6) = s1 - a(8) - a(11) - a(12) + a(13) - a(16)
If a(6) < m3 Or a(6) > m4 Then GoTo 80
a2 = Sqr(a(6)): If Int(a2) <> a2 Then GoTo 80
a(5) = -a(8) + a(10) + a(11)
If a(5) < m3 Or a(5) > m4 Then GoTo 80
a2 = Sqr(a(5)): If Int(a2) <> a2 Then GoTo 80
a(4) = s1 - a(7) - a(10) - a(13)
If a(4) < m3 Or a(4) > m4 Then GoTo 80
a2 = Sqr(a(4)): If Int(a2) <> a2 Then GoTo 80
a(3) = -s1 - a(8) + a(9) + 2 * a(10) + 2 * a(13) + a(14)
If a(3) < m3 Or a(3) > m4 Then GoTo 80
a2 = Sqr(a(3)): If Int(a2) <> a2 Then GoTo 80
a(2) = a(8) - a(9) - 2 * a(10) + a(15) + 2 * a(16)
If a(2) < m3 Or a(2) > m4 Then GoTo 80
a2 = Sqr(a(2)): If Int(a2) <> a2 Then GoTo 80
a(1) = a(8) + a(12) - a(13)
If a(1) < m3 Or a(1) > m4 Then GoTo 80
a2 = Sqr(a(1)): If Int(a2) <> a2 Then GoTo 80
' Exclude solutions with identical numbers
GoSub 800: If fl1 = 0 Then GoTo 80
' n9 = n9 + 1: GoSub 640 'Print results (selected numbers)
n10 = n10 + 1
n9 = n9 + 1: GoSub 650 'Print results (squares)
GoTo 1000 'Print only first square
80 Next j8
100 Next j10
110 Next j11
120 Next j12
140 Next j14
150 Next j15
160 Next j16
n10 = 0
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SqrsSqrs4a")
End
' 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 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
If n10 = 1 Then
Cells(k1, k2 + 1).Value = CStr(n10) + " (MC = " + CStr(s1) + " )"
Else
Cells(k1, k2 + 1).Value = CStr(n10)
End If
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
' Exclude solutions with identical numbers
800 fl1 = 1
For j1 = 1 To 16
a2 = a(j1)
For j2 = (1 + j1) To 16
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Exclude solutions with identical numbers (intermediate check)
850 fl1 = 1
j1 = i10
a2 = a(j1)
For j2 = (1 + j1) To 16
If a2 = a(j2) Then fl1 = 0: Return
Next j2
Return
End Sub
