Option Compare Database
Const maxBlocks As Integer = 512
Public Const maxSubBlocks As Integer = 12
Const maxUndos As Integer = 500
Const maxUndoBlocks As Integer = 4096

Type c
name As String
cList(1 To 10) As Integer
End Type

Type rBlock
BlockID As Integer
BlockName As String
Description As String
rstID As Long
bWidth As Single
bHeight As Single
bLeft As Single
bTop As Single
bRowNumber As Integer
bType As String
Mother As Integer
nSubBlocks As Integer
nActiveSubBlocks As Integer
SubBlocks(1 To maxSubBlocks) As Integer
BlockCapacity As Single
BlockType As String
SequenceNumber As Integer
n As Integer
ElementCapacity As Single
k As Integer
SystemID As Long
CmdID As Long
RelDataSource As String
RelDataType As String
RelDataPointer As Integer
MDT As Single
tau As Single

IsMarked As Boolean
ShowKooNCtl As String
End Type
Public nBlocks As Integer
Public Blocks(1 To maxBlocks) As rBlock
Public CopyPointer As Integer
Public CBlocks(1 To maxBlocks) As rBlock
Public UBlocks(1 To maxUndoBlocks) As rBlock
Dim UndoPtr As Integer
Dim Undo(1 To 2, 0 To maxUndos)
Dim DoCancel As Boolean
Dim CompNameImportance As String
Dim CompToImprove As String
Dim YearToImprove As Long
Dim LamVec(1 To maxBlocks) As Single
Dim MDTVec(1 To maxBlocks) As Single
Dim MDTPtr As Integer
Dim CurPtr As Integer
Dim IsChanged As Boolean
Dim CurrentComp As String
Function GetMaxSubBlocks()
GetMaxSubBlocks = maxSubBlocks
End Function


Function SetCurrentComp(ID As Integer)
CurrentComp = Blocks(ID).BlockName
End Function
Function GetCurrentComp()
GetCurrentComp = Nz(CurrentComp)
End Function
Function GetChildren(ID As Integer)
Dim s As String
Dim i As Integer
Dim child As Integer
s = "Sub elements of " & Blocks(ID).BlockName
For i = 1 To Blocks(ID).nSubBlocks
    child = Blocks(ID).SubBlocks(i)
    s = s & Chr(13) & Chr(10) & Blocks(child).BlockName
Next i
GetChildren = s
End Function


Function PageSaved()
IsChanged = False
End Function


Function SetChangeFlag(Optional Chnge As Boolean = True)
IsChanged = Chnge
If Not Chnge Then Forms!drwscreen.OnScreenChanged
End Function
Function PageIsChanged()
PageIsChanged = IsChanged
End Function

Function SetComponentImportance(CompName As String)
CompNameImportance = CompName
End Function
Function SetComponentToImprove(CompName As String, yr As Long)
CompToImprove = CompName
YearToImprove = yr
End Function


Function ComponentExist(comp As String)
Dim i As Integer
Dim ret As String
ret = ""
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) And UCase(.BlockName) = UCase(comp) Then
            ComponentExist = True
            Exit Function
        End If
    End If
    End With
Next i
ComponentExist = False
End Function



Function GetRelDataSource(comp As Variant)
Dim i As Integer
Dim ret As String
ret = ""
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) And .BlockName = comp Then
            If .RelDataSource <> "" Then
                ret = .RelDataSource
                Exit For
            End If
        End If
    End If
    End With
Next i
GetRelDataSource = ret
End Function

Function GetRelDataKooN(comp As Variant)
Dim i As Integer
Dim ret As String
ret = ""
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) And .BlockName = comp Then
            If .RelDataSource <> "" Then
                ret = Format(.k) & "oo" & Format(.n)
                Exit For
            End If
        End If
    End If
    End With
Next i
GetRelDataKooN = ret
End Function

Function GetRelDataTau(comp As Variant)
Dim i As Integer
Dim ret As Single
ret = 0
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) And .BlockName = comp Then
            If .RelDataSource <> "" Then
                ret = .tau
                Exit For
            End If
        End If
    End If
    End With
Next i
GetRelDataTau = ret
End Function

Function GetRelDataMTTR(comp As Variant)
Dim i As Integer
Dim ret As Single
ret = 0
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) And .BlockName = comp Then
            If .RelDataSource <> "" Then
                ret = .MDT
                Exit For
            End If
        End If
    End If
    End With
Next i
GetRelDataMTTR = ret
End Function
Function GetRelDataType(comp As Variant)
Dim i As Integer
Dim ret As String
ret = ""
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) And .BlockName = comp Then
            ret = .BlockType
            Exit For
        End If
    End If
    End With
Next i
GetRelDataType = ret
End Function

Function LoadRelData(Optional yr As Single)
Dim ErrStatus As Integer
Dim SVHlp As StateVariable
Dim l As Variant
Dim M As Variant
Dim i As Integer
Dim j As Integer
Dim Adjust As Single
Dim db As Database
Dim rst As Recordset

