' Generates Associated Magic Cubes of order 5 (Prime Numbers)
' Part II: Associated Inner Cube
' Tested with Office 365 under Windows 10
Sub PrimeCube5d2(x)
Dim a1(555), a(125), b1(37493), b(37493), c(125)
y = MsgBox("Locked", vbCritical, "Routine PrimeCube5d2")
End
n2 = 0: n9 = 0: n10 = 0: k1 = 1: k2 = 1
ShtNm1 = "Pairs7"
ShtNm2 = "AssBrdr5"
Sheets("Klad1").Select
t1 = Timer
For j100 = 5003 To 5500
' Start reading data from "AssBrdr5"
Rcrd1a = Sheets(ShtNm2).Cells(j100, 127).Value
s1 = Sheets(ShtNm2).Cells(j100, 126).Value
' Read Pairs
GoSub 2000
' Read Associated Border
Erase a
For i1 = 1 To 125
a(i1) = Sheets(ShtNm2).Cells(j100, i1).Value
Next i1
a(63) = Cntr5
' Block Used Primes
Erase b
For i1 = 1 To 125
If a(i1) <> 0 Then
b(a(i1)) = a(i1)
End If
Next i1
' Complets Cube
For j94 = m1 To m2
If b(a1(j94)) = 0 Then b(a1(j94)) = a1(j94): c(94) = a1(j94) Else GoTo 940
a(94) = a1(j94)
a(32) = Pr5 - a(94): If b(a(32)) = 0 Then b(a(32)) = a(32): c(32) = a(32) Else GoTo 320
For j93 = m1 To m2
If b(a1(j93)) = 0 Then b(a1(j93)) = a1(j93): c(93) = a1(j93) Else GoTo 930
a(93) = a1(j93)
a(33) = Pr5 - a(93):: If b(a(33)) = 0 Then b(a(33)) = a(33): c(33) = a(33) Else GoTo 330
a(92) = s1 - a(91) - a(93) - a(94) - a(95)
If a(92) < a1(m1) Or a(92) > a1(m2) Then GoTo 920
If b1(a(92)) = 0 Then GoTo 920
If b(a(92)) = 0 Then b(a(92)) = a(92): c(92) = a(92) Else GoTo 920
a(34) = Pr5 - a(92): If b(a(34)) = 0 Then b(a(34)) = a(34): c(34) = a(34) Else GoTo 340
For j89 = m1 To m2
If b(a1(j89)) = 0 Then b(a1(j89)) = a1(j89): c(89) = a1(j89) Else GoTo 890
a(89) = a1(j89)
a(37) = Pr5 - a(89): If b(a(37)) = 0 Then b(a(37)) = a(37): c(37) = a(37) Else GoTo 370
a(84) = s1 - a(79) - a(89) - a(94) - a(99)
If a(84) < a1(m1) Or a(84) > a1(m2) Then GoTo 840
If b1(a(84)) = 0 Then GoTo 840
If b(a(84)) = 0 Then b(a(84)) = a(84): c(84) = a(84) Else GoTo 840
a(42) = Pr5 - a(84): If b(a(42)) = 0 Then b(a(42)) = a(42): c(42) = a(42) Else GoTo 420
For j88 = m1 To m2
If b(a1(j88)) = 0 Then b(a1(j88)) = a1(j88): c(88) = a1(j88) Else GoTo 880
a(88) = a1(j88)
a(38) = Pr5 - a(88): If b(a(38)) = 0 Then b(a(38)) = a(38): c(38) = a(38) Else GoTo 380
a(87) = s1 - a(86) - a(88) - a(89) - a(90)
If a(87) < a1(m1) Or a(87) > a1(m2) Then GoTo 870
If b1(a(87)) = 0 Then GoTo 870
If b(a(87)) = 0 Then b(a(87)) = a(87): c(87) = a(87) Else GoTo 870
a(39) = Pr5 - a(87): If b(a(39)) = 0 Then b(a(39)) = a(39): c(39) = a(39) Else GoTo 390
a(83) = s1 - a(78) - a(88) - a(93) - a(98)
If a(83) < a1(m1) Or a(83) > a1(m2) Then GoTo 830
If b1(a(83)) = 0 Then GoTo 830
If b(a(83)) = 0 Then b(a(83)) = a(83): c(83) = a(83) Else GoTo 830
a(43) = Pr5 - a(83): If b(a(43)) = 0 Then b(a(43)) = a(43): c(43) = a(43) Else GoTo 430
a(82) = s1 - a(81) - a(83) - a(84) - a(85)
If a(82) < a1(m1) Or a(82) > a1(m2) Then GoTo 820
If b1(a(82)) = 0 Then GoTo 820
If b(a(82)) = 0 Then b(a(82)) = a(82): c(82) = a(82) Else GoTo 820
a(44) = Pr5 - a(82): If b(a(44)) = 0 Then b(a(44)) = a(44): c(44) = a(44) Else GoTo 440
a(69) = s1 - a(19) - a(44) - a(94) - a(119)
If a(69) < a1(m1) Or a(69) > a1(m2) Then GoTo 690
If b1(a(69)) = 0 Then GoTo 690
If b(a(69)) = 0 Then b(a(69)) = a(69): c(69) = a(69) Else GoTo 690
a(57) = Pr5 - a(69): If b(a(57)) = 0 Then b(a(57)) = a(57): c(57) = a(57) Else GoTo 570
a(68) = s1 - a(18) - a(43) - a(93) - a(118)
If a(68) < a1(m1) Or a(68) > a1(m2) Then GoTo 680
If b1(a(68)) = 0 Then GoTo 680
If b(a(68)) = 0 Then b(a(68)) = a(68): c(68) = a(68) Else GoTo 680
a(58) = Pr5 - a(68): If b(a(58)) = 0 Then b(a(58)) = a(58): c(58) = a(58) Else GoTo 580
a(67) = s1 - a(17) - a(42) - a(92) - a(117)
If a(67) < a1(m1) Or a(67) > a1(m2) Then GoTo 670
If b1(a(67)) = 0 Then GoTo 670
If b(a(67)) = 0 Then b(a(67)) = a(67): c(67) = a(67) Else GoTo 670
a(59) = Pr5 - a(67): If b(a(59)) = 0 Then b(a(59)) = a(59): c(59) = a(59) Else GoTo 590
''n9 = n9 + 1: GoSub 1750: End
a(64) = s1 - a(14) - a(39) - a(89) - a(114)
If a(64) < a1(m1) Or a(64) > a1(m2) Then GoTo 640
If b1(a(64)) = 0 Then GoTo 640
If b(a(64)) = 0 Then b(a(64)) = a(64): c(64) = a(64) Else GoTo 640
a(62) = Pr5 - a(64): If b(a(62)) = 0 Then b(a(62)) = a(62): c(62) = a(62) Else GoTo 620
' Exclude solutions with identical numbers (Back Check)
GoSub 1300: If fl1 = 0 Then GoTo 5
' n9 = n9 + 1: GoSub 1740 'Print results (selected numbers)
n9 = n9 + 1: GoSub 1750 'Print results (cubes)
Erase b, c: GoTo 1000 'Print only first cube
5
b(c(62)) = 0: c(62) = 0
620 b(c(64)) = 0: c(64) = 0
640 b(c(59)) = 0: c(59) = 0
590 b(c(67)) = 0: c(67) = 0
670 b(c(58)) = 0: c(58) = 0
580 b(c(68)) = 0: c(68) = 0
680 b(c(57)) = 0: c(57) = 0
570 b(c(69)) = 0: c(69) = 0
690 b(c(44)) = 0: c(44) = 0
440 b(c(82)) = 0: c(82) = 0
820 b(c(43)) = 0: c(43) = 0
430 b(c(83)) = 0: c(83) = 0
830 b(c(39)) = 0: c(39) = 0
390 b(c(87)) = 0: c(87) = 0
870 b(c(38)) = 0: c(38) = 0
380 b(c(88)) = 0: c(88) = 0
880 Next j88
b(c(42)) = 0: c(42) = 0
420 b(c(84)) = 0: c(84) = 0
840 b(c(37)) = 0: c(37) = 0
370 b(c(89)) = 0: c(89) = 0
890 Next j89
b(c(34)) = 0: c(34) = 0
340 b(c(92)) = 0: c(92) = 0
920 b(c(33)) = 0: c(33) = 0
330 b(c(93)) = 0: c(93) = 0
930 Next j93
b(c(32)) = 0: c(32) = 0
320 b(c(94)) = 0: c(94) = 0
940 Next j94
Erase b1, b, c
1000 Next j100
t2 = Timer
t10 = Str(t2 - t1) + " sec., " + Str(n9) + " Solutions for sum" + Str(s1)
y = MsgBox(t10, 0, "Routine PrimeCube5d2")
End
' Read Pairs
2000
Pr5 = Sheets(ShtNm1).Cells(Rcrd1a, 1).Value
s5 = 5 * Pr5 / 2
Cntr5 = Pr5 / 2
If s5 <> s1 Then
y = MsgBox("Conflict in Input", vbCritical, "CnstrAss5")
End
End If
nVar1 = Sheets(ShtNm1).Cells(Rcrd1a, 9).Value
For i1 = 1 To nVar1
a1(i1) = Sheets(ShtNm1).Cells(Rcrd1a, 9 + i1).Value
Next i1
m1 = 1: m2 = nVar1
Erase b1
For i1 = m1 To m2
b1(a1(i1)) = a1(i1)
Next i1
Return
' Print results (selected numbers)
1740 For i1 = 1 To 125
Cells(n9, i1).Value = a(i1)
Next i1
Return
' Print results (planes 11, 12, 13, 14 and 15)
1750 n2 = n2 + 1
If n2 = 7 Then
n2 = 1: k1 = k1 + 30: k2 = 1
Else
If n9 > 1 Then k2 = k2 + 6
End If
Cells(2, 1).Value = n9
For i0 = 1 To 5
i3 = (5 - i0) * 25
For i1 = 1 To 5
For i2 = 1 To 5
i3 = i3 + 1
Cells(k1 + i1 + (i0 - 1) * 6, k2 + i2).Value = a(i3)
'' Cells(k1 + i1 + (i0 - 1) * 6, k2 + 7 + i2).Value = i3 '*** Test ***
Next i2
Next i1
If i0 = 1 Then
''Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = "Plane 1" + CStr(i0) + ", C" + CStr(n9)
Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = " C" + CStr(n9)
Cells(k1 + (i0 - 1) * 6, k2 + 1 + 1).Value = j100
Else
''Cells(k1 + (i0 - 1) * 6, k2 + 1).Value = "Plane 1" + CStr(i0)
End If
Next i0
Sheets(ShtNm2).Cells(j100, 131).Value = "ok"
Return
' Check identical numbers
1300 fl1 = 1
For i1 = 1 To 125
a2 = a(i1): If a2 = 0 Then GoTo 1350
For i2 = (1 + i1) To 125
If a2 = a(i2) Then fl1 = 0: Return
Next i2
1350 Next i1
Return
End Sub
