Vorige Pagina About the Author

' Generates Semi Latin Composed Magic Squares (14 x 14)
' Self Orthogonal

' Tested with Office 365 under Windows 11

Sub CompLat14()

Dim a(225), b(14), a1(10), a2(4)
Dim b1(225), c(225)

y = MsgBox("Locked", vbCritical, "Routine CompLat14")
End

'   Define Sub Ranges

    n2 = 0: n9 = 0: k1 = 1: k2 = 1: s1 = 105
    
    Sheets("Klad1").Select
   
    m21 = 1: m22 = 4: s2 = 30

    a2(1) = 1:  a2(2) = 2: a2(3) = 13: a2(4) = 14:
     
    m11 = 1: m12 = 6: s3 = 45

    a1(1) = 5:  a1(2) = 6:  a1(3) = 7:  a1(4) = 8:  a1(5) = 9:  a1(6) = 10:

'   Define Corner Squares

    i3 = 0
    For i1 = 1 To 14
    For i2 = 1 To 14
        i3 = i3 + 1
        a(i3) = Sheets("Input14").Cells(i1 + 1, i2 + 1)
    Next i2
    Next i1

'   Generate Squares
    
    t1 = Timer

'   Main Diagonal (Latin)

'   Main Diagonal

For j14 = m11 To m12
a(14) = a1(j14)

If a(14) = a(66) Or a(14) = a(79) Or a(14) = a(92) Or a(14) = a(105) Or a(14) = a(118) Or a(14) = a(131) Then GoTo 140

For j27 = m11 To m12   '
a(27) = a1(j27)

If a(27) = a(66) Or a(27) = a(79) Or a(27) = a(92) Or a(27) = a(105) Or a(27) = a(118) Or a(27) = a(131) Then GoTo 270
If a(27) = a(14) Then GoTo 270

For j40 = m11 To m12
a(40) = a1(j40)

If a(40) = a(66) Or a(40) = a(79) Or a(40) = a(92) Or a(40) = a(105) Or a(40) = a(118) Or a(40) = a(131) Then GoTo 400
If a(40) = a(14) Or a(40) = a(27) Then GoTo 400

For j53 = m11 To m12
a(53) = a1(j53)

If a(53) = a(66) Or a(53) = a(79) Or a(53) = a(92) Or a(53) = a(105) Or a(53) = a(118) Or a(53) = a(131) Then GoTo 530
If a(53) = a(14) Or a(53) = a(27) Or a(53) = a(40) Then GoTo 530

For j144 = m21 To m22
a(144) = a2(j144)

If a(144) = a(66) Or a(144) = a(79) Or a(144) = a(92) Or a(144) = a(105) Or a(144) = a(118) Or a(144) = a(131) Then GoTo 1440
If a(144) = a(14) Or a(144) = a(27) Or a(144) = a(40) Or a(144) = a(53) Then GoTo 1440

For j157 = m21 To m22
a(157) = a2(j157)

If a(157) = a(66) Or a(157) = a(79) Or a(157) = a(92) Or a(157) = a(105) Or a(157) = a(118) Or a(157) = a(131) Then GoTo 1570
If a(157) = a(14) Or a(157) = a(27) Or a(157) = a(40) Or a(157) = a(53) Or a(157) = a(144) Then GoTo 1570

For j170 = m21 To m22
a(170) = a2(j170)

a(183) = s1 - a(170) - a(157) - a(144) - a(131) - a(118) - a(105) - a(92) - a(79) - a(66) - a(53) - a(40) - a(27) - a(14)
If a(183) <> a2(1) And a(183) <> a2(2) And a(183) <> a2(3) And a(183) <> a2(4) Then GoTo 1700

i2 = 14: For i1 = 1 To 14: b(i1) = a(i2): i2 = i2 + 13: Next i1      'Back Check Diagonal
GoSub 1800: If fl1 = 0 Then GoTo 1570

'   Row 1

For j9 = m11 To m12
a(9) = a1(j9)

For j10 = m11 To m12
a(10) = a1(j10)

For j11 = m11 To m12
a(11) = a1(j11)

For j12 = m11 To m12
a(12) = a1(j12)

a(13) = s3 - a(9) - a(10) - a(11) - a(12) - a(14)
If a(13) < a1(m11) Or a(13) > a1(m12) Then GoTo 120

For i1 = 1 To 14: b(i1) = a(i1): Next i1        'Back Check Row 1
GoSub 1800: If fl1 = 0 Then GoTo 120

'   Column 1

For j113 = m21 To m22
a(113) = a2(j113)

For j127 = m22 To m21 Step -1
a(127) = a2(j127)