Set db = CurrentDb
Set rst = db.OpenRecordset("qryFMECA")
If Nz(yr) = 0 Then yr = Year(Now())
MDTPtr = 0
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) Then
            If .RelDataSource <> "" Then
                If BinSeek(rst, "TagNr", .RelDataSource) Then
                    If CompToImprove = .BlockName And yr >= YearToImprove Then
                        Adjust = 1# / Nz(rst!NewLambdaFactor)
                    Else
                        Adjust = AdjustedLambda(Nz(rst!Lambda) * LambdaFac(), yr, Year(Now()), Nz(rst!ConstLambdaPeriod, 100), _
                        Nz(rst!GlobalAging), Nz(rst!PrRenewalGivenFailure), _
                        Nz(rst!LambdaRenewalFactor))
                    End If
                    Select Case .RelDataType
                        Case "Repairable"
                            MDTPtr = MDTPtr + 1
                            LamVec(MDTPtr) = Nz(rst!Lambda) * LambdaFac() * Adjust
                            MDTVec(MDTPtr) = Nz(rst!MDT)
                        If .BlockType = "n x Y%" Then
                            .RelDataPointer = nIdenticalComponents(.BlockName, Nz(rst!Lambda) * LambdaFac() * Adjust, Nz(rst!MDT), .n, .ElementCapacity / .BlockCapacity, .BlockCapacity)
                        Else
                            .RelDataPointer = Repairable(.BlockName, Nz(rst!Lambda) * LambdaFac() * Adjust, Nz(rst!MDT), .ElementCapacity)
                        End If
                        Case "Non rep."
                        
                        Case "On demand"
                            .RelDataPointer = sv(.BlockName, Array(0, .ElementCapacity), Array(Nz(rst!q), 1 - Nz(rst!q)))
                        Case "Func. Test"
                            .RelDataPointer = sv(.BlockName, Array(0, .ElementCapacity), Array(rst!Lambda * LambdaFac() * Adjust * rst!tau / 2, 1 - Nz(rst!Lambda) * LambdaFac() * Nz(rst!tau) / 2))
                        Case "Mult.st. P"
                            .RelDataPointer = sv(.BlockName, RstReadArray(rst, "Capacity", rst!nStates), RstReadArray(rst, "q", rst!nStates))
                        Case "Mult.st. F"
                            l = RstReadArray(rst, "Lambda", rst!nStates)
                            M = RstReadArray(rst, "MDT", rst!nStates)
                            l(rst!nStates - 1) = 1
                            For j = 0 To rst!nStates - 2
                                l(j) = l(j) * LambdaFac() * Adjust * M(j)
                                l(rst!nStates - 1) = l(rst!nStates - 1) - l(j)
                            Next j
                            .RelDataPointer = sv(.BlockName, RstReadArray(rst, "Capacity", rst!nStates), l)
                    End Select
                    If CompNameImportance = .BlockName Then
                        SetPerfectComponent .RelDataPointer
                    End If
                Else
                    If DoCancel Then Exit Function
                    ErrStatus = MsgBox("Missing link to reliabiltiy data: " _
                        & .BlockName & ". Continue to check?", vbOKCancel)
                    If ErrStatus = vbCancel Then
                        DoCancel = True
                        
                        Exit Function
                    End If
                End If
            Else
                If DoCancel Then Exit Function
                ErrStatus = MsgBox("Missing link to reliabiltiy data: " _
                    & .BlockName & ". Continue to check?", vbOKCancel)
                If ErrStatus = vbCancel Then
                    DoCancel = True
                    Exit Function
                End If
            End If
        End If
    End If
    End With
Next i
End Function
Function RstReadArray(rst As Recordset, Fld As String, n As Integer)
Dim r() As Single
Dim i As Integer
ReDim r(0 To n - 1)
    For i = 1 To n
        r(i - 1) = Nz(rst(Fld & Format(i)))
    Next i
    RstReadArray = r
End Function

Function GetLambdaAndMDT(Lambda As Single, MDT As Single)
' Reads lambda and tau from vectors, and return false when all are read
' Resets pointr, so we might read another time

CurPtr = Nz(CurPtr) + 1
If CurPtr > MDTPtr Then
    CurPtr = 0
    GetLambdaAndMDT = False
Else
    Lambda = LamVec(CurPtr)
    MDT = MDTVec(CurPtr)
    GetLambdaAndMDT = True
End If
End Function

Function AddSubBlock(Mother As Integer, Optional Silent As Boolean = False, Optional BlockType As String = "")
Dim i As Integer
Dim ID As Integer
Dim Maxi
If Blocks(Mother).nSubBlocks = maxSubBlocks Then
    MsgBox "Too many sub blocks for this current block. Maximum is:" & str(maxSubBlocks), vbCritical
    SetMarkerType "Pending"
    AddSubBlock = 0
    Exit Function
End If
SetChangeFlag
nBlocks = nBlocks + 1
Maxi = 0
For i = 1 To maxBlocks
    If Blocks(i).BlockID > 0 Then
        If Left(Blocks(i).BlockName, 3) = "New" Then
            If Val(Mid(Blocks(i).BlockName, 4)) > 0 Then
                Maxi = aMax(Val(Mid(Blocks(i).BlockName, 4)), Maxi)
            End If
        End If
    End If
