Option Explicit

' Optimised Carraghan, R., Pardalos, P. M. algorithm

' by using a heuristic vertex colouring classes for pruning

Private moClasses() As Long, mnClassesCount As Long

Private nLevelDegree() As Long

Private level_nodes() As Long, nStart() As Long, NodesNum() As Long

Private t As Long, mnMaxClique As Long

'

Public Function Start() As Long

Dim i As Long, t_minus_1 As Long

ReDim level_nodes(1 To Nodes, 1 To Nodes)

mnMaxClique = 0

'''''' each level has its own set of nodes

For i = 1 To Nodes

level_nodes(1, i) = i

Next

'''''

DefineClasses

ReDim NodesNum(1 To mnClassesCount)

ReDim nStart(1 To mnClassesCount)

ReDim nLevelDegree(1 To mnClassesCount)

NodesNum(1) = Nodes

t = 1

nStart(t) = 0

'''''''''''''''''''''''''''''''''''

While t >= 1

nStart(t) = nStart(t) + 1

''' Degree control

If NodesNum(t) < nStart(t) Then

t = t - 1

Else

''' if it is not first node (for fist node degree can not be adjusted)

''' and prev. node class is not the same then decrease degree

''' (can be done since vertices are sorted

''' and if cur. vertex class is not the same as for previous then

''' the prev. class is not any longer existing)

If nStart(t) > 1 Then

If (moClasses(level_nodes(t, nStart(t))) <> moClasses(level_nodes(t, nStart(t) - 1))) Then

nLevelDegree(t) = nLevelDegree(t) - 1

End If

Else

''' calculate degree on new depth

nLevelDegree(t) = LevelDegree()

End If

If (t - 1 + nLevelDegree(t)) > mnMaxClique Then

t_minus_1 = t

t = t + 1

nStart(t) = 0

NodesNum(t) = 0

''' define nodes for the next level

For i = nStart(t_minus_1) + 1 To NodesNum(t_minus_1)

If arr(level_nodes(t_minus_1, nStart(t_minus_1)), level_nodes(t_minus_1, i)) Then

NodesNum(t) = NodesNum(t) + 1

level_nodes(t, NodesNum(t)) = level_nodes(t_minus_1, i)

End If

Next

If NodesNum(t) = 0 Then

t = t - 1

If t > mnMaxClique Then

mnMaxClique = t

End If

End If

Else

t = t - 1

End If

End If

Wend

''' return size of maximum clique

Start = mnMaxClique

End Function

Private Function LevelDegree() As Long

Dim res As Long, i As Long, nClass As Long, aClass As Long

For i = nStart(t) To NodesNum(t)

''' for node on level define class (moClasses) and mark it as existing

nClass = moClasses(level_nodes(t, i))

If nClass <> aClass Then

aClass = nClass

res = res + 1

End If

Next

LevelDegree = res

End Function

Private Sub DefineClasses()

Dim class_init() As Boolean '' show if node exist

Dim i As Long, k As Long

Dim mnRemainNodes As Long, bFirstNode As Boolean, nkNode As Long

Dim nNodeNum As Long

mnClassesCount = 0

ReDim class_init(1 To Nodes)

''' get info about existing nodes

ReDim moClasses(1 To Nodes)

'''''

mnRemainNodes = Nodes

While True

''' build up new class

mnClassesCount = mnClassesCount + 1

bFirstNode = True

''' position of first node

i = mnRemainNodes

While i > 0

''' swap nodes

nNodeNum = level_nodes(1, i)

If i <> mnRemainNodes Then

''' swap rows

level_nodes(1, i) = level_nodes(1, mnRemainNodes)

level_nodes(1, mnRemainNodes) = nNodeNum

End If

'''

moClasses(nNodeNum) = mnClassesCount

mnRemainNodes = mnRemainNodes - 1

If mnRemainNodes = 0 Then Exit Sub

If bFirstNode Then

For k = 1 To mnRemainNodes

nkNode = level_nodes(1, k)

class_init(nkNode) = arr(nNodeNum, nkNode)

Next

Else

For k = 1 To mnRemainNodes

nkNode = level_nodes(1, k)

class_init(nkNode) = arr(nNodeNum, nkNode) Or class_init(nkNode)

Next

End If

bFirstNode = False

For i = mnRemainNodes To 1 Step -1

If Not class_init(level_nodes(1, i)) Then Exit For

Next

Wend

Wend

End Sub