'************************************************************
'* DNA CoveragePgm Version 1.0 *
'* Written April-May 2023 by W. Wesley Johnston *
'* Estimating DNA Coverage from a GEDCOM File: Calculate *
'* the DNA Coverage of the specified person. *
'************************************************************

'*********************************************************************************
'* Instructions: *
'* You must first create a worksheet titled "Report Results" in your Excel file. *
'* 1. In the line below, enter the RIN for the target person whose DNA coverage is to be calculated: XPerson. *
'* 2. In the next line, enter the full-path GEDCOM File name: GEDCOMFile. *
'* 3. To run the search, select RUN from the menu at the top. *
'*********************************************************************************
Const XPerson = 5880
' XPerson is the person whose DNA Coverage you want to estimate.
Const GEDCOMFile = "c:/Lake1.ged"
' GEDCOMFile is the GEDCOM file in which all the people are in a tree.

'**************************************
'* Globally define all the needed variables,
'* constants and arrays.
'*
'* The critical element for fast lookups is being able to
'* use an index-value lookup in an array.
'**************************************
Const RINLimit = 30000, MRINLimit = 5000, FPLimit = 3000, PFLimit = 2000
' See Table1KidLimit in subroutine for limiting number of children and also the related array size.

Dim RinFlag(1 To 2, 1 To RINLimit) As Boolean ' Cell Value is TRUE or FALSE
Dim RinName(1 To RINLimit) As String ' Cell Value is the Person's name
Dim RinatDNA(1 To RINLimit) As Boolean ' Cell Value is the Person's atDNA-tested status
Dim NRINS As Integer ' Count of the number of RINs in the file
Dim MAXRIN As Integer ' The highest RIN number in the file
Dim Rin As Integer
Dim MRin As Integer

Const Table1PieceLimit = 524288   ' Allows for up to 19 children
Const Table1KidLimit = 18 ' Allows for up to 18 children



'**************************************
'FamPers is a table of all the persons in a specific family.
'Each person (RIN) is in a separate record for the family (MRIN).
'So, a family is a collection of (MRIN, RIN) pairs in the array.
'**************************************
' FamPers (or just FP) uses a family MRIN to find all members' RINs
Dim FamPers(1 To MRINLimit, 1 To FPLimit) As Long ' Cell Value is a +/- RIN
'**************************************
'PersFam is a table of all the families to which a specific person belongs.
'Each family (MRIN) is connected to each child (RIN) in the family.
'So, a person is a collection of (RIN, MRIN) pairs in the array.
'**************************************
' PersFam (of just PF) uses a person's RIN to find all MRINs to which he/she belongs
Dim PersFam(1 To RINLimit, 1 To PFLimit) As Long ' Cell Value is +/- MRIN
' + = Spouse (i.e., if +MRin or +Rin, then person is a spouse in that MRin)
' - = Child (i.e., if -MRin or -Rin, then person is a child in that MRin)

Dim NMRINS As Integer ' Count of the number of MRINs in the file
Dim MAXMRIN As Integer ' The highest MRIN number in the file

Dim FPRin As Long
Dim PFMRin As Long
Dim TargetLDNACoverage As Double
Dim TargetUDNACoverage As Double

Dim FPSpouse As Boolean
Dim PFSpouse As Boolean

Dim LoopCt As Long
Dim LoopCt2 As Long
Dim XYCt As Integer

Dim RightSide As String
Dim LeftSide As String

'The following are for writing the results out.
 Dim LineCount As Integer ' Line Counter for output report
 Dim OutputRow(1 To 5000000) As String ' This can be an implicit limit on the number of children of any given parent. <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
 Dim OutputValue As String
 Dim OutputValuePiece As String
'*************************
'* END OF DEFINITIONS
'*************************
 
Sub DNACoverage()
'*************************
'* START OF MAIN PROGRAM *
'*************************

'****************************************************************************************************************
'*                                        Click in this area, and
'*                                        select RUN from the menu.
'****************************************************************************************************************

StartTime = Time
Call InitVars ' Initialize the variables, so that restarts run correctly
showit = "VARIABLE INITIALIZATION DONE"
MsgBox showit
Call ReadGEDCOM ' Read the GEDCOM File and assign all the variables.
PrepEndTime = Time
showit = "DONE WITH PREP--Start-" & StartTime & " PrepEnd-" & PrepEndTime & " NRINS =" & NRINS & " MAXRIN =" & MAXRIN & " NMRINS =" & NMRINS & " MAXMRIN =" & MAXMRIN
MsgBox showit

'*****************************************************************************************************************
' Write the first output line to the OutputRow array and increment the line counter.
'*****************************************************************************************************************

LineCount = 1
OutputRow(LineCount) = "Calculation of the DNA Coverage of RIN " & XPerson & " (" & RinName(XPerson) & ")"
LineCount = LineCount + 1

'*****************************************************************************************************************
' Calculate the DNA Coverage of the target person.
'*****************************************************************************************************************

TargetLDNACoverage = -1
TargetLDNACoverage = CalcLDNACoverage(XPerson) ' This is the real engine of the program for lower bound calculation.
showit = "DONE WITH Lower Bound"
MsgBox showit


