' Generates Pan Diagonal Top Squares for Pan Diagonal/Triagonal Cubes of order 5 for integers 0 thru 4
' Tested with Office 2007 under Windows 7
Sub SudCube5e1()
Dim a(125), a5(25), b(10)
y = MsgBox("Locked", vbCritical, "Routine SudCube5e1")
End
n2 = 0: n9 = 0: k1 = 1: k2 = 1
m1 = 0: m2 = 4: s1 = 10
Sheets("Klad1").Select
t1 = Timer
' Generate Top Squares
For j125 = m1 To m2
a(125) = j125
Cells(n9 + 1, 125).Select
Cells(n9 + 1, 125).Value = j125
For j124 = m1 To m2
a(124) = j124
Cells(n9 + 1, 124).Select
Cells(n9 + 1, 124).Value = j124
For j123 = m1 To m2
a(123) = j123
Cells(n9 + 1, 123).Select
Cells(n9 + 1, 123).Value = j123
For j122 = m1 To m2
a(122) = j122
Cells(n9 + 1, 122).Select
Cells(n9 + 1, 122).Value = j122
For j121 = m1 To m2
a(121) = j121
Cells(n9 + 1, 121).Select
Cells(n9 + 1, 121).Value = j121
For j120 = m1 To m2
If j120 = j121 Or j120 = j124 Then GoTo 1200
a(120) = j120
Cells(n9 + 1, 120).Select
Cells(n9 + 1, 120).Value = j120
For j119 = m1 To m2
If j119 = j123 Or j119 = j125 Then GoTo 1190
a(119) = j119
Cells(n9 + 1, 119).Select
Cells(n9 + 1, 119).Value = j119
For j118 = m1 To m2
If j118 = j122 Or j118 = j124 Then GoTo 1180
a(118) = j118
Cells(n9 + 1, 118).Select
Cells(n9 + 1, 118).Value = j118
For j117 = m1 To m2
If j117 = j121 Or j117 = j123 Then GoTo 1170
a(117) = j117
Cells(n9 + 1, 117).Select
Cells(n9 + 1, 117).Value = j117
For j116 = m1 To m2
If j116 = j122 Or j116 = j125 Then GoTo 1160
a(116) = j116
Cells(n9 + 1, 116).Select
Cells(n9 + 1, 116).Value = j116
For j115 = m1 To m2
If j115 = j119 Or j115 = j123 Or j115 = j116 Or j115 = j122 Then GoTo 1150
a(115) = j115
For j114 = m1 To m2
If j114 = j118 Or j114 = j122 Or j114 = j120 Or j114 = j121 Then GoTo 1140
a(114) = j114
For j113 = m1 To m2
If j113 = j117 Or j113 = j121 Or j113 = j119 Or j113 = j125 Then GoTo 1130
a(113) = j113
For j112 = m1 To m2
If j112 = j116 Or j112 = j125 Or j112 = j118 Or j112 = j124 Then GoTo 1120
a(112) = j112
For j111 = m1 To m2
If j111 = j120 Or j111 = j124 Or j111 = j117 Or j111 = j123 Then GoTo 1110
a(111) = j111
For j110 = m1 To m2
If j110 = j114 Or j110 = j118 Or j110 = j122 Then GoTo 1100
If j110 = j111 Or j110 = j117 Or j110 = j123 Then GoTo 1100
a(110) = j110
Cells(n9 + 1, 110).Select
Cells(n9 + 1, 110).Value = j110
a(109) = a(110) + a(111) - a(113) + a(114) - a(115) - a(116) + a(118) - a(119) + a(120) + a(124) - a(125)
If a(109) < m1 Or a(109) > m2 Then GoTo 1100
a(108) = a(110) + a(111) - a(112) - a(116) + a(117) + a(123) - a(125)
If a(108) < m1 Or a(108) > m2 Then GoTo 1100
a(107) = a(110) - a(113) + a(114) + a(118) - a(119) + a(122) - a(125)
If a(107) < m1 Or a(107) > m2 Then GoTo 1100
a(106) = a(110) + a(111) - a(112) + a(114) - a(115) - a(116) + a(117) - a(119) + a(120) + a(121) - a(125)
If a(106) < m1 Or a(106) > m2 Then GoTo 1100
a(105) = s1 - a(110) - a(111) - a(114) + a(115) + a(116) - a(117) - a(118) + a(119) - a(120) - a(121) - a(124) + a(125)
If a(105) < m1 Or a(105) > m2 Then GoTo 1100
a(104) = s1 - a(110) - a(111) - a(117) - a(123)
If a(104) < m1 Or a(104) > m2 Then GoTo 1100
a(103) = s1 - a(110) - a(111) + a(113) - a(114) - a(118) + a(119) - a(120) - a(122) - a(124) + a(125)
If a(103) < m1 Or a(103) > m2 Then GoTo 1100
a(102) = s1 - a(110) - a(111) + a(112) - a(114) + a(116) - a(117) - a(120) - a(121) - a(123) + a(125)
If a(102) < m1 Or a(102) > m2 Then GoTo 1100
a(101) = s1 - a(110) - a(114) - a(118) - a(122)
If a(101) < m1 Or a(101) > m2 Then GoTo 1100
' Exclude solutions with identical numbers in Pan Diagonals, Pan Triagonals (?)
GoSub 800: If fl1 = 0 Then GoTo 1100
n9 = n9 + 1
GoSub 1740 'Print results (selected numbers)
1100 Next j110
1110 Next j111
1120 Next j112
1130 Next j113
1140 Next j114
1150 Next j115
1160 Next j116
1170 Next j117
1180 Next j118
1190 Next j119
1200 Next j120
1210 Next j121
1220 Next j122
1230 Next j123
1240 Next j124
1250 Next j125
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions"
y = MsgBox(t10, 0, "Routine SudCube5e2")
End
' Check (Pan) Diagonals Top Square
800 fl1 = 1
For i1 = 1 To 25
a5(i1) = a(100 + i1)
Next i1
b(1) = a5(1): b(2) = a5(7): b(3) = a5(13): b(4) = a5(19): b(5) = a5(25): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(2): b(2) = a5(8): b(3) = a5(14): b(4) = a5(20): b(5) = a5(21): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(3): b(2) = a5(9): b(3) = a5(15): b(4) = a5(16): b(5) = a5(22): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(4): b(2) = a5(10): b(3) = a5(11): b(4) = a5(17): b(5) = a5(23): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(5): b(2) = a5(6): b(3) = a5(12): b(4) = a5(18): b(5) = a5(24): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(5): b(2) = a5(9): b(3) = a5(13): b(4) = a5(17): b(5) = a5(21): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(4): b(2) = a5(8): b(3) = a5(12): b(4) = a5(16): b(5) = a5(25): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(3): b(2) = a5(7): b(3) = a5(11): b(4) = a5(20): b(5) = a5(24): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(2): b(2) = a5(6): b(3) = a5(15): b(4) = a5(19): b(5) = a5(23): GoSub 860: If fl1 = 0 Then Return
b(1) = a5(1): b(2) = a5(10): b(3) = a5(14): b(4) = a5(18): b(5) = a5(22): GoSub 860: If fl1 = 0 Then Return
Return
860 fl1 = 1
For j1 = 1 To 5
b2 = b(j1)
For j2 = (1 + j1) To 5
If b2 = b(j2) Then fl1 = 0: Return
Next j2
Next j1
Return
' Print results (selected numbers)
1740 For i1 = 101 To 125
Cells(n9, i1).Value = a(i1)
Next i1
Return
End Sub