Next i
BlockID = 0
For i = 1 To maxBlocks
    If Blocks(i).BlockID = 0 Then
        BlockID = i
        With Blocks(BlockID)
            .BlockID = BlockID
            .Mother = Mother
            .BlockName = "New" + Format(Maxi + 1)
            .Description = "<Description>"
            .SystemID = GetSystemID()
            .BlockType = BlockType
            .nSubBlocks = 0
            .MDT = 0
            .RelDataSource = ""
            .tau = 12
            .k = 0
            .n = 0
        End With
        Exit For
    End If
Next i
If BlockID = 0 Then
    MsgBox ("Too many blocks, recompile!")
    SetMarkerType "Pending"
    AddSubBlock = 0
    Exit Function
End If

Blocks(Mother).nSubBlocks = Blocks(Mother).nSubBlocks + 1
If Blocks(Mother).nSubBlocks = 1 Then Blocks(Mother).BlockType = "Parallel"
If Blocks(Mother).nActiveSubBlocks > 0 Then Blocks(Mother).nActiveSubBlocks = Blocks(Mother).nSubBlocks

Blocks(Mother).SubBlocks(Blocks(Mother).nSubBlocks) = BlockID
If Not Silent Then Redraw
SetMarkerType "Pending"
AddSubBlock = BlockID
End Function
Function aMax(A As Variant, B As Variant)
aMax = IIf(A > B, A, B)
End Function


Function AddSubBlockSerial(Mother As Integer)
DoCmd.OpenForm "frmCMDDataPDSHlp", , , , , , Format(Mother) & " Serial"
End Function

Function AddSubBlockParallel(Mother As Integer)
DoCmd.OpenForm "frmCMDDataPDSHlp", , , , , , Format(Mother) & " Parallel"
End Function

Function MoveUp(ID As Integer)
Dim Mother As Integer
Dim i As Integer
SetChangeFlag
Mother = Blocks(ID).Mother
For i = 2 To Blocks(Mother).nSubBlocks
    If Blocks(Mother).SubBlocks(i) = ID Then
        SwapBlock Blocks(Mother).SubBlocks(i), _
        Blocks(Mother).SubBlocks(i - 1)
        Exit For
    End If
Next i
Redraw
End Function

Function MoveDown(ID As Integer)
Dim Mother As Integer
Dim i As Integer
SetChangeFlag
Mother = Blocks(ID).Mother
For i = 1 To Blocks(Mother).nSubBlocks - 1
    If Blocks(Mother).SubBlocks(i) = ID Then
        SwapBlock Blocks(Mother).SubBlocks(i), _
        Blocks(Mother).SubBlocks(i + 1)
        Exit For
    End If
Next i
Redraw
End Function

Function MoveLeft(ID As Integer)
MoveUp ID
End Function
Function MoveRight(ID As Integer)
MoveDown ID
End Function

Function SwapBlock(A As Integer, B As Integer)
Dim h As rBlock
h = Blocks(A)
Blocks(A) = Blocks(B)
Blocks(A).BlockID = B
Blocks(B) = h
Blocks(B).BlockID = A
For i = 1 To nBlocks
    If Blocks(i).BlockID > 0 Then
        If Blocks(i).Mother = A Then
            Blocks(i).Mother = B
        ElseIf Blocks(i).Mother = B Then
            Blocks(i).Mother = A
        End If
    End If
Next i
End Function

Function ReadBlocksFromFile(SystemID)
Dim rst As Recordset
Dim db As Database
Dim BlockID As Integer
Dim nMothers As Integer
UndoPtr = 0
nBlocks = 0
IsChanged = False
For i = 1 To maxBlocks
    Blocks(i).BlockID = 0
    Blocks(i).Mother = 0
    Blocks(i).rstID = 0
    Blocks(i).BlockName = ""
Next i
Set db = CurrentDb()
Set rst = db.OpenRecordset("tblBlocks")
With rst
If .RecordCount > 0 Then .MoveFirst
Do While Not .EOF
    If !SystemID = SystemID Then
        BlockID = !BlockID
        If nBlocks < BlockID Then nBlocks = BlockID
        Blocks(BlockID).BlockName = !BlockName
        Blocks(BlockID).BlockID = !BlockID
        Blocks(BlockID).Description = Nz(!Description)
        Blocks(BlockID).rstID = !ID
        Blocks(BlockID).Mother = !Mother
        Blocks(BlockID).BlockCapacity = Nz(!BlockCapacity)
        Blocks(BlockID).BlockType = Nz(!BlockType)
        Blocks(BlockID).n = Nz(!n)
        Blocks(BlockID).ElementCapacity = Nz(!ElementCapacity)
        Blocks(BlockID).k = Nz(!k)
        Blocks(BlockID).nActiveSubBlocks = Nz(!nActiveSubBlocks)
        Blocks(BlockID).RelDataSource = Nz(!RelDataSource)
        Blocks(BlockID).RelDataType = Nz(!RelDataType)
        Blocks(BlockID).SystemID = SystemID
        Blocks(BlockID).MDT = Nz(!MDT)
        Blocks(BlockID).tau = Nz(!tau, 12)
    End If
    .MoveNext
Loop
.Close
End With

For i = 1 To nBlocks
'    Debug.Print Blocks(i).BlockID, Blocks(i).Mother, Blocks(i).BlockName
Next i