TargetUDNACoverage = -1
TargetUDNACoverage = CalcUDNACoverage(XPerson) ' This is the real engine of the program for lower bound calculation.
showit = "DONE WITH Upper Bound"
MsgBox showit
showit = "1-LineCount=" & LineCount
MsgBox showit

'*****************************************************************************************************************
' Now that the DNA Coverage is calculated, write all the lines of output to the Results Report worksheet.
'*****************************************************************************************************************

Set wout = Sheets("Results Report")
wout.Activate
wout.Cells.ClearContents

' Writing output now
showit = "2-LineCount=" & LineCount
MsgBox showit
For j = 1 To LineCount
wout.Cells(j, 1) = OutputRow(j)
Next ' For j = 1 to LineCount

RunEndTime = Time
showit = "DONE"
MsgBox showit


'*************************
'* END OF MAIN PROGRAM *
'*************************
End Sub
Function InitVars()

NRINS = 0
MAXRIN = 0
NMRINS = 0
MAXMRIN = 0

For LoopCt = 1 To RINLimit
RinName(LoopCt) = ""
RinatDNA(LoopCt) = False ' Intialize the atDNA-test status as False for everyone

For LoopCt2 = 1 To PFLimit
PersFam(LoopCt, LoopCt2) = 0
Next ' For LoopCt2 = 1 To PFLimit
If LoopCt < MRINLimit + 1 Then
For LoopCt2 = 1 To FPLimit
FamPers(LoopCt, LoopCt2) = 0
Next ' For LoopCt2 = 1 To FPLimit
End If ' If LoopCt < MRINLimit + 1 Then
Next ' For LoopCt = 1 To RINLimit

UnableToExpandLevel = False
FoundAConnection = False

End Function
Function ReadGEDCOM()

'****************************************
'* Read through the GEDCOM file and
'* 1. Define RIN-Name Index -- OBSOLETE: and X and Y RIN Flag Arrays
'* 2. Define Family-Person File and Family Counter Array
'* Only the INDI records of the GEDCOM file are used.
'****************************************

Const ForReading = 1, ForWriting = 2, ForAppending = 3
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0
Dim fso, ts, s

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.OpenTextFile(GEDCOMFile, ForReading, TristateUseDefault)

Dim RINSDone As Boolean
RINSDone = False
Dim EndofINDI As Boolean
EndofINDI = False
Dim PersCount As Integer ' Will run from 1 to FPLimit
Dim FamCount As Integer ' Will run from 1 to PFLimit

'Dim loopct As Integer
'For loopct = 1 To 500

' *
' ***************** Start Main GEDCOM Read Routine **********************
' *

Do While ts.AtEndOfLine <> True ' Read all the records in the GEDCOM file
s = ts.ReadLine ' This reads the current line of the GEDCOM file and assigns it to the variable s.

' *
' ***************** Start Section FoundZeroINDI **********************
' * Find a "0 ... INDI" record which is the first record of Person X.
' * Capture the RIN number, the name, the atDNA flag (if any) and the records of the families to which Person X belongs.
' * Remember that there are "0" records before the first "0 ... INDI". You have to bypass those first.
' *
FoundZeroINDI:
If RINSDone = False Then ' Keep processing until reach the end of the RINs. After that do the MRINs.
If Left(s, 1) = 0 Then ' Look for a zero in column 1.
If Right(s, 4) = "INDI" Then ' Found the initial record for a new person *********************
' This begins a lot of processing before you find the associated End If
NRINS = NRINS + 1 ' Increment the count of the number of RINs in the file

' FoundZeroINDI-Part 1 ***** Now find and capture the RIN value itself *********************
RightSide = Right(s, Len(s) - 4)
For ctspaces = 1 To 10 ' Find the first @ symbol that defines the RIN number location.
If Mid(RightSide, ctspaces, 1) = "@" Then
GoTo FoundRinAt
End If
Next ' For ctspaces = 1 To 10

FoundRinAt:
' Once a RIN is found, capture the RIN value
Rin = (Left(RightSide, (ctspaces - 1)))

' FoundZeroINDI-Part 2 ***** Now read the next line which is the name line and capture the name *********************
s = ts.ReadLine
RinName(Rin) = Right(s, Len(s) - 7) ' Capture the name for Person X (the Person with this RIN).

' *
' FoundZeroINDI-Part 3 ******* Now, READ ALL THE REST OF THE RECORDS FOR Person X. ********
' *
' * Find any TYPE or FAMS or FAMC records for this person and load to arrays. ********
' "2 TYPE atDNA" records are those that indicate that the person has done an autosomal DNA test.
' "1 FAMS" records are those where the person is a spouse/parent in the family.
' "1 FAMC" records are those where the person is a child in the family.
' Do not confuse the "1 FAM" records of the person (RIN) with the "0 @F1@ FAM" MRIN records.
' The TYPE record, if there is one, comes before the FAMS or FAMC records.
' So, the initial search is for a TYPE record.
' If you find a new zero-record, then you have found a new person so that you have to start work on that person.

EndofINDI = False
Do Until EndofINDI = True ' Read all the records of person X until done with person X.
s = ts.ReadLine
' Sending control to LoopToFindFAM causes this Do Loop to end processing for Person X and read the next GEDCOM record.