For j141 = m22 To m21 Step -1
a(141) = a2(j141)
If a(141) = a(64) Then GoTo 1410

For j155 = m21 To m22
a(155) = a2(j155)
If a(155) = a(157) Then GoTo 1550

a(169) = s3 - a(113) - a(127) - a(141) - a(155) - a(183)
If a(169) <> a2(1) And a(169) <> a2(2) And a(169) <> a2(3) And a(169) <> a2(4) Then GoTo 1550

If a(169) = a(170) Then GoTo 1550

'   Row 2

For j23 = m12 To m11 Step -1
a(23) = a1(j23)

For j24 = m12 To m11 Step -1
a(24) = a1(j24)

For j25 = m12 To m11 Step -1
a(25) = a1(j25)

a(39) = s2 - a(11) - a(25) - a(53)
If a(39) < a1(m11) Or a(39) > a1(m12) Then GoTo 250

For j26 = m12 To m11 Step -1
a(26) = a1(j26)

a(28) = s3 - a(23) - a(24) - a(25) - a(26) - a(27)
If a(28) < a1(m11) Or a(28) > a1(m12) Then GoTo 260

a(54) = s2 - a(12) - a(26) - a(40)
If a(54) < a1(m11) Or a(54) > a1(m12) Then GoTo 260

For i1 = 15 To 28: b(i1 - 14) = a(i1): Next i1      'Back Check Row 2
GoSub 1800: If fl1 = 0 Then GoTo 260

'   Column 2

For j114 = m21 To m22
a(114) = a2(j114)
If a(114) = a(113) Then GoTo 1140

For j128 = m21 To m22
a(128) = a2(j128)
If a(128) = a(127) Then GoTo 1280

For j142 = m21 To m22
a(142) = a2(j142)
If a(142) = a(141) Or a(142) = a(144) Then GoTo 1420

a(143) = s2 - a(141) - a(142) - a(144)
If a(143) <> a2(1) And a(143) <> a2(2) And a(143) <> a2(3) And a(143) <> a2(4) Then GoTo 1420

If a(169) = a(170) Then GoTo 1550

For j156 = m21 To m22
a(156) = a2(j156)
If a(156) = a(155) Or a(156) = a(157) Then GoTo 1560

a(158) = s2 - a(155) - a(156) - a(157)
If a(158) <> a2(1) And a(158) <> a2(2) And a(158) <> a2(3) And a(158) <> a2(4) Then GoTo 1560

a(184) = s3 - a(114) - a(128) - a(142) - a(156) - a(170)
If a(184) <> a2(1) And a(184) <> a2(2) And a(184) <> a2(3) And a(184) <> a2(4) Then GoTo 1560

If a(184) = a(183) Then GoTo 1560

'   Row 3 / 4

For j37 = m11 To m12
a(37) = a1(j37)
If a(37) = a(39) Or a(37) = a(40) Then GoTo 370

a(51) = s2 - a(9) - a(23) - a(37)
If a(51) < a1(m11) Or a(51) > a1(m12) Then GoTo 370

For j38 = m11 To m12
a(38) = a1(j38)
If a(38) = a(37) Or a(38) = a(39) Or a(38) = a(40) Then GoTo 380

a(52) = s2 - a(10) - a(24) - a(38)
If a(52) < a1(m11) Or a(52) > a1(m12) Then GoTo 380

For j41 = m11 To m12
a(41) = a1(j41)
If a(41) = a(37) Or a(41) = a(38) Or a(41) = a(39) Or a(41) = a(40) Then GoTo 410

a(55) = s2 - a(13) - a(27) - a(41)
If a(55) < a1(m11) Or a(55) > a1(m12) Then GoTo 410

a(42) = s3 - a(37) - a(38) - a(39) - a(40) - a(41)
If a(42) < a1(m11) Or a(42) > a1(m12) Then GoTo 410

For i1 = 29 To 42: b(i1 - 28) = a(i1): Next i1      'Back Check Row 3
GoSub 1800: If fl1 = 0 Then GoTo 410

a(56) = s3 - a(51) - a(52) - a(53) - a(54) - a(55)
If a(56) < a1(m11) Or a(56) > a1(m12) Then GoTo 410

For i1 = 43 To 56: b(i1 - 42) = a(i1): Next i1      'BacK Check Row 4
GoSub 1800: If fl1 = 0 Then GoTo 410

'   Column 3 / 4

For j115 = m21 To m22
a(115) = a2(j115)
If a(115) = a(113) Or a(115) = a(114) Then GoTo 1150

a(116) = s2 - a(113) - a(114) - a(115)
If a(116) <> a2(1) And a(116) <> a2(2) And a(116) <> a2(3) And a(116) <> a2(4) Then GoTo 1150

