Simulation of DNA kinship 3

Simulation of DNA kinship 3



 6 generations from a 
founding couple with all 'mates' from external randoms 
except the cousin pairings 
3rd generation cousin pairings 3.7%
4th gen 2.4%
5th gen 1.2%
6th gen 0.4%
Repeated 20 times to produce 20 unrelated 'families'
Then randomly choosing 1 in every 20 to produce the pg0 
external profiles to 'marry' into the core family.
Sorted profiles and then checked for >= 5 pairs of 
adjascent alleles.
Output file is then checked for single allele matches 
and further checked for non sibling matches in 
the 11 to 20 digit area.
Before going into Visual Basic Editor go into ordinary 
Word and call up anything in the directory you want 
the VB files to go into as this is not designated in the 
following code.
Using plain text handling Notepad with no line wrap 
Copy visual basic code ( between horizontal 
black lines ),place between sub () and 
end sub,reset and run.
Try code in dnas5.htm before trying this dnas4.htm code 
as the 5 simulation is much more straightforward to 
understand what is going on and is more compact.


' 20 founding families ' Generating 10 loci x2 profiles ' to be called on later ' 2 +3 +9 +27 +81 +243 = 365 = profiles ' repeated xx (20) times ' the whole routine up to final single allele ' matches repeated tt (20 ) times ' for first run change tt to just 2 zz = 0 Dim ph(20) Dim ps As String Dim pg0(365, 20) ' pg8 is 20 founding families from which to select the pg0 file Dim pg8(20, 1095) Dim pg1(1, 20) Dim pg2(2, 20) ' initialising RNG Randomize a = 214013 c = 2531011 x0 = Timer z = 2 ^ 24 Dim pg3(8, 20) Dim pg4(26, 20) Dim pg5(80, 20) Dim pg6(242, 20) Dim pg7(728, 20) Open "sept29-7m.txt" For Output As #2 Open "sept29-24" For Output As #24 Open "sept29-25" For Output As #25 Open "sept29-26" For Output As #26 Open "sept29-27" For Output As #27 ' change tt limit for overall repeats of routine For tt = 0 To 19 Open "sept29-28" For Output As #28 ' change xx limit here and mid-way down for ' changing < or > the number of founder families For xx = 0 To 19 count9 = 0 count8 = 0 Open "sept29-0" For Output As #10 Open "sept29-1" For Output As #11 Open "sept29-2" For Output As #12 Open "sept29-3" For Output As #13 Open "sept29-4" For Output As #14 Open "sept29-5" For Output As #15 Open "sept29-6" For Output As #16 Open "sept29-7" For Output As #17 For x = 0 To 364 For j = 0 To 1 ' vWA ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.001 Then ph(j) = 11 If ph(j) < 0.106 Then ph(j) = 1 If ph(j) < 0.186 Then ph(j) = 2 If ph(j) < 0.402 Then ph(j) = 3 If ph(j) < 0.672 Then ph(j) = 4 If ph(j) < 0.891 Then ph(j) = 5 If ph(j) < 0.984 Then ph(j) = 6 If ph(j) < 0.998 Then ph(j) = 7 If ph(j) < 1 Then ph(j) = 8 If ph(j) > 10 Then ph(j) = 0 Next j For j = 2 To 3 ' THO1 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.002 Then ph(j) = 11 If ph(j) < 0.243 Then ph(j) = 1 If ph(j) < 0.437 Then ph(j) = 2 If ph(j) < 0.545 Then ph(j) = 3 If ph(j) < 0.546 Then ph(j) = 4 If ph(j) < 0.686 Then ph(j) = 5 If ph(j) < 0.99 Then ph(j) = 6 If ph(j) < 1 Then ph(j) = 7 If ph(j) > 10 Then ph(j) = 0 Next j For j = 4 To 5 ' D8 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.018 Then ph(j) = 11 If ph(j) < 0.031 Then ph(j) = 1 If ph(j) < 0.125 Then ph(j) = 2 If ph(j) < 0.191 Then ph(j) = 3 If ph(j) < 0.334 Then ph(j) = 4 If ph(j) < 0.667 Then ph(j) = 5 If ph(j) < 0.876 Then ph(j) = 6 If ph(j) < 0.964 Then ph(j) = 7 If ph(j) < 0.995 Then ph(j) = 8 If ph(j) < 1 Then ph(j) = 9 If ph(j) > 10 Then ph(j) = 0 Next j For j = 6 To 7 ' FGA ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.025 Then ph(j) = 11 If ph(j) < 0.081 Then ph(j) = 1 If ph(j) < 0.224 Then ph(j) = 2 If ph(j) < 0.411 Then ph(j) = 3 If ph(j) < 0.576 Then ph(j) = 4 If ph(j) < 0.587 Then ph(j) = 5 If ph(j) < 0.726 Then ph(j) = 6 If ph(j) < 0.872 Then ph(j) = 7 If ph(j) < 0.947 Then ph(j) = 8 If ph(j) < 0.982 Then ph(j) = 9 If ph(j) < 1 Then ph(j) = 0 ' 1.8% not generated If ph(j) > 10 Then ph(j) = 0 Next j For j = 8 To 9 ' D21 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.031 Then ph(j) = 11 If ph(j) < 0.191 Then ph(j) = 1 If ph(j) < 0.417 Then ph(j) = 2 If ph(j) < 0.675 Then ph(j) = 3 If ph(j) < 0.702 Then ph(j) = 4 If ph(j) < 0.771 Then ph(j) = 5 If ph(j) < 0.864 Then ph(j) = 6 If ph(j) < 0.882 Then ph(j) = 7 If ph(j) < 0.972 Then ph(j) = 8 If ph(j) < 0.994 Then ph(j) = 9 If ph(j) < 1 Then ph(j) = 0 ' 0.5% not generated If ph(j) > 10 Then ph(j) = 0 Next j For j = 10 To 11 ' D18 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.012 Then ph(j) = 11 If ph(j) < 0.151 Then ph(j) = 1 If ph(j) < 0.276 Then ph(j) = 2 If ph(j) < 0.44 Then ph(j) = 3 If ph(j) < 0.585 Then ph(j) = 4 If ph(j) < 0.722 Then ph(j) = 5 If ph(j) < 0.837 Then ph(j) = 6 If ph(j) < 0.917 Then ph(j) = 7 If ph(j) < 0.958 Then ph(j) = 8 If ph(j) < 0.975 Then ph(j) = 9 If ph(j) < 1 Then ph(j) = 0 ' 2.5% not generated If ph(j) > 10 Then ph(j) = 0 Next j For j = 12 To 13 ' D2S1338 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.037 Then ph(j) = 11 If ph(j) < 0.222 Then ph(j) = 1 If ph(j) < 0.309 Then ph(j) = 2 If ph(j) < 0.419 Then ph(j) = 3 If ph(j) < 0.557 Then ph(j) = 4 If ph(j) < 0.589 Then ph(j) = 5 If ph(j) < 0.613 Then ph(j) = 6 If ph(j) < 0.725 Then ph(j) = 7 If ph(j) < 0.867 Then ph(j) = 8 If ph(j) < 0.978 Then ph(j) = 9 If ph(j) < 1 Then ph(j) = 0 ' 2.2% not generated If ph(j) > 10 Then ph(j) = 0 Next j For j = 14 To 15 ' D16 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.019 Then ph(j) = 11 If ph(j) < 0.148 Then ph(j) = 1 If ph(j) < 0.202 Then ph(j) = 2 If ph(j) < 0.491 Then ph(j) = 3 If ph(j) < 0.779 Then ph(j) = 4 If ph(j) < 0.965 Then ph(j) = 5 If ph(j) < 0.994 Then ph(j) = 6 If ph(j) < 1 Then ph(j) = 7 If ph(j) > 10 Then ph(j) = 0 Next j For j = 16 To 17 ' D19 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.087 Then ph(j) = 11 If ph(j) < 0.309 Then ph(j) = 1 If ph(j) < 0.322 Then ph(j) = 2 If ph(j) < 0.704 Then ph(j) = 3 If ph(j) < 0.713 Then ph(j) = 4 If ph(j) < 0.896 Then ph(j) = 5 If ph(j) < 0.934 Then ph(j) = 6 If ph(j) < 0.975 Then ph(j) = 7 If ph(j) < 0.992 Then ph(j) = 8 If ph(j) < 0.997 Then ph(j) = 9 If ph(j) < 1 Then ph(j) = 0 If ph(j) > 10 Then ph(j) = 0 ' 0.3% not generated Next j For j = 18 To 19 ' D3 ' RNG temp = x0 * a + c temp = temp / z x1 = (temp - Fix(temp)) * z x0 = x1 phj = x1 / z ph(j) = phj If ph(j) < 0.001 Then ph(j) = 11 If ph(j) < 0.007 Then ph(j) = 1 If ph(j) < 0.139 Then ph(j) = 2 If ph(j) < 0.404 Then ph(j) = 3 If ph(j) < 0.651 Then ph(j) = 4 If ph(j) < 0.846 Then ph(j) = 5 If ph(j) < 0.987 Then ph(j) = 6 If ph(j) < 1 Then ph(j) = 7 If ph(j) > 10 Then ph(j) = 0 Next j ' directing pairs For j = 0 To 18 Step 2 If ph(j + 1) < ph(j) Then jjj = ph(j) ph(j) = ph(j + 1) ph(j + 1) = jjj End If pg0(x, j) = ph(j) pg0(x, j + 1) = ph(j + 1) Next j Write #10, pg0(x, 0) & pg0(x, 1) & pg0(x, 2) & pg0(x, 3) & pg0(x, 4) & pg0(x, 5) & pg0(x, 6) & pg0(x, 7) & pg0(x, 8) & pg0(x, 9) & pg0(x, 10) & pg0(x, 11) & pg0(x, 12) & pg0(x, 13) & pg0(x, 14) & pg0(x, 15) & pg0(x, 16) & pg0(x, 17) & pg0(x, 18) & pg0(x, 19) Next x ' founding couple For m = 0 To 1 For k = 0 To 19 pg1(m, k) = pg0(m, k) Next k Write #11, pg1(m, 0) & pg1(m, 1) & pg1(m, 2) & pg1(m, 3) & pg1(m, 4) & pg1(m, 5) & pg1(m, 6) & pg1(m, 7) & pg1(m, 8) & pg1(m, 9) & pg1(m, 10) & pg1(m, 11) & pg1(m, 12) & pg1(m, 13) & pg1(m, 14) & pg1(m, 15) & pg1(m, 16) & pg1(m, 17) & pg1(m, 18) & pg1(m, 19) Write #28, pg1(m, 0) & pg1(m, 1) & pg1(m, 2) & pg1(m, 3) & pg1(m, 4) & pg1(m, 5) & pg1(m, 6) & pg1(m, 7) & pg1(m, 8) & pg1(m, 9) & pg1(m, 10) & pg1(m, 11) & pg1(m, 12) & pg1(m, 13) & pg1(m, 14) & pg1(m, 15) & pg1(m, 16) & pg1(m, 17) & pg1(m, 18) & pg1(m, 19) & zz & tt & zz & m Next m ' first generation of 3 offspring ' 4 way random to select one of ' 2 alleles from adam and one of 2 from eve ' 3 times over For m = 0 To 2 For k = 0 To 18 Step 2 rr = Rnd pg2(m, k) = pg1(0, k) pg2(m, k + 1) = pg1(1, k) If rr < 0.75 Then pg2(m, k) = pg1(0, k) pg2(m, k + 1) = pg1(1, k + 1) End If If rr < 0.5 Then pg2(m, k) = pg1(0, k + 1) pg2(m, k + 1) = pg1(1, k) End If If rr < 0.25 Then pg2(m, k) = pg1(0, k + 1) pg2(m, k + 1) = pg1(1, k + 1) End If Next k ' directing pairs For j = 0 To 18 Step 2 If pg2(m, j + 1) < pg2(m, j) Then jjj = pg2(m, j) pg2(m, j) = pg2(m, j + 1) pg2(m, j + 1) = jjj End If Next j Write #12, pg2(m, 0) & pg2(m, 1) & pg2(m, 2) & pg2(m, 3) & pg2(m, 4) & pg2(m, 5) & pg2(m, 6) & pg2(m, 7) & pg2(m, 8) & pg2(m, 9) & pg2(m, 10) & pg2(m, 11) & pg2(m, 12) & pg2(m, 13) & pg2(m, 14) & pg2(m, 15) & pg2(m, 16) & pg2(m, 17) & pg2(m, 18) & pg2(m, 19) Write #28, pg2(m, 0) & pg2(m, 1) & pg2(m, 2) & pg2(m, 3) & pg2(m, 4) & pg2(m, 5) & pg2(m, 6) & pg2(m, 7) & pg2(m, 8) & pg2(m, 9) & pg2(m, 10) & pg2(m, 11) & pg2(m, 12) & pg2(m, 13) & pg2(m, 14) & pg2(m, 15) & pg2(m, 16) & pg2(m, 17) & pg2(m, 18) & pg2(m, 19) & zz & tt & zz & m Next m ' second generation of 3 offspring of each pg2 parent ' 4 way random to select one of ' 2 alleles from each offsping and ' one of 2 from a random parent For mm = 0 To 6 Step 3 ' mm 1,2 or3 rd child For m = 0 To 2 ' m parent For k = 0 To 18 Step 2 rr = Rnd ' mm+m+2 (2 as 2 called up previously in pg0) pg3(mm + m, k) = pg0(m + 2, k) pg3(mm + m, k + 1) = pg2(m, k) If rr < 0.75 Then pg3(mm + m, k) = pg0(m + 2, k) pg3(mm + m, k + 1) = pg2(m, k + 1) End If If rr < 0.5 Then pg3(mm + m, k) = pg0(m + 2, k + 1) pg3(mm + m, k + 1) = pg2(m, k) End If If rr < 0.25 Then pg3(mm + m, k) = pg0(m + 2, k + 1) pg3(mm + m, k + 1) = pg2(m, k + 1) End If Next k ' directing pairs For j = 0 To 18 Step 2 If pg3(mm + m, j + 1) < pg3(mm + m, j) Then jjj = pg3(mm + m, j) pg3(mm + m, j) = pg3(mm + m, j + 1) pg3(mm + m, j + 1) = jjj End If Next j Write #13, pg3(mm + m, 0) & pg3(mm + m, 1) & pg3(mm + m, 2) & pg3(mm + m, 3) & pg3(mm + m, 4) & pg3(mm + m, 5) & pg3(mm + m, 6) & pg3(mm + m, 7) & pg3(mm + m, 8) & pg3(mm + m, 9) & pg3(mm + m, 10) & pg3(mm + m, 11) & pg3(mm + m, 12) & pg3(mm + m, 13) & pg3(mm + m, 14) & pg3(mm + m, 15) & pg3(mm + m, 16) & pg3(mm + m, 17) & pg3(mm + m, 18) & pg3(mm + m, 19) Write #28, pg3(mm + m, 0) & pg3(mm + m, 1) & pg3(mm + m, 2) & pg3(mm + m, 3) & pg3(mm + m, 4) & pg3(mm + m, 5) & pg3(mm + m, 6) & pg3(mm + m, 7) & pg3(mm + m, 8) & pg3(mm + m, 9) & pg3(mm + m, 10) & pg3(mm + m, 11) & pg3(mm + m, 12) & pg3(mm + m, 13) & pg3(mm + m, 14) & pg3(mm + m, 15) & pg3(mm + m, 16) & pg3(mm + m, 17) & pg3(mm + m, 18) & pg3(mm + m, 19) & zz & tt & zz & mm & zz & m Next m Next mm ' third generation of 3 offspring of each pg3 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 18 Step 9 For m = 0 To 8 For k = 0 To 18 Step 2 rr = Rnd ' the + as first 2 + 3used previously pg4(mm + m, k) = pg0(m + 5, k) pg4(mm + m, k + 1) = pg3(m, k) If rr < 0.75 Then pg4(mm + m, k) = pg0(m + 5, k) pg4(mm + m, k + 1) = pg3(m, k + 1) End If If rr < 0.5 Then pg4(mm + m, k) = pg0(m + 5, k + 1) pg4(mm + m, k + 1) = pg3(m, k) End If If rr < 0.25 Then pg4(mm + m, k) = pg0(m + 5, k + 1) pg4(mm + m, k + 1) = pg3(m, k + 1) End If Next k ' cousin marriage on 27th mating rrr = Rnd * 6 If mm + m = 26 Then Write #24, mm + m, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) For k = 0 To 18 Step 2 rr = Rnd yy = 7 If rrr < 5 Then yy = 6 If rrr < 4 Then yy = 4 If rrr < 3 Then yy = 3 If rrr < 2 Then yy = 1 If rrr < 1 Then yy = 0 pg4(mm + m, k) = pg3(yy, k) pg4(mm + m, k + 1) = pg3(m, k) If rr < 0.75 Then pg4(mm + m, k) = pg3(yy, k) pg4(mm + m, k + 1) = pg3(m, k + 1) End If If rr < 0.5 Then pg4(mm + m, k) = pg3(yy, k + 1) pg4(mm + m, k + 1) = pg3(m, k) End If If rr < 0.25 Then pg4(mm + m, k) = pg3(yy, k + 1) pg4(mm + m, k + 1) = pg3(m, k + 1) End If Next k Write #24, mm + m, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg4(mm + m, j + 1) < pg4(mm + m, j) Then jjj = pg4(mm + m, j) pg4(mm + m, j) = pg4(mm + m, j + 1) pg4(mm + m, j + 1) = jjj End If Next j Write #14, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) Write #28, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) & zz & tt & zz & mm & zz & m Next m Next mm ' fourth generation of 3 offspring of each pg4 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 54 Step 27 For m = 0 To 26 For k = 0 To 18 Step 2 rr = Rnd ' the +14 as first 2 +3+ 9 used previously pg5(mm + m, k) = pg0(m + 14, k) pg5(mm + m, k + 1) = pg4(m, k) If rr < 0.75 Then pg5(mm + m, k) = pg0(m + 14, k) pg5(mm + m, k + 1) = pg4(m, k + 1) End If If rr < 0.5 Then pg5(mm + m, k) = pg0(m + 14, k + 1) pg5(mm + m, k + 1) = pg4(m, k) End If If rr < 0.25 Then pg5(mm + m, k) = pg0(m + 14, k + 1) pg5(mm + m, k + 1) = pg4(m, k + 1) End If Next k ' cousin marriage on 40th mating rrr1 = Rnd * 6 rrr2 = Rnd * 6 If mm + m = 40 Or mm + m = 80 Then Write #25, mm + m, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) If mm + m = 40 Then rrr = rrr1 If mm + m = 40 Then rrr = rrr2 For k = 0 To 18 Step 2 rr = Rnd yy = 19 If rrr < 5 Then yy = 25 If rrr < 4 Then yy = 24 If rrr < 3 Then yy = 23 If rrr < 2 Then yy = 21 If rrr < 1 Then yy = 20 pg5(mm + m, k) = pg4(yy, k) pg5(mm + m, k + 1) = pg4(m, k) If rr < 0.75 Then pg5(mm + m, k) = pg4(yy, k) pg5(mm + m, k + 1) = pg4(m, k + 1) End If If rr < 0.5 Then pg5(mm + m, k) = pg4(yy, k + 1) pg5(mm + m, k + 1) = pg4(m, k) End If If rr < 0.25 Then pg5(mm + m, k) = pg4(yy, k + 1) pg5(mm + m, k + 1) = pg4(m, k + 1) End If Next k Write #25, mm + m, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg5(mm + m, j + 1) < pg5(mm + m, j) Then jjj = pg5(mm + m, j) pg5(mm + m, j) = pg5(mm + m, j + 1) pg5(mm + m, j + 1) = jjj End If Next j Write #15, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) Write #28, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) & zz & tt & zz & mm & zz & m Next m Next mm ' fifth generation of 3 offspring of each pg5 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 162 Step 81 For m = 0 To 80 For k = 0 To 18 Step 2 rr = Rnd pg6(mm + m, k) = pg0(m + 41, k) pg6(mm + m, k + 1) = pg5(m, k) If rr < 0.75 Then pg6(mm + m, k) = pg0(m + 41, k) pg6(mm + m, k + 1) = pg5(m, k + 1) End If If rr < 0.5 Then pg6(mm + m, k) = pg0(m + 41, k + 1) pg6(mm + m, k + 1) = pg5(m, k) End If If rr < 0.25 Then pg6(mm + m, k) = pg0(m + 41, k + 1) pg6(mm + m, k + 1) = pg5(m, k + 1) End If Next k ' cousin marriage on 79th mating rrr = Rnd * 6 If m = 79 Then Write #26, mm + m, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) For k = 0 To 18 Step 2 rr = Rnd yy = 77 If rrr < 5 Then yy = 75 If rrr < 4 Then yy = 73 If rrr < 3 Then yy = 71 If rrr < 2 Then yy = 69 If rrr < 1 Then yy = 67 pg6(mm + m, k) = pg5(yy, k) pg6(mm + m, k + 1) = pg5(m, k) If rr < 0.75 Then pg6(mm + m, k) = pg5(yy, k) pg6(mm + m, k + 1) = pg5(m, k + 1) End If If rr < 0.5 Then pg6(mm + m, k) = pg5(yy, k + 1) pg6(mm + m, k + 1) = pg5(m, k) End If If rr < 0.25 Then pg6(mm + m, k) = pg5(yy, k + 1) pg6(mm + m, k + 1) = pg5(m, k + 1) End If Next k Write #26, mm + m, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg6(mm + m, j + 1) < pg6(mm + m, j) Then jjj = pg6(mm + m, j) pg6(mm + m, j) = pg6(mm + m, j + 1) pg6(mm + m, j + 1) = jjj End If Next j Write #16, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) Write #28, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) & zz & tt & zz & mm & zz & m ' zz is just 0 spacer for the ident numbers at the end of the #28 file and later similar idents Next m Next mm ' sixth generation of 3 offspring of each pg6 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 486 Step 243 For m = 0 To 242 For k = 0 To 18 Step 2 rr = Rnd pg7(mm + m, k) = pg0(m + 122, k) pg7(mm + m, k + 1) = pg6(m, k) If rr < 0.75 Then pg7(mm + m, k) = pg0(m + 122, k) pg7(mm + m, k + 1) = pg6(m, k + 1) End If If rr < 0.5 Then pg7(mm + m, k) = pg0(m + 122, k + 1) pg7(mm + m, k + 1) = pg6(m, k) End If If rr < 0.25 Then pg7(mm + m, k) = pg0(m + 122, k + 1) pg7(mm + m, k + 1) = pg6(m, k + 1) End If Next k ' cousin marriage on 79th mating rrr = Rnd * 6 If m = 79 Then Write #27, mm + m, pg7(mm + m, 0) & pg7(mm + m, 1) & pg7(mm + m, 2) & pg7(mm + m, 3) & pg7(mm + m, 4) & pg7(mm + m, 5) & pg7(mm + m, 6) & pg7(mm + m, 7) & pg7(mm + m, 8) & pg7(mm + m, 9) & pg7(mm + m, 10) & pg7(mm + m, 11) & pg7(mm + m, 12) & pg7(mm + m, 13) & pg7(mm + m, 14) & pg7(mm + m, 15) & pg7(mm + m, 16) & pg7(mm + m, 17) & pg7(mm + m, 18) & pg7(mm + m, 19) For k = 0 To 18 Step 2 rr = Rnd yy = 76 If rrr < 5 Then yy = 74 If rrr < 4 Then yy = 72 If rrr < 3 Then yy = 70 If rrr < 2 Then yy = 69 If rrr < 1 Then yy = 68 pg7(mm + m, k) = pg6(yy, k) pg7(mm + m, k + 1) = pg6(m, k) If rr < 0.75 Then pg7(mm + m, k) = pg6(yy, k) pg7(mm + m, k + 1) = pg6(m, k + 1) End If If rr < 0.5 Then pg7(mm + m, k) = pg6(yy, k + 1) pg7(mm + m, k + 1) = pg6(m, k) End If If rr < 0.25 Then pg7(mm + m, k) = pg6(yy, k + 1) pg7(mm + m, k + 1) = pg6(m, k + 1) End If Next k Write #27, mm + m, pg7(mm + m, 0) & pg7(mm + m, 1) & pg7(mm + m, 2) & pg7(mm + m, 3) & pg7(mm + m, 4) & pg7(mm + m, 5) & pg7(mm + m, 6) & pg7(mm + m, 7) & pg7(mm + m, 8) & pg7(mm + m, 9) & pg7(mm + m, 10) & pg7(mm + m, 11) & pg7(mm + m, 12) & pg7(mm + m, 13) & pg7(mm + m, 14) & pg7(mm + m, 15) & pg7(mm + m, 16) & pg7(mm + m, 17) & pg7(mm + m, 18) & pg7(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg7(mm + m, j + 1) < pg7(mm + m, j) Then jjj = pg7(mm + m, j) pg7(mm + m, j) = pg7(mm + m, j + 1) pg7(mm + m, j + 1) = jjj End If Next j ' adds leading zeros to numbers less than 100 ' to structure each number to occupy 3 spaces plus a 0 null spacer/divider If tt < 10 Then px = "00" & Trim(Str(tt)) End If If tt > 9 And tt < 100 Then px = "0" & Trim(Str(tt)) End If If tt > 99 Then px = Trim(Str(tt)) End If If mm < 10 Then py = "00" & Trim(Str(mm)) End If If mm > 9 And mm < 100 Then py = "0" & Trim(Str(mm)) End If If mm > 99 Then py = Trim(Str(mm)) End If If m < 10 Then pz = "00" & Trim(Str(m)) End If If m > 9 And m < 100 Then pz = "0" & Trim(Str(m)) End If If m > 99 Then pz = Trim(Str(m)) End If Write #17, pg7(mm + m, 0) & pg7(mm + m, 1) & pg7(mm + m, 2) & pg7(mm + m, 3) & pg7(mm + m, 4) & pg7(mm + m, 5) & pg7(mm + m, 6) & pg7(mm + m, 7) & pg7(mm + m, 8) & pg7(mm + m, 9) & pg7(mm + m, 10) & pg7(mm + m, 11) & pg7(mm + m, 12) & pg7(mm + m, 13) & pg7(mm + m, 14) & pg7(mm + m, 15) & pg7(mm + m, 16) & pg7(mm + m, 17) & pg7(mm + m, 18) & pg7(mm + m, 19) & zz & px & zz & py & zz & pz Next m Next mm Close #10 Close #11 Close #12 Close #13 Close #14 Close #15 Close #16 Close #17 Next xx Close #24 Close #25 Close #26 Close #27 Close #28 ' randomly selects one of 20 for the pg0 file ' of external 'mates' Open "sept29-28" For Input As #28 ' change the limit 19 below and the 20 ' in the rpg variable below to match ' the xx limit at the beginning for < or > than 20 founding families For xx = 0 To 19 For mm = 0 To 364 Input #28, pg8(xx, mm) Next mm Next xx Close #28 Open "sept29-29" For Output As #29 For mm = 0 To 364 rpg = Int(Rnd * 20) pgd = pg8(rpg, mm) Write #29, pgd For k = 1 To 20 pg0(mm, k) = Mid(pgd, k, 1) Next k Next mm Close #29 ' core family generated using external input from 20 families Open "sept29-24" For Output As #24 Open "sept29-25" For Output As #25 Open "sept29-26" For Output As #26 Open "sept29-27" For Output As #27 count9 = 0 count8 = 0 Open "sept29-0" For Output As #10 Open "sept29-1" For Output As #11 Open "sept29-2" For Output As #12 Open "sept29-3" For Output As #13 Open "sept29-4" For Output As #14 Open "sept29-5" For Output As #15 Open "sept29-6" For Output As #16 Open "sept29-7" For Output As #17 ' generating adam and eve For m = 0 To 1 For k = 0 To 19 pg1(m, k) = pg0(m, k) Next k Write #11, pg1(m, 0) & pg1(m, 1) & pg1(m, 2) & pg1(m, 3) & pg1(m, 4) & pg1(m, 5) & pg1(m, 6) & pg1(m, 7) & pg1(m, 8) & pg1(m, 9) & pg1(m, 10) & pg1(m, 11) & pg1(m, 12) & pg1(m, 13) & pg1(m, 14) & pg1(m, 15) & pg1(m, 16) & pg1(m, 17) & pg1(m, 18) & pg1(m, 19) Next m ' first generation of 3 offspring ' 4 way random to select one of ' 2 alleles from adam and one of 2 from eve ' 3 times over For m = 0 To 2 For k = 0 To 18 Step 2 rr = Rnd pg2(m, k) = pg1(0, k) pg2(m, k + 1) = pg1(1, k) If rr < 0.75 Then pg2(m, k) = pg1(0, k) pg2(m, k + 1) = pg1(1, k + 1) End If If rr < 0.5 Then pg2(m, k) = pg1(0, k + 1) pg2(m, k + 1) = pg1(1, k) End If If rr < 0.25 Then pg2(m, k) = pg1(0, k + 1) pg2(m, k + 1) = pg1(1, k + 1) End If Next k ' directing pairs For j = 0 To 18 Step 2 If pg2(m, j + 1) < pg2(m, j) Then jjj = pg2(m, j) pg2(m, j) = pg2(m, j + 1) pg2(m, j + 1) = jjj End If Next j Write #12, pg2(m, 0) & pg2(m, 1) & pg2(m, 2) & pg2(m, 3) & pg2(m, 4) & pg2(m, 5) & pg2(m, 6) & pg2(m, 7) & pg2(m, 8) & pg2(m, 9) & pg2(m, 10) & pg2(m, 11) & pg2(m, 12) & pg2(m, 13) & pg2(m, 14) & pg2(m, 15) & pg2(m, 16) & pg2(m, 17) & pg2(m, 18) & pg2(m, 19) Next m ' second generation of 3 offspring of each pg2 parent ' 4 way random to select one of ' 2 alleles from each offsping and ' one of 2 from a random parent For mm = 0 To 6 Step 3 ' mm 1,2 or3 rd child For m = 0 To 2 ' m parent For k = 0 To 18 Step 2 rr = Rnd ' mm+m+2 (2 as 2 called up previously in pg0) pg3(mm + m, k) = pg0(m + 2, k) pg3(mm + m, k + 1) = pg2(m, k) If rr < 0.75 Then pg3(mm + m, k) = pg0(m + 2, k) pg3(mm + m, k + 1) = pg2(m, k + 1) End If If rr < 0.5 Then pg3(mm + m, k) = pg0(m + 2, k + 1) pg3(mm + m, k + 1) = pg2(m, k) End If If rr < 0.25 Then pg3(mm + m, k) = pg0(m + 2, k + 1) pg3(mm + m, k + 1) = pg2(m, k + 1) End If Next k ' directing pairs For j = 0 To 18 Step 2 If pg3(mm + m, j + 1) < pg3(mm + m, j) Then jjj = pg3(mm + m, j) pg3(mm + m, j) = pg3(mm + m, j + 1) pg3(mm + m, j + 1) = jjj End If Next j Write #13, pg3(mm + m, 0) & pg3(mm + m, 1) & pg3(mm + m, 2) & pg3(mm + m, 3) & pg3(mm + m, 4) & pg3(mm + m, 5) & pg3(mm + m, 6) & pg3(mm + m, 7) & pg3(mm + m, 8) & pg3(mm + m, 9) & pg3(mm + m, 10) & pg3(mm + m, 11) & pg3(mm + m, 12) & pg3(mm + m, 13) & pg3(mm + m, 14) & pg3(mm + m, 15) & pg3(mm + m, 16) & pg3(mm + m, 17) & pg3(mm + m, 18) & pg3(mm + m, 19) Next m Next mm ' third generation of 3 offspring of each pg3 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 18 Step 9 For m = 0 To 8 For k = 0 To 18 Step 2 rr = Rnd ' the + as first 2 + 3used previously pg4(mm + m, k) = pg0(m + 5, k) pg4(mm + m, k + 1) = pg3(m, k) If rr < 0.75 Then pg4(mm + m, k) = pg0(m + 5, k) pg4(mm + m, k + 1) = pg3(m, k + 1) End If If rr < 0.5 Then pg4(mm + m, k) = pg0(m + 5, k + 1) pg4(mm + m, k + 1) = pg3(m, k) End If If rr < 0.25 Then pg4(mm + m, k) = pg0(m + 5, k + 1) pg4(mm + m, k + 1) = pg3(m, k + 1) End If Next k ' cousin marriage on 27th mating rrr = Rnd * 6 If mm + m = 26 Then Write #24, mm + m, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) For k = 0 To 18 Step 2 rr = Rnd yy = 7 If rrr < 5 Then yy = 6 If rrr < 4 Then yy = 4 If rrr < 3 Then yy = 3 If rrr < 2 Then yy = 1 If rrr < 1 Then yy = 0 pg4(mm + m, k) = pg3(yy, k) pg4(mm + m, k + 1) = pg3(m, k) If rr < 0.75 Then pg4(mm + m, k) = pg3(yy, k) pg4(mm + m, k + 1) = pg3(m, k + 1) End If If rr < 0.5 Then pg4(mm + m, k) = pg3(yy, k + 1) pg4(mm + m, k + 1) = pg3(m, k) End If If rr < 0.25 Then pg4(mm + m, k) = pg3(yy, k + 1) pg4(mm + m, k + 1) = pg3(m, k + 1) End If Next k Write #24, mm + m, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg4(mm + m, j + 1) < pg4(mm + m, j) Then jjj = pg4(mm + m, j) pg4(mm + m, j) = pg4(mm + m, j + 1) pg4(mm + m, j + 1) = jjj End If Next j Write #14, pg4(mm + m, 0) & pg4(mm + m, 1) & pg4(mm + m, 2) & pg4(mm + m, 3) & pg4(mm + m, 4) & pg4(mm + m, 5) & pg4(mm + m, 6) & pg4(mm + m, 7) & pg4(mm + m, 8) & pg4(mm + m, 9) & pg4(mm + m, 10) & pg4(mm + m, 11) & pg4(mm + m, 12) & pg4(mm + m, 13) & pg4(mm + m, 14) & pg4(mm + m, 15) & pg4(mm + m, 16) & pg4(mm + m, 17) & pg4(mm + m, 18) & pg4(mm + m, 19) Next m Next mm ' fourth generation of 3 offspring of each pg4 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 54 Step 27 For m = 0 To 26 For k = 0 To 18 Step 2 rr = Rnd ' the +14 as first 2 +3+ 9 used previously pg5(mm + m, k) = pg0(m + 14, k) pg5(mm + m, k + 1) = pg4(m, k) If rr < 0.75 Then pg5(mm + m, k) = pg0(m + 14, k) pg5(mm + m, k + 1) = pg4(m, k + 1) End If If rr < 0.5 Then pg5(mm + m, k) = pg0(m + 14, k + 1) pg5(mm + m, k + 1) = pg4(m, k) End If If rr < 0.25 Then pg5(mm + m, k) = pg0(m + 14, k + 1) pg5(mm + m, k + 1) = pg4(m, k + 1) End If Next k ' cousin marriage on 40th mating rrr1 = Rnd * 6 rrr2 = Rnd * 6 If mm + m = 40 Or mm + m = 80 Then Write #25, mm + m, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) If mm + m = 40 Then rrr = rrr1 If mm + m = 40 Then rrr = rrr2 For k = 0 To 18 Step 2 rr = Rnd yy = 19 If rrr < 5 Then yy = 25 If rrr < 4 Then yy = 24 If rrr < 3 Then yy = 23 If rrr < 2 Then yy = 21 If rrr < 1 Then yy = 20 pg5(mm + m, k) = pg4(yy, k) pg5(mm + m, k + 1) = pg4(m, k) If rr < 0.75 Then pg5(mm + m, k) = pg4(yy, k) pg5(mm + m, k + 1) = pg4(m, k + 1) End If If rr < 0.5 Then pg5(mm + m, k) = pg4(yy, k + 1) pg5(mm + m, k + 1) = pg4(m, k) End If If rr < 0.25 Then pg5(mm + m, k) = pg4(yy, k + 1) pg5(mm + m, k + 1) = pg4(m, k + 1) End If Next k Write #25, mm + m, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg5(mm + m, j + 1) < pg5(mm + m, j) Then jjj = pg5(mm + m, j) pg5(mm + m, j) = pg5(mm + m, j + 1) pg5(mm + m, j + 1) = jjj End If Next j Write #15, pg5(mm + m, 0) & pg5(mm + m, 1) & pg5(mm + m, 2) & pg5(mm + m, 3) & pg5(mm + m, 4) & pg5(mm + m, 5) & pg5(mm + m, 6) & pg5(mm + m, 7) & pg5(mm + m, 8) & pg5(mm + m, 9) & pg5(mm + m, 10) & pg5(mm + m, 11) & pg5(mm + m, 12) & pg5(mm + m, 13) & pg5(mm + m, 14) & pg5(mm + m, 15) & pg5(mm + m, 16) & pg5(mm + m, 17) & pg5(mm + m, 18) & pg5(mm + m, 19) Next m Next mm ' fifth generation of 3 offspring of each pg5 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 162 Step 81 For m = 0 To 80 For k = 0 To 18 Step 2 rr = Rnd pg6(mm + m, k) = pg0(m + 41, k) pg6(mm + m, k + 1) = pg5(m, k) If rr < 0.75 Then pg6(mm + m, k) = pg0(m + 41, k) pg6(mm + m, k + 1) = pg5(m, k + 1) End If If rr < 0.5 Then pg6(mm + m, k) = pg0(m + 41, k + 1) pg6(mm + m, k + 1) = pg5(m, k) End If If rr < 0.25 Then pg6(mm + m, k) = pg0(m + 41, k + 1) pg6(mm + m, k + 1) = pg5(m, k + 1) End If Next k ' cousin marriage on 79th mating rrr = Rnd * 6 If m = 79 Then Write #26, mm + m, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) For k = 0 To 18 Step 2 rr = Rnd yy = 77 If rrr < 5 Then yy = 75 If rrr < 4 Then yy = 73 If rrr < 3 Then yy = 71 If rrr < 2 Then yy = 69 If rrr < 1 Then yy = 67 pg6(mm + m, k) = pg5(yy, k) pg6(mm + m, k + 1) = pg5(m, k) If rr < 0.75 Then pg6(mm + m, k) = pg5(yy, k) pg6(mm + m, k + 1) = pg5(m, k + 1) End If If rr < 0.5 Then pg6(mm + m, k) = pg5(yy, k + 1) pg6(mm + m, k + 1) = pg5(m, k) End If If rr < 0.25 Then pg6(mm + m, k) = pg5(yy, k + 1) pg6(mm + m, k + 1) = pg5(m, k + 1) End If Next k Write #26, mm + m, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg6(mm + m, j + 1) < pg6(mm + m, j) Then jjj = pg6(mm + m, j) pg6(mm + m, j) = pg6(mm + m, j + 1) pg6(mm + m, j + 1) = jjj End If Next j Write #16, pg6(mm + m, 0) & pg6(mm + m, 1) & pg6(mm + m, 2) & pg6(mm + m, 3) & pg6(mm + m, 4) & pg6(mm + m, 5) & pg6(mm + m, 6) & pg6(mm + m, 7) & pg6(mm + m, 8) & pg6(mm + m, 9) & pg6(mm + m, 10) & pg6(mm + m, 11) & pg6(mm + m, 12) & pg6(mm + m, 13) & pg6(mm + m, 14) & pg6(mm + m, 15) & pg6(mm + m, 16) & pg6(mm + m, 17) & pg6(mm + m, 18) & pg6(mm + m, 19) Next m Next mm ' sixth generation of 3 offspring of each pg6 parent ' 4 way random to select one of ' 2 alleles from each parent and ' 2 from a random parent For mm = 0 To 486 Step 243 For m = 0 To 242 For k = 0 To 18 Step 2 rr = Rnd pg7(mm + m, k) = pg0(m + 122, k) pg7(mm + m, k + 1) = pg6(m, k) If rr < 0.75 Then pg7(mm + m, k) = pg0(m + 122, k) pg7(mm + m, k + 1) = pg6(m, k + 1) End If If rr < 0.5 Then pg7(mm + m, k) = pg0(m + 122, k + 1) pg7(mm + m, k + 1) = pg6(m, k) End If If rr < 0.25 Then pg7(mm + m, k) = pg0(m + 122, k + 1) pg7(mm + m, k + 1) = pg6(m, k + 1) End If Next k ' cousin marriage on 79th mating rrr = Rnd * 6 If m = 79 Then Write #27, mm + m, pg7(mm + m, 0) & pg7(mm + m, 1) & pg7(mm + m, 2) & pg7(mm + m, 3) & pg7(mm + m, 4) & pg7(mm + m, 5) & pg7(mm + m, 6) & pg7(mm + m, 7) & pg7(mm + m, 8) & pg7(mm + m, 9) & pg7(mm + m, 10) & pg7(mm + m, 11) & pg7(mm + m, 12) & pg7(mm + m, 13) & pg7(mm + m, 14) & pg7(mm + m, 15) & pg7(mm + m, 16) & pg7(mm + m, 17) & pg7(mm + m, 18) & pg7(mm + m, 19) For k = 0 To 18 Step 2 rr = Rnd yy = 76 If rrr < 5 Then yy = 74 If rrr < 4 Then yy = 72 If rrr < 3 Then yy = 70 If rrr < 2 Then yy = 69 If rrr < 1 Then yy = 68 pg7(mm + m, k) = pg6(yy, k) pg7(mm + m, k + 1) = pg6(m, k) If rr < 0.75 Then pg7(mm + m, k) = pg6(yy, k) pg7(mm + m, k + 1) = pg6(m, k + 1) End If If rr < 0.5 Then pg7(mm + m, k) = pg6(yy, k + 1) pg7(mm + m, k + 1) = pg6(m, k) End If If rr < 0.25 Then pg7(mm + m, k) = pg6(yy, k + 1) pg7(mm + m, k + 1) = pg6(m, k + 1) End If Next k Write #27, mm + m, pg7(mm + m, 0) & pg7(mm + m, 1) & pg7(mm + m, 2) & pg7(mm + m, 3) & pg7(mm + m, 4) & pg7(mm + m, 5) & pg7(mm + m, 6) & pg7(mm + m, 7) & pg7(mm + m, 8) & pg7(mm + m, 9) & pg7(mm + m, 10) & pg7(mm + m, 11) & pg7(mm + m, 12) & pg7(mm + m, 13) & pg7(mm + m, 14) & pg7(mm + m, 15) & pg7(mm + m, 16) & pg7(mm + m, 17) & pg7(mm + m, 18) & pg7(mm + m, 19) End If ' directing pairs For j = 0 To 18 Step 2 If pg7(mm + m, j + 1) < pg7(mm + m, j) Then jjj = pg7(mm + m, j) pg7(mm + m, j) = pg7(mm + m, j + 1) pg7(mm + m, j + 1) = jjj End If Next j ' adds leading zeros to numbers less than 100 If tt < 10 Then px = "00" & Trim(Str(tt)) End If If tt > 9 And tt < 100 Then px = "0" & Trim(Str(tt)) End If If tt > 99 Then px = Trim(Str(tt)) End If If mm < 10 Then py = "00" & Trim(Str(mm)) End If If mm > 9 And mm < 100 Then py = "0" & Trim(Str(mm)) End If If mm > 99 Then py = Trim(Str(mm)) End If If m < 10 Then pz = "00" & Trim(Str(m)) End If If m > 9 And m < 100 Then pz = "0" & Trim(Str(m)) End If If m > 99 Then pz = Trim(Str(m)) End If ' ident added at the end of #17 file Write #17, pg7(mm + m, 0) & pg7(mm + m, 1) & pg7(mm + m, 2) & pg7(mm + m, 3) & pg7(mm + m, 4) & pg7(mm + m, 5) & pg7(mm + m, 6) & pg7(mm + m, 7) & pg7(mm + m, 8) & pg7(mm + m, 9) & pg7(mm + m, 10) & pg7(mm + m, 11) & pg7(mm + m, 12) & pg7(mm + m, 13) & pg7(mm + m, 14) & pg7(mm + m, 15) & pg7(mm + m, 16) & pg7(mm + m, 17) & pg7(mm + m, 18) & pg7(mm + m, 19) & zz & px & zz & py & zz & pz Next m Next mm Close #10 Close #11 Close #12 Close #13 Close #14 Close #15 Close #16 Close #17 ' sort contents of file sept29-7 Documents.Open FileName:="sept29-7", ConfirmConversions:=False, ReadOnly:= _ False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:= _ "", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", _ Format:=wdOpenFormatAuto Selection.Sort ExcludeHeader:=False, FieldNumber:="Paragraphs", _ SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending, _ FieldNumber2:="", SortFieldType2:=wdSortFieldAlphanumeric, SortOrder2:= _ wdSortOrderAscending, FieldNumber3:="", SortFieldType3:= _ wdSortFieldAlphanumeric, SortOrder3:=wdSortOrderAscending, Separator:= _ wdSortSeparateByTabs, SortColumn:=False, CaseSensitive:=False, LanguageID _ :=wdLanguageNone ActiveDocument.SaveAs FileName:="sept29-7.txt", FileFormat:=wdFormatText, _ LockComments:=False, Password:="", AddToRecentFiles:=True, WritePassword _ :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _ SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _ False ActiveWindow.Close ' Find matching pairs in 10 digits ' xxxx is count = xxxx = 729 bb$ = "0" count1 = 0 Open "sept29-7.txt" For Input As #1 ' for 10 matches xxxx = xxxx - 1 For x = 0 To xxxx Input #1, ps aa$ = Left(ps, 10) If aa$ = bb$ Then Write #2, ps, pps count1 = count1 + 1 End If bb$ = aa$ pps = ps Next x ' most write statements following are disabled If count1 > 0 Then ' Write #2, xx, count1 End If Close #1 Open "sept29-7.txt" For Input As #1 ' Find matching pairs in 12 digits bb$ = "0" count2 = 0 For x = 0 To xxxx Input #1, ps aa$ = Left(ps, 12) If aa$ = bb$ Then ' Write #2, "twelve", ps, pps count2 = count2 + 1 End If bb$ = aa$ pps = ps Next x If count2 > 0 Then ' Write #2, xx, count2 End If Close #1 Open "sept29-7.txt" For Input As #1 ' Find matching pairs in 14 digits bb$ = "0" count3 = 0 For x = 0 To xxxx Input #1, ps aa$ = Left(ps, 14) If aa$ = bb$ Then ' Write #2, ps count3 = count3 + 1 End If bb$ = aa$ Next x If count3 > 0 Then ' Write #2, xx, count3 End If Close #1 Open "sept29-7.txt" For Input As #1 ' Find matching pairs in 16 digits bb$ = "0" count4 = 0 For x = 0 To xxxx Input #1, ps aa$ = Left(ps, 16) If aa$ = bb$ Then ' Write #2, ps count4 = count4 + 1 End If bb$ = aa$ Next x If count4 > 0 Then ' Write #2, xx, count4 End If Close #1 Open "sept29-7.txt" For Input As #1 ' Find matching pairs in 18 digits bb$ = "0" count5 = 0 For x = 0 To xxxx Input #1, ps aa$ = Left(ps, 6) If aa$ = bb$ Then ' Write #2, ps count5 = count5 + 1 End If bb$ = aa$ Next x If count5 > 0 Then ' Write #2, xx, count5 End If Close #1 Open "sept29-7.txt" For Input As #1 ' Find matching pairs in 20 digits bb$ = "0" count6 = 0 For x = 0 To xxxx Input #1, ps aa$ = Left(ps, 8) If aa$ = bb$ Then ' Write #2, ps count6 = count6 + 1 End If bb$ = aa$ Next x If count6 > 0 Then ' Write #2, xx, count6 End If count1t = count1t + count1 count2t = count2t + count2 count3t = count3t + count3 count4t = count4t + count4 count5t = count5t + count5 count6t = count6t + count6 Close #1 Next tt Write #2, count1t, count2t, count3t, count4t,count5t, count6t Close #2 Close #24 Close #25 Close #26 ' counts of matches of single alleles over 10 Dim ca(20) Dim da(20) Dim ct(1000) Dim pt As String xxxx = count1t count1 = 0 count2 = 0 count3 = 0 count4 = 0 count5 = 0 count6 = 0 count7 = 0 count8 = 0 count9 = 0 count10 = 0 Open "sept29-7m.txt" For Input As #1 Open "sept29-7r.txt" For Output As #2 For x = 1 To xxxx Input #1, ps, pt For j = 11 To 20 ca(j) = Mid(ps, j, 1) da(j) = Mid(pt, j, 1) Next j ' figures at end of profiles are tt,mm and m - if m the same ,then siblings ' last 11 digits are idents e = Right(ps, 11) f = Right(pt, 11) ' last 3 digits are the same if siblings e2 = Right(ps, 3) f2 = Right(pt, 3) Count = 0 For j = 11 To 19 Step 2 flag = 0 If ca(j) = da(j) Or ca(j) = da(j + 1) Then Count = Count + 1 flag = flag + 1 End If If ca(j + 1) = da(j) Or ca(j + 1) = da(j + 1) Then Count = Count + 1 flag = flag + 1 ' dis-counting false additions concerning unfounded repeats End If If ca(j) = ca(j + 1) And da(j) <> da(j + 1) And flag = 2 Then Count = Count - 1 Next j If Count = 1 Then count1 = count1 + 1 If Count = 2 Then count2 = count2 + 1 If Count = 3 Then count3 = count3 + 1 If Count = 4 Then count4 = count4 + 1 If Count = 5 Then count5 = count5 + 1 If Count = 6 Then count6 = count6 + 1 If Count = 7 Then count7 = count7 + 1 If Count = 8 Then count8 = count8 + 1 If Count = 9 Then count9 = count9 + 1 If Count = 10 Then count10 = count10 + 1 ' count for first ten only match not recorded ' no diference in match data for adjascent lines of results ' differences only for 11 to 20 matches between suceeding lines Write #2, count1, count2, count3, count4, count5, count6, count7, count8, count9, count10, e, f If e2 <> f2 Then Write #2, " ** non-sib match ** ", e2, f2 End If Next x Close #1 Close #2
A simulation of a large DNA profile database
A simulation of DNA profile 'families'
A simulation of DNA profile families with consanguinity
Simulation of kinship
dnas.htm revisited with all alleles represented
dnas.htm revisited for >8 percent allele frequency subset (similar ancestry )
Simulation of Taiwanese Tao and Rukai populations to explore the effect of within and without ancestral clusters
Basques autochthonous DNA profiles simulation, 9 loci
Australian Capital Caucasian 9 loci simulation
Australian Capital Caucasian 9 loci simulation, >= 5% allele frequency
CODIS, 13 Loci Caucasian Simulation
Automating the macros
Exploring other DNA profile match scenarios
Suspect familial matching
Return to co-ancestry factor in the NDNAD simulations
144 random matches in 65,000 -- ONLY?
Background
'Peer review' of some of the dnapr.htm material

Powered by counter.bloke.com