' First, check to see if you have finished processing Person X.
If Left(s, 1) = 0 Then ' Check to see if you found a new 0 (zero) record which means you are done processing Person X. So,stop processing person X.
EndofINDI = True ' You stop processing Person X by setting EndofINDI to TRUE to end the Do loop which will take you to EndofINDI.
End If ' If Left(s, 1) = 0


' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
' *
' FoundZeroINDI-Part 3A ******* See if Person X did an autosomal DNA test. ********
' *
' You will know that they tested if they have a "2 TYPE atDNA" record.
' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
If Left(s, 12) = "2 TYPE atDNA" Then ' The person has tested for autosomal DNA. So, set their RinatDNA flag to TRUE.
RinatDNA(Rin) = True
GoTo LoopToFindFAM ' Since you have processed this record, go on to read the next record.
End If ' If Left(s, 12) = "2 TYPE atDNA"
' *
' If you have reached this point, then you know that there is no "2 TYPE atDNA" left to find for Person X.
' Either there was one and you already processed it or else there was none.
' So, you now are looking for "1 FAMS" or "1 FAMC" records for Person X.
' *



' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
' *
'        FoundZeroINDI-Part 3B ******* Find FAMS and/or FAMC records of Person X. ********
' *
' <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
If Left(s, 5) <> "1 FAM" Then ' If you do not have a FAMS or FAMC record, go on to the next GEDCOM record.
GoTo LoopToFindFAM ' Since this record is not relevant, go on to read the next GEDCOM record.
End If ' If Left(s, 5) <> "1 FAM"
' If you reach this point, you have found a "1 FAM" record. So check to see if it is FAMS or FAMC.

' ****************************************************************************
'        FoundZeroINDI-Part 3B1: FAMS Check and Processing
' ****************************************************************************
If Mid(s, 3, 4) = "FAMS" Then ' Found the record of the family in which Person X is a parent/spouse.
' Write as POSITIVE number since positive numbers will designate parents and negatives will designate children in the family.
' Parse to find the S-MRIN number.
'
' The following code starts at the 9th position in the record and searches for @.
' The record is "1 FAMS $F" in the first 9 positions. The MRIN value starts in the 10th position.
' To find the MRIN value, you have to find the second @ in the record.
' You then know the starting and ending positions of the MRIN value so that you can capture it.
RightSide = Right(s, Len(s) - 9)
For ctspaces = 1 To 10
If Mid(RightSide, ctspaces, 1) = "@" Then
GoTo FoundSMRinAt ' FoundSMRinAt is the subroutine that captures the value of the MRIN in which Person X is a spouse/parent.
End If ' If Mid(RightSide, ctspaces, 1) = "@"
Next ' For ctspaces = 1 To 10
' *
' Subroutine FoundSMRinAt to capture the FAMS MRIN
' * There is a hazard here. If any GEDCOM ever has a huge MRIN number, then the processing will fall through here.
' * That would lead to the subroutine FoundSMRinAt being executed when it should not.
' *
FoundSMRinAt:
MRin = (Left(RightSide, (ctspaces - 1))) ' The MRIN to be captured starts in the right side 1st position (column 10) and ends in the position just before ctspaces.
' Store in the Family-Person Array
For PersCount = 1 To FPLimit
If FamPers(MRin, PersCount) = 0 Then
FamPers(MRin, PersCount) = Rin
GoTo LoadFAMStoPF
End If
' Since this Rin slot is already filled, check the next one.
Next ' For PersCount = 1 To 30
LoadFAMStoPF:
' Store in the Person-Family Array
For FamCount = 1 To PFLimit
If PersFam(Rin, FamCount) = 0 Then
PersFam(Rin, FamCount) = MRin
' showit = "PersFam(" & Rin & "," & FamCount & ") = " & MRin
' MsgBox showit
GoTo LoopToFindFAM ' done processing this FAMS record
End If
' Since this Rin slot is already filled, check the next one.
Next ' For FamCount = 1 To 30
End If ' If Right(s, 4) = "FAMS"

' ****************************************************************************
'        FoundZeroINDI-Part 3B2: FAMC Check and Processing
' ****************************************************************************
If Mid(s, 3, 4) = "FAMC" Then
' Write as NEGATIVE number since positive numbers will designate parents and negatives will designate children in the family.
' Parse the C-MRIN.
'
' The following code starts at the 9th position in the record and searches for @.
' The record is "1 FAMC $F" in the first 9 positions. The MRIN value starts in the 10th position.
' To find the MRIN value, you have to find the second @ in the record.
' You then know the starting and ending positions of the MRIN value so that you can capture it.
RightSide = Right(s, Len(s) - 9)
For ctspaces = 1 To 10
If Mid(RightSide, ctspaces, 1) = "@" Then
GoTo FoundCMRinAt
End If
Next
' *
' Subroutine FoundCMRinAt to capture the FAMC MRIN
' * There is a hazard here. If any GEDCOM ever has a huge MRIN number, then the processing will fall through here.
' * That would lead to the subroutine FoundCMRinAt being executed when it should not.
' *
FoundCMRinAt:
MRin = (Left(RightSide, (ctspaces - 1))) ' The MRIN to be captured starts in the right side 1st position (column 10) and ends in the position just before ctspaces.
' Store in the Family-Person Array
For PersCount = 1 To FPLimit
If FamPers(MRin, PersCount) = 0 Then
FamPers(MRin, PersCount) = -Rin
GoTo LoadFAMCtoPF
End If
' Since this Rin slot is already filled, check the next one.
Next ' For PersCount = 1 To 30
LoadFAMCtoPF:
' Store in the Person-Family Array
For FamCount = 1 To PFLimit
If PersFam(Rin, FamCount) = 0 Then
PersFam(Rin, FamCount) = -MRin
GoTo LoopToFindFAM ' done processing this FAMC record
End If
' Since this Rin slot is already filled, check the next one.
Next ' For FamCount = 1 To 30
End If ' If Right(s, 4) = "FAMC"



