' Constructs Associated Semi-Latin Squares (9 x 9)
' Diamond Inlays Order 4 and 5
' Tested with Office 365 under Windows 10
Sub SemiLat9b()
Dim a(81), a1(9), b(9)
Dim b1(81), c(81)
y = MsgBox("Locked", vbCritical, "Routine SemiLat9b")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 1: m2 = 9: s1 = 36: p9 = 8
For i1 = 1 To 9
a1(i1) = i1 - 1
Next i1
' Generate data
Sheets("Klad1").Select
t1 = Timer
a(41) = 4
For j77 = m1 To m2 'a(77) Dia 5 x 5
a(77) = a1(j77)
Cells(2, 1).Value = j77
For j69 = m1 To m2 'a(69)
a(69) = a1(j69)
Cells(3, 1).Value = j69
For j61 = m1 To m2 'a(61)
a(61) = a1(j61)
Cells(4, 1).Value = j61
For j53 = m1 To m2 'a(53)
a(53) = a1(j53)
Cells(5, 1).Value = j53
a(45) = 5 * s1 / 9 - a(53) - a(61) - a(69) - a(77)
If a(45) < a1(m1) Or a(45) > a1(m2) Then GoTo 530
For j67 = m1 To m2 'a(67)
a(67) = a1(j67)
For j59 = m1 To m2 'a(59)
a(59) = a1(j59)
For j51 = m1 To m2 'a(51)
a(51) = a1(j51)
For j43 = m1 To m2 'a(43)
a(43) = a1(j43)
a(35) = 5 * s1 / 9 - a(43) - a(51) - a(59) - a(67)
If a(35) < a1(m1) Or a(35) > a1(m2) Then GoTo 430
a(57) = 6 * s1 / 9 - a(43) - a(51) - a(59) - 2 * a(67) + a(45) - a(77)
If a(57) < a1(m1) Or a(57) > a1(m2) Then GoTo 430
a(49) = s1 / 9 + a(43) - a(59) + a(53) - a(69)
If a(49) < a1(m1) Or a(49) > a1(m2) Then GoTo 430
a(33) = p9 - a(49): a(25) = p9 - a(57): a(47) = p9 - a(35): a(39) = p9 - a(43)
a(31) = p9 - a(51): a(23) = p9 - a(59): a(15) = p9 - a(67): a(37) = p9 - a(45)
a(29) = p9 - a(53): a(21) = p9 - a(61): a(13) = p9 - a(69): a(5) = p9 - a(77)
' Check Diamond 5 x 5
n10 = 2: b(1) = a(67): b(2) = a(69)
GoSub 1800: If fl1 = 0 Then GoTo 430
n10 = 3: b(1) = a(57): b(2) = a(59): b(3) = a(61)
GoSub 1800: If fl1 = 0 Then GoTo 430
n10 = 4: b(1) = a(47): b(2) = a(49): b(3) = a(51): b(4) = a(53)
GoSub 1800: If fl1 = 0 Then GoTo 430
n10 = 5: b(1) = a(37): b(2) = a(39): b(3) = a(41): b(4) = a(43): b(5) = a(45)
GoSub 1800: If fl1 = 0 Then GoTo 430
' Diagonals
n10 = 5: b(1) = a(21): b(2) = a(31): b(3) = a(41): b(4) = a(51): b(5) = a(61)
GoSub 1800: If fl1 = 0 Then GoTo 430
n10 = 5: b(1) = a(25): b(2) = a(33): b(3) = a(41): b(4) = a(49): b(5) = a(57)
GoSub 1800: If fl1 = 0 Then GoTo 430
For j68 = m1 To m2 'a(68) Dia 4 x 4
a(68) = a1(j68)
For j60 = m1 To m2 'a(60)
a(60) = a1(j60)
For j52 = m1 To m2 'a(52)
a(52) = a1(j52)
a(44) = 4 * s1 / 9 - a(52) - a(60) - a(68)
If a(44) < a1(m1) Or a(44) > a1(m2) Then GoTo 520
For j58 = m1 To m2 'a(58)
a(58) = a1(j58)
a(50) = 4 * s1 / 9 - a(58) - a(60) - a(68)
If a(50) < a1(m1) Or a(50) > a1(m2) Then GoTo 580
a(42) = a(50) - a(52) + a(60)
If a(42) < a1(m1) Or a(42) > a1(m2) Then GoTo 580
a(34) = 4 * s1 / 9 - a(42) - a(50) - a(58)
If a(34) < a1(m1) Or a(34) > a1(m2) Then GoTo 580
a(48) = p9 - a(34): a(40) = p9 - a(42): a(32) = p9 - a(50): a(24) = p9 - a(58):
a(38) = p9 - a(44): a(30) = p9 - a(52): a(22) = p9 - a(60): a(14) = p9 - a(68):
' Check Diamond 4 x 4 / 5 x 5
n10 = 3: b(1) = a(67): b(2) = a(68): b(3) = a(69)
GoSub 1800: If fl1 = 0 Then GoTo 580
n10 = 5: b(1) = a(57): b(2) = a(58): b(3) = a(59): b(4) = a(60): b(5) = a(61)
GoSub 1800: If fl1 = 0 Then GoTo 580
n10 = 7: b(1) = a(47): b(2) = a(48): b(3) = a(49): b(4) = a(50): b(5) = a(51): b(6) = a(52): b(7) = a(53)
GoSub 1800: If fl1 = 0 Then GoTo 580
n10 = 9: b(1) = a(37): b(2) = a(38): b(3) = a(39): b(4) = a(40): b(5) = a(41): b(6) = a(42): b(7) = a(43):
b(8) = a(44): b(9) = a(45)
GoSub 1800: If fl1 = 0 Then GoTo 580
For j81 = m1 To m2 'a(81) Border
a(81) = a1(j81)
If a(81) = a(77) Then GoTo 810
For j80 = m1 To m2 'a(80)
a(80) = a1(j80)
If a(80) = a(81) Or a(80) = a(77) Then GoTo 800
For j79 = m1 To m2 'a(79)
a(79) = a1(j79)
If a(79) = a(81) Or a(79) = a(80) Or a(79) = a(77) Then GoTo 790
For j78 = m1 To m2 'a(78)
a(78) = a1(j78)
If a(78) = a(81) Or a(78) = a(80) Or a(78) = a(79) Or a(78) = a(77) Then GoTo 780
a(76) = -4 * s1 / 9 + a(78) + a(42) - a(58) + a(60) + a(15) - a(43) + a(51) + a(59) - a(53) + 2 * a(69)
If a(76) < a1(m1) Or a(76) > a1(m2) Then GoTo 780
If a(76) = a(81) Or a(76) = a(80) Or a(76) = a(79) Or a(76) = a(78) Or a(76) = a(77) Then GoTo 780
For j75 = m1 To m2 'a(78)
a(75) = a1(j75)
For j74 = m1 To m2 'a(78)
a(74) = a1(j74)
a(73) = s1 - a(74) - a(75) - a(76) - a(77) - a(78) - a(79) - a(80) - a(81)
If a(73) < a1(m1) Or a(73) > a1(m2) Then GoTo 740
' Check Rows 1/9
For i1 = 1 To 9
b(i1) = a(72 + i1)
Next i1
n10 = 9: GoSub 1800: If fl1 = 0 Then GoTo 740
a(9) = p9 - a(73):: a(8) = p9 - a(74): a(7) = p9 - a(75): a(6) = p9 - a(76)
a(4) = p9 - a(78): a(3) = p9 - a(79): a(2) = p9 - a(80): a(1) = p9 - a(81)
For j72 = m1 To m2 'a(72)
a(72) = a1(j72)
If a(72) = a(67) Or a(72) = a(68) Or a(72) = a(69) Then GoTo 720
a(10) = p9 - a(72)
For j71 = m1 To m2 'a(71)
a(71) = a1(j71)
If a(71) = a(67) Or a(71) = a(68) Or a(71) = a(69) Or a(71) = a(72) Then GoTo 710
a(11) = p9 - a(71)
' Check Diagonal 1
For i1 = 1 To 9
i2 = 81 - (i1 - 1) * 10
b(i1) = a(i2)
Next i1
n10 = 9: GoSub 1800: If fl1 = 0 Then GoTo 710
For j70 = m1 To m2 'a(70)
a(70) = a1(j70)
If a(70) = a(67) Or a(70) = a(68) Or a(70) = a(69) Or a(70) = a(72) Or a(70) = a(71) Then GoTo 700
a(12) = p9 - a(70)
a(66) = -3 * s1 / 9 + a(70) - a(75) + a(79) + a(34) + a(52) - a(57) + a(43) + a(61)
If a(66) < a1(m1) Or a(66) > a1(m2) Then GoTo 700
For i1 = 1 To 7
b(i1) = a(65 + i1)
Next i1
n10 = 7: GoSub 1800: If fl1 = 0 Then GoTo 700
a(16) = p9 - a(66)
For j65 = m1 To m2 'a(70)
a(65) = a1(j65)
For i1 = 1 To 8
b(i1) = a(64 + i1)
Next i1
n10 = 8: GoSub 1800: If fl1 = 0 Then GoTo 650
a(17) = p9 - a(65)
' Check Diagonal 2
For i1 = 1 To 9
i2 = 73 - (i1 - 1) * 8
b(i1) = a(i2)
Next i1
n10 = 9: GoSub 1800: If fl1 = 0 Then GoTo 650
a(64) = s1 - a(65) - a(66) - a(67) - a(68) - a(69) - a(70) - a(71) - a(72)
If a(64) < a1(m1) Or a(64) > a1(m2) Then GoTo 650
' Check Row 2 / 8
For i1 = 1 To 9
b(i1) = a(63 + i1)
Next i1
n10 = 9: GoSub 1800: If fl1 = 0 Then GoTo 650
a(18) = p9 - a(64)
For j63 = m1 To m2 'a(63)
a(63) = a1(j63)
a(19) = p9 - a(63)
For j62 = m1 To m2 'a(62)
a(62) = a1(j62)
a(20) = p9 - a(62)
For i1 = 1 To 7
b(i1) = a(56 + i1)
Next i1
n10 = 7: GoSub 1800: If fl1 = 0 Then GoTo 620
a(56) = 6 * s1 / 9 + a(62) - a(65) + a(71) - a(74) + a(80) - a(52) - a(60) - a(68) - a(43) - a(51) - a(59) - a(67) + a(53)
If a(56) < a1(m1) Or a(56) > a1(m2) Then GoTo 620
a(55) = 3 * s1 / 9 - 2*a(62)-a(63)+a(65)-a(71)+a(74)-a(80)-a(58)+a(52)+a(68)-a(57)+a(43)+a(51)+a(67)-a(53)-a(61)
If a(55) < a1(m1) Or a(55) > a1(m2) Then GoTo 620
a(27) = p9 - a(55): a(26) = p9 - a(56)
' Check Row 3 / 7
For i1 = 1 To 9
b(i1) = a(54 + i1)
Next i1
n10 = 9: GoSub 1800: If fl1 = 0 Then GoTo 620
a(54) = 19 * s1 / 9 -a(62)-a(63)-a(70)-a(71)-a(72)-a(78)-a(79)-a(80)-a(81)-0.5*a(42)-0.5*a(50)-0.5*a(52)-0.5*a(60) +
-0.5*a(15)-0.5*a(43)-a(51)-0.5*a(59)-0.5*a(67)-0.5*a(45)-a(53)-a(61)-a(69)-0.5*a(77)
If a(54) < a1(m1) Or a(54) > a1(m2) Or CInt(a(54)) <> a(54) Then GoTo 620
a(46) = s1 - a(54) + a(34) - a(50) - a(52) - 2 * a(43) - 2 * a(51) - a(67) - 2 * a(53) + a(69)
If a(46) < a1(m1) Or a(46) > a1(m2) Then GoTo 620
a(36) = p9 - a(46): a(28) = p9 - a(54):
' Check Row 4 / 6
For i1 = 1 To 9
b(i1) = a(45 + i1)
Next i1
n10 = 9: GoSub 1800: If fl1 = 0 Then GoTo 620
' Calculate c() = 9 * a() + b1() + 1
GoSub 1500: If fl1 = 0 Then GoTo 620
n9 = n9 + 1
GoSub 2650 'Print results (squares)
' GoSub 2645 'Print results (selected numbers
' Cells(1, 1).Value = n9 'Counting
620 Next j62
630 Next j63
650 Next j65
700 Next j70
710 Next j71
720 Next j72
740 Next j74
750 Next j75
780 Next j78
790 Next j79
800 Next j80
810 Next j81
580 Next j58
520 Next j52
600 Next j60
680 Next j68
430 Next j43
510 Next j51
590 Next j59
670 Next j67
530 Next j53
610 Next j61
690 Next j69
770 Next j77
1000
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine SemiLat9b")
End
1500 fl1 = 1
' Rotated
b1(1) = a(73): b1(2) = a(64): b1(3) = a(55): b1(4) = a(46): b1(5) = a(37):
b1(6) = a(28): b1(7) = a(19): b1(8) = a(10): b1(9) = a(1):
b1(10) = a(74): b1(11) = a(65): b1(12) = a(56): b1(13) = a(47): b1(14) = a(38):
b1(15) = a(29): b1(16) = a(20): b1(17) = a(11): b1(18) = a(2):
b1(19) = a(75): b1(20) = a(66): b1(21) = a(57): b1(22) = a(48): b1(23) = a(39):
b1(24) = a(30): b1(25) = a(21): b1(26) = a(12): b1(27) = a(3):
b1(28) = a(76): b1(29) = a(67): b1(30) = a(58): b1(31) = a(49): b1(32) = a(40):
b1(33) = a(31): b1(34) = a(22): b1(35) = a(13): b1(36) = a(4):
b1(37) = a(77): b1(38) = a(68): b1(39) = a(59): b1(40) = a(50): b1(41) = a(41):
b1(42) = a(32): b1(43) = a(23): b1(44) = a(14): b1(45) = a(5):
b1(46) = a(78): b1(47) = a(69): b1(48) = a(60): b1(49) = a(51): b1(50) = a(42):
b1(51) = a(33): b1(52) = a(24): b1(53) = a(15): b1(54) = a(6):
b1(55) = a(79): b1(56) = a(70): b1(57) = a(61): b1(58) = a(52): b1(59) = a(43):
b1(60) = a(34): b1(61) = a(25): b1(62) = a(16): b1(63) = a(7):
b1(64) = a(80): b1(65) = a(71): b1(66) = a(62): b1(67) = a(53): b1(68) = a(44):
b1(69) = a(35): b1(70) = a(26): b1(71) = a(17): b1(72) = a(8):
b1(73) = a(81): b1(74) = a(72): b1(75) = a(63): b1(76) = a(54): b1(77) = a(45):
b1(78) = a(36): b1(79) = a(27): b1(80) = a(18): b1(81) = a(9):
For i1 = 1 To 81
c(i1) = 9 * a(i1) + b1(i1) + 1
Next i1
fl1 = 1: n20 = 0
For j1 = 1 To 81
a2 = c(j1):
For j2 = (1 + j1) To 81
If a2 = c(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Exclude solutions with identical numbers Latin Lines Order 9
1800 fl1 = 1
For j1 = 1 To n10
a2 = b(j1):
For j2 = (1 + j1) To n10
If a2 = b(j2) Then fl1 = 0: Return
Next j2
1810 Next j1
Return
' Print results (selected numbers)
2645 For i1 = 1 To 81
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (squares)
2650 n2 = n2 + 1
If n2 = 5 Then
n2 = 1: k1 = k1 + 10: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 10
End If
Cells(1, 1).Value = n9
Cells(k1, k2 + 1).Font.Color = -4165632
Cells(k1, k2 + 1).Value = CStr(n9)
Cells(k1, k2 + 2).Value = j69
i3 = 0
For i1 = 1 To 9
For i2 = 1 To 9
i3 = i3 + 1
Cells(k1 + i1, k2 + i2).Value = c(i3) ''a(i3)
Next i2
Next i1
Return
End Sub
