' Searches for 4 x 4 Magic Squares of Squares
' Parametric Solutions (Euler)
' Tested with Office 365 under Windows 11
Sub SqrsSqr4c()
Dim a1(16) 'Non Quadreatic Terms (Intermediate)
Dim a2(16) 'Quadreatic Terms
Dim s2(10)
y = MsgBox("Locked", vbCritical, "Routine Euler4a")
End
n1 = 0: n9 = 0: k1 = 1: k2 = 1
Sheets("Klad1").Select
t1 = Timer
' Define Parameter Ranges
ma1 = 1: ma2 = 9
mb1 = 1: mb2 = 25: 'k
mc1 = 5: mc2 = 18: 'mc1 > 0
md1 = 0: md2 = 4:
mp1 = 1: mp2 = 6
mq1 = 2: mq2 = 8:
mr1 = 6: mr2 = 21:
ms1 = -12: ms2 = -3:
For a = ma1 To ma2
For c = mc1 To mc2
For d = md1 To md2
For p = mp1 To mp2
For q = mq1 To mq2
For r = mr1 To mr2
For s = ms1 To ms2
For b = mb1 To mb2
GoSub 100: If fl1 = 0 Then GoTo 5 'Initiate Model
'' GoSub 900: ''If fl1 = 0 Then GoTo 5 'Check if only odd or even numbers (Option)
'' If n10 < 14 Then GoTo 5
For i1 = 1 To 16
a2(i1) = a1(i1) ^ 2
Next i1
' Check identical integers
GoSub 800: If fl1 = 0 Then GoTo 5
' Check Magic Properties a2()
GoSub 850: If fl1 = 0 Then GoTo 5
n9 = n9 + 1: GoSub 650 'Print (Squared) Integers
'' n9 = n9 + 1: GoSub 700 'Print parameters
5
Next b
Next s
Next r
Next q
Next p
Next d
Next c
Next a
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine Euler4a")
End
' Non Quadreatic Terms (Intermediate)
100 fl1 = 1
Chk1 = (p * r + q * s)
If Chk1 <> 0 Then fl1 = 0: Return
chk21 = (b * (p * q + r * s) + d * (p * s + q * r)) 'Prevent devision by zero
If chk21 = 0 Then fl1 = 0: Return
Chk2 = (-d * (p * q + r * s) - b * (p * s + q * r)) / (b * (p * q + r * s) + d * (p * s + q * r))
If Chk2 <> (a / c) Then fl1 = 0: Return
s20 = (a ^ 2 + b ^ 2 + c ^ 2 + d ^ 2) * (p ^ 2 + q ^ 2 + r ^ 2 + s ^ 2)
a1(1) = (a * p + b * q + c * r + d * s)
a1(2) = (a * r - b * s - c * p + d * q)
a1(3) = (-a * s - b * r + c * q + d * p)
a1(4) = (a * q - b * p + c * s - d * r)
a1(5) = (-a * q + b * p + c * s - d * r)
a1(6) = (a * s + b * r + c * q + d * p)
a1(7) = (a * r - b * s + c * p - d * q)
a1(8) = (a * p + b * q - c * r - d * s)
a1(9) = (a * r + b * s - c * p - d * q)
a1(10) = (-a * p + b * q - c * r + d * s)
a1(11) = (a * q + b * p + c * s + d * r)
a1(12) = (a * s - b * r - c * q + d * p)
a1(13) = (-a * s + b * r - c * q + d * p)
a1(14) = (-a * q - b * p + c * s + d * r)
a1(15) = (-a * p + b * q + c * r - d * s)
a1(16) = (a * r + b * s + c * p + d * q)
Return
' Print results (squares)
650 n1 = n1 + 1
If n1 = 5 Then
n1 = 1: k1 = k1 + 5: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 5
End If
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = s20
Cells(k1, k2 + 4).Value = b
i3 = 0
For i1 = 1 To 4
For i2 = 1 To 4
i3 = i3 + 1
'' Cells(k1 + i1, k2 + i2).Value = a2(i3)
Cells(k1 + i1, k2 + i2).Value = Sqr(a2(i3))
Next i2
Next i1
Return
' Print Parameters
700
Cells(n9, 1).Value = a
Cells(n9, 2).Value = b
Cells(n9, 3).Value = c
Cells(n9, 4).Value = d
Cells(n9, 5).Value = p
Cells(n9, 6).Value = q
Cells(n9, 7).Value = r
Cells(n9, 8).Value = s
Cells(n9, 9).Value = s20
Cells(n9, 10).Value = n9
Cells(1, 11).Value = n9
Return
' Print Square (line format)
750 For i1 = 10 To 25
Cells(n9, 9).Value = Sqr(a2(i1 - 9))
Next i1
Return
' Exclude solutions with identical (squared) numbers
800 fl1 = 1
For j1 = 1 To 16
a20 = a2(j1)
For j2 = (1 + j1) To 16
If a20 = a2(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Check Magic Squares of Sqiares a2()
850 fl1 = 1
s2(1) = a2(1) + a2(2) + a2(3) + a2(4)
'' s20 = s2(1)
s2(2) = a2(5) + a2(6) + a2(7) + a2(8)
s2(3) = a2(9) + a2(10) + a2(11) + a2(12)
s2(4) = a2(13) + a2(14) + a2(15) + a2(16)
s2(5) = a2(1) + a2(5) + a2(9) + a2(13)
s2(6) = a2(2) + a2(6) + a2(10) + a2(14)
s2(7) = a2(3) + a2(7) + a2(11) + a2(15)
s2(8) = a2(4) + a2(8) + a2(12) + a2(16)
s2(9) = a2(1) + a2(6) + a2(11) + a2(16)
s2(10) = a2(4) + a2(7) + a2(10) + a2(13)
For j20 = 1 To 10
If s2(j20) <> s20 Then fl1 = 0: Return
Next j20
Return
' Count Odd or even Numbers
900 fl1 = 0
n10 = 0
For i1 = 1 To 16
If CInt(a1(i1) / 2) <> a1(i1) / 2 Then n10 = n10 + 1 'is odd
'' If CInt(a1(i1) / 2) = a1(i1) / 2 Then n10 = n10 + 1 'is even
Next i1
Return
End Sub