For j129 = m21 To m22
a(129) = a2(j129)
If a(129) = a(127) Or a(129) = a(128) Then GoTo 1290

a(130) = s2 - a(127) - a(128) - a(129)
If a(130) <> a2(1) And a(130) <> a2(2) And a(130) <> a2(3) And a(130) <> a2(4) Then GoTo 1290

For j171 = m21 To m22
a(171) = a2(j171)
If a(171) = a(169) Or a(171) = a(170) Then GoTo 1710

a(185) = s3 - a(115) - a(129) - a(143) - a(157) - a(171)
If a(185) <> a2(1) And a(185) <> a2(2) And a(185) <> a2(3) And a(185) <> a2(4) Then GoTo 1710

If a(185) = a(183) Or a(185) = a(184) Then GoTo 1710

a(172) = s2 - a(169) - a(170) - a(171)
If a(172) <> a2(1) And a(172) <> a2(2) And a(172) <> a2(3) And a(172) <> a2(4) Then GoTo 1710

a(186) = s2 - a(183) - a(184) - a(185)
If a(186) <> a2(1) And a(186) <> a2(2) And a(186) <> a2(3) And a(186) <> a2(4) Then GoTo 1710


GoSub 3000: If fl1 = 0 Then GoTo 1710                                'Check Self Orthogonal
n9 = n9 + 1: GoSub 2650: End


1710  Next j171
1290  Next j129
1150  Next j115

410 Next j41
380 Next j38
370 Next j37

1560  Next j156
1420  Next j142
1280  Next j128
1140  Next j114

260 Next j26
250 Next j25
240 Next j24
230 Next j23

1550  Next j155
1410  Next j141
1270  Next j127
1130  Next j113

120  Next j12
110  Next j11
100  Next j10
90  Next j9

1700 Next j170
1570 Next j157
1440 Next j144
530 Next j53
400 Next j40
270 Next j27
140 Next j14

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

End

3000 fl1 = 1: n14 = 0

'    Transpose: b1() = T(a())

b1(1) = a(1):   b1(2) = a(15):   b1(3) = a(29):  b1(4) = a(43):  b1(5) = a(57):  b1(6) = a(71):  b1(7) = a(85):
b1(15) = a(2):  b1(16) = a(16):  b1(17) = a(30): b1(18) = a(44): b1(19) = a(58): b1(20) = a(72): b1(21) = a(86):
b1(29) = a(3):  b1(30) = a(17):  b1(31) = a(31): b1(32) = a(45): b1(33) = a(59): b1(34) = a(73): b1(35) = a(87):
b1(43) = a(4):  b1(44) = a(18):  b1(45) = a(32): b1(46) = a(46): b1(47) = a(60): b1(48) = a(74): b1(49) = a(88):
b1(57) = a(5):  b1(58) = a(19):  b1(59) = a(33): b1(60) = a(47): b1(61) = a(61): b1(62) = a(75): b1(63) = a(89):
b1(71) = a(6):  b1(72) = a(20):  b1(73) = a(34): b1(74) = a(48): b1(75) = a(62): b1(76) = a(76): b1(77) = a(90):
b1(85) = a(7):  b1(86) = a(21):  b1(87) = a(35): b1(88) = a(49): b1(89) = a(63): b1(90) = a(77): b1(91) = a(91):
b1(99) = a(8):  b1(100) = a(22): b1(101) = a(36): b1(102) = a(50): b1(103) = a(64): b1(104) = a(78): b1(105) = a(92):
b1(113) = a(9): b1(114) = a(23): b1(115) = a(37): b1(116) = a(51): b1(117) = a(65): b1(118) = a(79): b1(119) = a(93):
b1(127) = a(10): b1(128) = a(24): b1(129) = a(38): b1(130) = a(52): b1(131) = a(66): b1(132) = a(80): b1(133) = a(94):
b1(141) = a(11): b1(142) = a(25): b1(143) = a(39): b1(144) = a(53): b1(145) = a(67): b1(146) = a(81): b1(147) = a(95):
b1(155) = a(12): b1(156) = a(26): b1(157) = a(40): b1(158) = a(54): b1(159) = a(68): b1(160) = a(82): b1(161) = a(96):
b1(169) = a(13): b1(170) = a(27): b1(171) = a(41): b1(172) = a(55): b1(173) = a(69): b1(174) = a(83): b1(175) = a(97):
b1(183) = a(14): b1(184) = a(28): b1(185) = a(42): b1(186) = a(56): b1(187) = a(70): b1(188) = a(84): b1(189) = a(98):