LoopToFindFAM:
' This step takes you to the next record in the GEDCOM.
Loop ' Do Until EndofINDI = True
' *************************************************************************************************
'        End of FoundZeroINDI-Part 3 and of all processing for Person X.
' *************************************************************************************************




' *************************************************************************************************
'   EndofINDI: Finished processing Person X. So, see if it current record is the last RIN record.
' *************************************************************************************************
EndofINDI: ' You have finished the current individual's records.
' The first MRIN record will have the form "0 ... FAM".
' A search for "FAM" in the rightmost 3 characeters will tell you that you have reached the MRIN reocrds.
If Right(s, 3) = "FAM" Then ' The first "0 ... FAM" record in the GEDCOM indicates RINS are done.
RINSDone = True
GoTo RINSDone
End If ' If Right(s, 3) = "FAM"
GoTo FoundZeroINDI: ' go back and process the new individual you have found.
Else ' If Right(s, 4) = "INDI" Then
If Right(s, 3) = "FAM" Then ' The first "0 ... FAM" indicates RINS are done.
RINSDone = True
GoTo RINSDone
End If ' If Right(s, 3) = "FAM" Then
End If ' If Right(s, 4) = "INDI" Then
End If ' If Left(s, 1) = 0 Then
Else ' If RINSDone = False Then

End If ' If RINSDone = False Then


' *************************************************************************************************
'                                            RINSDone
'                    You have finished processing all the RINs in the GEDCOM.
'                    Capture the NMAXRINS count of RINs and MAXMRIN count of MRINs.
'                                  Then exit the ReadGEDCOM Function.
' *************************************************************************************************
RINSDone:

'Next ' For loopct = 1 To 100
Loop 'Do While ts.AtEndOfLine <> True

ts.Close

MAXRIN = Rin ' Capture the highest RIN, which will be the last one
' Figure out MAXMRIN and NMRINS
For LoopCt = 1 To MRINLimit
If FamPers(LoopCt, 1) <> 0 Then
NMRINS = NMRINS + 1
MAXMRIN = LoopCt
End If ' If FamPers(LoopCt, 1) <> 0
Next ' For LoopCt = 1 To MRINLimit

End Function ' ReadGEDCOM()
Function CalcLDNACoverage(ReceivedRIN)

'Initial setup for Target Person
'Find all children of target person and create upper and lower bounds arrays for them -- LTable2(ChildSeq,ChildRIN,ChildCoverage) and UTable2
'Set values of N, P, M and set up LTable1 and LTable2 of Venn Diagram representation for lower and upper bounds
'For each child, call GetChildCoverage for child and enter it in Table2
'When processed all children, use tables to calculate target person's coverage, report it and end.

'CalcLDNACoverage:
'Find all children of received person and create upper and lower bounds arrays for them -- LTable2(ChildSeq,ChildRIN,ChildCoverage) and UTable2
'Set values of N, P, M and set up LTable1 and LTable2 of Venn Diagram representation for lower and upper bounds
'For each child, call GetChildCoverage for child and enter it in Table2
'When processed all children, use tables to calculate received person's coverage, report it for family, return the coverage to call and end.

CalcLDNACoverage = 0
Dim RinReceived As Integer
RinReceived = ReceivedRIN

Dim MRINFound As Integer
Dim KidsFound As Integer

Dim PieceCount As Long

'****************************************************************
'   Set up LTable2 and UTable2 (Lower and Upper-Bound Table 2s)
'   The index value is the number of the child in the table.
'   xTable2RIN is the RIN of the child.
'   xTable2Coverage is the DNA coverage of the child, initially zero.
'****************************************************************
Dim LTable2RIN(1 To Table1KidLimit) As Integer
Dim LTable2Coverage(1 To Table1KidLimit) As Double

'****************************************************************
'   If the person has DNA-tested, set value to 1 (100%).
'   Then exit the function.
'****************************************************************
If RinatDNA(RinReceived) = True Then ' Do I need to write an outputrow for this???????????????????????????????????????????????????????
    CalcLDNACoverage = 1
    GoTo EndCalc ' Go to the exit of this function.
End If

'************************************************************************************************
'         If you reach this point, the person has NOT done an autosomal DNA test.
'            So, find Person X's children to calculate the person's coverage.

'************************************************************************************************