VerifyRead
'Debug.Print "--"
For i = 1 To nBlocks
   ' Debug.Print Blocks(i).BlockID, Blocks(i).Mother, Blocks(i).BlockName, Blocks(i).nSubBlocks
Next i
'Debug.Print "**"
Pack
For i = 1 To nBlocks
    'Debug.Print Blocks(i).BlockID, Blocks(i).Mother, Blocks(i).BlockName, Blocks(i).nSubBlocks
Next i
UpdateChildren
End Function


Function VerifyRead()
Dim i As Integer
Dim nMothers As Integer
Dim Txt As String
Dim IsMother As Integer
Dim Ans As Integer
Dim err As Boolean
err = False
nMothers = 0
If nBlocks = 0 Then Exit Function
For i = 1 To nBlocks
    If Blocks(i).Mother = 0 And Blocks(i).BlockID > 0 Then nMothers = nMothers + 1
Next i
If nMothers > 1 Then
    Txt = "More than one block is defined as the TOP level block!"
ElseIf nMothers = 0 Then
    Txt = "No blocks are defined as the TOP level block!"
End If
IsMother = 0
If nMothers <> 1 Then
    err = True
    If MsgBox(Txt & vbCrLf & "Search for TOP event?", vbYesNoCancel, "PDSTool - Critical structure error") = vbYes Then
        For i = 1 To nBlocks
            If IsMother = 0 Then
                If Blocks(i).BlockName <> "" Then
                    Ans = MsgBox("Define: " & Blocks(i).BlockName & " as top level?", vbYesNoCancel)
                    Select Case Ans
                        Case vbYes
                            Blocks(i).Mother = 0
                            Blocks(i).BlockName = Blocks(i).BlockName & "$"
                            IsMother = i
                        Case vbCancel
                            Exit For
                        Case vbNo
                            If Blocks(i).Mother = 0 Then
                                 Blocks(i).BlockID = 0
                            End If
                    End Select
                End If
             End If
             If i <> IsMother Then
                If Blocks(i).Mother = 0 Then Blocks(i).BlockID = 0
             End If
        Next i
    Else
    
    End If
End If
For i = 1 To nBlocks
    If Blocks(i).BlockID * Blocks(i).Mother > 0 Then
        If Blocks(i).BlockID = Blocks(i).Mother Then
            err = True
            MsgBox "Element: " & Blocks(i).BlockName & " is refering to it self, and has been deleted"
            Blocks(i).BlockID = 0
        ElseIf Blocks(Blocks(i).Mother).BlockID = 0 Then
            err = True
            MsgBox "Element: " & Blocks(i).BlockName & " is refering to a non existing element, and has been delted"
            Blocks(i).BlockID = 0
        End If
    End If
Next
If err Then
    VerifyRead
    Exit Function
End If

End Function


Function WriteBlocksToFile()
Dim rstDel As Recordset
Dim rst As Recordset
Dim db As Database
Dim BlockID As Integer
Dim i As Integer
IsChanged = False
UndoPtr = 0
Pack
Set db = CurrentDb()
Set rstDel = db.OpenRecordset("select * from tblBlocks where systemid=" & GetSystemID())
Set rst = db.OpenRecordset("select * from tblblocks order by id;")
If rstDel.RecordCount > 0 Then
    rstDel.MoveFirst
    Do While Not rstDel.EOF
        rstDel.Edit
        rstDel!Delete = True
        rstDel.update
        rstDel.MoveNext
    Loop
End If
With rst
For i = 1 To nBlocks
    If Blocks(i).BlockID > 0 Then
        .AddNew
        !BlockID = i
        !BlockName = Nz(Blocks(!BlockID).BlockName)
        !Description = Nz(Blocks(!BlockID).Description)
        !Mother = Nz(Blocks(!BlockID).Mother)
        !BlockCapacity = Nz(Blocks(!BlockID).BlockCapacity)
        !BlockType = Nz(Blocks(!BlockID).BlockType)
        !n = Nz(Blocks(!BlockID).n)
        !ElementCapacity = Nz(Blocks(!BlockID).ElementCapacity)
        !k = Nz(Blocks(!BlockID).k)
        !nActiveSubBlocks = Blocks(!BlockID).nActiveSubBlocks
        !RelDataSource = Blocks(!BlockID).RelDataSource
        !RelDataType = Blocks(!BlockID).RelDataType
        !SystemID = Blocks(!BlockID).SystemID
        !MDT = Blocks(!BlockID).MDT
        !tau = Blocks(!BlockID).tau
        !Delete = False
        Blocks(i).rstID = !ID
        .update
    End If
Next
.Close
End With
If rstDel.RecordCount > 0 Then
    rstDel.MoveFirst
    Do While Not rstDel.EOF
        If rstDel!Delete Then rstDel.Delete
        rstDel.MoveNext
    Loop
End If
UpdateChildren
Forms.drwscreen.OnScreenChanged
End Function




Function UpdateChildren()
Dim i As Integer
For i = 1 To nBlocks
    UpdateMyChildren i
    'Debug.Print Blocks(i).BlockName, Blocks(i).nSubBlocks
    
Next i
End Function


Function UpdateMyChildren(ID As Integer)
Dim i As Integer
Blocks(ID).nSubBlocks = 0

