About the Author

' Calculates Semi Bimagic Squares of order 8, Magic Sum 260
' Based on Conjugation of 8 x 8 Generators

' Tested with Office 2007 under Windows 7

Sub ConjSqrs1502()

Dim a0(8, 8), b0(8, 8), a1(64, 2)
Dim a2(8, 8)
Dim Scr8(8, 8)

y = MsgBox("Blocked", vbInformation, "ConjSqrs1502")
End

Sheets("Klad1").Select

n1 = 0: n9 = 0: k1 = 1: k2 = 1
s1 = 260: s2 = 11180

t1 = Timer

For j100 = 1730 To 2305 'Group 4

'   Define a0()

    i1 = 1: i2 = 0
    For i3 = 1 To 64
        i2 = i2 + 1: If i2 = 9 Then i2 = 1: i1 = i1 + 1
        x = Sheets("GenLns8").Cells(j100, i3)
        a0(i1, i2) = Sheets("GenLns8").Cells(j100, i3)
    Next i3
    Grp1 = Sheets("GenLns8").Cells(j100, 66)

For j200 = 2306 To 2881 'Group 5

'   Defien b0()

    i1 = 1: i2 = 0
    For i3 = 1 To 64
        i2 = i2 + 1: If i2 = 9 Then i2 = 1: i1 = i1 + 1
        Scr8(i1, i2) = Sheets("GenLns8").Cells(j200, i3)
    Next i3
    Grp2 = Sheets("GenLns8").Cells(j200, 66)
    
    For i1 = 1 To 8
    For i2 = 1 To 8
        b0(i1, i2) = Scr8(i2, i1)
    Next i2
    Next i1

'   Define a1()

    For i1 = 1 To 8
    For i2 = 1 To 8
        x = a0(i1, i2): a1(x, 1) = i1   'Row    in a0()
        x = b0(i1, i2): a1(x, 2) = i2   'Column in b0()
    Next i2
    Next i1

'   Construct a2()

    Erase a2
    For i3 = 1 To 64
        i1 = a1(i3, 1)                  'Row
        i2 = a1(i3, 2)                  'Column
        a2(i1, i2) = i3
    Next i3

    GoSub 800: If fl1 = 0 Then GoTo 5   'Check empyy cells

    n9 = n9 + 1: GoSub 650              'Print Square

5

2000 Next j200
1000 Next j100

t2 = Timer
    
    t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
    y = MsgBox(t10, 0, "Routine ConjSqrs1502")

End

'   Print Square

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
    Cells(k1, k2 + 1).Font.Color = -4165632
    Cells(k1, k2 + 1).Value = n9
    Cells(k1, k2 + 2).Value = j100
    Cells(k1, k2 + 3).Value = j200
    Cells(k1, k2 + 5).Font.Color = -4165632
    Cells(k1, k2 + 5).Value = "Group"
    Cells(k1, k2 + 7).Value = Grp1
    Cells(k1, k2 + 8).Value = Grp2

    For i1 = 1 To 8
    For i2 = 1 To 8
        Cells(i1 + k1, i2 + k2).Value = a2(i1, i2)
    Next i2
    Next i1

    Return

'   Check empty cells

800 fl1 = 1
    For i1 = 1 To 8
        For i2 = 1 To 8
            x = a2(i1, i2)
            If IsEmpty(x) = True Then fl1 = 0: Return
        Next i2
    Next i1
    Return

End Sub

About the Author