'************************************************************************************************
' To find the children, first find all the PersFam entries for which person X is a parent.
' That is, find all the families in which person X is a parent
' Search PersFam for the RIN of Person X (the row variable of PersFam).
' Then for each child of that MRIN (in FamPers), if the value (the RIN) is positive, Person X is a parent in that MRIN.
' So, use that MRIN to search FamPers.
' For any FamPers record for this MRIN, if the second element (RIN) is negative, then that person is a child of that parent in that family.
' So, capture the postive value of that child's RIN into Table 2 (both) as a child of Person X.
'************************************************************************************************
KidsFound = 0
For CountFamilies = 1 To PFLimit
    If PersFam(RinReceived, CountFamilies) > 0 Then ' Have found a family record (MRIN) of Person X - so now find all children of that family and load to Table 2
        MRINFound = PersFam(RinReceived, CountFamilies)
        For CountChildren = 1 To FPLimit
            If FamPers(MRINFound, CountChildren) < 0 Then
                KidsFound = KidsFound + 1
                LTable2RIN(KidsFound) = Abs(FamPers(MRINFound, CountChildren))
                LTable2Coverage(KidsFound) = 0 ' Initialize the Child's DNA Coverage at zero
            End If ' If FamPers(MRINFound, CountChildren) <> 0
        Next ' For CountChildren = 1 To FPLimit
    End If ' If PersFam(RinReceived, CountFamilies) <> 0
Next ' For CountFamilies = 1 To PFLimit

'************************************************************************************************
' So now, you have built both versions (L and U) of Table2.
' So calculate the key constants.
' N = number of children of the parent
' P = Pieces of the Venn diagram of the parent =(2^N)-1
' M = Max percent of parent that each piece of the Venn diagram can contribute = 1/(2^N)
' M is calculated as a decimal and not as a percent
'************************************************************************************************
Dim N, P As Long
Dim M As Double

N = KidsFound
P = (2 ^ N) - 1
M = 1 / (2 ^ N)

If N >= 13 Then
showit = "RinReceived=" & RinReceived & " and N=" & N & " and P=" & P
MsgBox showit
End If

'************************************************************************************************
' Now create both versions (L and U) of Table1. Each column is a separate 1-dim array.
' Each row of Table 1 has one column for each child with the binary value of that row number in those columns.
' Each row of Table 1 also has one column for M which is the constant M for all rows.
' Each row of Table 1 also has one column for W (weight)/
' -- For the lower bound W is the maximum coverage of any child with a 1 in their column in that row.
'************************************************************************************************
' -- For the upper bound W is the minimum of 1 or of the sum of the coverages of all the children with a 1 in their column in that row.
'************************************************************************************************
' Each row of Table 1 also has one column for R (result) which is M * W.
'************************************************************************************************

'****************************************************************
'   Set up LTable1 and UTable1 (Lower and Upper-Bound Table 1s)
'   The index value is the number of the piece of the Venn diagram in the table.
'   Thus the index number is the row number in Table1.
'
'****************************************************************
Dim LTable1Binary(1 To Table1PieceLimit, 1 To Table1KidLimit) As Integer
Dim LTable1M(1 To Table1PieceLimit) As Double
Dim LTable1W(1 To Table1PieceLimit) As Double
Dim LTable1R(1 To Table1PieceLimit) As Double

'****************************************************************
'   Set the Binary Value for Each Piece/Row in the Child Columns
'   Convert Venn Diagragm piece number to its binary equivalent and put bits into Table1 child cells
'   Works by reducing piece number by power of 2 on each iteration
'****************************************************************
For PieceNum = 1 To P
    LTable1W(PieceNum) = 0
    LTable1M(PieceNum) = M
    LTable1R(PieceNum) = 0
    Remainder = PieceNum
    For KidNum = 1 To N
        BitPower = N - KidNum
        Bit = WorksheetFunction.Power(2, BitPower)  ' Power(2, BitPower)
        If Remainder >= Bit Then
            LTable1Binary(PieceNum, KidNum) = 1
            Remainder = Remainder - Bit
        Else
            LTable1Binary(PieceNum, KidNum) = 0
        End If ' If Remainder >= Bit
    Next ' For KidNum = 1 To N
Next ' For PieceNum = 1 To P

'************************************************************************************************
' Now that both tables are set up, step through each child to obtain their DNA coverage in Table2.
' This is done be recursive calls to this same routine.
'************************************************************************************************
For ChildCount = 1 To N
    ChildRin = LTable2RIN(ChildCount)
    TargetLDNACoverage = CalcLDNACoverage(ChildRin) ' <<<< THIS CALL FAILS FOR ChildRin=5879 ----------------------------- <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
    LTable2Coverage(ChildCount) = TargetLDNACoverage
Next ' For ChildCount = 1 To N

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++ THE KEY CALCULATION ++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Now the children have all been found and their own DNA Coverage has been calculated.
' So, calculate the coverage of their parent.
' This is the KEY CALCULATION of this function.
' It is the only place that the calculation of the lower and upper bounds differ.
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

'************************************************************************************************
' Now that the DNA coverage of all children is known, calculate the DNA coverage of Person X who is RINReceived.
' Calcualte the contribution of each piece of the Venn Diagram and add them up.
''************************************************************************************************
Dim MaxChildDNA As Double
MaxChildDNA = 0
Dim ChildProduct As Double
Dim WorkingCalcLDNACoverage As Double
WorkingCalcLDNACoverage = 0