b1(8) = a(99):   b1(9) = a(113):  b1(10) = a(127): b1(11) = a(141): b1(12) = a(155): b1(13) = a(169): b1(14) = a(183):
b1(22) = a(100): b1(23) = a(114): b1(24) = a(128): b1(25) = a(142): b1(26) = a(156): b1(27) = a(170): b1(28) = a(184):
b1(36) = a(101): b1(37) = a(115): b1(38) = a(129): b1(39) = a(143): b1(40) = a(157): b1(41) = a(171): b1(42) = a(185):
b1(50) = a(102): b1(51) = a(116): b1(52) = a(130): b1(53) = a(144): b1(54) = a(158): b1(55) = a(172): b1(56) = a(186):
b1(64) = a(103): b1(65) = a(117): b1(66) = a(131): b1(67) = a(145): b1(68) = a(159): b1(69) = a(173): b1(70) = a(187):
b1(78) = a(104): b1(79) = a(118): b1(80) = a(132): b1(81) = a(146): b1(82) = a(160): b1(83) = a(174): b1(84) = a(188):
b1(92) = a(105): b1(93) = a(119): b1(94) = a(133): b1(95) = a(147): b1(96) = a(161): b1(97) = a(175): b1(98) = a(189):
b1(106) = a(106): b1(107) = a(120): b1(108) = a(134): b1(109) = a(148): b1(110) = a(162): b1(111) = a(176): b1(112) = a(190):
b1(120) = a(107): b1(121) = a(121): b1(122) = a(135): b1(123) = a(149): b1(124) = a(163): b1(125) = a(177): b1(126) = a(191):
b1(134) = a(108): b1(135) = a(122): b1(136) = a(136): b1(137) = a(150): b1(138) = a(164): b1(139) = a(178): b1(140) = a(192):
b1(148) = a(109): b1(149) = a(123): b1(150) = a(137): b1(151) = a(151): b1(152) = a(165): b1(153) = a(179): b1(154) = a(193):
b1(162) = a(110): b1(163) = a(124): b1(164) = a(138): b1(165) = a(152): b1(166) = a(166): b1(167) = a(180): b1(168) = a(194):
b1(176) = a(111): b1(177) = a(125): b1(178) = a(139): b1(179) = a(153): b1(180) = a(167): b1(181) = a(181): b1(182) = a(195):
b1(190) = a(112): b1(191) = a(126): b1(192) = a(140): b1(193) = a(154): b1(194) = a(168): b1(195) = a(182): b1(196) = a(196):

'    Determine Simple Magic Square c()
    
     For i1 = 1 To 196
          c(i1) = a(i1) + 14 * (b1(i1) - 1)
     Next i1

'    Check Identical Numbers

     For j1 = 1 To 196
        c2 = c(j1): If c2 = -14 Then GoTo 3010
        For j2 = (1 + j1) To 196
            If c2 = c(j2) Then fl1 = 0: Return
        Next j2
3010 Next j1

Return

'    Exclude solutions with identical numbers Latin Lines Order 14

1800 fl1 = 1
     For j1 = 1 To 14
        a20 = b(j1): If a20 = 0 Then GoTo 1810
        For j2 = (1 + j1) To 14
            If a20 = b(j2) Then fl1 = 0: Return
        Next j2
1810 Next j1
     Return

'   Print results (squares)

2650 n2 = n2 + 1
     If n2 = 3 Then
         n2 = 1: k1 = k1 + 15: k2 = 1
     Else
         If n9 > 1 Then k2 = k2 + 15
     End If
     
     Cells(k1, k2 + 1).Font.Color = -4165632
     Cells(k1, k2 + 1).Value = CStr(n9)
    
     i3 = 0
     For i1 = 1 To 14
         For i2 = 1 To 14
             i3 = i3 + 1
             Cells(k1 + i1, k2 + i2).Value = a(i3)
         Next i2
     Next i1
    
     Return

'   Print results (squares)

2750 n2 = n2 + 1
     If n2 = 3 Then
         n2 = 1: k1 = k1 + 15: k2 = 1
     Else
         If n9 > 1 Then k2 = k2 + 15
     End If
     
     Cells(k1, k2 + 1).Font.Color = -4165632
     Cells(k1, k2 + 1).Value = CStr(n9)
    
     i3 = 0
     For i1 = 1 To 14
         For i2 = 1 To 14
             i3 = i3 + 1
             If c(i3) <> -14 Then
                Cells(k1 + i1 + 17, k2 + i2).Value = c(i3)
             End If
         Next i2
     Next i1
    
     Return
     
End Sub

Vorige Pagina About the Author