For i = 1 To nBlocks
    If Blocks(i).Mother = ID Then
        Blocks(ID).nSubBlocks = Blocks(ID).nSubBlocks + 1
        Blocks(ID).SubBlocks(Blocks(ID).nSubBlocks) = i
    End If
Next i
If Blocks(ID).nActiveSubBlocks > 0 Then Blocks(ID).nActiveSubBlocks = Blocks(ID).nSubBlocks
End Function

Function Pack()
Dim i As Integer
Dim j As Integer
Dim ID As Integer
i = 1
If nbocks = 0 Then Exit Function
Do While Blocks(nBlocks).BlockID = 0 ' Sletter evt blanke på slutten
    nBlocks = nBlocks - 1
Loop
Do While i < nBlocks
    If Blocks(i).BlockID = 0 Then 'En blank
       ' Debug.Print Blocks(i).BlockName
       For j = i To nBlocks - 1 ' Fytter alle ned ett skritt til venstre
            If Blocks(j + 1).BlockID > 0 Then ' Was not blank
                ChangeMother j + 1, j
                Blocks(j) = Blocks(j + 1)
                Blocks(j).BlockID = j
            Else
                Blocks(j).BlockID = 0
            End If
        Next j
        nBlocks = nBlocks - 1
    Else
        i = i + 1
    End If
Loop
End Function

Private Function ChangeMother(OldMother As Integer, NewMother As Integer)
Dim i As Integer
For i = 1 To nBlocks
    If Blocks(i).BlockID > 0 Then
        If Blocks(i).Mother = OldMother Then Blocks(i).Mother = NewMother
    End If
Next i
End Function




Function nrtest()
ReadBlocksFromFile 1
End Function

Function DeleteBlockOK(B As Integer)
Dim Mother
Mother = Blocks(B).Mother
If Blocks(Mother).nSubBlocks > 2 Then
    DeleteBlockOK = True
Else
    DeleteBlockOK = False
    MsgBox "Cannot delete block with less than 2 blocks on the same level", vbCritical
End If
End Function

Function DeleteBlock(B As Integer)
Dim i As Integer
SetChangeFlag
For i = 1 To maxBlocks
    If Blocks(i).Mother = B Then DeleteBlock i
Next i
Blocks(B).BlockID = 0
If Mother > 0 Then
    If Blocks(Blocks(B).Mother).nSubBlocks > 0 Then
        Blocks(Blocks(B).Mother).nSubBlocks = Blocks(Blocks(B).Mother).nSubBlocks - 1
    End If
End If
Blocks(B).Mother = 0
Blocks(B).BlockName = ""
Blocks(B).BlockType = ""
Blocks(B).BlockID = 0
End Function

Function DeleteAllChildren(Mother As Integer)
Dim i As Integer
For i = 1 To maxBlocks
    If Blocks(i).Mother = Mother Then DeleteBlock i
Next i
Blocks(Mother).nActiveSubBlocks = 0
Pack
Redraw
End Function
 
 
Function MarkBlock(B As Integer)
Dim i As Integer
Blocks(B).IsMarked = True
cmdColor B, 255
End Function
Function Unmark()
Dim i As Integer
For i = 1 To nBlocks
    Blocks(i).IsMarked = False
     cmdColor i, -2147483630
Next i
End Function


Function LoadRelData2Fortran(Optional yr As Single)
Dim ErrStatus As Integer
Dim SVHlp As StateVariable
Dim l As Variant
Dim M As Variant
Dim i As Integer
Dim j As Integer
Dim Adjust As Single
Dim db As Database
Dim FortRet As Long
Dim rst As Recordset
Set db = CurrentDb
Set rst = db.OpenRecordset("qryFMECA")
If Nz(yr) = 0 Then yr = Year(Now())
MDTPtr = 0
InitCompList ' FOr å resette antall componenter
For i = 1 To maxBlocks
    With Blocks(i)
    If .BlockID > 0 Then
        If IsComponent(.BlockType) Then
            If .RelDataSource <> "" Then
                If BinSeek(rst, "TagNr", .RelDataSource) Then
                    If CompToImprove = .BlockName And yr >= YearToImprove Then
                        Adjust = 1# / Nz(rst!NewLambdaFactor)
                    Else
                     Adjust = AdjustedLambda(Nz(rst!Lambda) * LambdaFac(), yr, Year(Now()), Nz(rst!ConstLambdaPeriod, 100), _
                        Nz(rst!GlobalAging), Nz(rst!PrRenewalGivenFailure), _
                        Nz(rst!LambdaRenewalFactor))
                    End If
                    Select Case .RelDataType
                        Case "Repairable"
                            MDTPtr = MDTPtr + 1
                            LamVec(MDTPtr) = Nz(rst!Lambda) * LambdaFac() * Adjust
                            MDTVec(MDTPtr) = Nz(rst!MDT)
                        If .BlockType = "n x Y%" Then
                            FortRet = InsertnOfYCapacity(lng(.BlockID), lng(.n), Nz(rst!Lambda) * LambdaFac() * Adjust, Nz(rst!MDT), .ElementCapacity, .BlockCapacity)
                        Else
                            FortRet = InsertBinarySV(lng(.BlockID), Nz(rst!Lambda, 0.000001) * LambdaFac() * Adjust, Nz(rst!MDT, 0.000001), .ElementCapacity)
                        End If
                        SaveCompInfo Nz(.BlockName), FortRet, Nz(.Description)