For PieceCount = 1 To P
' *********************************************************************************************
' Calculate lower bound W = max of the products of each child's coverage (from Table 2)
' Calculate lower bound R = W * M
' *********************************************************************************************
 
    MaxChildDNA = 0
    For ChildCount = 1 To N
    ' *********************************************************************************************
    ' Calculate lower bound W = max of the products of each child's coverage (from Table 2)
    ' *********************************************************************************************
        ChildProduct = LTable2Coverage(ChildCount) * LTable1Binary(PieceCount, ChildCount)
        MaxChildDNA = WorksheetFunction.Max(MaxChildDNA, ChildProduct)
        LTable1W(PieceCount) = MaxChildDNA
    Next 'For ChildCount = 1 To N
    
    LTable1R(PieceCount) = LTable1W(PieceCount) * LTable1M(PieceCount)
    WorkingCalcLDNACoverage = WorkingCalcLDNACoverage + LTable1R(PieceCount)
Next ' For PieceCount = 1 To P

' *********************************************************************************************
' Set the output value to be returned
' *********************************************************************************************
CalcLDNACoverage = WorkingCalcLDNACoverage

' *********************************************************************************************
' Now that the calculation for this person is complete, write the output rows
' for this person and the children and Tables 1 and 2 values.
' *********************************************************************************************
OutputValue = "--------------------------------------------------------------------------"
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

OutputValue = "LOWER BOUND DNA Coverage of RIN " & RinReceived & " (" & RinName(RinReceived) & ") = " & CalcLDNACoverage
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

OutputValue = "Children of RIN " & RinReceived & " (" & RinName(RinReceived) & ")"
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

For ChildCount = 1 To N
    OutputValue = "RIN " & LTable2RIN(ChildCount) & " (" & RinName(LTable2RIN(ChildCount)) & ")"
    OutputRow(LineCount) = OutputValue
    LineCount = LineCount + 1
Next ' For ChildCount = 1 to N




' If N >= 13 Then
' showit = "XX-Made it here for RinReceived=" & RinReceived
' MsgBox showit
' End If




' *********************************************************************************************
' Write out Table 2
' *********************************************************************************************
OutputValue = "***** Table 2 *****"
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

OutputValueRIN = ""
OutputValueCoverage = ""
For ChildCount = 1 To N
    OutputValueRIN = OutputValueRIN & LTable2RIN(ChildCount) & "--"
    OutputValueCoverage = OutputValueCoverage & LTable2Coverage(ChildCount) & "--"
Next ' For ChildCount = 1 to N

OutputRow(LineCount) = "RINS--" & OutputValueRIN
LineCount = LineCount + 1

OutputRow(LineCount) = "DNA--" & OutputValueCoverage
LineCount = LineCount + 1

' *********************************************************************************************
' Write out Table 1
' THIS IS COMMENTED OUT IN THE PRODUCTION VERSION SINCE IT IS UNNECESSARY
' *********************************************************************************************
'OutputValue = "***** Table 1 *****"
'OutputRow(LineCount) = OutputValue
'LineCount = LineCount + 1

'OutputValuePiece = ""
'OutputValueHeader = "----R----M----W<<<<"
'For ChildCount = 1 To N
'    OutputValueHeader = OutputValueHeader & LTable2RIN(ChildCount) & "+"
'Next ' For ChildCount = 1 To N

'OutputRow(LineCount) = OutputValueHeader
'LineCount = LineCount + 1

'OutputValuePiece = ""
'For PieceCount = 1 To P
'    OutputValuePiece = OutputValuePiece & "----" & LTable1R(PieceCount) & "--" & LTable1M(PieceCount) & "--" & LTable1W(PieceCount) & "<<<<"
'    For ChildCount = 1 To N
'        OutputValuePiece = OutputValuePiece & LTable1Binary(PieceCount, ChildCount) & "+"
'    Next ' For ChildCount = 1 to N
'    OutputRow(LineCount) = OutputValuePiece
'    LineCount = LineCount + 1
'    OutputValuePiece = ""
'Next ' For PieceCount = 1 to P


'    If N >= 13 Then
'    showit = "Made it to EndCalc (Lower) for RinReceived=" & RinReceived
'    MsgBox showit
'    End If

If RinReceived = 5881 Then
showit = "EndCalc-RinReceived=" & RinReceived & "--RINS--" & OutputValueRIN
MsgBox showit
showit = "EndCalc-RinReceived=" & RinReceived & "--DNA--" & OutputValueCoverage
MsgBox showit
showit = "EndCalc-RinReceived=" & RinReceived & "--CalcLDNACoverage=" & CalcLDNACoverage
MsgBox showit
End If

EndCalc:
End Function ' CalcLDNACoverage
Function CalcUDNACoverage(ReceivedRIN)
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++'

'Initial setup for Target Person
'Find all children of target person and create upper and lower bounds arrays for them -- LTable2(ChildSeq,ChildRIN,ChildCoverage) and UTable2
'Set values of N, P, M and set up LTable1 and LTable2 of Venn Diagram representation for lower and upper bounds
'For each child, call GetChildCoverage for child and enter it in Table2
'When processed all children, use tables to calculate target person's coverage, report it and end.

