' Generates Pan Diagonal/Complete Bimagic Squares (Benson/Jacobi)
' Tested with Office 2007 under Windows 7
Sub MgcSqr15314()
Dim a(64), b(64), c(64), a1(8), b1(4)
y = MsgBox("Locked", vbCritical, "Routine MgcSqr15314")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 64: s1 = 260: s2 = 11180: s3 = 540800
ShtNm1 = "MgcLns8"
Sheets("Klad1").Select
t1 = Timer
For j100 = 2 To 9451 ' 4597 = Benson Jacobi
Chk1 = Sheets(ShtNm1).Cells(j100, 9).Value
If Chk1 = "" Then GoTo 1000
For i1 = 1 To 8
a1(i1) = Sheets(ShtNm1).Cells(j100, i1).Value
Next i1
' Batch 1: j64, j63, j62 = 1 to 4 and j60, j59, j58 = 5 to 8
' Batch 2: j64, j63, j62 = 5 to 8 and j60, j59, j58 = 1 to 4
For j64 = 1 To 4 'a(64)
If b(a1(j64)) = 0 Then b(a1(j64)) = a1(j64): c(64) = a1(j64) Else GoTo 640
a(64) = a1(j64)
For j63 = 1 To 4 'a(63)
If b(a1(j63)) = 0 Then b(a1(j63)) = a1(j63): c(63) = a1(j63) Else GoTo 630
a(63) = a1(j63)
For j62 = 1 To 4 'a(62)
If b(a1(j62)) = 0 Then b(a1(j62)) = a1(j62): c(62) = a1(j62) Else GoTo 620
a(62) = a1(j62)
a(61) = 0.5 * s1 - a(62) - a(63) - a(64)
If a(61) < m1 Or a(61) > m2 Then GoTo 610
If b(a(61)) = 0 Then b(a(61)) = a(61): c(61) = a(61) Else GoTo 610
For j60 = 5 To 8 'a(60)
If b(a1(j60)) = 0 Then b(a1(j60)) = a1(j60): c(60) = a1(j60) Else GoTo 600
a(60) = a1(j60)
For j59 = 5 To 8 'a(59)
If b(a1(j59)) = 0 Then b(a1(j59)) = a1(j59): c(59) = a1(j59) Else GoTo 590
a(59) = a1(j59)
For j58 = 5 To 8 'a(58)
If b(a1(j58)) = 0 Then b(a1(j58)) = a1(j58): c(58) = a1(j58) Else GoTo 580
a(58) = a1(j58)
a(57) = 0.5 * s1 - a(58) - a(59) - a(60)
If a(57) < m1 Or a(57) > m2 Then GoTo 570:
If b(a(57)) = 0 Then b(a(57)) = a(57): c(57) = a(57) Else GoTo 570
For j56 = m1 To m2 'a(56)
If b(j56) = 0 Then b(j56) = j56: c(56) = j56 Else GoTo 560
a(56) = j56
For j55 = m1 To m2 'a(55)
If b(j55) = 0 Then b(j55) = j55: c(55) = j55 Else GoTo 550
a(55) = j55
jj = 55
a(54) = 0.5 * s1 - a(55) - a(62) - a(63)
j = 54: GoSub 3000: If fl1 = 1 Then GoTo 550
a(53) = -a(56) + a(62) + a(63)
j = 53: GoSub 3000: If fl1 = 1 Then GoTo 550
a(52) = -0.5 * s1 + a(55) + a(58) + a(62) + a(63) + a(64)
j = 52: GoSub 3000: If fl1 = 1 Then GoTo 550
a(51) = 0.5 * s1 + a(56) - a(58) - a(59) - a(60) - a(62)
j = 51: GoSub 3000: If fl1 = 1 Then GoTo 550
a(50) = -a(56) + a(60) + a(62)
j = 50: GoSub 3000: If fl1 = 1 Then GoTo 550
a(49) = 0.5 * s1 - a(55) + a(59) - a(62) - a(63) - a(64)
j = 49: GoSub 3000: If fl1 = 1 Then GoTo 550
j = 49: GoSub 3100: If fl1 = 1 Then GoTo 550 'Check Bimagic Row 2
For j48 = m1 To m2 'a(48)
If b(j48) = 0 Then b(j48) = j48: c(48) = j48 Else GoTo 480
a(48) = j48
jj = 48
a(47) = a(48) - a(58) - a(60) + a(62) + a(63):
j = 47: GoSub 3000: If fl1 = 1 Then GoTo 480
a(46) = -a(48) + a(58) + a(60):
j = 46: GoSub 3000: If fl1 = 1 Then GoTo 480
a(45) = 0.5 * s1 - a(48) - a(62) - a(63):
j = 45: GoSub 3000: If fl1 = 1 Then GoTo 480
a(44) = a(48) - a(58) - a(59) - a(60) + a(62) + a(63) + a(64):
j = 44: GoSub 3000: If fl1 = 1 Then GoTo 480
a(43) = a(48) - a(60) + a(63):
j = 43: GoSub 3000: If fl1 = 1 Then GoTo 480
a(42) = -a(48) + a(58) + a(59) + a(60) - a(63):
j = 42: GoSub 3000: If fl1 = 1 Then GoTo 480
a(41) = 0.5 * s1 - a(48) + a(60) - a(62) - a(63) - a(64):
j = 41: GoSub 3000: If fl1 = 1 Then GoTo 480
a(40) = -a(48) - a(56) + a(58) + a(60) + a(62):
j = 40: GoSub 3000: If fl1 = 1 Then GoTo 480
a(39) = s1 - a(48) - a(55) - 2 * a(62) - 2 * a(63) - a(64):
j = 39: GoSub 3000: If fl1 = 1 Then GoTo 480
a(38) = -0.5 * s1 + a(48) + a(55) + a(62) + a(63) + a(64):
j = 38: GoSub 3000: If fl1 = 1 Then GoTo 480
a(37) = a(48) + a(56) - a(58) - a(60) + a(63):
j = 37: GoSub 3000: If fl1 = 1 Then GoTo 480
a(36) = 0.5 * s1 - a(48) - a(55) + a(58) + a(59) + a(60) - a(62) - 2 * a(63) - a(64):
j = 36: GoSub 3000: If fl1 = 1 Then GoTo 480
a(35) = 0.5 * s1 - a(48) - a(56) + a(60) - a(63) - a(64):
j = 35: GoSub 3000: If fl1 = 1 Then GoTo 480
a(34) = a(48) + a(56) - a(58) - a(59) - a(60) + a(63) + a(64):
j = 34: GoSub 3000: If fl1 = 1 Then GoTo 480
a(33) = -0.5 * s1 + a(48) + a(55) - a(60) + a(62) + 2 * a(63) + a(64):
j = 33: GoSub 3000: If fl1 = 1 Then GoTo 480
j = 33: GoSub 3200: If fl1 = 1 Then GoTo 480 'Check Bimagic Rows 3 and 4
' Complete the Square:
a(32) = s1 / 4 - a(60): a(24) = s1 / 4 - a(52): a(16) = s1 / 4 - a(44): a(8) = s1 / 4 - a(36)
a(31) = s1 / 4 - a(59): a(23) = s1 / 4 - a(51): a(15) = s1 / 4 - a(43): a(7) = s1 / 4 - a(35)
a(30) = s1 / 4 - a(58): a(22) = s1 / 4 - a(50): a(14) = s1 / 4 - a(42): a(6) = s1 / 4 - a(34)
a(29) = s1 / 4 - a(57): a(21) = s1 / 4 - a(49): a(13) = s1 / 4 - a(41): a(5) = s1 / 4 - a(33)
a(28) = s1 / 4 - a(64): a(20) = s1 / 4 - a(56): a(12) = s1 / 4 - a(48): a(4) = s1 / 4 - a(40)
a(27) = s1 / 4 - a(63): a(19) = s1 / 4 - a(55): a(11) = s1 / 4 - a(47): a(3) = s1 / 4 - a(39)
a(26) = s1 / 4 - a(62): a(18) = s1 / 4 - a(54): a(10) = s1 / 4 - a(46): a(2) = s1 / 4 - a(38)
a(25) = s1 / 4 - a(61): a(17) = s1 / 4 - a(53): a(9) = s1 / 4 - a(45): a(1) = s1 / 4 - a(37)
' Row 5 ... 8 will be Bimagic
j = 33: GoSub 3300: If fl1 = 1 Then GoTo 480 'Check Bimagic Columns
j = 33: GoSub 3400: If fl1 = 1 Then GoTo 480 'Check Bimagic Main - and Semi Diagonals
'Check Trimagic Main Diagonals
n9 = n9 + 1
GoSub 650 'Print results (squares)
' GoSub 645 'Print results (selected numbers)
' Erase b, c: GoTo 1000 'Print only first square (Option)
5
jj = 48: GoSub 3050 'Reset b() and c()
480 Next j48
jj = 55: GoSub 3050 'Reset b() and c()
550 Next j55
b(c(56)) = 0: c(56) = 0
560 Next j56
b(c(57)) = 0: c(57) = 0
570 b(c(58)) = 0: c(58) = 0
580 Next j58
b(c(59)) = 0: c(59) = 0
590 Next j59
b(c(60)) = 0: c(60) = 0
600 Next j60
b(c(61)) = 0: c(61) = 0
610 b(c(62)) = 0: c(62) = 0
620 Next j62
b(c(63)) = 0: c(63) = 0
630 Next j63
b(c(64)) = 0: c(64) = 0
640 Next j64
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr15314")
End
' Exclude identical solutions and solutions out of range
3000 fl1 = 0
If a(j) <= 0 Or a(j) > 64 Then fl1 = 1: GoTo 3010
If b(a(j)) = 0 Then b(a(j)) = a(j): c(j) = a(j) Else fl1 = 1
3010 If fl1 = 1 Then 'Reset b() and c()
For i = j + 1 To jj
b(c(i)) = 0: c(i) = 0
Next i
End If
Return
' Reset b() and c() after completion loop
3050 For i = j To jj
b(c(i)) = 0: c(i) = 0
Next i
Return
' Check Bimagic Row 2
3100 fl1 = 0
s21 = a(49) ^ 2 + a(50) ^ 2 + a(51) ^ 2 + a(52) ^ 2 + a(53) ^ 2 + a(54) ^ 2 + a(55) ^ 2 + a(56) ^ 2
If s21 <> s2 Then fl1 = 1
3150 For i = j To jj
b(c(i)) = 0: c(i) = 0
Next i
Return
' Check Bimagic Row 3 and 4
3200 fl1 = 0
s21 = a(41) ^ 2 + a(42) ^ 2 + a(43) ^ 2 + a(44) ^ 2 + a(45) ^ 2 + a(46) ^ 2 + a(47) ^ 2 + a(48) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3250
s21 = a(33) ^ 2 + a(34) ^ 2 + a(35) ^ 2 + a(36) ^ 2 + a(37) ^ 2 + a(38) ^ 2 + a(39) ^ 2 + a(40) ^ 2
If s21 <> s2 Then fl1 = 1
3250 For i = j To jj
b(c(i)) = 0: c(i) = 0
Next i
Return
' Check Bimagic Columns
3300 fl1 = 0
s21 = a(1) ^ 2 + a(9) ^ 2 + a(17) ^ 2 + a(25) ^ 2 + a(33) ^ 2 + a(41) ^ 2 + a(49) ^ 2 + a(57) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(2) ^ 2 + a(10) ^ 2 + a(18) ^ 2 + a(26) ^ 2 + a(34) ^ 2 + a(42) ^ 2 + a(50) ^ 2 + a(58) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(3) ^ 2 + a(11) ^ 2 + a(19) ^ 2 + a(27) ^ 2 + a(35) ^ 2 + a(43) ^ 2 + a(51) ^ 2 + a(59) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(4) ^ 2 + a(12) ^ 2 + a(20) ^ 2 + a(28) ^ 2 + a(36) ^ 2 + a(44) ^ 2 + a(52) ^ 2 + a(60) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(5) ^ 2 + a(13) ^ 2 + a(21) ^ 2 + a(29) ^ 2 + a(37) ^ 2 + a(45) ^ 2 + a(53) ^ 2 + a(61) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(6) ^ 2 + a(14) ^ 2 + a(22) ^ 2 + a(30) ^ 2 + a(38) ^ 2 + a(46) ^ 2 + a(54) ^ 2 + a(62) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(7) ^ 2 + a(15) ^ 2 + a(23) ^ 2 + a(31) ^ 2 + a(39) ^ 2 + a(47) ^ 2 + a(55) ^ 2 + a(63) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3350
s21 = a(8) ^ 2 + a(16) ^ 2 + a(24) ^ 2 + a(32) ^ 2 + a(40) ^ 2 + a(48) ^ 2 + a(56) ^ 2 + a(64) ^ 2
If s21 <> s2 Then fl1 = 1
3350 For i = j To jj
b(c(i)) = 0: c(i) = 0
Next i
Return
' Check Bimagic Main - and Semi Diagonals
' Check Trimagic Main Diagonals
3400 fl1 = 0
s21 = a(1) ^ 2 + a(10) ^ 2 + a(19) ^ 2 + a(28) ^ 2 + a(37) ^ 2 + a(46) ^ 2 + a(55) ^ 2 + a(64) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3450
s21 = a(8) ^ 2 + a(15) ^ 2 + a(22) ^ 2 + a(29) ^ 2 + a(36) ^ 2 + a(43) ^ 2 + a(50) ^ 2 + a(57) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3450
s21 = a(5) ^ 2 + a(14) ^ 2 + a(23) ^ 2 + a(32) ^ 2 + a(33) ^ 2 + a(42) ^ 2 + a(51) ^ 2 + a(60) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3450
s21 = a(4) ^ 2 + a(11) ^ 2 + a(18) ^ 2 + a(25) ^ 2 + a(40) ^ 2 + a(47) ^ 2 + a(54) ^ 2 + a(61) ^ 2
If s21 <> s2 Then fl1 = 1: GoTo 3450
s31 = a(1) ^ 3 + a(10) ^ 3 + a(19) ^ 3 + a(28) ^ 3 + a(37) ^ 3 + a(46) ^ 3 + a(55) ^ 3 + a(64) ^ 3
If s31 <> s3 Then fl1 = 1: GoTo 3450
s31 = a(8) ^ 3 + a(15) ^ 3 + a(22) ^ 3 + a(29) ^ 3 + a(36) ^ 3 + a(43) ^ 3 + a(50) ^ 3 + a(57) ^ 3
If s31 <> s3 Then fl1 = 1:
3450 For i = j To jj
b(c(i)) = 0: c(i) = 0
Next i
Return
' Print results (selected numbers)
645 For i1 = 1 To 64
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 65).Value = j100
Cells(n9, 66).Value = n9
Return
' Print results (squares)
650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Range(Cells(k1, k2 + 1), Cells(k1, k2 + 4)).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
Cells(k1, k2 + 2).Value = j100
i3 = 0
For i1 = 1 To 8
For i2 = 1 To 8
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Sheets(ShtNm1).Cells(j100, 9).Value = "ok"
Return
End Sub
