' Generates Associated Latin Diagonal Squares (7 x 7)
' Total: 135168 Solutions in 550 sec.
' With Main Diagonal Constant for LDR Base Squares:
' Sub Total: 2816 Solutions in 10 sec.
' Tested with Office 2007 under Windows 7
Sub MgcSqr7j2()
Dim a(49), b(7), a1(7)
y = MsgBox("Locked", vbCritical, "Routine MgcSqr7j2")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 7: s1 = 21: PR7 = 2 * s1 / 7
a1(1) = 0: a1(2) = 1: a1(3) = 2: a1(4) = 3: a1(5) = 4: a1(6) = 5: a1(7) = 6
Sheets("Klad1").Select
t1 = Timer
a(25) = s1 / 7:
' Base Ldr
For j49 = 7 To 7 ''m1 To m2 'a(49) 7 to 7
a(49) = a1(j49)
a(1) = PR7 - a(49)
For j48 = m1 To m2 'a(48)
a(48) = a1(j48)
If a(48) = a(49) Then GoTo 480
a(2) = PR7 - a(48)
For j47 = m1 To m2 'a(47)
a(47) = a1(j47)
If a(47) = a(48) Or a(47) = a(49) Then GoTo 470
a(3) = PR7 - a(47)
For j46 = m1 To m2 'a(46)
a(46) = a1(j46)
If a(46) = a(47) Or a(46) = a(48) Or a(46) = a(49) Then GoTo 460
a(4) = PR7 - a(46)
For j45 = m1 To m2 'a(45)
a(45) = a1(j45)
If a(45) = a(46) Or a(45) = a(47) Or a(45) = a(48) Or a(45) = a(49) Then GoTo 450
a(5) = PR7 - a(45)
For j44 = m1 To m2 'a(44)
a(44) = a1(j44)
If a(44) = a(45) Or a(44) = a(46) Or a(44) = a(47) Or a(44) = a(48) Or a(44) = a(49) Then GoTo 440
a(6) = PR7 - a(44)
a(43) = s1 - a(44) - a(45) - a(46) - a(47) - a(48) - a(49)
If a(43) < a1(m1) Or a(43) > a1(m2) Then GoTo 440
a(7) = PR7 - a(43)
If a(43) = a(1) Or a(44) = a(2) Or a(45) = a(3) Or a(46) = a(4) Then GoTo 440
If a(47) = a(5) Or a(48) = a(6) Or a(49) = a(7) Then GoTo 440
If a(46) = a(25) Or a(4) = a(25) Then GoTo 440
For j42 = m1 To m2 'a(42)
a(42) = a1(j42)
If a(42) = a(49) Or a(42) = a(7) Then GoTo 420
a(8) = PR7 - a(42)
For j41 = 6 To 6 ''m1 To m2 'a(41) 6 To 6
a(41) = a1(j41)
If a(41) = a(42) Then GoTo 410
If a(41) = a(48) Or a(41) = a(6) Then GoTo 410
If a(41) = a(49) Or a(41) = a(25) Or a(41) = a(1) Then GoTo 410
a(9) = PR7 - a(41)
For j40 = m1 To m2 'a(40)
a(40) = a1(j40)
If a(40) = a(41) Or a(40) = a(42) Then GoTo 400
If a(40) = a(47) Or a(40) = a(5) Then GoTo 400
a(10) = PR7 - a(40)
For j39 = m1 To m2 'a(39)
a(39) = a1(j39)
If a(39) = a(40) Or a(39) = a(41) Or a(39) = a(42) Then GoTo 390
If a(39) = a(46) Or a(39) = a(25) Or a(39) = a(4) Then GoTo 390
a(11) = PR7 - a(39)
For j38 = m1 To m2 'a(38)
a(38) = a1(j38)
If a(38) = a(39) Or a(38) = a(40) Or a(38) = a(41) Or a(38) = a(42) Then GoTo 380
If a(38) = a(45) Or a(38) = a(10) Or a(38) = a(3) Then GoTo 380
a(12) = PR7 - a(38)
For j37 = m1 To m2 'a(37)
a(37) = a1(j37)
If a(37) = a(38) Or a(37) = a(39) Or a(37) = a(40) Or a(37) = a(41) Or a(37) = a(42) Then GoTo 370
If a(37) = a(44) Or a(37) = a(9) Or a(37) = a(2) Then GoTo 370
a(13) = PR7 - a(37)
a(36) = s1 - a(37) - a(38) - a(39) - a(40) - a(41) - a(42)
If a(36) < a1(m1) Or a(36) > a1(m2) Then GoTo 370
a(14) = PR7 - a(36)
For i1 = 36 To 42
If a(i1) = a(i1 + 7) Or a(i1) = a(i1 - 28) Or a(i1) = a(i1 - 35) Then GoTo 370
Next i1
If a(37) = a(43) Or a(37) = a(25) Or a(37) = a(13) Or a(37) = a(7) Then GoTo 370
For j35 = m1 To m2 'a(35)
a(35) = a1(j35)
a(15) = PR7 - a(35)
If a(35) = a(49) Or a(35) = a(42) Or a(35) = a(14) Or a(35) = a(7) Then GoTo 350
For j34 = m1 To m2 'a(34)
a(34) = a1(j34)
If a(34) = a(35) Then GoTo 340
If a(34) = a(48) Or a(34) = a(41) Or a(34) = a(13) Or a(34) = a(6) Then GoTo 340
a(16) = PR7 - a(34)
For j33 = 5 To 5 ''m1 To m2 'a(33) 5 To 5
a(33) = a1(j33)
If a(33) = a(34) Or a(33) = a(35) Then GoTo 330
If a(33) = a(47) Or a(33) = a(40) Or a(33) = a(12) Or a(33) = a(5) Then GoTo 330
If a(33) = a(49) Or a(33) = a(41) Or a(33) = a(25) Or a(33) = a(9) Or a(33) = a(1) Then GoTo 330
a(17) = PR7 - a(33)
For j32 = m1 To m2 'a(32)
a(32) = a1(j32)
If a(32) = a(33) Or a(32) = a(34) Or a(32) = a(35) Then GoTo 320
If a(32) = a(46) Or a(32) = a(39) Or a(32) = a(25) Or a(32) = a(11) Or a(32) = a(4) Then GoTo 320
a(18) = PR7 - a(32)
For j31 = m1 To m2 'a(31)
a(31) = a1(j31)
If a(31) = a(32) Or a(31) = a(33) Or a(31) = a(34) Or a(31) = a(35) Then GoTo 310
If a(31) = a(45) Or a(31) = a(38) Or a(31) = a(17) Or a(31) = a(10) Or a(31) = a(3) Then GoTo 310
If a(31) = a(43) Or a(31) = a(37) Or a(31) = a(25) Or a(31) = a(13) Or a(31) = a(7) Then GoTo 310
a(19) = PR7 - a(31)
For j30 = m1 To m2 'a(30)
a(30) = a1(j30)
If a(30) = a(31) Or a(30) = a(32) Or a(30) = a(33) Or a(30) = a(34) Or a(30) = a(35) Then GoTo 300
If a(30) = a(44) Or a(30) = a(37) Or a(30) = a(16) Or a(30) = a(9) Or a(30) = a(2) Then GoTo 300
a(20) = PR7 - a(30)
a(29) = s1 - a(30) - a(31) - a(32) - a(33) - a(34) - a(35)
If a(29) < a1(m1) Or a(29) > a1(m2) Then GoTo 300
a(21) = PR7 - a(29)
a(28) = s1 / 7 + a(29) - a(35) + a(36) - a(42) + a(43) - a(49)
If a(28) < a1(m1) Or a(28) > a1(m2) Then GoTo 300
a(22) = PR7 - a(28)
a(27) = s1 / 7 + a(30) - a(34) + a(37) - a(41) + a(44) - a(48)
If a(27) < a1(m1) Or a(27) > a1(m2) Then GoTo 300
a(23) = PR7 - a(27)
a(26) = s1 / 7 + a(31) - a(33) + a(38) - a(40) + a(45) - a(47)
If a(26) < a1(m1) Or a(26) > a1(m2) Then GoTo 300
a(24) = PR7 - a(26)
GoSub 800: If fl1 = 0 Then GoTo 5
n9 = n9 + 1
Cells(1, 1).Value = n9
' GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers)
''End
5
300 Next j30
310 Next j31
320 Next j32
330 Next j33
340 Next j34
350 Next j35
370 Next j37
380 Next j38
390 Next j39
400 Next j40
410 Next j41
420 Next j42
440 Next j44
450 Next j45
460 Next j46
470 Next j47
480 Next j48
490 Next j49
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine MgcSqr7j2")
End
' Exclude solutions with identical numbers in rows, columns, diagonals
800 fl1 = 1
' Rows
i1 = -6
For i0 = 1 To 7
i1 = i1 + 7
b(1) = a(i1): b(2) = a(i1 + 1): b(3) = a(i1 + 2): b(4) = a(i1 + 3):
b(5) = a(i1 + 4): b(6) = a(i1 + 5): b(7) = a(i1 + 6)
GoSub 860: If fl1 = 0 Then Return
Next i0
' Columns
i1 = 0
For i0 = 1 To 7
i1 = i1 + 1
b(1) = a(i1): b(2) = a(i1 + 7): b(3) = a(i1 + 14): b(4) = a(i1 + 21):
b(5) = a(i1 + 28): b(6) = a(i1 + 35): b(7) = a(i1 + 42)
GoSub 860: If fl1 = 0 Then Return
Next i0
' Diagonals
b(1) = a(1): b(2) = a(9): b(3) = a(17): b(4) = a(25): b(5) = a(33): b(6) = a(41): b(7) = a(49):
GoSub 860: If fl1 = 0 Then Return
b(1) = a(43): b(2) = a(37): b(3) = a(31): b(4) = a(25): b(5) = a(19): b(6) = a(13): b(7) = a(7):
GoSub 860: If fl1 = 0 Then Return
Return
860 fl1 = 1
For j1 = 1 To 7
b2 = b(j1)
For j2 = (1 + j1) To 7
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 49
Cells(n9, i1).Value = a(i1)
Next i1
Cells(n9, 50).Value = n9
Cells(1, 51).Value = n9
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 8: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 8
End If
Cells(k1, k2 + 1).Select
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = n9
i3 = 0
For i1 = 1 To 7
For i2 = 1 To 7
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = a(i3)
Next i2
Next i1
Return
End Sub