'CalcLDNACoverage:
'Find all children of received person and create upper and lower bounds arrays for them -- LTable2(ChildSeq,ChildRIN,ChildCoverage) and UTable2
'Set values of N, P, M and set up LTable1 and LTable2 of Venn Diagram representation for lower and upper bounds
'For each child, call GetChildCoverage for child and enter it in Table2
'When processed all children, use tables to calculate received person's coverage, report it for family, return the coverage to call and end.

CalcUDNACoverage = 0
Dim RinReceived As Integer
RinReceived = ReceivedRIN

Dim MRINFound As Integer
Dim KidsFound As Integer

Dim PieceCount As Long

'****************************************************************
'   Set up LTable2 and UTable2 (Lower and Upper-Bound Table 2s)
'   The index value is the number of the child in the table.
'   xTable2RIN is the RIN of the child.
'   xTable2Coverage is the DNA coverage of the child, initially zero.
'****************************************************************
Dim UTable2RIN(1 To FPLimit) As Integer
Dim UTable2Coverage(1 To FPLimit) As Double

'****************************************************************
'   If the person has DNA-tested, set value to 1 (100%).
'   Then exit the function.
'****************************************************************
If RinatDNA(RinReceived) = True Then ' Do I need to write an outputrow for this???????????????????????????????????????????????????????
    CalcUDNACoverage = 1
    GoTo EndCalc ' Go to the exit of this function.
End If

'************************************************************************************************
'         If you reach this point, the person has NOT done an autosomal DNA test.
'            So, find Person X's children to calculate the person's coverage.

'************************************************************************************************

'************************************************************************************************
' To find the children, first find all the PersFam entries for which person X is a parent.
' That is, find all the families in which person X is a parent
' Search PersFam for the RIN of Person X (the row variable of PersFam).
' Then for each child of that MRIN (in FamPers), if the value (the RIN) is positive, Person X is a parent in that MRIN.
' So, use that MRIN to search FamPers.
' For any FamPers record for this MRIN, if the second element (RIN) is negative, then that person is a child of that parent in that family.
' So, capture the postive value of that child's RIN into Table 2 (both) as a child of Person X.
'************************************************************************************************
KidsFound = 0
For CountFamilies = 1 To PFLimit
    If PersFam(RinReceived, CountFamilies) > 0 Then ' Have found a family record (MRIN) of Person X - so now find all children of that family and load to Table 2
        MRINFound = PersFam(RinReceived, CountFamilies)
        For CountChildren = 1 To FPLimit
            If FamPers(MRINFound, CountChildren) < 0 Then
                KidsFound = KidsFound + 1
                UTable2RIN(KidsFound) = Abs(FamPers(MRINFound, CountChildren))
                UTable2Coverage(KidsFound) = 0 ' Initialize the Child's DNA Coverage at zero
            End If ' If FamPers(MRINFound, CountChildren) <> 0
        Next ' For CountChildren = 1 To FPLimit
    End If ' If PersFam(RinReceived, CountFamilies) <> 0
Next ' For CountFamilies = 1 To PFLimit

'************************************************************************************************
' So now, you have built both versions (L and U) of Table2.
' So calculate the key constants.
' N = number of children of the parent
' P = Pieces of the Venn diagram of the parent =(2^N)-1
' M = Max percent of parent that each piece of the Venn diagram can contribute = 1/(2^N)
' M is calculated as a decimal and not as a percent
'************************************************************************************************
Dim N, P As Long
Dim M As Double

N = KidsFound
P = (2 ^ N) - 1
M = 1 / (2 ^ N)




'************************************************************************************************
' Now create both versions (L and U) of Table1. Each column is a separate 1-dim array.
' Each row of Table 1 has one column for each child with the binary value of that row number in those columns.
' Each row of Table 1 also has one column for M which is the constant M for all rows.
' Each row of Table 1 also has one column for W (weight)/
' -- For the lower bound W is the maximum coverage of any child with a 1 in their column in that row.
'************************************************************************************************
' -- For the upper bound W is the minimum of 1 or of the sum of the coverages of all the children with a 1 in their column in that row.
'************************************************************************************************
' Each row of Table 1 also has one column for R (result) which is M * W.
'************************************************************************************************

'****************************************************************
'   Set up LTable1 and UTable1 (Lower and Upper-Bound Table 1s)
'   The index value is the number of the piece of the Venn diagram in the table.
'   Thus the index number is the row number in Table1.
'
'****************************************************************
Dim UTable1Binary(1 To Table1PieceLimit, 1 To Table1KidLimit) As Integer
Dim UTable1M(1 To Table1PieceLimit) As Double
Dim UTable1W(1 To Table1PieceLimit) As Double
Dim UTable1R(1 To Table1PieceLimit) As Double

'****************************************************************
'   Set the Binary Value for Each Piece/Row in the Child Columns
'   Convert Venn Diagragm piece number to its binary equivalent and put bits into Table1 child cells
'   Works by reducing piece number by power of 2 on each iteration
'****************************************************************

