' Calculates Related Bimagic Squares of order 8, Magic Sum 260
' Based on 8 x 8 Semi Bimagic Squares
' Tested with Office 2007 under Windows 7
Sub CnstrSqrs1503()
Dim a(64), a1(8), a2(8)
Dim n(8, 2)
Dim a3(8, 8), a4(8, 8), a5(16), d1(8), d2(8)
y = MsgBox("Blocked", vbInformation, "CnstrSqrs1503")
End
Sheets("Klad1").Select
n5 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 260: s2 = 11180
n1 = 2: n2 = 2 'start row : column
n4 = 0: i4 = 0 'current square
n41 = 4: n3 = 360
ShtNm1 = "Conjugated8"
ShtNm2 = "ScrSht8"
t1 = Timer
For j3 = 1 To n3 'Square nr j3 current
n4 = n4 + 1: n2 = 2 + (n4 - 1) * 9: i4 = 0
For j1 = n1 To n1 + 7 'Row within square j3
For j2 = n2 To n2 + 7 'Column within square j3
i4 = i4 + 1
a(i4) = Sheets(ShtNm1).Cells(j1, j2).Value 'load square
If a(i4) = 64 Then i41 = j1 - n1 + 1: i42 = j2 - n2 + 1
Next j2
Next j1
Seq8 = Sheets(ShtNm1).Cells(n1 - 1, n2).Value
Grp1 = Sheets(ShtNm1).Cells(n1 - 1, n2 + 6).Value
Grp2 = Sheets(ShtNm1).Cells(n1 - 1, n2 + 7).Value
' Check Possible Diagonals
GoSub 200: If fl1 = 0 Then GoTo 5 'Write Sets 'ScrSht8'
GoSub 400: If n29 = 0 Then GoTo 5 'Check Valid Sets
n9 = n9 + 1: GoSub 650 'Print results (squares)
5
If n4 = n41 Then n4 = 0: n1 = n1 + 9: n2 = 2
Next j3
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine CnstrSqrs1503")
End
' Check Possibility Diagonals
200 fl1 = 1
i2 = 1: i3 = 0
For i1 = 1 To 64:
i3 = i3 + 1: If i3 = 9 Then i3 = 1: i2 = i2 + 1
a3(i2, i3) = a(i1)
Next i1
i19 = 0
For i11 = 1 To 8
For i12 = 1 To 8
If i12 = i11 Then GoTo 220
For i13 = 1 To 8
If i13 = i11 Or i13 = i12 Then GoTo 230
For i14 = 1 To 8
If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
For i15 = 1 To 8
If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
For i16 = 1 To 8
If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260
For i17 = 1 To 8
If i17 = i11 Or i17 = i12 Or i17 = i13 Or i17 = i14 Or i17 = i15 Or i17 = i16 Then GoTo 270
For i18 = 1 To 8
If i18 = i11 Or i18 = i12 Or i18 = i13 Or i18 = i14 Or i18 = i15 Or i18 = i16 Or i18 = i17 Then GoTo 280
s11 = a3(1, i11) + a3(2, i12) + a3(3, i13) + a3(4, i14) + a3(5, i15) + a3(6, i16) + a3(7, i17) + a3(8, i18)
If s11 <> s1 Then GoTo 280
s22 = a3(1, i11) ^ 2 + a3(2, i12) ^ 2 + a3(3, i13) ^ 2 + a3(4, i14) ^ 2 + a3(5, i15) ^ 2 + a3(6, i16) ^ 2 + a3(7, i17) ^ 2 + a3(8, i18) ^ 2
If s22 <> s2 Then GoTo 280
i19 = i19 + 1
Sheets("ScrSht8").Cells(i19, 11).Value = a3(1, i11)
Sheets("ScrSht8").Cells(i19, 12).Value = a3(2, i12)
Sheets("ScrSht8").Cells(i19, 13).Value = a3(3, i13)
Sheets("ScrSht8").Cells(i19, 14).Value = a3(4, i14)
Sheets("ScrSht8").Cells(i19, 15).Value = a3(5, i15)
Sheets("ScrSht8").Cells(i19, 16).Value = a3(6, i16)
Sheets("ScrSht8").Cells(i19, 17).Value = a3(7, i17)
Sheets("ScrSht8").Cells(i19, 18).Value = a3(8, i18)
280 Next i18
270 Next i17
260 Next i16
250 Next i15
240 Next i14
230 Next i13
220 Next i12
210 Next i11
If i19 < 2 Then fl1 = 0: Return
n19 = 0
For j11 = 1 To i19
n20 = 8: Erase a5
For i1 = 1 To 8
a1(i1) = Sheets("ScrSht8").Cells(j11, i1 + 10).Value
Next i1
For i1 = 1 To 8 'First Line
a5(i1) = a1(i1)
Next i1
For j12 = j11 + 1 To i19
j300 = j12: GoSub 300: If fl2 = 0 Then GoTo 120
' Write Set Diagonals to 'ScrSht8'
For i1 = 1 To 2
n19 = n19 + 1
For i2 = 1 To 8
Sheets("ScrSht8").Cells(n19, i2 + 20).Value = a5(i2 + (i1 - 1) * 8)
Next i2
Sheets("ScrSht8").Cells(n19, 9 + 20).Value = i1
Next i1
n20 = n20 - 8
120 Next j12
n20 = n20 - 8
110 Next j11
If n19 < 2 Then fl1 = 0
Return
' Construct Set Bimagic Diagonals
300 fl2 = 1
For i1 = 1 To 8
a2(i1) = Sheets("ScrSht8").Cells(j300, i1 + 10).Value
Next i1
For i1 = 1 To 8
a20 = a2(i1)
For i2 = 1 To n20
If a20 = a5(i2) Then fl2 = 0: Return
Next i2
Next i1
n20 = n20 + 8
i2 = 0
For i1 = n20 - 8 + 1 To n20
i2 = i2 + 1
a5(i1) = a2(i2)
Next i1
Return
' Read Diagonals for Final Check
400
n29 = 0
For j20 = 1 To n19 - 1 Step 2
For i1 = 1 To 8
d1(i1) = Sheets("ScrSht8").Cells(j20, i1 + 20).Value
d2(i1) = Sheets("ScrSht8").Cells(j20 + 1, i1 + 20).Value
Next i1
Erase a4
For i1 = 1 To 8
For i2 = 1 To 8
If a3(i1, i2) = d1(i1) Then a4(i1, i2) = 1
If a3(i1, i2) = d2(i1) Then a4(i1, i2) = 2
Next i2
Next i1
GoSub 450 'Check if transformation is possible
If fl1 = 1 Then n29 = n29 + 1
Next j20
Return
' Check if transformation is possible
450 fl1 = 1
For i1 = 1 To 8 'rows
n21 = 0
For i2 = 1 To 8 'clmns
If a4(i1, i2) <> 0 Then
n21 = n21 + 1
If n21 = 1 Then i41 = i2 Else i42 = i2
End If
Next i2
For i3 = i1 + 1 To 8
If a4(i3, i41) = 0 And a4(i3, i42) = 0 Then
'continue
Else
If a4(i3, i41) = a4(i1, i42) And a4(i3, i42) = a4(i1, i41) Then
Exit For 'ok
Else
fl1 = 0: Return 'no match
End If
End If
Next i3
Next i1
Return
' Print results (squares)
650 n5 = n5 + 1
If n5 = 5 Then
n5 = 1: k1 = k1 + 9: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 9
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = Seq8
Cells(k1, k2 + 2).Value = n29
Cells(k1, k2 + 6).Value = Grp1
Cells(k1, k2 + 7).Value = Grp2
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
Return
End Sub
