Option Explicit

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

' by using a heuristic vertex colouring and a backtrack search

Private moClasses() As Long, mnClassesCount As Long

Private level_nodes() As Long, nStart() As Long, NodesNum() As Long ' number of nodes on level

Private t As Long, mnMaxClique As Long

Private nLevelWAcc() As Long

Private nLevelDegree() As Long

Private nMaxCliques() As Long

'

Public Function Start() As Long

Dim i As Long, t_minus_1 As Long, nn As Long, wt As Long

ReDim level_nodes(1 To Nodes, 1 To Nodes, 0 To 1)

ReDim nMaxCliques(1 To Nodes)

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

For i = 1 To Nodes

level_nodes(1, i, 0) = i

Next

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

DefineClasses

ResortByWeights

For i = 1 To Nodes

level_nodes(1, i, 1) = i

Next

ReDim NodesNum(1 To mnClassesCount)

ReDim nStart(1 To mnClassesCount)

ReDim nLevelDegree(1 To mnClassesCount)

ReDim nLevelWAcc(1 To mnClassesCount)

NodesNum(1) = Nodes

For nn = Nodes To 1 Step -1

t = 2

NodesNum(t) = 0

nLevelWAcc(t) = w(level_nodes(1, nn, 0))

For i = nn + 1 To Nodes

If arr(level_nodes(1, nn, 0), level_nodes(1, i, 0)) Then

NodesNum(t) = NodesNum(t) + 1

level_nodes(t, NodesNum(t), 0) = level_nodes(1, i, 0)

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

End If

Next

If NodesNum(t) = 0 Then

t = t - 1

If nLevelWAcc(t + 1) > mnMaxClique Then

mnMaxClique = nLevelWAcc(t + 1)

End If

Else

nStart(t) = 0

End If

While t >= 2

nStart(t) = nStart(t) + 1

If NodesNum(t) < nStart(t) Then

t = t - 1

Else

If (nLevelWAcc(t) + nMaxCliques(level_nodes(t, nStart(t), 1))) > _

mnMaxClique Then

If nStart(t) > 1 Then

If (moClasses(level_nodes(t, nStart(t), 0)) <> _

moClasses(level_nodes(t, nStart(t) - 1, 0))) Then

nLevelDegree(t) = nLevelDegree(t) - w(level_nodes(t, nStart(t) - 1, 0))

Else

nLevelDegree(t) = nLevelDegree(t) - w(level_nodes(t, nStart(t) - 1, 0)) _

+ w(level_nodes(t, nStart(t), 0))

End If

Else

''' calculate degree on new depth

nLevelDegree(t) = LevelDegree()

End If

If (nLevelWAcc(t) + nLevelDegree(t)) > mnMaxClique Then

t_minus_1 = t

t = t + 1

nStart(t) = 0

NodesNum(t) = 0

nLevelWAcc(t) = nLevelWAcc(t_minus_1) + _

w(level_nodes(t_minus_1, nStart(t_minus_1), 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), 0), _

level_nodes(t_minus_1, i, 0)) Then

NodesNum(t) = NodesNum(t) + 1

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

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

End If

Next

If NodesNum(t) = 0 Then

t = t - 1

If nLevelWAcc(t + 1) > mnMaxClique Then

mnMaxClique = nLevelWAcc(t + 1)

End If

End If

Else

t = t - 1

End If

Else

t = t - 1

End If

End If

Wend

nMaxCliques(nn) = mnMaxClique

Next

''' return size of maximu clique

Start = mnMaxClique

End Function

Private Sub DefineClasses()

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

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, 0)

If i <> mnRemainNodes Then

''' swap rows

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

level_nodes(1, mnRemainNodes, 0) = 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, 0)

class_init(nkNode) = arr(nNodeNum, nkNode)

Next

Else

For k = 1 To mnRemainNodes

nkNode = level_nodes(1, k, 0)

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, 0)) Then Exit For

Next

Wend

Wend

End Sub

Private Function LevelDegree() As Long

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

For i = NodesNum(t) To nStart(t) Step -1

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

nClass = moClasses(level_nodes(t, i, 0))

If nClass <> aClass Then

res = res + w(level_nodes(t, i, 0))

aClass = nClass

End If

Next

LevelDegree = res

End Function

Public Sub ResortByWeights()

Dim i As Long, j As Long, maxi As Long, maxw As Long, aClass As Long

Dim nNode As Long

For i = Nodes To 2 Step -1

maxi = i

nNode = level_nodes(1, maxi, 0)

maxw = w(nNode)

aClass = moClasses(nNode)

For j = i - 1 To 1 Step -1

nNode = level_nodes(1, j, 0)

If moClasses(nNode) <> aClass Then Exit For

If maxw < w(nNode) Then

maxi = j

maxw = w(nNode)

End If

Next

If i <> maxi Then

nNode = level_nodes(1, i, 0)

level_nodes(1, i, 0) = level_nodes(1, maxi, 0)

level_nodes(1, maxi, 0) = nNode

End If

Next

End Sub