For PieceNum = 1 To P
    UTable1W(PieceNum) = 0
    UTable1M(PieceNum) = M
    UTable1R(PieceNum) = 0
    Remainder = PieceNum
    For KidNum = 1 To N
        BitPower = N - KidNum
        Bit = WorksheetFunction.Power(2, BitPower)  ' Power(2, BitPower)
        If Remainder >= Bit Then
            UTable1Binary(PieceNum, KidNum) = 1
            Remainder = Remainder - Bit
        Else
            UTable1Binary(PieceNum, KidNum) = 0
        End If ' If Remainder >= Bit
    Next ' For KidNum = 1 To N
Next ' For PieceNum = 1 To P

'************************************************************************************************
' Now that both tables are set up, step through each child to obtain their DNA coverage in Table2.
' This is done be recursive calls to this same routine.
'************************************************************************************************
For ChildCount = 1 To N
    ChildRin = UTable2RIN(ChildCount)
    TargetUDNACoverage = CalcUDNACoverage(ChildRin)
    UTable2Coverage(ChildCount) = TargetUDNACoverage
Next ' For ChildCount = 1 To N



'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++++++++++++++++++++++++++++++++++++++++++++++++ THE KEY CALCULATION ++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
' Now the children have all been found and their own DNA Coverage has been calculated.
' So, calculate the coverage of their parent.
' This is the KEY CALCULATION of this function.
' It is the only place that the calculation of the lower and upper bounds differ.
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
WorkingCalcUDNACoverage = 0
For PieceCount = 1 To P
' *********************************************************************************************
' Calculate upper bound W = max of the products of each child's coverage (from Table 2)
' Calculate upper bound R = W * M
' *********************************************************************************************
    SumChildDNA = 0
    For ChildCount = 1 To N
    ' *********************************************************************************************
    ' Calculate lower bound W = max of the products of each child's coverage (from Table 2)
    ' *********************************************************************************************
        ChildProduct = UTable2Coverage(ChildCount) * UTable1Binary(PieceCount, ChildCount) * M
        SumChildDNA = SumChildDNA + ChildProduct
        UTable1W(PieceCount) = SumChildDNA
    Next 'For ChildCount = 1 To N
    UTable1R(PieceCount) = WorksheetFunction.Min(UTable1W(PieceCount), UTable1M(PieceCount))
    WorkingCalcUDNACoverage = WorkingCalcUDNACoverage + UTable1R(PieceCount)
Next ' For PieceCount = 1 To P


' *********************************************************************************************
' Set the output value to be returned
' *********************************************************************************************
CalcUDNACoverage = WorkingCalcUDNACoverage

' *********************************************************************************************
' Now that the calculation for this person is complete, write the output rows
' for this person and the children and Tables 1 and 2 values.
' *********************************************************************************************
OutputValue = "++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++"
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

OutputValue = "UPPER BOUND DNA Coverage of RIN " & RinReceived & " (" & RinName(RinReceived) & ") = " & CalcUDNACoverage
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

OutputValue = "Children of RIN " & RinReceived & " (" & RinName(RinReceived) & ")"
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

For ChildCount = 1 To N
    OutputValue = "RIN " & UTable2RIN(ChildCount) & " (" & RinName(UTable2RIN(ChildCount)) & ")"
    OutputRow(LineCount) = OutputValue
    LineCount = LineCount + 1
Next ' For ChildCount = 1 to N


' *********************************************************************************************
' Write out Table 2
' *********************************************************************************************
OutputValue = "***** Table 2 *****"
OutputRow(LineCount) = OutputValue
LineCount = LineCount + 1

OutputValueRIN = ""
OutputValueCoverage = ""
For ChildCount = 1 To N
    OutputValueRIN = OutputValueRIN & UTable2RIN(ChildCount) & "--"
    OutputValueCoverage = OutputValueCoverage & UTable2Coverage(ChildCount) & "--"
Next ' For ChildCount = 1 to N

OutputRow(LineCount) = "RINS--" & OutputValueRIN
LineCount = LineCount + 1

OutputRow(LineCount) = "DNA--" & OutputValueCoverage
LineCount = LineCount + 1

' *********************************************************************************************
' Write out Table 1
' THIS IS COMMENTED OUT IN THE PRODUCTION VERSION SINCE IT IS UNNECESSARY
' *********************************************************************************************
'OutputValue = "***** Table 1 *****"
'OutputRow(LineCount) = OutputValue
'LineCount = LineCount + 1

'OutputValuePiece = ""
'OutputValueHeader = "----R----M----W<<<<"
'For ChildCount = 1 To N
'    OutputValueHeader = OutputValueHeader & UTable2RIN(ChildCount) & "+"
'Next ' For ChildCount = 1 To N

'OutputRow(LineCount) = OutputValueHeader
'LineCount = LineCount + 1

'OutputValuePiece = ""
'For PieceCount = 1 To P
'    OutputValuePiece = OutputValuePiece & "----" & UTable1R(PieceCount) & "--" & UTable1M(PieceCount) & "--" & UTable1W(PieceCount) & "<<<<"
'    For ChildCount = 1 To N
'        OutputValuePiece = OutputValuePiece & UTable1Binary(PieceCount, ChildCount) & "+"
'    Next ' For ChildCount = 1 to N
'    OutputRow(LineCount) = OutputValuePiece
'    LineCount = LineCount + 1
'    OutputValuePiece = ""
'Next ' For PieceCount = 1 to P


EndCalc:
End Function ' CalcUDNACoverage