'                        Debug.Print .BlockName
  '                       PrintFortranSV2 FortRet
    '                    Debug.Print 1
                    End Select
                    If CompNameImportance = .BlockName Then
'                        SetPerfectComponent .RelDataPointer
                        MakeItPerfect Node2SV(FortRet), -1#
                    End If
                Else
                    If DoCancel Then Exit Function
                    ErrStatus = MsgBox("Missing link to reliabiltiy data: " _
                        & .BlockName & ". Continue to check?", vbOKCancel)
                    If ErrStatus = vbCancel Then
                        DoCancel = True
                        Exit Function
                    End If
                End If
            Else
                If DoCancel Then Exit Function
                ErrStatus = MsgBox("Missing link to reliabiltiy data: " _
                    & .BlockName & ". Continue to check?", vbOKCancel)
                If ErrStatus = vbCancel Then
                    DoCancel = True
                    Exit Function
                End If
            End If
        End If
    End If
    End With
Next i
End Function
Function GetRelabilityOfSV(nPtr As Long)
Dim Values(1 To 50) As Single
Dim probs(1 To 50) As Single
Dim rates(1 To 512) As Single
Dim VisitFrequencies(1 To 50)
Dim n As Long
Dim i As Integer
Dim r As Single
GetStateVariableData Node2SV(nPtr), Values(1), probs(1), rates(1), VisitFrequencies(1), n
r = 0#
For i = 1 To n
r = r + Values(i) * probs(i)
Next i
If Values(i) > 0 Then
    r = r / Values(n)
Else
    r = 0#
End If
GetRelabilityOfSV = r
End Function
Function PrintFortranSV(nPtr As Long)
PrintFortranSV = PrintFortranSVHlp(Node2SV(nPtr))
End Function

Function PrintFortranSVHlp(nPtr As Long)
Dim Values(1 To 50) As Single
Dim probs(1 To 50) As Single
Dim rates(1 To 512) As Single
Dim VisitFrequencies(1 To 50)
Dim n As Long
Dim i As Integer
Dim NodeID As Long
Dim NodeType As Long
Dim k As Long
Dim j As Integer
Dim n2 As Integer
Dim h1 As Long, h2 As Long, ret As Long
Dim sing As Single
Dim t As Single, dt As Single
Dim StrToPrint As String
Dim db As Database
Dim rst As Recordset
Dim r As Single
ZAP "tblCapacityAndProbability"
Set db = CurrentDb()
Set rst = db.OpenRecordset("tblCapacityAndProbability")
With rst
GetStateVariableData nPtr, Values(1), probs(1), rates(1), VisitFrequencies(1), n
r = 0
For i = 1 To n
    .AddNew
    !Capacity = Values(i)
    !Probability = probs(i)
    !VisitFrequency = VisitFrequencies(i)
    !VisitFrequency = -probs(i) * rates((i - 1) * n + i)
    r = r + Values(i) * probs(i)
    .update
Next i
rst.Close
End With
If Values(n) > 0 Then
    PrintFortranSVHlp = r / Values(n)
Else
    PrintFortranSVHlp = 0
End If
End Function



Function ShowSVGeneral(sv As Long, Caption As String, item As String, Description As String, Optional CloseIt As String)
Dim hString As String
hString = AddVarToString("Regularity", PrintFortranSVHlp(sv)) & _
AddVarToString("Caption", Caption) & _
AddVarToString("Item", item) & _
AddVarToString("Description", Description)
If Nz(CloseIt) <> "" Then
    hString = hString & AddVarToString("CloseIt", CloseIt)
End If
DoCmd.OpenForm "frmshowregularity", , , , , , hString
End Function


Function PrintFortranSV2(nPtr As Long)
Dim Values(1 To 50) As Single
Dim probs(1 To 50) As Single
Dim rates(1 To 512) As Single
Dim VisitFrequencies(1 To 50)
Dim n As Long
Dim i As Integer
Dim NodeID As Long
Dim NodeType As Long
Dim k As Long
Dim j As Integer
Dim n2 As Integer
Dim h1 As Long, h2 As Long, ret As Long
Dim sing As Single
Dim t As Single, dt As Single
Dim StrToPrint As String
Dim db As Database
Dim rst As Recordset
Dim r As Single

GetStateVariableData nPtr, Values(1), probs(1), rates(1), VisitFrequencies(1), n
r = 0
Debug.Print "N=", n
For i = 1 To n
    Debug.Print Values(i), probs(i)
    
Next i
End Function

Function GetMarkedBlocks()
Dim i As Integer
Dim RetStr As String
Dim sep As String
sep = "{"
RetStr = ""
For i = 1 To maxBlocks
    If Blocks(i).IsMarked Then
        RetStr = RetStr & sep & Blocks(i).BlockName
        sep = ","
    End If
Next i
If RetStr <> "" Then RetStr = RetStr & "}"
GetMarkedBlocks = RetStr
End Function


