' Generates 6 x 6 Semi Magic Squares of Squares
' Based on `6 x 6 Generators

' Tested with Office 2007 under Windows 7

Sub CnstrSqrs6()

Dim a(36), a0(6, 6), a1(6), a2(6), s(14)
Dim n(6, 2)
Dim a3(6, 6), a4(6, 6), a5(16), d1(6), d2(6)

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

n1 = 0: n9 = 0: k1 = 1: k2 = 1

ShtNm1 = "GenLns6"
ShtNm2 = "ScrSht6"

t1 = Timer

For j100 = 1 To 9

i2 = 1: i3 = 0
For i1 = 1 To 36:
i3 = i3 + 1: If i3 = 7 Then i3 = 1: i2 = i2 + 1
a0(i2, i3) = Sheets(ShtNm1).Cells(j100, i1)
Next i1
s2 = Sheets(ShtNm1).Cells(j100, 38)

Sheets(ShtNm2).Select
Cells.Select: Selection.ClearContents
Range("A1").Select

GoSub 500               ' Prepare Scratch Sheet

For j1 = n(1, 1) To n(1, 2)

n10 = 6: Erase a
For i1 = 1 To 6
a1(i1) = Sheets(ShtNm2).Cells(j1, i1).Value
Next i1
For i1 = 1 To 6         ' First Line
a(i1) = a1(i1)
Next i1

For j2 = n(2, 1) To n(2, 2)
j300 = j2: GoSub 100: If fl1 = 0 Then GoTo 20

For j3 = n(3, 1) To n(3, 2)
j300 = j3: GoSub 100: If fl1 = 0 Then GoTo 30

For j4 = n(4, 1) To n(4, 2)
j300 = j4: GoSub 100: If fl1 = 0 Then GoTo 40

For j5 = n(5, 1) To n(5, 2)
j300 = j5: GoSub 100: If fl1 = 0 Then GoTo 50

For j6 = n(6, 1) To n(6, 2)
j300 = j6: GoSub 100: If fl1 = 0 Then GoTo 60

Nc9 = Nc9 + 1                        'Unchecked

'      Check Possible Diagonals

GoSub 200: If fl1 = 0 Then GoTo 5    'Write Sets 'ScrSht6'
GoSub 400: If n29 = 0 Then GoTo 5    'Check Valid Sets

'      n9 = n9 + 1: GoSub 750               'Print Semi Magic Squares
'Related number of Magic Squares Shown (n29)

5
n10 = n10 - 6
60     Next j6
n10 = n10 - 6
50     Next j5
n10 = n10 - 6
40     Next j4
n10 = n10 - 6
30     Next j3
n10 = n10 - 6
20     Next j2
n10 = n10 - 6
10     Next j1

1000 Next j100

t2 = Timer

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

'   Construct Semi Bimagic Squares

100 fl1 = 1

For i1 = 1 To 6
a2(i1) = Sheets(ShtNm2).Cells(j300, i1).Value
Next i1

For i1 = 1 To 6
a20 = a2(i1)
For i2 = 1 To n10
If a20 = a(i2) Then fl1 = 0: Return
Next i2
Next i1

n10 = n10 + 6
i2 = 0
For i1 = n10 - 6 + 1 To n10
i2 = i2 + 1
a(i1) = a2(i2)
Next i1

Return

'   Check Possibility Diagonals (Bimagic)

200 fl1 = 1

i2 = 1: i3 = 0
For i1 = 1 To 36:
i3 = i3 + 1: If i3 = 7 Then i3 = 1: i2 = i2 + 1
a3(i2, i3) = a(i1)
Next i1

i19 = 0
For i11 = 1 To 6
For i12 = 1 To 6
If i12 = i11 Then GoTo 220
For i13 = 1 To 6
If i13 = i11 Or i13 = i12 Then GoTo 230
For i14 = 1 To 6
If i14 = i11 Or i14 = i12 Or i14 = i13 Then GoTo 240
For i15 = 1 To 6
If i15 = i11 Or i15 = i12 Or i15 = i13 Or i15 = i14 Then GoTo 250
For i16 = 1 To 6
If i16 = i11 Or i16 = i12 Or i16 = i13 Or i16 = i14 Or i16 = i15 Then GoTo 260

s12 = a3(1, i11) ^ 2 + a3(2, i12) ^ 2 + a3(3, i13) ^ 2 + a3(4, i14) ^ 2 + a3(5, i15) ^ 2 + a3(6, i16) ^ 2
If s12 <> s2 Then GoTo 260