Function ScanL2(BlockID As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim LastK As Integer
Dim LastN As Integer
Dim LastSource As String
Dim Arg As String
Dim LastArg As String
Dim Source As String
Dim n As Integer
Dim Names(1 To 12) As String
Dim Sources(1 To 12) As String
Dim ret As String
With Blocks(BlockID)
   ' Debug.Print .BlockName
    
    If Not IsComponent(.BlockType) Then
        ' Kun N = 2
        If .nSubBlocks = 2 Then
            n = .nSubBlocks
            Select Case .BlockType
                Case "Serial"
                    k = n
                Case "Parallel"
                    k = 1
                Case Else
                    k = .k
            End Select
            ret = Format(k) & "oo" & Format(n) & "("
            LastN = 0
            For i = 1 To n
                j = .SubBlocks(i)
                If Not IsComponent(Blocks(j).BlockType) Then
                    n = Blocks(j).nSubBlocks
                    Select Case Blocks(j).BlockType
                    Case "Serial"
                        k = n
                    Case "Parallel"
                        k = 1
                    Case Else
                        k = Blocks(j).k
                    End Select
                    If LastN = 0 Then
                        LastK = k
                    Else
                        If k <> LastK Or LastN <> n Then
                            ScanL2 = ""
                            Exit Function
                        End If
                    End If
                    If ScanL1Hlp(j, Names, Sources) > 0 Then
                        If k < n Then
                            ' Må være like i hver gren
                            For j = 2 To n
                                If Sources(j) <> Sources(1) Then
                                    ScanL2 = ""
                                    Exit Function
                                End If
                            Next j
                        ElseIf LastN = 0 Then
                            ' Første gang, beregn ny string
                            LastSource = ""
                            For j = 1 To n
                                LastSource = LastSource & Sources(j) & IIf(j = n, ")", ",")
                            Next j
                        Else
                            Source = ""
                            For j = 1 To n
                                Source = Source & Sources(j) & IIf(j = n, ")", ",")
                            Next j
                            If Source <> LastSource Then
                                ScanL2 = ""
                                Exit Function
                            End If
                        End If
                        ret = ret & Format(k) & "oo" & Format(n) & "("
                        For j = 1 To n
                            ret = ret & Names(j) & IIf(j = n, ")", ",")
                        Next j
                        ret = ret & IIf(LastN = 0, ",", ")")
                    End If
                    LastN = n
                Else
                    ScanL2 = ""
                    Exit Function
                End If
            Next i
        Else
            ret = ""
        End If
    Else
        ret = ""
    End If
End With
ScanL2 = ret
End Function

Function ScanL1(BlockID As Integer)
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Arg As String
Dim LastArg As String
Dim Source As String
Dim n As Integer
Dim Names(1 To 12) As String
Dim Sources(1 To 12) As String
Dim ret As String
With Blocks(BlockID)
    If Not IsComponent(.BlockType) Then
        n = .nSubBlocks
        Select Case .BlockType
            Case "Serial"
                k = n
            Case "Parallel"
                k = 1
            Case Else
                k = .k
        End Select
        If k = n Then
            ScanL1 = ""
            Exit Function
        End If
        ret = Format(k) & "oo" & Format(n) & "("
        If ScanL1Hlp(BlockID, Names, Sources) > 0 Then
            For j = 2 To n
                If Sources(j) <> Sources(1) Then
                    ScanL1 = ""
                    Exit Function
                 End If
            Next j
            For j = 1 To n
                ret = ret & Names(j) & IIf(j = n, ")", ",")
            Next j
        Else
            ret = ""
        End If
    Else
        ret = ""
    End If
End With
ScanL1 = ret
End Function



Function ScanL1Hlp(BlockID As Integer, Names() As String, Source() As String)
Dim i As Integer
Dim j As Integer
With Blocks(BlockID)
For i = 1 To .nSubBlocks
    j = .SubBlocks(i)
    If Not IsComponent(Blocks(j).BlockType) Then
        ScanL1Hlp = 0
        Exit Function
    End If
    Names(i) = Blocks(j).BlockName
    Source(i) = Blocks(j).RelDataSource
Next i
qcSort Names, .nSubBlocks
qcSort Source, .nSubBlocks
ScanL1Hlp = .nSubBlocks
End With
End Function


Function AddVotings()
Dim i As Integer
Dim r As String
Dim tmp As String
Dim Used(0 To maxBlocks) As Boolean
Used(0) = False
r = ""
For i = 1 To nBlocks
    tmp = ScanL2(i)
    If tmp <> "" Then
        r = r & "Voting -> " & tmp & Chr(13) & Chr(10)
        Used(i) = True
    Else
        Used(i) = False
    End If
Next i
For i = 1 To nBlocks
    If Not Used(Blocks(i).Mother) Then
        tmp = ScanL1(i)
        If tmp <> "" Then
            r = r & "Voting -> " & tmp & Chr(13) & Chr(10)
        End If
    End If
Next i

AddVotings = r
End Function


Function Testl()
Dim Names(1 To 50) As String
Dim Sources(1 To 50) As String
Dim i As Integer
For i = 1 To nBlocks
    Debug.Print ScanL2(i)
    
Next i
End Function


Function DeleteOnlyOne(ID As Integer)
Dim Mother As Integer
Mother = Blocks(ID).Mother
For i = 1 To nBlocks
    'Debug.Print Blocks(i).Mother
    If Blocks(i).Mother = ID Then
        Blocks(i).Mother = Mother
        DeleteBlock ID
        Pack
        Redraw
        Exit For
    End If
Next i
End Function

Function BlockCopy(First As Integer)
CopyPointer = First
dbg "Copy", Blocks(First).BlockName

Dim i As Integer
For i = 1 To nBlocks
    CBlocks(i) = Blocks(i)
Next i
End Function

Function BlockPaste(Mother As Integer)
' Skal lime inn kopierte blokker under 'Mother'


If Mother > 0 And CopyPointer > 0 Then
PushUndo
dbg "Paste", Blocks(Mother).BlockName, CopyPointer
    PasteInNode CopyPointer, Mother
    Redraw
End If
End Function


Function PasteInNode(BlockToPaste As Integer, Mother As Integer)
Dim NewBlock As Integer
Dim i As Integer
NewBlock = AddSubBlock(Mother, True)
If NewBlock = 0 Then Exit Function
Blocks(NewBlock).BlockID = NewBlock
Blocks(NewBlock).BlockName = CBlocks(BlockToPaste).BlockName
Blocks(NewBlock).Description = CBlocks(BlockToPaste).Description
Blocks(NewBlock).BlockType = CBlocks(BlockToPaste).BlockType
Blocks(NewBlock).nSubBlocks = CBlocks(BlockToPaste).nSubBlocks
Blocks(NewBlock).nActiveSubBlocks = CBlocks(BlockToPaste).nActiveSubBlocks
Blocks(NewBlock).BlockCapacity = CBlocks(BlockToPaste).BlockCapacity
Blocks(NewBlock).BlockType = CBlocks(BlockToPaste).BlockType
Blocks(NewBlock).n = CBlocks(BlockToPaste).n
Blocks(NewBlock).ElementCapacity = CBlocks(BlockToPaste).ElementCapacity
Blocks(NewBlock).k = CBlocks(BlockToPaste).k
Blocks(NewBlock).CmdID = CBlocks(BlockToPaste).CmdID
Blocks(NewBlock).RelDataSource = CBlocks(BlockToPaste).RelDataSource
Blocks(NewBlock).RelDataType = CBlocks(BlockToPaste).RelDataType
Blocks(NewBlock).RelDataPointer = CBlocks(BlockToPaste).RelDataPointer
Blocks(NewBlock).MDT = CBlocks(BlockToPaste).MDT
Blocks(NewBlock).tau = CBlocks(BlockToPaste).tau
For i = 1 To Blocks(NewBlock).nSubBlocks
    Blocks(NewBlock).SubBlocks(i) = PasteInNode(CBlocks(BlockToPaste).SubBlocks(i), NewBlock)
Next i
End Function

Function PushUndo()
Dim i As Integer
Dim s As Integer
' Må sjekkte på undo stacken, i tillegg til UndoBlock
If UndoPtr = maxUndos Then
    UndoPtr = UndoPtr - 1
    For i = 1 To UndoPtr
        Undo(1, i) = Undo(1, i + 1)
        Undo(2, i) = Undo(2, i + 1)
    Next i
End If
Do While True
    s = Undo(1, UndoPtr) + Undo(2, UndoPtr) + 1
    If s + nBlocks < maxUndoBlocks Then Exit Do
    PopFirst
Loop
UndoPtr = UndoPtr + 1
Undo(1, UndoPtr) = s
Undo(2, UndoPtr) = nBlocks
'Debug.Print nBlocks
For i = 1 To nBlocks
    UBlocks(s) = Blocks(i)
    'Debug.Print UBlocks(S).BlockName, UBlocks(S).nSubBlocks
    
    s = s + 1
Next i
End Function

Function PopUndo()
Dim i As Integer
Dim s As Integer
If UndoPtr > 0 Then
    s = Undo(1, UndoPtr)
    nBlocks = Undo(2, UndoPtr)
    'Debug.Print nBlocks
    For i = 1 To nBlocks
        Blocks(i) = UBlocks(s)
       ' Debug.Print Blocks(i).BlockName, Blocks(i).nSubBlocks, UBlocks(S).nSubBlocks
        
        s = s + 1
    Next i
    Redraw
    drwAfterRedraw
    UndoPtr = UndoPtr - 1
Else
    MsgBox "Nothing to undo"
End If
End Function

Function PopFirst()
Dim i As Integer
' Sletter første
Dim L1 As Integer, L2 As Integer
L1 = Undo(2, 1)
L2 = Undo(1, UndoPtr) + Undo(2, UndoPtr) - 1
For i = L1 To L2
    UBlocks(i - L1 + 1) = UBlocks(i)
Next i
For i = 1 To UndoPtr - 1
    Undo(1, i) = Undo(1, i + 1)
    Undo(2, i) = Undo(2, i + 1)
Next i
UndoPtr = UndoPtr - 1
End Function


Function cTest()

Dim t1(1 To 10) As c
Dim t2(1 To 10) As c
t1(1).name = "test"
t1(1).cList(1) = 2
t1(1).cList(2) = 3
t2(1) = t1(1)
Debug.Print t2(1).name
Debug.Print t2(1).cList(1)
Debug.Print t2(1).cList(2)


End Function