i19 = i19 + 1

Sheets(ShtNm2).Cells(i19, 11).Value = a3(1, i11)
Sheets(ShtNm2).Cells(i19, 12).Value = a3(2, i12)
Sheets(ShtNm2).Cells(i19, 13).Value = a3(3, i13)
Sheets(ShtNm2).Cells(i19, 14).Value = a3(4, i14)
Sheets(ShtNm2).Cells(i19, 15).Value = a3(5, i15)
Sheets(ShtNm2).Cells(i19, 16).Value = a3(6, i16)

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 = 6: Erase a5
For i1 = 1 To 6
a1(i1) = Sheets(ShtNm2).Cells(j11, i1 + 10).Value
Next i1
For i1 = 1 To 6   '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 'ScrSht6'

For i1 = 1 To 2

n19 = n19 + 1
For i2 = 1 To 6
Sheets(ShtNm2).Cells(n19, i2 + 20).Value = a5(i2 + (i1 - 1) * 6)
Next i2
Sheets(ShtNm2).Cells(n19, 9 + 20).Value = i1

Next i1

n20 = n20 - 6
120    Next j12
n20 = n20 - 6
110    Next j11

If n19 < 2 Then fl1 = 0

Return

'   Construct Magic Set Diagonals

300 fl2 = 1

For i1 = 1 To 6
a2(i1) = Sheets(ShtNm2).Cells(j300, i1 + 10).Value
Next i1

For i1 = 1 To 6
a20 = a2(i1)
For i2 = 1 To n20
If a20 = a5(i2) Then fl2 = 0: Return
Next i2
Next i1

n20 = n20 + 6
i2 = 0
For i1 = n20 - 6 + 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 6
d1(i1) = Sheets(ShtNm2).Cells(j20, i1 + 20).Value
d2(i1) = Sheets(ShtNm2).Cells(j20 + 1, i1 + 20).Value
Next i1

Erase a4
For i1 = 1 To 6
For i2 = 1 To 6
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

'           Print Semi Magic Squares
'           Required Transformation Highlighted
n9 = n9 + 1: GoSub 650

End If

Next j20

Return

'   Check if transformation is possible

450 fl1 = 1

For i1 = 1 To 6                 'rows
n21 = 0
For i2 = 1 To 6             '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 6
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

'   Prepare Scratch Sheet

500

i9 = 0: n(1, 1) = 1

For i1 = 1 To 6
For i2 = 1 To 6
For i3 = 1 To 6
For i4 = 1 To 6
For i5 = 1 To 6
For i6 = 1 To 6

s12 = a0(1, i1) ^ 2 + a0(2, i2) ^ 2 + a0(3, i3) ^ 2 + a0(4, i4) ^ 2 + a0(5, i5) ^ 2 + a0(6, i6) ^ 2
If s12 <> s2 Then GoTo 560

i9 = i9 + 1
Cells(i9, 1).Value = a0(1, i1)
Cells(i9, 2).Value = a0(2, i2)
Cells(i9, 3).Value = a0(3, i3)
Cells(i9, 4).Value = a0(4, i4)
Cells(i9, 5).Value = a0(5, i5)
Cells(i9, 6).Value = a0(6, i6)

560 Next i6
550 Next i5
540 Next i4
530 Next i3
520 Next i2

n(i1, 2) = i9: If i1 <> 6 Then n(i1 + 1, 1) = i9 + 1

510 Next i1

n(6, 2) = i9

Return

'   Print Semi Magic Squares
'   Required Transformation Highlighted

650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 7: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 7
End If

Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = Nc9 ''n9
Cells(k1, k2 + 2).Value = n29

Cells(k1, k2 + 6).Value = j100  'Generator  Bimagic Lines

i3 = 0
For i1 = 1 To 6
For i2 = 1 To 6
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)

Select Case a4(i1, i2)

Case 1

Range(Cells(k1 + i1, k2 + i2), Cells(k1 + i1, k2 + i2)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
End With

Case 2

Range(Cells(k1 + i1, k2 + i2), Cells(k1 + i1, k2 + i2)).Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorAccent5
End With

Case 0

End Select

Next i2
Next i1

Return

'   Print results (Semi Magic Squares)
'   Related number of Magic Squares Shown (n29)

750 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 7: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 7
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 = n29

Cells(k1, k2 + 6).Value = j100  'Generator  Bimagic Lines

i3 = 0
For i1 = 1 To 6
For i2 = 1 To 6
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1

Return

End Sub