Model Code Table of Contents Model Code Table of Contents 1 Instructions for Viewing Code 1 Code for Form 1 1 Private Sub Command1_Click() 1 Private Sub Picture1_DblClick() 2 Private Sub Picture2_DblClick() 2 Private Sub Picture3_DblClick() 2 Private Sub Picture5_DblClick() 3 Code for Module 1 3 Sub SurvInterceptAdjust() 4 Sub StepThroughParameter() 6 Sub MultipleRuns() 11 Sub ReadInputFiles() 11 Sub SOSPModel() 13 Sub SetTerritories() 14 Sub SetPairs() 15 Sub IndepPerFemale() 17 Sub ComputeFcoef() 20 Sub WinterSurvival() 21 Sub WinterSuvivalFlat() 26 Sub GeneticDemographicImmigration() 27 Sub MultiRunAverage() 43 Sub ExportSummary() 45 Sub ExportMultiRunSummary() 46 Function GetRandom(ByVal iLo As Long, ByVal iHi As Long) As Long 47 Instructions for Viewing Code The table of contents is hyperlinked in Microsoft Word to aid in navigating the code. Simply click on a heading in the table of contents to go to the heading in the text. Use the back arrows to return to the table of contents. Please also use the Document Map. Click the “View” menu, and then “Document Map”. Code for Form 1 Private Sub Command1_Click() Dim A As Double, B As Double, TotalTime As Double Form1.Command1.BackColor = &H808000 DoEvents If Form1.Check4.Value = Checked Then Randomize 'this seeds the rnd function off the timer so a dif series is generated each time!! Form1.Text9.Text = Val(Form1.Text11.Text) + Val(Form1.Text8.Text) - 1 'FinishAnalYear = AnalysisWindow(200 years) + StartAnalYear -1 NYrs = Val(Form1.Text9.Text) + Val(Form1.Text10.Text) + 1 'read in number of years to run model: FinishAnalYear + CorrelYrs (+1 for an extra buffer and to round off the number) Form1.Text1.Text = Val(NYrs) Form1.Text53.Text = Val(NYrs) Form1.Text54.Text = Val(NYrs) Form1.Text55.Text = Val(NYrs) A = Timer 'Timer records seconds since midnight If Form1.Check2.Value = Unchecked Then Call MultipleRuns ElseIf Form1.Check2.Value = Checked Then Call StepThroughParameter End If B = Timer If B > A Then 'an imperfect solution to the problem of trying to time past midnight: TotalTime = B - A ElseIf A >= B Then TotalTime = 24# * 60# * 60# - A + B End If Form1.Text5.Text = Val(TotalTime) Beep Beep Form1.Command1.BackColor = &HC0& End Sub Private Sub Picture1_DblClick() Form1.Picture1.Cls Form1.Picture2.Cls Form1.Picture3.Cls Form1.Picture5.Cls End Sub Private Sub Picture2_DblClick() Form1.Picture1.Cls Form1.Picture2.Cls Form1.Picture3.Cls Form1.Picture5.Cls End Sub Private Sub Picture3_DblClick() Form1.Picture1.Cls Form1.Picture2.Cls Form1.Picture3.Cls Form1.Picture5.Cls End Sub Private Sub Picture5_DblClick() Form1.Picture1.Cls Form1.Picture2.Cls Form1.Picture3.Cls Form1.Picture5.Cls End Sub Code for Module 1 Option Explicit 'forces variable declaration Option Base 1 'sets array to lable row 1 as row 1, unless alternate index specified Dim Y As Integer 'year counter Dim NYrs As Integer 'years to run model Dim YrSurvArray() As Double 'data for the year will be summarized here and written to a text file 'Year, BirdID, Sex, Fcoef, Age, IndepsProduced, RecruitsProduced, Catagory(floater=1,unpaired=2,paired=3), Survived?, Immigrant?, SireID, DamID Dim SummarySurvArray() As Double Dim SummaryYearArray() As Double 'Year, NMales, NFemales, NTerr, NPaired, NSingle, NFloater, NImmigrant, NIndependents, NRecruits, WinterStress Dim NPop As Integer 'population size (males + females in spring) Dim NMales As Integer 'number of males in spring Dim NTerr As Integer 'number territories Dim NFem As Integer 'number of females in spring Dim BreedArray() As Double 'FemBirdID, MaleBirdID, NInd, NRec (NRec does not get filled in) Dim PediArray() As Double 'BirdID by BirdID, Fcoef+1 along diagonal Dim NInd As Integer 'number of independents produced per year Dim BirdIDCounter As Double 'keep track of BirdID's assigned to independents Dim NImm As Integer 'number of immigrants each year Dim NImmFem As Integer 'number female immigrants Dim NImmMale As Integer 'number of male immigrants Dim AllYearsBirdCounter As Long 'counter for dimensioning SummarySurvArray (reset for multiple model runs) Dim ImmigArray() As Double 'BirdID, sex Dim Run As Integer 'counter for Runs Dim NRuns As Integer 'total number of Runs Dim NewNFem As Integer Dim MyArray() As Double 'for ColumnNMeanVarMaxMin function input Dim BasicStats() As Double 'for ColumnNMeanVarMaxMin function output Dim MultiRunStats() As Double Dim SmoothedYearArray() As Double Dim CorrelArray() As Double 'Correlogram: Year, r-value Dim CorrelYrs As Integer 'Scope of Correlogram Dim ExtinctionYear As Integer Dim SurvAgeSexEffect() As Double 'survival rates for truncation selection Dim IndDist() As Double 'Mandarte distribution of independents Dim FractionImmFem As Double 'fraction of immigrants female Dim FAveImm As Double 'average Fcoef of immigrants for the year Dim ParameterStepThrough() As Double 'output array to hold output of stepping through a parameter Dim MultiRunTrajectory() As Double 'output array to hold all the female trajectories for each run, given a step setting for a certain variable Dim StepThroughTrajectory() As Double 'output array which holds the female trajectory of the 1st run for each step setting of a certain variable Dim ParamValue As Double Dim PoissonArray() As Double 'Poisson Distribution for immigrants Dim Lambda As Double 'mean for Poisson Distribution of immigrants Dim ParamName As String 'name of parameter for Sub StepThroughParameter Dim SortedPopArray() As Double 'sorted female trajectory for determining 25, 50, 75 percentiles Dim FinalPopSizes() As Double 'final pop sizes at year 230 for each Parameter Step Dim FinalPopFreqDist() As Double Dim FinalPopCummDist() As Double 'for export - cummulative Dist of final pop sizes Dim FAveBreeders As Double 'average inbreeding level for breeding males and females Dim CorrelAverageArray() As Double 'average of correlogram outputs for each parameter stepp 'Dim LinReg() As Double 'for LinearRegression output 'Dim NIDReg As Integer 'number of times (runs) to calculate effective I.D.@F=.25 from SummarySurvArrays Dim InSurvInterceptAdjust As Integer Dim z As Integer 'step number for ParameterStepThrough Dim Q30 As Long, Q229 As Long, QExtinct As Long 'Row numbers indicating start and end of Analysis Window for SummarySurvArray Sub SurvInterceptAdjust() 'adjust survival rates for each age class. Dim SP As Double 'Precision of SurvInterceptAdjust subroutine Dim i1 As Integer, TrueNRuns As Integer, Iterations As Integer Dim Test1 As Integer, Test2 As Integer, Test3 As Integer, Test4 As Integer Dim Test5 As Integer, Test6 As Integer, Test7 As Integer, Test8 As Integer, Test9 As Integer Dim k0 As Long, k1 As Long, td As Double, t0 As Double, t1 As Double, q As Long Dim k2 As Long, k3 As Long, k4 As Long, t2 As Double, t3 As Double, t4 As Double InSurvInterceptAdjust = 1 TrueNRuns = Val(Form1.Text4.Text) 'record number of times to run model Form1.Text4.Text = 1 'set NRuns = 1 Run = 1 NRuns = 1 SP = 0.01 Iterations = 0 Do Test1 = 0 Test2 = 0 ExtinctionYear = 0 AllYearsBirdCounter = 0 'reset the size of the SummarySurvArray Q30 = 0: Q229 = 0: QExtinct = 0 Call SOSPModel 'Calculate Observed Average Survival Rates for Juv's and Age1 birds so that Surv 'intercepts for adults and juv's may be adjusted '1.Juv's: observed surv intercept = (average suvival rate) - (-0.0048)*(average number of females) '(Note that -0.0048 is the expected slope of the relationship: JuvSurv = -0.0048*NFem +0.06041 '2. FeMale Age 1's: Observed Surv = average of all survival rates for age 1 birds k0 = 0 k1 = 0 k2 = 0 k3 = 0 k4 = 0 td = 0 t0 = 0 t1 = 0 t2 = 0 t3 = 0 t4 = 0 For q = 1 To AllYearsBirdCounter 'loop through entire SummarySurvArray If SummarySurvArray(5, q) = 0 Then 'if age = 0 k0 = k0 + 1 t0 = t0 + SummarySurvArray(13, q) 'sum survival rates td = td + SummarySurvArray(15, q) 'sum female density ElseIf SummarySurvArray(3, q) = 1 And SummarySurvArray(5, q) = 1 Then 'if female and age = 1 k1 = k1 + 1 t1 = t1 + SummarySurvArray(13, q) 'sum surival rates ElseIf SummarySurvArray(3, q) = 1 And SummarySurvArray(5, q) = 2 Then 'if female and age = 2 k2 = k2 + 1 t2 = t2 + SummarySurvArray(13, q) 'sum surival rates ElseIf SummarySurvArray(3, q) = 1 And SummarySurvArray(5, q) = 3 Then 'if female and age = 3 k3 = k3 + 1 t3 = t3 + SummarySurvArray(13, q) 'sum surival rates ElseIf SummarySurvArray(3, q) = 1 And SummarySurvArray(5, q) >= 4 Then 'if female and age = 4+ k4 = k4 + 1 t4 = t4 + SummarySurvArray(13, q) 'sum surival rates End If Next q If k0 = 0 Then Form1.Text22.Text = Form1.Text36.Text - 0.011 ElseIf k0 > 0 Then Form1.Text22.Text = t0 / k0 + 0.0048 * (td / k0) 'Observed Juv Survival Rate Intercept (assume slope is still 0.0048) End If If k1 = 0 Then Form1.Text35.Text = Form1.Text37.Text - 0.011 ElseIf k1 > 0 Then Form1.Text35.Text = t1 / k1 'Observed FAge1 Suvival Rate End If If k2 = 0 Then Form1.Text41.Text = Form1.Text44.Text - 0.011 ElseIf k2 > 0 Then Form1.Text41.Text = t2 / k2 'Observed FAge2 Suvival Rate End If If k3 = 0 Then Form1.Text42.Text = Form1.Text45.Text - 0.011 'if no one in this age class lived, then say the observed rate was the prediced rate minus .011 so that another iteration occurs ElseIf k3 > 0 Then Form1.Text42.Text = t3 / k3 'Observed FAge3 Suvival Rate End If If k4 = 0 Then Form1.Text43.Text = Form1.Text46.Text - 0.011 ElseIf k4 > 0 Then Form1.Text43.Text = t4 / k4 'Observed FAge4+ Suvival Rate End If Form1.Text38.Text = Val(Form1.Text36.Text) - Val(Form1.Text22.Text) 'suggest adjustment for juv intercept (adjustment = expected - observed) Form1.Text39.Text = Val(Form1.Text37.Text) - Val(Form1.Text35.Text) 'suggest adjustment for adult intercept1 Form1.Text47.Text = Val(Form1.Text44.Text) - Val(Form1.Text41.Text) 'suggest adjustment for adult intercept2 Form1.Text48.Text = Val(Form1.Text45.Text) - Val(Form1.Text42.Text) 'suggest adjustment for adult intercept3 Form1.Text49.Text = Val(Form1.Text46.Text) - Val(Form1.Text43.Text) 'suggest adjustment for adult intercept4+ Form1.Text12.Text = Val(Form1.Text12.Text) + Val(Form1.Text38.Text) 'adjust juv intercept (Survival rate at NFem=0) Form1.Text16.Text = Val(Form1.Text16.Text) + Val(Form1.Text39.Text) 'adjust adult intercept (average survival rate)1 Form1.Text40.Text = Val(Form1.Text40.Text) + Val(Form1.Text47.Text) 'adjust adult intercept (average survival rate)2 Form1.Text50.Text = Val(Form1.Text50.Text) + Val(Form1.Text48.Text) 'adjust adult intercept (average survival rate)3 Form1.Text51.Text = Val(Form1.Text51.Text) + Val(Form1.Text49.Text) 'adjust adult intercept (average survival rate)4+ Iterations = Iterations + 1 If ((((Val(Form1.Text38.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text39.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text47.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text48.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text49.Text)) ^ 2) ^ 0.5) < SP) Then Test2 = 1 End If 'If (((((Val(Form1.Text38.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text39.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text47.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text48.Text)) ^ 2) ^ 0.5) < SP And (((Val(Form1.Text49.Text)) ^ 2) ^ 0.5) < SP) Or (Iterations > 14)) Then Test1 = 1 If Test2 = 1 Or Iterations >= 200 Then Test1 = 1 End If Loop Until Test1 = 1 'loop until absolute value of adjustments to surv intercepts are all less than 0.01, or 15 iterations have been done Form1.Text52.Text = Iterations Form1.Text4.Text = TrueNRuns 'reset NRuns to original level NRuns = TrueNRuns InSurvInterceptAdjust = 0 End Sub Sub StepThroughParameter() Dim Start As Double, Finish As Double, Stepp As Double, Nstepps As Integer Dim Outfile As String, i As Integer, j As Integer, w As Integer, k As Integer, m As Integer Dim Cumm As Integer, Sum As Double, k1 As Integer 'MaxFinalPop As Integer 'for Parameter X, step through from ___ to ___ with small step ___. 'compare mean of ___ (eg number of cycles, correlogram maxima, percent decline) 'versus parameter value. Output to Excel (could make a little graph on the form too. 'Randomize 'this seeds the rnd function off the timer so a dif series is generated each time!! Form1.Text9.Text = Val(Form1.Text11.Text) + Val(Form1.Text8.Text) - 1 'FinishAnalYear = AnalysisWindow(200 years) + StartAnalYear -1 NYrs = Val(Form1.Text9.Text) + Val(Form1.Text10.Text) + 1 'read in number of years to run model: FinishAnalYear + CorrelYrs (+1 for an extra buffer and to round off the number) Form1.Text1.Text = Val(NYrs) NRuns = Val(Form1.Text4.Text) 'read in number of times to run model CorrelYrs = Val(Form1.Text10.Text) 'read in scope of Correlogram in years - start with 30 years Start = Val(Form1.Text17.Text) Finish = Val(Form1.Text18.Text) Stepp = Val(Form1.Text19.Text) Nstepps = Round((Finish - Start) / Stepp, 0) + 1 ReDim ParameterStepThrough(54, Nstepps) ParamValue = Start ReDim StepThroughTrajectory(Nstepps + 1, NYrs) ReDim FinalPopSizes(Nstepps + 1, NRuns) ReDim FinalPopCummDist(Nstepps + 1, 131) ReDim CorrelAverageArray(Nstepps + 1, 0 To CorrelYrs) 'Set up for stepping through parameter: If Form1.Option4(0).Value = True Then 'number of immigrants Form1.Option7(4).Value = True 'set for Poisson Distribution of immigrants and vary the mean ParamName = "PoissonImmig" ElseIf Form1.Option4(1).Value = True Then 'Truncation Inflection Point ParamName = "FScaler,TruncSpread" ElseIf Form1.Option4(2).Value = True Then 'inbreeding depression in survival ParamName = "%I.D.(delta)" ElseIf Form1.Option4(3).Value = True Then 'Linear interaction strength fcoef*Wstress ParamName = "LinInteracStrength" ElseIf Form1.Option4(4).Value = True Then 'truncation Slope ParamName = "SPower,TruncInflPt" End If For z = 1 To Nstepps 'Select which the text box for the changing parameter value: If Form1.Option4(0).Value = True Then 'number of immigrants Form1.Text26.Text = ParamValue 'Set Lamdba for Poisson Dist of Immigrants ElseIf Form1.Option4(1).Value = True Then 'FScaler/TruncSpread Form1.Text15.Text = ParamValue 'set FScaler/TruncSpread ElseIf Form1.Option4(2).Value = True Then '%inbreeding depression in survival Form1.Text14.Text = ParamValue 'set inbreeding depression level ElseIf Form1.Option4(3).Value = True Then 'linear interaction strength fcoef*Wstress Form1.Text32.Text = ParamValue 'set interaction strength ElseIf Form1.Option4(4).Value = True Then 'truncation level Form1.Text21.Text = ParamValue 'set truncation slope End If Call MultipleRuns ParameterStepThrough(1, z) = ParamValue 'Lambda ParameterStepThrough(2, z) = MultiRunStats(3, 2) 'mean pop mean ParameterStepThrough(3, z) = MultiRunStats(4, 2) 'mean pop Variance ParameterStepThrough(4, z) = MultiRunStats(8, 2) 'mean period length ParameterStepThrough(5, z) = MultiRunStats(13, 2) 'mean % decline ParameterStepThrough(6, z) = MultiRunStats(18, 2) 'mean rate of decline ParameterStepThrough(7, z) = MultiRunStats(25, 1) / NRuns '% of runs crashed ParameterStepThrough(8, z) = MultiRunStats(6, 2) 'mean pop min ParameterStepThrough(9, z) = MultiRunStats(27, 2) 'mean 25th percentile ParameterStepThrough(10, z) = MultiRunStats(28, 2) 'mean pop median (50th percentile) ParameterStepThrough(11, z) = MultiRunStats(29, 2) 'mean 75th percentile ParameterStepThrough(12, z) = MultiRunStats(5, 2) 'mean pop max ParameterStepThrough(13, z) = MultiRunStats(30, 2) 'mean(absolute value of)SmallScale ParameterStepThrough(14, z) = Val(Form1.Text12.Text) 'Juv Survival Intercept at NFem = 0 ParameterStepThrough(15, z) = Val(Form1.Text16.Text) 'Adult Survival Intercept Age1 ParameterStepThrough(16, z) = Val(Form1.Text40.Text) 'Adult Survival Intercept Age2 ParameterStepThrough(17, z) = Val(Form1.Text50.Text) 'Adult Survival Intercept Age3 ParameterStepThrough(18, z) = Val(Form1.Text51.Text) 'Adult Survival Intercept Age4+ ParameterStepThrough(19, z) = Val(Form1.Text52.Text) 'Number of Iterations required to adjust survival intercepts ParameterStepThrough(20, z) = MultiRunStats(31, 2) 'mean average FAveAfterWinter (doesn't include immigrants) ParameterStepThrough(21, z) = MultiRunStats(32, 2) 'mean variance FAveAfterWinter ParameterStepThrough(22, z) = MultiRunStats(33, 2) 'mean max FAveAfterWinter ParameterStepThrough(23, z) = MultiRunStats(34, 2) 'mean AverageFAveFall-FAveAfterWinter ParameterStepThrough(24, z) = MultiRunStats(35, 2) 'mean VarianceFAveFall-FAveAfterWinter ParameterStepThrough(25, z) = MultiRunStats(36, 2) 'mean MaxFAveFall-FAveAfterWinter ParameterStepThrough(26, z) = MultiRunStats(37, 2) 'mean FAveFall ParameterStepThrough(27, z) = MultiRunStats(38, 2) 'mean average surv F=0 (Wo) ParameterStepThrough(28, z) = MultiRunStats(39, 2) 'mean average surv F=0.125 (Wi1) ParameterStepThrough(29, z) = MultiRunStats(40, 2) 'mean average surv F=0.25 (Wi2) If MultiRunStats(38, 2) = 0 Or MultiRunStats(38, 2) = 9999999999# Then 'if Wo=0 or nothing then can't calculate %ID or B ParameterStepThrough(30, z) = 9999999999# '%ID for F=0.125 (1-Wi/Wo) ParameterStepThrough(31, z) = 9999999999# '%ID for F=0.25 ParameterStepThrough(32, z) = 9999999999# 'B for F=0.125 (B=-ln(Wi1/Wo)/.125) ParameterStepThrough(33, z) = 9999999999# 'B for F=0.25 (B=-ln(Wi2/Wo)/.25) ElseIf MultiRunStats(38, 2) <> 0 And MultiRunStats(38, 2) <> 9999999999# Then If MultiRunStats(39, 2) = 0 Then 'if there were F=0.125 birds, but survival rates averaged zero ParameterStepThrough(30, z) = 1 - MultiRunStats(39, 2) / MultiRunStats(38, 2) '%ID for F=0.125 (1-Wi/Wo) ParameterStepThrough(32, z) = 9999999999# 'B for F=0.125 (B=-ln(Wi1/Wo)/.125) 'can't calculate B ElseIf MultiRunStats(39, 2) <> 0 And MultiRunStats(39, 2) < 9999999999# Then ParameterStepThrough(30, z) = 1 - MultiRunStats(39, 2) / MultiRunStats(38, 2) '%ID for F=0.125 (1-Wi/Wo) ParameterStepThrough(32, z) = -Log(MultiRunStats(39, 2) / MultiRunStats(38, 2)) / 0.125 'B for F=0.125 (B=-ln(Wi1/Wo)/.125) ElseIf MultiRunStats(39, 2) = 9999999999# Then 'if there were no F=0.125 birds ParameterStepThrough(30, z) = 9999999999# '%ID for F=0.125 (1-Wi/Wo) ParameterStepThrough(32, z) = 9999999999# 'B for F=0.125 (B=-ln(Wi1/Wo)/.125) End If If MultiRunStats(40, 2) = 0 Then ParameterStepThrough(31, z) = 1 - MultiRunStats(40, 2) / MultiRunStats(38, 2) '%ID for F=0.25 ParameterStepThrough(33, z) = 9999999999# 'B for F=0.25 (B=-ln(Wi2/Wo)/.25) ElseIf MultiRunStats(40, 2) <> 0 And MultiRunStats(40, 2) < 9999999999# Then ParameterStepThrough(31, z) = 1 - MultiRunStats(40, 2) / MultiRunStats(38, 2) '%ID for F=0.25 ParameterStepThrough(33, z) = -Log(MultiRunStats(40, 2) / MultiRunStats(38, 2)) / 0.25 'B for F=0.25 (B=-ln(Wi2/Wo)/.25) ElseIf MultiRunStats(40, 2) = 9999999999# Then ParameterStepThrough(31, z) = 9999999999# '%ID for F=0.25 ParameterStepThrough(33, z) = 9999999999# 'B for F=0.25 (B=-ln(Wi2/Wo)/.25) End If End If If MultiRunStats(4, 2) <> 9999999999# And MultiRunStats(3, 2) <> 9999999999# Then ParameterStepThrough(34, z) = ((MultiRunStats(4, 2)) ^ 0.5) / MultiRunStats(3, 2) 'coefficient of variation ((Var)^.5/mean) ElseIf MultiRunStats(4, 2) = 9999999999# Or MultiRunStats(3, 2) = 9999999999# Then ParameterStepThrough(34, z) = 9999999999# 'coefficient of variation ((Var)^.5/mean) End If ParameterStepThrough(37, z) = MultiRunStats(13, 3) 'variance, % Decline ParameterStepThrough(38, z) = MultiRunStats(8, 3) 'variance, Period Length ParameterStepThrough(39, z) = MultiRunStats(54, 2) 'mean, AveNPerFem ParameterStepThrough(40, z) = MultiRunStats(55, 2) 'mean, AveIndPerFem ParameterStepThrough(41, z) = MultiRunStats(56, 2) 'mean, InterceptIndPerFem ParameterStepThrough(42, z) = MultiRunStats(41, 2) 'mean, Age 0 male survival rate ParameterStepThrough(43, z) = MultiRunStats(42, 2) 'mean, Age 1 male survival rate ParameterStepThrough(44, z) = MultiRunStats(43, 2) 'mean, Age 2 male survival rate ParameterStepThrough(45, z) = MultiRunStats(44, 2) 'mean, Age 3 male survival rate ParameterStepThrough(46, z) = MultiRunStats(45, 2) 'mean, Age 4+ male survival rate ParameterStepThrough(47, z) = MultiRunStats(46, 2) 'mean, Age 0 female survival rate ParameterStepThrough(48, z) = MultiRunStats(47, 2) 'mean, Age 1 female survival rate ParameterStepThrough(49, z) = MultiRunStats(48, 2) 'mean, Age 2 female survival rate ParameterStepThrough(50, z) = MultiRunStats(49, 2) 'mean, Age 3 female survival rate ParameterStepThrough(51, z) = MultiRunStats(50, 2) 'mean, Age 4+ female survival rate ParameterStepThrough(52, z) = MultiRunStats(57, 2) 'mean, DD (NFem=0) Intercept Age 0 male survival rate ParameterStepThrough(53, z) = MultiRunStats(58, 2) 'mean, DD (NFem=0) Intercept Age 0 female survival rate ParameterStepThrough(54, z) = MultiRunStats(59, 2) 'mean, Average number of independents produced per year 'add average correlogram values to CorrelAverageArray For j = 0 To CorrelYrs 'loop through all offset/lag values in CorrelArray If z = 1 Then 'enter row headings (z goes from 1 to Nstepps) CorrelAverageArray(1, j) = j 'enter the offset/lag value as row headings End If k1 = 0 'counter Sum = 0 For w = 1 To NRuns 'calculate average r-value for all runs at that offset value If CorrelArray(w + 1, j) <> 9999999999# Then k1 = k1 + 1 Sum = CorrelArray(w + 1, j) + Sum End If Next w If k1 > 0 Then CorrelAverageArray(z + 1, j) = Sum / k1 'average r-value over all runs ElseIf k1 = 0 Then CorrelAverageArray(z + 1, j) = 9999999999# End If Next j For w = 1 To NYrs If z = 1 Then StepThroughTrajectory(1, w) = w 'enter year StepThroughTrajectory(1 + z, w) = MultiRunTrajectory(2, w) 'copy 1st trajectory for each Parameter value Next w For w = 1 To NRuns If z = 1 Then FinalPopSizes(1, w) = w 'enter run 'If w = 1 Then FinalPopSizes(z + 1, 0) = MultiRunStats(26, 4) 'record max final pop FinalPopSizes(1 + z, w) = MultiRunStats(26, w + 5) 'copy final pop sizes for each Parameter value Next w ParamValue = ParamValue + Stepp 'set parameter value for runs in next loop through Next z 'z is step number 'make FinalPopCummDist: For i = 1 To Nstepps 'loop through columns FinalPopSizes to determine FinalPopFreqDist 'MaxFinalPop = FinalPopSizes(i + 1, 0) Cumm = 0 'get max final pop For m = 0 To 130 'loop through potential final sizes k = 0 'counter for number of runs with each final size For j = 1 To NRuns 'loop through rows of FinalPopSizes If FinalPopSizes(i + 1, j) = m Then k = k + 1 'count Next j Cumm = Cumm + k If i = 1 Then FinalPopCummDist(1, m + 1) = m 'enter pop sizes being counted FinalPopCummDist(i + 1, m + 1) = Cumm 'enter count Next m Next i Outfile = CurDir + "\" + "Output" + "\" + "1FinalPopCummDist" & ParamName & ".csv" Open Outfile For Output As 7 Write #7, "FinalPopulationSize", ParamName & "-" & Format(Start, "0.000"), ParamName & "-" & Format(Start + Stepp, "0.000"), ParamName & "-" & Format(Start + 2 * Stepp, "0.000"), ParamName & "-" & Format(Start + 3 * Stepp, "0.000") For i = 1 To 131 'row For j = 1 To (Nstepps + 1) 'column Write #7, FinalPopCummDist(j, i); Next j Write #7, Next i Close 7 Outfile = CurDir + "\" + "Output" + "\" + "1ParmeterStepThrough" & ParamName & ".csv" Open Outfile For Output As 5 Write #5, ParamName, "MeanPopMean", "MeanPopVar", "MeanPeriodLength", "Mean%Decline", "MeanRateOfDecline", "%RunsCrashed", "MeanPopMin", "Mean25thPercentile", "MeanPopMedian", "Mean75thPercentile", "MeanPopMax", "MeanSmallScale", "JuvIntercept", "MAge1Intercept", "MAge2Intercept", "MAge3Intercept", "MAge4+Intercept", "IterationsRequired", "AveFAveAfterWinter", "AveVarFAveAfterWinter", "AveMaxFAveAfterWinter", "AveFaveFall-AfterWinter", "AveVarFAveFall-AfterWinter", "MaxFAveFall-AfterWinter", "AveFAveFall", "WoMeanAveSurvF=0", "Wi1MeanAveSurvF=0.125", "Wi2MeanAveSurvF=0.25", "%IDF=0.125", "%IDF=0.25", "B F=0.125", "B F=0.25", "CoefVar", "StressInflPtF=0.03125", "StressInflPtF=0.25", "Var%Decline", "VarPeriodLength", "AveNFem", "AveIndPerFem", "InterceptIndPerFem", "SurvM0", "SurvM1", "SurvM2", "SurvM3", "SurvM4+", "SurvF0", "SurvF1", "SurvF2", "SurvF3", "SurvF4+", "InterceptSurvM0", "InterceptSurvF0", "AveIndPerYear" For i = 1 To Nstepps 'row For j = 1 To 53 'column Write #5, ParameterStepThrough(j, i); Next j Write #5, Next i Close 5 Outfile = CurDir + "\" + "Output" + "\" + "1StepThroughTrajectory" & ".csv" Open Outfile For Output As 6 Write #6, "Year", ParamName & "-" & Format(Start, "0.000"), ParamName & "-" & Format(Start + Stepp, "0.000"), ParamName & "-" & Format(Start + 2 * Stepp, "0.000"), ParamName & "-" & Format(Start + 3 * Stepp, "0.000") For i = 1 To NYrs 'row For j = 1 To Nstepps + 1 'column Write #6, StepThroughTrajectory(j, i); Next j Write #6, Next i Close 6 Outfile = CurDir + "\" + "Output" + "\" + "1CorrelAverageArray" & ".csv" Open Outfile For Output As 7 Write #7, "Lag", ParamName & "-" & Format(Start, "0.000"), ParamName & "-" & Format(Start + Stepp, "0.000"), ParamName & "-" & Format(Start + 2 * Stepp, "0.000"), ParamName & "-" & Format(Start + 3 * Stepp, "0.000") For i = 0 To CorrelYrs 'row For j = 1 To Nstepps + 1 'column Write #7, CorrelAverageArray(j, i); Next j Write #7, Next i Close 7 End Sub 'I will use a 'column,row' protocol for arrays so I can redim and change number of rows. '(One can only redimension the last dimension of arrays.) Sub MultipleRuns() Dim i As Integer, j As Integer Form1.Text9.Text = Val(Form1.Text11.Text) + Val(Form1.Text8.Text) - 1 'FinishAnalYear = AnalysisWindow(200 years) + StartAnalYear -1 NYrs = Val(Form1.Text9.Text) + Val(Form1.Text10.Text) + 1 'read in number of years to run model: FinishAnalYear + CorrelYrs (+1 for an extra buffer and to round off the number) Form1.Text1.Text = Val(NYrs) NRuns = Val(Form1.Text4.Text) 'read in number of times to run model CorrelYrs = Val(Form1.Text10.Text) 'read in scope of Correlogram in years - start with 30 years ReDim MultiRunTrajectory(NRuns + 1, NYrs) ReDim MultiRunStats(59, 5 + NRuns) ReDim CorrelArray(NRuns + 1, 0 To CorrelYrs) 'Year, r-value for run1, run2 . . . Nruns, for 30 years Call ReadInputFiles 'read input files some setting information If Form1.Option7(4).Value = True Then Call PoissonDistribution 'calculate a cummulative poisson distribution If Form1.Check6.Value = Checked Then Call SurvInterceptAdjust 'adjust survival rates for each age class 'fill MultiRunStats and CorrelArray with 9999999999's, instead of zeros, so that crashed runs are not counted For i = 1 To 59 'columns For j = 1 To (5 + NRuns) 'rows MultiRunStats(i, j) = 9999999999# Next j Next i For i = 1 To (NRuns + 1) 'columns For j = 0 To CorrelYrs 'rows CorrelArray(i, j) = 9999999999# Next j Next i For Run = 1 To NRuns ExtinctionYear = 0 AllYearsBirdCounter = 0 'reset the size of the SummarySurvArray Q30 = 0: Q229 = 0: QExtinct = 0 Call SOSPModel Next Run If NRuns > 1 Then Call MultiRunAverage Call ExportMultiRunSummary End If End Sub Sub ReadInputFiles() Dim i As Integer, InitFile As String, junk As String 'if variance in SRS is check on Form1, then read in variance If Form1.Check3.Value = Checked Then 'variance in SRS ReDim IndDist(7, 13) If Form1.Option3(0).Value = True Then 'Ind = fx(female age, density) - no fcoef effect on SRS i = 1 InitFile = CurDir + "\IndDist(dens,age).txt" Open InitFile For Input As 1 Line Input #1, junk For i = 1 To 13 Input #1, IndDist(1, i), IndDist(2, i), IndDist(3, i), IndDist(4, i), IndDist(5, i), IndDist(6, i), IndDist(7, i) 'WinterStress is Column 1, Cummulative Distribution in Column 2 Next i Close 1 ElseIf Form1.Option3(1).Value = True Then 'Ind = fx(female fcoef, age, density) - inbreeding depression in SRS ReDim IndDist(7, 13) i = 1 InitFile = CurDir + "\IndDist(fcoef,dens,age).txt" Open InitFile For Input As 2 Line Input #2, junk For i = 1 To 13 Input #2, IndDist(1, i), IndDist(2, i), IndDist(3, i), IndDist(4, i), IndDist(5, i), IndDist(6, i), IndDist(7, i) 'WinterStress is Column 1, Cummulative Distribution in Column 2 Next i Close 2 End If End If 'read survival rates for adults If Form1.Option2(1).Value = True Then ReDim SurvAgeSexEffect(3, 6) i = 1 InitFile = CurDir + "\SurvAllYrs4Plus.txt" 'these survival rates are from \Thesis\SurvHazardsModel\SurvHazSummary.xls worksheet EmpiracleSrvRate1-28bySexAge5+ Open InitFile For Input As 1 Line Input #1, junk 'Line Input #1, junk For i = 1 To 4 Input #1, SurvAgeSexEffect(1, i), SurvAgeSexEffect(2, i), SurvAgeSexEffect(3, i) 'Age is Column 1,FemSurvAllYrsAge4+ in Column 2, MaleSurvAllYrsAge4+ in Column 3 Next i Close 1 End If End Sub Sub PoissonDistribution() 'create PoissonArray for specified Lambda ReDim PoissonArray(3, 0 To 50) 'integer, probability, cummulative probability Dim i As Integer, j As Integer, Excl As Double, Cumm As Double, k As Integer Lambda = Val(Form1.Text26.Text) For i = 0 To 50 'calculate probablitities of each integer value from 0 to 50 immigrants If i = 0 Then Excl = 1 ' Excl is i factorial ElseIf i <> 0 Then Excl = 1 For j = 1 To i Excl = Excl * j Next j End If PoissonArray(1, i) = i 'integer PoissonArray(2, i) = (Lambda ^ i / (Excl)) * Exp(-Lambda) 'probablity of that many immigrants Cumm = 0 'cummulative distribution For j = 0 To i Cumm = PoissonArray(2, j) + Cumm Next j PoissonArray(3, i) = Cumm Next i End Sub Sub SOSPModel() Call ReadInitPedigree For Y = 0 To NYrs Call SetTerritories 'count males and determine number of territories If NMales <= 0 Then QExtinct = AllYearsBirdCounter Exit For 'if population crashed in previous year, go to GraphIt End If Call SetPairs 'fill BreedArray Call IndepPerFemale 'determines independents per female & assigns paternity assuming no EPF's Call ComputeFcoef 'determine inbreeding level of independent young Call WinterSurvival 'determine survival based on sex, age, fcoef, and winter badness Call Summarize 'add the data for the year to SummarySurvArray and SummaryYearArray Call GeneticDemographicImmigration 'determine number of immigrants, and whether they contribute genes and/or bodies Call Condense 'Condense SurvArray's , BreedArray, PediArray - eliminated empty rows and columns If NewNFem <= 0 Then QExtinct = AllYearsBirdCounter Exit For 'if population crashed, go to GraphIt End If Next Y If InSurvInterceptAdjust = 0 Then 'If the run was adjusting the survival rates, don't bother analysing, graphing or exporting Call AnalyseRun If Run = 1 Then Call GraphIt 'graph data in SummaryYearArray End If Call ExportSummary 'export summary arrays to text files End If End Sub Sub ReadInitPedigree() 'read in initial pedigree of variable size (but no more than 100 birds) from a tab delim file 'Sex: 1=female, 2=male 'There must be a ' 0 0 0 0' under the last line of input to indicate that the initial input is finished 'all birds are assumed to be outbred (fcoef=0) initially Dim junk As String, InitFile As String, i As Double ReDim YrSurvArray(15, 100) 'Year, BirdID, Sex, Fcoef, Age . . . i = 1 InitFile = CurDir + "\initpedi.txt" Open InitFile For Input As 1 Line Input #1, junk Do Input #1, YrSurvArray(2, i), YrSurvArray(3, i), YrSurvArray(4, i), YrSurvArray(5, i) YrSurvArray(1, i) = 0 'input Year=0 for first year i = i + 1 If i >= 101 Then MsgBox ("Initial population cannot exceed 100 birds!") Loop Until YrSurvArray(2, i - 1) = 0 Close 1 NPop = i - 2 Form1.Text3.Text = Val(NPop) ReDim Preserve YrSurvArray(15, NPop) BirdIDCounter = YrSurvArray(2, NPop) NFem = 0 'count number of females so that BreedArray can be initialized For i = 1 To NPop If YrSurvArray(3, i) = 1 Then NFem = NFem + 1 Next i ReDim BreedArray(6, NFem) ReDim PediArray(0 To 1050, 0 To 1050) 'dim to max expected # of adults plus independents in August For i = 1 To NPop 'initialize the Pedigree array PediArray(0, i) = YrSurvArray(2, i) 'BirdID PediArray(i, 0) = YrSurvArray(2, i) ' BirdID PediArray(i, i) = 1 'Fcoef = 0 for all birds to start Next i NImm = 0 'assume no immigrants in 1st year ReDim SummaryYearArray(40, 0 To NYrs) 'summary for each run of the model over all years ReDim SummarySurvArray(15, 1) 'Dimension SummarySurvArray to avoid errors in Export if all birds die in 1st year End Sub Sub SetTerritories() Dim i As Integer, SurvHolders As Integer, AvailTerrs As Integer, k As Integer NMales = 0 'count number of males and surviving territory holders For i = 1 To NPop If YrSurvArray(3, i) = 2 Then NMales = NMales + 1 'count males If (YrSurvArray(8, i) = 2 Or YrSurvArray(8, i) = 3) Then SurvHolders = SurvHolders + 1 'count surviving holders End If Next i If NMales <= 0 Then MultiRunStats(25, 5 + Run) = Y 'write year crashed to MultiRunStats ExtinctionYear = Y 'record the year of the crash Exit Sub 'exits out to Sub SOSPModel and then to GraphIt End If 'NTerr = Round(0.826 * NMales, 0) 'set number of territories (could add variance) 'Beverton-Holt curve for territory number - slightly better fit than straight line, gives one extra territory at low density NTerr = Round(((0.97896 * NMales) / (1 + 0.0027112 * NMales)), 0) 'set number of territories (could add variance) AvailTerrs = NTerr - SurvHolders '# available territories = #territories - #SurvivingHolders k = 0 For i = 1 To NPop 'indicate which males get territories in the YrSurvArray If k < AvailTerrs Then If (YrSurvArray(3, i) = 2) And (YrSurvArray(8, i) < 2) Then YrSurvArray(8, i) = 2 'if he was a Floater or a Juv/recruit then he becomes Holder(Unpaired) k = k + 1 'count how many Available Territories have been filled End If End If Next i End Sub Sub SetPairs() Dim i As Integer, j As Integer, k As Integer, l As Integer, UBd As Integer Dim NFloater As Integer, NSingleHolder As Integer, NPairedHolder As Integer, q As Integer '1. bring in surviving birds from last year's BreedArray (they will be there after Sub Condense) '2. add females to empty spots on the BreedArray '3. add males to empty spots on the BreedArray, 'Note: Currently old birds have the advantage w.r.t. getting territories and polygamy ' Old birds retain territories until they die and are 1st to get females ' Later assignment could be made random to see if this causes in the inbreeding structure or population stability l = 1 '2. add females to empty spots on the BreedArray For j = 1 To NFem 'loop through BreedArray If BreedArray(1, j) = 0 Then 'if there is an empty female spot in the BreedArray For k = l To NPop 'loop through YrSurvArray If ((YrSurvArray(3, k) = 1) And (YrSurvArray(8, k) <> 3)) Then 'scan the YrSurvArray till you come to a female who was not on the BreedArray last year (ie was not Paired) BreedArray(1, j) = YrSurvArray(2, k) 'and put that female into the empty spot BreedArray(5, j) = YrSurvArray(4, k) 'bring female Fcoef to BreedArray BreedArray(6, j) = YrSurvArray(5, k) 'bring female Age to BreedArray YrSurvArray(8, k) = 3 'update Catagory to show female is Paired l = k + 1 'next time we will start part way through the YrSurvArray Exit For 'k = NPop 'you found a female, so get out of the YrSurvArray loop and go back to the next row on the BreedArray End If Next k End If Next j If NFem < NTerr Then 'loop through smaller dimension to prevent script out of bound errors q = NFem ElseIf NFem >= NTerr Then q = NTerr End If l = 1 '3. add males to empty spots on the BreedArray For j = 1 To q If BreedArray(2, j) = 0 Then 'if there is an empty male spot in the BreedArray For k = l To NPop If YrSurvArray(3, k) = 2 And YrSurvArray(8, k) <> 3 Then 'scan the YrSurvArray till you come to a male who was not on the BreedArray last year (ie was not Paired) BreedArray(2, j) = YrSurvArray(2, k) 'and put that male into the empty spot YrSurvArray(8, k) = 3 'update Catagory to show male is Paired l = k + 1 'next time we will start part way through the YrSurvArray Exit For 'k = NPop 'you found a male, so get out of the YrSurvArray loop and go back to the next row on the BreedArray End If Next k End If Next j If NFem > NTerr Then 'if there are more females than males Holders, senior males get 2 females l = 1 '3. add males to empty spots on the BreedArray, For j = NTerr To NFem If BreedArray(2, j) = 0 Then 'if there is an empty male spot in the BreedArray For k = l To NPop If YrSurvArray(3, k) = 2 Then 'scan the YrSurvArray till you come to a male who was not on the BreedArray last year (ie was not Paired) BreedArray(2, j) = YrSurvArray(2, k) 'and put that male into the empty spot 'YrSurvArray(8, k) = 3 'update Catagory to show male is Paired l = k + 1 'next time we will start part way through the YrSurvArray Exit For 'k = NPop 'you found a male, so get out of the YrSurvArray loop and go back to the next row on the BreedArray End If Next k End If Next j End If 'go back through breedarray to look for males who remained on the breedarray, but didn't get a female 'then change their status in the YrSurvArray to singleholder(2) For i = 1 To NPop k = 0 If YrSurvArray(3, i) = 2 And YrSurvArray(8, i) = 3 Then 'look at all male 'paired holders' For j = 1 To NFem If BreedArray(2, j) = YrSurvArray(2, i) Then 'if BirdID's match in breedarray k = k + 1 'no problem End If Next j If k = 0 Then YrSurvArray(8, i) = 2 'if the bird wasn't in the breedarray, reduce its status/catagory to singleholder End If Next i 'Summarize Male Category (juv=0, floater=1, unpaired holder=2, paired holder=3 NFloater = 0 NSingleHolder = 0 NPairedHolder = 0 For i = 1 To NPop If YrSurvArray(3, i) = 2 Then 'if male If YrSurvArray(8, i) = 0 Then YrSurvArray(8, i) = 1 'update Juv's to Floaters If YrSurvArray(8, i) = 1 Then 'count floaters NFloater = NFloater + 1 ElseIf YrSurvArray(8, i) = 2 Then NSingleHolder = NSingleHolder + 1 'count unpaired Holders ElseIf YrSurvArray(8, i) = 3 Then NPairedHolder = NPairedHolder + 1 'count paired Holders End If End If Next i 'calculate FAveBreeders FAveBreeders = 0 k = 0 For i = 1 To NPop If YrSurvArray(8, i) = 3 Then 'if paired and a breeder FAveBreeders = YrSurvArray(4, i) + FAveBreeders k = k + 1 End If Next i FAveBreeders = FAveBreeders / k SummaryYearArray(1, Y) = Y SummaryYearArray(2, Y) = NMales SummaryYearArray(3, Y) = NFem SummaryYearArray(4, Y) = NTerr SummaryYearArray(5, Y) = NPairedHolder SummaryYearArray(6, Y) = NSingleHolder SummaryYearArray(7, Y) = NFloater SummaryYearArray(8, Y) = NImm SummaryYearArray(15, Y) = NImmFem SummaryYearArray(16, Y) = NImmMale SummaryYearArray(17, Y) = FAveImm SummaryYearArray(19, Y) = FAveBreeders End Sub Sub IndepPerFemale() Dim IndPred As Integer, i As Integer, AgeEffect As Double, Rd As Double, j As Integer Dim k As Integer, l As Integer, FactorRmax As Double, FactorK As Double FactorRmax = Val(Form1.Text31.Text) 'factor for increasing intercept (rate of reproduction at female density of zero) FactorK = Val(Form1.Text56.Text) 'factor of adjusting the carrying capacity (value at which reproduction declines to zero) 'include whether female is an immigrant in GLM to predict # ind young? - not significant P = 0.9944! 'it appears that density dependence in production of independents is necessary to cap population If Form1.Option3(0).Value = True Then 'Ind = fx(female age, density) - no effect of inbreeding on SRS 'from "MyDocuments\THESIS\SOSP Model\ not code \Ind per fem=fx(age, dens).xls" For i = 1 To NFem 'loop through BreedArray to assign number of independent young If BreedArray(6, i) = 1 Then 'determine age effect with age as catagorical variable'parameters are from Proc Reg, years 1982 to 2001'indep per female = fx(femDens, femAge) AgeEffect = 0 'age 1 effect is in the intercept ElseIf BreedArray(6, i) = 2 Then AgeEffect = 0.89876 ElseIf BreedArray(6, i) = 3 Then AgeEffect = 0.3251 ElseIf BreedArray(6, i) = 4 Then AgeEffect = -0.1423 ElseIf BreedArray(6, i) = 5 Then AgeEffect = -0.4156 ElseIf BreedArray(6, i) = 6 Then AgeEffect = -1.01478 ElseIf BreedArray(6, i) >= 7 Then AgeEffect = -0.50066 End If IndPred = Round(FactorRmax * (4.43275 + AgeEffect - 0.04583 * NFem / FactorK), 0) 'determine an interger number of predicted independents (0 to 0.5 > 0, 0.5 to 1.5 > 1, 1.5 to 2.5 > 2 etc.) 'IndPred = Round(InterceptPlus + 4.43275 - 0.04583 * NFem + AgeEffect, 0) 'determine an interger number of predicted independents (0 to 0.5 > 0, 0.5 to 1.5 > 1, 1.5 to 2.5 > 2 etc.) 'intercept, density, fcoef, age; at 87 females Predicted ind > 0 (note > means 'goes to' in this case) If Form1.Check3.Value = Unchecked Then 'no variance in SRS - just use IndPred (mean predicted number of independents) If IndPred <= 0 Then BreedArray(3, i) = 0 ElseIf IndPred > 0 Then BreedArray(3, i) = IndPred End If ElseIf Form1.Check3.Value = Checked Then 'variance in SRS 'cummulative distribution of actual Mandarte independent young was imported in Sub ReadInputFiles If IndPred <= 0 Then IndPred = 0 If IndPred >= 5 Then IndPred = 5 Rd = Rnd For j = 1 To 13 If IndDist(IndPred + 2, j) >= Rd Then BreedArray(3, i) = IndDist(1, j) Exit For 'check that it is leaving when this first happens End If Next j End If Next i ElseIf Form1.Option3(1).Value = True Then 'ID:# independents = fx(female fcoef, age, density) - inbreeding depression in SRS 'from "MyDocuments\THESIS\SOSP Model\ not code \Ind per fem=fx(age,fcoef,dens).xls" For i = 1 To NFem 'loop through BreedArray to assign number of independent young If BreedArray(6, i) = 1 Then 'determine age effect with age as catagorical variable'parameters are from Proc Reg, years 1982 to 2001'indep per female = fx(femDens, femAge, femFcoef) AgeEffect = 0 'age 1 effect is in the intercept ElseIf BreedArray(6, i) = 2 Then AgeEffect = 0.89812 ElseIf BreedArray(6, i) = 3 Then AgeEffect = 0.34155 ElseIf BreedArray(6, i) = 4 Then AgeEffect = -0.14091 ElseIf BreedArray(6, i) = 5 Then AgeEffect = -0.43119 ElseIf BreedArray(6, i) = 6 Then AgeEffect = -0.95977 ElseIf BreedArray(6, i) >= 7 Then AgeEffect = -0.57018 End If ' IndPred = 4.63062 - 0.04747 * NFem - 3.42774 * BreedArray(5, i) + AgeEffect 'determine an interger number of predicted independents (0 to 0.5 > 0, 0.5 to 1.5 > 1, 1.5 to 2.5 > 2 etc.) IndPred = Round(FactorRmax * (4.63062 + AgeEffect - 3.42774 * BreedArray(5, i) - 0.04747 * NFem / FactorK), 0) 'determine an interger number of predicted independents (0 to 0.5 > 0, 0.5 to 1.5 > 1, 1.5 to 2.5 > 2 etc.) 'IndPred = Round((4.63062 + AgeEffect - 3.42774 * BreedArray(5, i) - 0.04747 * NFem), 0) 'determine an interger number of predicted independents (0 to 0.5 > 0, 0.5 to 1.5 > 1, 1.5 to 2.5 > 2 etc.) 'intercept, density, fcoef, age; at 87 females Predicted ind > 0 (note > means 'goes to' in this case) If Form1.Check3.Value = Unchecked Then 'no variance in SRS - just use IndPred (mean predicted number of independents) If IndPred <= 0 Then ' BreedArray(3, i) = IndPred BreedArray(3, i) = 0 ElseIf IndPred > 0 Then BreedArray(3, i) = IndPred 'can potentially get more that 5 independents End If ElseIf Form1.Check3.Value = Checked Then 'variance in SRS 'cummulative distribution of actual Mandarte independent young was imported in Sub ReadInputFiles If IndPred <= 0 Then IndPred = 0 If IndPred >= 5 Then IndPred = 5 Rd = Rnd For j = 1 To 13 If IndDist(IndPred + 2, j) >= Rd Then BreedArray(3, i) = IndDist(1, j) Exit For 'check that it is leaving when this first happens End If Next j End If Next i End If For i = 1 To NFem 'add number of independents produced per female to Surv array For j = 1 To NPop If BreedArray(1, i) = YrSurvArray(2, j) Then YrSurvArray(6, j) = BreedArray(3, i) Next j Next i NInd = 0 'count number of independents produced For i = 1 To NFem ' NInd = NInd + Round(BreedArray(3, i), 0) NInd = NInd + BreedArray(3, i) Next i SummaryYearArray(9, Y) = NInd 'add number of independents produced to summary ReDim Preserve YrSurvArray(15, NPop + NInd) ' redimension the array to include the independents For i = 1 To NInd 'create new birdID numbers & assign sex for the independents in the Surv array YrSurvArray(2, i + NPop) = BirdIDCounter + 1 BirdIDCounter = BirdIDCounter + 1 YrSurvArray(1, i + NPop) = Y 'year Rd = Rnd 'determine sex of independents If Rd < 0.428 Then YrSurvArray(3, i + NPop) = 1 '42.8% chance independent is female ElseIf Rd >= 0.428 Then YrSurvArray(3, i + NPop) = 2 '57.2% chance independent is male End If YrSurvArray(5, i + NPop) = 0 'age zero YrSurvArray(8, i + NPop) = 0 'catagory zero Next i l = 0 'record DamID and SireID in Surv array For i = 1 To NFem 'loop through BreedArray k = 0 ' Do While k < Round(BreedArray(3, i), 0) 'keep listing the same DamID until you hit the # of independents she produced Do While k < BreedArray(3, i) 'keep listing the same DamID until you hit the # of independents she produced YrSurvArray(12, NPop + l + 1) = BreedArray(1, i) 'assign maternity YrSurvArray(11, NPop + l + 1) = BreedArray(2, i) 'assign paternity (assumes no EPF's) k = k + 1 l = l + 1 Loop Next i End Sub Sub ComputeFcoef() Dim i As Integer, j As Integer, s As Integer, d As Integer, k As Integer, l As Integer Dim FTotFall As Double, FAveFall As Double If Form1.Option5(0).Value = True Then 'Recursive Inbreeding Coefficient Calculation based on pedigree For i = 1 To NInd 'add BirdID's of independents to Pedigree array PediArray(0, NPop + i) = YrSurvArray(2, NPop + i) PediArray(NPop + i, 0) = YrSurvArray(2, NPop + i) Next i For i = (NPop + 1) To (NPop + NInd) 'only have to compute Fcoef's for the independents s = 0 'get location of sire on PediArray For l = 1 To NPop 'loop through Pediarray until you get to the sire s = s + 1 If PediArray(l, 0) = YrSurvArray(11, i) Then Exit For 'assuming that order of birds on PediArray is same as order of birds on YrSurvArray Next l d = 0 'get location of dam on PediArray For l = 1 To NPop 'loop through Pediarray until you get to the sire d = d + 1 If PediArray(l, 0) = YrSurvArray(12, i) Then Exit For 'assuming that order of birds on PediArray is same as order of birds on YrSurvArray Next l For j = 1 To (NPop + NInd) If i > j Then PediArray(i, j) = 0.5 * (PediArray(s, j) + PediArray(d, j)) PediArray(j, i) = PediArray(i, j) ElseIf i = j Then PediArray(i, j) = 1 + 0.5 * (PediArray(s, d)) End If Next j Next i FTotFall = 0 For i = 1 To (NPop + NInd) YrSurvArray(4, i) = PediArray(i, i) - 1 'add Fcoefs to Surv array FTotFall = FTotFall + PediArray(i, i) - 1 'sum fcoef's for the current population Next i ElseIf Form1.Option5(1).Value = True Then 'Cohort-uniform inbreeding calculation based on average fcoef of parent popultion Dim FAveAfterWinter As Double, Fcoef As Double, Ne As Double, NImme As Double If Y = 0 Then FAveAfterWinter = 0 Fcoef = 0 ElseIf Y > 0 Then FAveAfterWinter = SummaryYearArray(13, Y - 1) Ne = 4 * 0.6 * NFem '2(for diploid) * 2(for both sexes) * .65 for Ne/N ratio (THIS RATIO MAY INCLUDE Immigrants already, therefore, may be lower) NImme = 1.5 * NImm '2(for diploid)*.75 for % female minus a bit because they don't all have equal variance in RS Fcoef = 1 / (2 * (Ne + NImme)) + FAveAfterWinter * (1 - (1 / (Ne + 1.5 * NImme))) * ((1 - (NImme) / (Ne + NImme)) ^ 2) ' 'F Coef ' Fcoef = 1 / (2 * (Ne + NImme)) + FAveBreeders * (1 - (1 / (Ne + 1.5 * NImme))) * ((1 - (NImme) / (Ne + NImme)) ^ 2) ' 'F Coef FTotFall = 0 For i = 1 To (NPop + NInd) YrSurvArray(4, i) = Fcoef 'add Fcoefs to Surv array FTotFall = FTotFall + Fcoef 'sum fcoef's for the current population Next i End If End If 'Debug.Print FTotFall 'prints to the immediate window If (NPop + NInd) > 0 Then FAveFall = FTotFall / (NPop + NInd) 'calculate average Fcoef for fall Else: FAveFall = 0 End If SummaryYearArray(12, Y) = FAveFall 'enter the average Fcoef for fall in the year summary End Sub Sub WinterSurvival() Dim i As Integer, FTotAfterWinter As Double, FAveAfterWinter As Double, Survd As Double If Form1.Option2(5).Value = True Then Call WinterSuvivalFlat ElseIf Form1.Option2(1).Value = True Then Call WinterSurvivalSmoothTruncation End If 'Determine FAveAfterWinter for surviving birds, excluding immigrants FTotAfterWinter = 0 Survd = 0 For i = 1 To (NPop + NInd) 'loop through YrSurvArray If YrSurvArray(9, i) = 1 Then FTotAfterWinter = FTotAfterWinter + YrSurvArray(4, i) Survd = Survd + 1 End If Next i If Survd > 0 Then FAveAfterWinter = FTotAfterWinter / Survd 'calculate average Fcoef for Spring Else: FAveAfterWinter = 0 End If SummaryYearArray(13, Y) = FAveAfterWinter 'enter the average Fcoef for Spring in the year summary SummaryYearArray(20, Y) = SummaryYearArray(12, Y) - FAveAfterWinter 'FAveFall-FAveAfterWinter 'new section for age-sex specific survival rates Dim k0m As Integer, k1m As Integer, k2m As Integer, k3m As Integer, k4m As Integer Dim k0f As Integer, k1f As Integer, k2f As Integer, k3f As Integer, k4f As Integer Dim k0ms As Integer, k1ms As Integer, k2ms As Integer, k3ms As Integer, k4ms As Integer Dim k0fs As Integer, k1fs As Integer, k2fs As Integer, k3fs As Integer, k4fs As Integer k0m = 0: k1m = 0: k2m = 0: k3m = 0: k4m = 0 'recall that : starts a new line; this is a way to save space k0f = 0: k1f = 0: k2f = 0: k3f = 0: k4f = 0 k0ms = 0: k1ms = 0: k2ms = 0: k3ms = 0: k4ms = 0 k0fs = 0: k1fs = 0: k2fs = 0: k3fs = 0: k4fs = 0 For i = 1 To (NPop + NInd) 'loop through YrSurvArray If YrSurvArray(3, i) = 2 Then 'if male If YrSurvArray(5, i) = 0 Then 'age 0 k0m = k0m + 1 If YrSurvArray(9, i) = 1 Then k0ms = k0ms + 1 ElseIf YrSurvArray(5, i) = 1 Then k1m = k1m + 1 If YrSurvArray(9, i) = 1 Then k1ms = k1ms + 1 ElseIf YrSurvArray(5, i) = 2 Then k2m = k2m + 1 If YrSurvArray(9, i) = 1 Then k2ms = k2ms + 1 ElseIf YrSurvArray(5, i) = 3 Then k3m = k3m + 1 If YrSurvArray(9, i) = 1 Then k3ms = k3ms + 1 ElseIf YrSurvArray(5, i) >= 4 Then k4m = k4m + 1 If YrSurvArray(9, i) = 1 Then k4ms = k4ms + 1 End If ElseIf YrSurvArray(3, i) = 1 Then 'if female If YrSurvArray(5, i) = 0 Then 'age 0 k0f = k0f + 1 If YrSurvArray(9, i) = 1 Then k0fs = k0fs + 1 ElseIf YrSurvArray(5, i) = 1 Then k1f = k1f + 1 If YrSurvArray(9, i) = 1 Then k1fs = k1fs + 1 ElseIf YrSurvArray(5, i) = 2 Then k2f = k2f + 1 If YrSurvArray(9, i) = 1 Then k2fs = k2fs + 1 ElseIf YrSurvArray(5, i) = 3 Then k3f = k3f + 1 If YrSurvArray(9, i) = 1 Then k3fs = k3fs + 1 ElseIf YrSurvArray(5, i) >= 4 Then k4f = k4f + 1 If YrSurvArray(9, i) = 1 Then k4fs = k4fs + 1 End If End If Next i If k0m <> 0 Then SummaryYearArray(21, Y) = k0ms / k0m 'number of survivors, Age 0 Males If k1m <> 0 Then SummaryYearArray(22, Y) = k1ms / k1m 'number of survivors,Age 1 Males If k2m <> 0 Then SummaryYearArray(23, Y) = k2ms / k2m 'number of survivors,Age 2 Males If k3m <> 0 Then SummaryYearArray(24, Y) = k3ms / k3m 'number of survivors,Age 3 Males If k4m <> 0 Then SummaryYearArray(25, Y) = k4ms / k4m 'number of survivors,Age 4+ Males If k0f <> 0 Then SummaryYearArray(26, Y) = k0fs / k0f 'number of survivors,Age 0 Females If k1f <> 0 Then SummaryYearArray(27, Y) = k1fs / k1f 'number of survivors,Age 1 Females If k2f <> 0 Then SummaryYearArray(28, Y) = k2fs / k2f 'number of survivors,Age 2 Females If k3f <> 0 Then SummaryYearArray(29, Y) = k3fs / k3f 'number of survivors,Age 3 Females If k4f <> 0 Then SummaryYearArray(30, Y) = k4fs / k4f 'number of survivors,Age 4+ Females If k0m = 0 Then SummaryYearArray(21, Y) = 9999999999# 'number of survivors, Age 0 Males If k1m = 0 Then SummaryYearArray(22, Y) = 9999999999# 'number of survivors,Age 1 Males If k2m = 0 Then SummaryYearArray(23, Y) = 9999999999# 'number of survivors,Age 2 Males If k3m = 0 Then SummaryYearArray(24, Y) = 9999999999# 'number of survivors,Age 3 Males If k4m = 0 Then SummaryYearArray(25, Y) = 9999999999# 'number of survivors,Age 4+ Males If k0f = 0 Then SummaryYearArray(26, Y) = 9999999999# 'number of survivors,Age 0 Females If k1f = 0 Then SummaryYearArray(27, Y) = 9999999999# 'number of survivors,Age 1 Females If k2f = 0 Then SummaryYearArray(28, Y) = 9999999999# 'number of survivors,Age 2 Females If k3f = 0 Then SummaryYearArray(29, Y) = 9999999999# 'number of survivors,Age 3 Females If k4f = 0 Then SummaryYearArray(30, Y) = 9999999999# 'number of survivors,Age 4+ Females SummaryYearArray(31, Y) = k0m 'number of Age 0 Males, for age structure SummaryYearArray(32, Y) = k1m 'number of Age 1 Males SummaryYearArray(33, Y) = k2m 'number of Age 2 Males SummaryYearArray(34, Y) = k3m 'number of Age 3 Males SummaryYearArray(35, Y) = k4m 'number of Age 4+ Males SummaryYearArray(36, Y) = k0f 'number of Age 0 Females SummaryYearArray(37, Y) = k1f 'number of Age 1 Females SummaryYearArray(38, Y) = k2f 'number of Age 2 Females SummaryYearArray(39, Y) = k3f 'number of Age 3 Females SummaryYearArray(40, Y) = k4f 'number of Age 4+ Females End Sub Sub WinterSurvivalSmoothTruncation() 'includes interactions Dim JuvIntercept As Double, AdultIntercept As Double, i As Integer Dim InbrDep25 As Double, WStress As Double, Cutoff As Double, Rd As Double Dim Age As Integer, Sex As Integer, Fcoef As Double, Surv As Double Dim DensityEffect As Double, SexEffect As Double, k As Integer Dim WStressScaler As Double, TruncSlope As Double, TruncInflPt As Double Dim LinInteractStrength As Double, B As Double Dim InbrStressFx As Double, LogisticFx As Double Dim LogisticFx0 As Double, FPower As Double, SPower As Double Dim SS As Double, FS As Double 'Sub SmoothTruncation models inbreeding depression as an exponential decay from an intercept (SurvOutbred) which includes the effects of Age, Sex and Stress. 'very Fcoef and Stress have limited effect, except when Stress*Fcoef is high 'adjust the intercept (SurvOutbred) to keep means in the right place. 'include dd in juv survival. If Form1.Text32.Text = "shared" Then InbrDep25 = Val(Form1.Text14.Text) 'inbreeding depression in 0 stress years for fcoef=.25 B = -(Log(1 - InbrDep25)) / 0.25 B = B / 2 'split the ID between %ID and Interaction LinInteractStrength = 2 * B 'must multiply by 2 because mean of WStress is 0.5 ElseIf Form1.Text32.Text <> "shared" Then InbrDep25 = Val(Form1.Text14.Text) 'inbreeding depression in 0 stress years for fcoef=.25 B = -(Log(1 - InbrDep25)) / 0.25 LinInteractStrength = Val(Form1.Text32.Text) End If JuvIntercept = Val(Form1.Text12.Text) TruncSlope = Val(Form1.Text34.Text) TruncInflPt = Val(Form1.Text33.Text) WStressScaler = Val(Form1.Text20.Text) 'the most winter can reduce survival SPower = Val(Form1.Text21.Text) FPower = 0.7 * (SPower) ^ (0.15) SS = 1.5 'StressScaler FS = Val(Form1.Text15.Text) 'FcoefScaler 'record Stress Inflection Point (StressInflPtF=0.03125/0.25). Stress above this value will cause survival to be severely reduced. If Form1.Check2.Value = Checked Then ParameterStepThrough(35, z) = SS * Exp((1 / SPower) * Log(TruncInflPt * (0.03125 / FS) ^ (-FPower))) If ParameterStepThrough(35, z) > 1 Then ParameterStepThrough(35, z) = 1 ParameterStepThrough(36, z) = SS * Exp((1 / SPower) * Log(TruncInflPt * (0.25 / FS) ^ (-FPower))) If ParameterStepThrough(36, z) > 1 Then ParameterStepThrough(36, z) = 1 End If 'Winter Severity: winters cause survival to fluctuate by WStressScaler% (ie +/- WStressScaler/2) 'NOTE: Survival intercepts for each age class compensate for the effects of inbreeding depression (WStress causes no change in mean) Rd = Rnd WStress = Rd SummaryYearArray(11, Y) = WStress 'Add WinterStress to Summary k = 0 'counter for number of independents which survive to become recruits For i = 1 To (NPop + NInd) 'loop through Surv array to determine if each bird survives Sex = YrSurvArray(3, i) Fcoef = YrSurvArray(4, i) Age = YrSurvArray(5, i) If Age > 4 Then Age = 4 'amalgamate older age classes into "4+" for females and males If Age = 0 Then 'Juveniles - must incorporate density DensityEffect = -0.0048 * NFem + 0.6041 'can remove density dependence in survival of juv's here: DensityEffect = 0.6041 'Sex ratio for juveniles is set in IndPerFemale, therefore SexEffect = 0 for juveniles InbrStressFx = (JuvIntercept + DensityEffect) * (1 + WStressScaler * (0.5 - WStress)) * Exp(-(B + WStress * LinInteractStrength) * Fcoef) On Error GoTo SurvError 'catches overflow error due to dividing one v. small # by another LogisticFx = (1 - Exp(TruncSlope * (((Fcoef / FS) ^ FPower) * ((WStress / SS) ^ SPower) - TruncInflPt)) / (1 + Exp(TruncSlope * (((Fcoef / FS) ^ FPower) * ((WStress / SS) ^ SPower) - TruncInflPt)))) On Error GoTo 0 'turns error handler off 'LogisticFx0 is the value of the LogisticFx when WStress=0 and Fcoef=0. This is used to scale the Survival function so that the Logistic can't make it drop to half its value when TruncSlope or TruncInfPt = 0 LogisticFx0 = (1 - Exp(TruncSlope * (0 - TruncInflPt)) / (1 + Exp(TruncSlope * (0 - TruncInflPt)))) Surv = InbrStressFx * LogisticFx / LogisticFx0 'Surv is the chance of survival for the bird YrSurvArray(13, i) = Surv 'record survival rate YrSurvArray(14, i) = WStress YrSurvArray(15, i) = NFem Rd = Rnd 'get a random number, Rd If Rd <= Surv Then 'compare Rd to Surv to see if the bird survives YrSurvArray(9, i) = 1 'bird survives k = k + 1 'count number of independents which recruit ElseIf Rd > Surv Then YrSurvArray(9, i) = 0 'bird dies End If ElseIf Age <> 0 Then 'Adults If Age = 1 Then AdultIntercept = Val(Form1.Text16.Text) ElseIf Age = 2 Then AdultIntercept = Val(Form1.Text40.Text) ElseIf Age = 3 Then AdultIntercept = Val(Form1.Text50.Text) ElseIf Age >= 4 Then AdultIntercept = Val(Form1.Text51.Text) End If If Form1.Check7.Value = Unchecked Or Sex = 2 Then 'apply ID to males and females InbrStressFx = (AdultIntercept + SurvAgeSexEffect(Sex + 1, Age)) * (1 + WStressScaler * (0.5 - WStress)) * Exp(-(B + WStress * LinInteractStrength) * Fcoef) On Error GoTo SurvError LogisticFx = (1 - Exp(TruncSlope * (((Fcoef / FS) ^ FPower) * ((WStress / SS) ^ SPower) - TruncInflPt)) / (1 + Exp(TruncSlope * (((Fcoef / FS) ^ FPower) * ((WStress / SS) ^ SPower) - TruncInflPt)))) On Error GoTo 0 'turns error handler off 'Scale with value of LogisticFx at Stress=0 and Fcoef=0 LogisticFx0 = (1 - Exp(TruncSlope * (0 - TruncInflPt)) / (1 + Exp(TruncSlope * (0 - TruncInflPt)))) Surv = InbrStressFx * LogisticFx / LogisticFx0 'Surv is the chance of survival for the bird ElseIf Form1.Check7.Value = Checked And Sex = 1 Then 'apply ID to males only; no ID in Surv for females Surv = SurvAgeSexEffect(Sex + 1, Age) * (1 + WStressScaler * (0.5 - WStress)) 'Surv is the chance of survival for the bird End If YrSurvArray(13, i) = Surv 'record survival rate YrSurvArray(14, i) = WStress YrSurvArray(15, i) = NFem Rd = Rnd 'roll the dice If Rd <= Surv Then YrSurvArray(9, i) = 1 'bird survives ElseIf Rd > Surv Then YrSurvArray(9, i) = 0 'bird dies End If End If Next i SummaryYearArray(10, Y) = k 'number of independents which survived to become recruits Exit Sub SurvError: If Err.Number = 6 Then 'if Overflow error LogisticFx = 0 Resume Next Else MsgBox "WinterSurvivalSmoothTruncation Error # " & Err.Number End End If End Sub Sub WinterSuvivalFlat() Dim Rd As Double, i As Integer, Surv As Double, k As Integer, Age As Integer Surv = Val(Form1.Text13.Text) 'read in flat survival rate k = 0 'counter for number of independents which survive to become recruits For i = 1 To (NPop + NInd) 'loop through Surv array to determine if each bird survives Age = YrSurvArray(5, i) If Age = 0 Then 'Juveniles; separate juvs and adults to keep track of recruitment Rd = Rnd 'get a random number, Rd If Rd <= Surv Then 'compare Rd to Surv to see if the bird survives YrSurvArray(9, i) = 1 'bird survives k = k + 1 ElseIf Rd > Surv Then YrSurvArray(9, i) = 0 'bird dies End If ElseIf Age <> 0 Then 'Adults Rd = Rnd If Rd > Surv Then YrSurvArray(9, i) = 0 ElseIf Rd <= 0.5 Then YrSurvArray(9, i) = 1 End If End If Next i SummaryYearArray(10, Y) = k 'number of independents which survived to become recruits End Sub Sub Summarize() 'add the data for the year to SummarySurvArray (SummaryYearArray is done as we go) Dim i As Integer, q As Long, j As Integer If Y = 30 Then Q30 = AllYearsBirdCounter 'row indicator for beginning of Analysis Window on SummarySurvArray q = AllYearsBirdCounter 'previous size of SummarySurvArray AllYearsBirdCounter = AllYearsBirdCounter + NPop + NInd If Y = 229 Then Q229 = AllYearsBirdCounter 'row indicator for end of Analysis Window on SummarySurvArray ReDim Preserve SummarySurvArray(15, AllYearsBirdCounter) 'note the 'Preserve' keyword For i = 1 To (NPop + NInd) 'write YrSurvArray onto bottom of SummarySurvArray For j = 1 To 15 SummarySurvArray(j, q + i) = YrSurvArray(j, i) Next j Next i End Sub Sub GeneticDemographicImmigration() Dim k As Integer, i As Integer, j As Integer, Died As Integer, Lived As Integer Dim Rd As Double, Nest As Integer NImmFem = 0 'reset counters for number of female and male immigrants NImmMale = 0 NImm = 0 FractionImmFem = Val(Form1.Text2.Text) 'fraction of 'immigrants' female If Form1.Option6(0).Value = True Then 'regular immigration (Demographic and Genetic) Call DetermineNImm 'assign sex and BirdID to new demog/gentic immigrants (sire, dam and fcoef = 0) If NImm <= 0 Then NImmFem = 0 NImmMale = 0 ReDim ImmigArray(5, 1) 'clear off ImmigArray just in case ElseIf NImm >= 1 Then ReDim ImmigArray(5, NImm) 'BirdID, Sex, SireID, DamID, Fcoef 'MALE IMMIGRANTS ARE ADDED TO THE BOTTOM OF THE ARRAYS, SO MALE IMMIGRANTS MAY NOT GET FEMALES 'FEMALES IMMIGRANTS ARE MORE LIKELY TO BE SHARING A MALE NImmFem = 0 'counter for number female immigrants NImmMale = 0 'counter for number of male immigrants For i = 1 To NImm ImmigArray(1, i) = BirdIDCounter + 1 BirdIDCounter = BirdIDCounter + 1 'create new birdID's for immigrants Rd = Rnd If Rd > FractionImmFem Then ImmigArray(2, i) = 2 '26% chance that immigrant is a male NImmMale = NImmMale + 1 ElseIf Rd <= FractionImmFem Then ImmigArray(2, i) = 1 '74% chance that immigrant is a female NImmFem = NImmFem + 1 End If Next i End If ElseIf Form1.Option6(1).Value = True Then 'Demographic - clone a live juv 'don't select from dead juv's unless there are no live ones. This is to allow selection against 'inbred juv's to occur. The objective here is to introduce extra bodies, but not to change the 'average Fcoef of the spring population. Lived = 0 Died = 0 For i = (NPop + 1) To (NPop + NInd) 'count how many independents lived If YrSurvArray(9, i) = 1 Then Lived = Lived + 1 ElseIf YrSurvArray(9, i) = 0 Then Died = Died + 1 End If Next i Call DetermineNImm 'determine how many Demographic immigrants will be added this year If NImm <= 0 Then ReDim ImmigArray(5, 1) 'clear off ImmigArray just in case ElseIf NImm >= 1 Then ReDim ImmigArray(5, NImm) 'BirdID, Sex, SireID, DamID, Fcoef If Lived > 0 Then 'if some juv's lived, select a live juv to clone For i = 1 To NImm Do k = GetRandom(1, NInd) For j = (NPop + k) To (NPop + NInd) 'loop through juvs in YrSurvArray If YrSurvArray(9, NPop + k) = 1 Then 'if you got a live one then take it's info ImmigArray(1, i) = BirdIDCounter + 1 'BirdID BirdIDCounter = BirdIDCounter + 1 Rd = Rnd 'Sex If Rd > FractionImmFem Then ImmigArray(2, i) = 2 '26% chance that immigrant is a male NImmMale = NImmMale + 1 ElseIf Rd <= FractionImmFem Then ImmigArray(2, i) = 1 '74% chance that immigrant is a female NImmFem = NImmFem + 1 End If ImmigArray(3, i) = YrSurvArray(11, j) 'SireID ImmigArray(4, i) = YrSurvArray(12, j) 'DamID ImmigArray(5, i) = YrSurvArray(4, j) 'Fcoef - put this in just to double check that it is the same when it is run later Exit For 'you got one, so exit End If 'if you didn't get a live one, try the next one Next j Loop While ImmigArray(1, i) = 0 'if you didn't get any live ones, choose a new random start point and try again Next i ElseIf (Lived = 0) And (Died > 0) Then 'select from dead juv's For i = 1 To NImm k = GetRandom(1, NInd) 'choose one of the dead juv's at random ImmigArray(1, i) = BirdIDCounter + 1 'BirdID BirdIDCounter = BirdIDCounter + 1 Rd = Rnd 'Sex If Rd > FractionImmFem Then ImmigArray(2, i) = 2 '26% chance that immigrant is a male NImmMale = NImmMale + 1 ElseIf Rd <= FractionImmFem Then ImmigArray(2, i) = 1 '74% chance that immigrant is a female NImmFem = NImmFem + 1 End If ImmigArray(3, i) = YrSurvArray(11, k) 'SireID ImmigArray(4, i) = YrSurvArray(12, k) 'DamID ImmigArray(5, i) = YrSurvArray(4, k) 'Fcoef - put this in just to double check that it is the same when it is run later Next i ElseIf (Lived = 0) And (Died = 0) Then 'if there were no independents 'randomly select parents from the breed array For i = 1 To NImm Nest = GetRandom(1, NFem) 'choose a nest(sire and dam) from BreedArray ImmigArray(1, i) = BirdIDCounter + 1 'BirdID BirdIDCounter = BirdIDCounter + 1 ImmigArray(4, i) = BreedArray(1, Nest) 'DamID ImmigArray(3, i) = BreedArray(2, Nest) 'SireID Rd = Rnd 'Sex If Rd > FractionImmFem Then ImmigArray(2, i) = 2 '26% chance that immigrant is a male NImmMale = NImmMale + 1 ElseIf Rd <= FractionImmFem Then ImmigArray(2, i) = 1 '74% chance that immigrant is a female NImmFem = NImmFem + 1 End If 'fill in Fcoef by running recursive fx later Next i End If End If ElseIf Form1.Option6(4).Value = True Then 'Genetic only 'count how many independents lived For i = (NPop + 1) To (NPop + NInd) If YrSurvArray(9, i) = 1 Then Lived = Lived + 1 Next i Call DetermineNImm If NImm <= 0 Then ReDim ImmigArray(5, 1) 'redim, just to clear off the array ElseIf NImm > 0 Then ReDim ImmigArray(5, NImm) If Lived < NImm Then NImm = Lived 'reset NImm, so that no extra bodies are added 'set the Sire and Dam of a few juv's to 0, so that they are 'outbred' and can help with genetic rescue For j = 1 To NImm Do k = GetRandom(1, NInd) 'pick a juv at random to make unrelated For i = (NPop + k) To (NPop + NInd) 'loop through independents on YrSurvArray If YrSurvArray(9, i) = 1 Then 'if kid lived then YrSurvArray(9, i) = 0 'say that the kid died and make him/her an immigrant with immigrants change of being male or female ImmigArray(1, j) = BirdIDCounter + 1 'BirdID BirdIDCounter = BirdIDCounter + 1 Rd = Rnd 'Sex If Rd > FractionImmFem Then ImmigArray(2, j) = 2 '26% chance that immigrant is a male NImmMale = NImmMale + 1 ElseIf Rd <= FractionImmFem Then ImmigArray(2, j) = 1 '74% chance that immigrant is a female NImmFem = NImmFem + 1 End If ImmigArray(3, j) = 0 'SireID ImmigArray(4, j) = 0 'DamID ImmigArray(5, j) = 0 'Fcoef Exit For End If Next i Loop While ImmigArray(1, j) = 0 Next j 'must remove fcoef's from PediArray too*************** 'It is easier to move these birds to ImmigArray and set surv=0 so they are wiped off the PediArray 'then add them in to PediArray as Immigrants End If ElseIf Form1.Option6(3).Value = True Then 'no immigration Form1.Option7(0).Value = True 'set immigration rate constant Form1.Text23.Text = 0 NImmFem = 0 NImmMale = 0 ReDim ImmigArray(5, 1) 'clear off ImmigArray just in case 'Call Immigration End If If NImm > 0 Then Call AddImmigToArrays End Sub Sub AddImmigToArrays() 'ImmigArray has been created and there is at least 1 immigrant. 'Now add immigrants to YrSurvArray and PediArray Dim FTotImm As Double, i As Integer, j As Integer, s As Integer, d As Integer, l As Integer 'Add immigrants to PediArray If Form1.Option6(0).Value = True Then 'regular immigration (Demographic and Genetic) For i = 1 To NImm PediArray(NPop + NInd + i, 0) = ImmigArray(1, i) 'only need to add BirdID's - rest of PediArrays stay's 0 for immigrants PediArray(0, NPop + NInd + i) = ImmigArray(1, i) PediArray(NPop + NInd + i, NPop + NInd + i) = ImmigArray(5, i) + 1 'Fcoef -diagonal is 1 if Fcoef=0 Next i 'ImmigArray(5, i) should be 0 - check this ElseIf Form1.Option6(1).Value = True Then 'Demographic - run recursive fx to fill in PediArray and calculate Fcoef's For i = 1 To NImm 'add BirdID's of immigrants to Pedigree array PediArray(0, NPop + NInd + i) = ImmigArray(1, i) PediArray(NPop + NInd + i, 0) = ImmigArray(1, i) Next i For i = (NPop + NInd + 1) To (NPop + NInd + NImm) 'only have to compute Fcoef's for the immigrants s = 0 'get location of sire on PediArray For l = 1 To NPop 'loop through possible breeders on Pediarray until you get to the sire s = s + 1 'don't bother looking at juvs) If PediArray(l, 0) = ImmigArray(3, i - NPop - NInd) Then Exit For 'assuming that order of birds on PediArray is same as order of birds on YrSurvArray Next l d = 0 'get location of dam on PediArray For l = 1 To NPop 'loop through Pediarray until you get to the sire d = d + 1 If PediArray(l, 0) = ImmigArray(4, i - NPop - NInd) Then Exit For 'assuming that order of birds on PediArray is same as order of birds on YrSurvArray Next l For j = 1 To (NPop + NInd + NImm) 'loop through PediArray If i > j Then PediArray(i, j) = 0.5 * (PediArray(s, j) + PediArray(d, j)) PediArray(j, i) = PediArray(i, j) ElseIf i = j Then PediArray(i, j) = 1 + 0.5 * (PediArray(s, d)) End If Next j Next i ElseIf Form1.Option6(4).Value = True Then 'Genetic only - reset PediArray values to 0(off-diagonal) or 1(diagonal) For i = 1 To NImm 'add BirdID's of immigrants to Pedigree array PediArray(0, NPop + NInd + i) = ImmigArray(1, i) PediArray(NPop + NInd + i, 0) = ImmigArray(1, i) Next i For j = 1 To (NPop + NInd + NImm) 'loop through PediArray For i = (NPop + NInd + 1) To (NPop + NInd + NImm) 'only have to compute Fcoef's for the immigrants If i > j Then PediArray(i, j) = 0 PediArray(j, i) = 0 ElseIf i = j Then PediArray(i, j) = 1 End If Next i Next j End If 'determine the average Fcoef of the immigrants FTotImm = 0 For i = (NPop + NInd + 1) To (NPop + NInd + NImm) ImmigArray(5, i - NPop - NInd) = PediArray(i, i) - 1 'add Fcoefs to ImmigArray FTotImm = FTotImm + PediArray(i, i) - 1 'sum fcoef's for the current population Next i FAveImm = FTotImm / NImm 'calculate average Fcoef for immigrants ReDim Preserve YrSurvArray(15, NPop + NInd + NImm) 'Add immigrants to YrSurvArray For i = 1 To NImm YrSurvArray(1, NPop + NInd + i) = Y + 1 YrSurvArray(2, NPop + NInd + i) = ImmigArray(1, i) 'BirdID YrSurvArray(3, NPop + NInd + i) = ImmigArray(2, i) 'sex YrSurvArray(4, NPop + NInd + i) = ImmigArray(5, i) 'Fcoef YrSurvArray(5, NPop + NInd + i) = 0 'Set Age to 0 - this will be updated to 1 in Condense YrSurvArray(6, NPop + NInd + i) = 0 'indep's YrSurvArray(7, NPop + NInd + i) = 0 'recruits YrSurvArray(8, NPop + NInd + i) = 1 'set catagory as floater for immigrants initially YrSurvArray(9, NPop + NInd + i) = 1 'survived If Form1.Option6(0).Value = True Then YrSurvArray(10, NPop + NInd + i) = 1 'ordinary immigrant ElseIf Form1.Option6(1).Value = True Then YrSurvArray(10, NPop + NInd + i) = 2 'demographic immigrant ElseIf Form1.Option6(4).Value <> True Then YrSurvArray(10, NPop + NInd + i) = 3 'genetic immigrant End If YrSurvArray(11, NPop + NInd + i) = ImmigArray(3, i) 'SireID YrSurvArray(12, NPop + NInd + i) = ImmigArray(4, i) 'DamID Next i End Sub Sub DetermineNImm() 'determine number of immigrants Dim i As Integer, Rd As Double, LowImm As Integer, HighImm As Integer 'determine number of immigrants for the year If Form1.Option7(0).Value = True Then 'if immigration is selected to be constant then NImm = Val(Form1.Text23.Text) 'read in a constant number of immigrants per year ElseIf Form1.Option7(1).Value = True Then 'if immigration is random between a low and high number LowImm = Val(Form1.Text24.Text) 'read in a low number of immigrants per year HighImm = Val(Form1.Text25.Text) 'read in a high number of immigrants per year NImm = GetRandom(LowImm, HighImm) 'random number of immigrants between 0 and 4, with equal probabilities - leads to a higher number of immigrants than the Mandarte Distribution ElseIf Form1.Option7(3).Value = True Then 'Mandarte Distribution from years 1975 to 2002 Rd = Rnd If Rd < 0.035714 Then NImm = 4 'get 4 immigrants 3.6% of the time ElseIf Rd >= 0.035714 And Rd < 0.107143 Then NImm = 3 'get 3 immig 7.1% of time ElseIf Rd >= 0.107143 And Rd < 0.285714 Then NImm = 2 'get 2 immig 17.9% of time ElseIf Rd >= 0.285714 And Rd < 0.678571 Then NImm = 1 'get 1 immig 39.3% of time ElseIf Rd >= 0.678571 Then NImm = 0 ' get 0 immig 32.1% of time End If ElseIf Form1.Option7(2).Value = True Then 'Mandarte Female Only Distribution from years 1975 to 2002 Rd = Rnd If Rd < 0.035714286 Then NImm = 3 'get 3 female immigrants 3.6% of the time ElseIf Rd >= 0.035714286 And Rd < 0.214285714 Then NImm = 2 'get 2 Femimmig 17.9% of time ElseIf Rd >= 0.214285714 And Rd < 0.571428571 Then NImm = 1 'get 1 Femimmig 35.7% of time ElseIf Rd >= 0.571428571 Then NImm = 0 'get 0 femImm 42.9% of time End If Form1.Text2.Text = 1 ElseIf Form1.Option7(4).Value = True Then 'Poisson Distribution Rd = Rnd For i = 0 To 50 If PoissonArray(3, i) >= Rd Then NImm = PoissonArray(1, i) Exit For End If Next i End If End Sub Sub Condense() 'Condense SurvArray's , BreedArray, PediArray - eliminated empty rows and columns Dim i As Integer, k As Integer, m As Integer, j As Integer Dim TempYrSurvArray() As Double, TempBreedArray() As Double, TempPediArray() As Double Dim MinPop As Integer, SurvdImm As Integer Dim FAveAfterWinter As Double, FTotSpring As Double 'Dim k0m As Integer, k1m As Integer, k2m As Integer, k3m As Integer, k4m As Integer 'Dim k0f As Integer, k1f As Integer, k2f As Integer, k3f As Integer, k4f As Integer 'Dim k0ms As Integer, k1ms As Integer, k2ms As Integer, k3ms As Integer, k4ms As Integer 'Dim k0fs As Integer, k1fs As Integer, k2fs As Integer, k3fs As Integer, k4fs As Integer ' ' 'k0m = 0: k1m = 0: k2m = 0: k3m = 0: k4m = 0 'recall that : starts a new line; this is a way to save space 'k0f = 0: k1f = 0: k2f = 0: k3f = 0: k4f = 0 'k0ms = 0: k1ms = 0: k2ms = 0: k3ms = 0: k4ms = 0 'k0fs = 0: k1fs = 0: k2fs = 0: k3fs = 0: k4fs = 0 SurvdImm = 0 'counter for survivors and immigrants NewNFem = 0 'counter for number of surviving females (includes immigrants) For i = 1 To (NPop + NInd + NImm) If YrSurvArray(9, i) = 1 Then SurvdImm = SurvdImm + 1 'count number of survivors If YrSurvArray(9, i) = 1 And YrSurvArray(3, i) = 1 Then NewNFem = NewNFem + 1 'New section tabulating age-sex specific survival rates: ' If YrSurvArray(10, i) <> 1 Then 'if not an immigrant ' If YrSurvArray(3, i) = 2 Then 'if male ' If YrSurvArray(5, i) = 0 Then 'age 0 ' k0m = k0m + 1 ' If YrSurvArray(9, i) = 1 Then k0ms = k0ms + 1 ' ElseIf YrSurvArray(5, i) = 1 Then ' k1m = k1m + 1 ' If YrSurvArray(9, i) = 1 Then k1ms = k1ms + 1 ' ElseIf YrSurvArray(5, i) = 2 Then ' k2m = k2m + 1 ' If YrSurvArray(9, i) = 1 Then k2ms = k2ms + 1 ' ElseIf YrSurvArray(5, i) = 3 Then ' k3m = k3m + 1 ' If YrSurvArray(9, i) = 1 Then k3ms = k3ms + 1 ' ElseIf YrSurvArray(5, i) >= 4 Then ' k4m = k4m + 1 ' If YrSurvArray(9, i) = 1 Then k4ms = k4ms + 1 ' End If ' ElseIf YrSurvArray(3, i) = 1 Then 'if female ' If YrSurvArray(5, i) = 0 Then 'age 0 ' k0f = k0f + 1 ' If YrSurvArray(9, i) = 1 Then k0fs = k0fs + 1 ' ElseIf YrSurvArray(5, i) = 1 Then ' k1f = k1f + 1 ' If YrSurvArray(9, i) = 1 Then k1fs = k1fs + 1 ' ElseIf YrSurvArray(5, i) = 2 Then ' k2f = k2f + 1 ' If YrSurvArray(9, i) = 1 Then k2fs = k2fs + 1 ' ElseIf YrSurvArray(5, i) = 3 Then ' k3f = k3f + 1 ' If YrSurvArray(9, i) = 1 Then k3fs = k3fs + 1 ' ElseIf YrSurvArray(5, i) >= 4 Then ' k4f = k4f + 1 ' If YrSurvArray(9, i) = 1 Then k4fs = k4fs + 1 ' End If ' End If ' End If Next i 'write WinterMortality to SummaryYearArray SummaryYearArray(14, Y) = 1 - ((SurvdImm - NImm) / (NPop + NInd)) 'mortality rate 'new section: 'If k0m <> 0 Then SummaryYearArray(21, Y) = k0ms / k0m 'number of survivors, Age 0 Males 'If k1m <> 0 Then SummaryYearArray(22, Y) = k1ms / k1m 'number of survivors,Age 1 Males 'If k2m <> 0 Then SummaryYearArray(23, Y) = k2ms / k2m 'number of survivors,Age 2 Males 'If k3m <> 0 Then SummaryYearArray(24, Y) = k3ms / k3m 'number of survivors,Age 3 Males 'If k4m <> 0 Then SummaryYearArray(25, Y) = k4ms / k4m 'number of survivors,Age 4+ Males 'If k0f <> 0 Then SummaryYearArray(26, Y) = k0fs / k0f 'number of survivors,Age 0 Females 'If k1f <> 0 Then SummaryYearArray(27, Y) = k1fs / k1f 'number of survivors,Age 1 Females 'If k2f <> 0 Then SummaryYearArray(28, Y) = k2fs / k2f 'number of survivors,Age 2 Females 'If k3f <> 0 Then SummaryYearArray(29, Y) = k3fs / k3f 'number of survivors,Age 3 Females 'If k4f <> 0 Then SummaryYearArray(30, Y) = k4fs / k4f 'number of survivors,Age 4+ Females ' 'If k0m = 0 Then SummaryYearArray(21, Y) = 9999999999# 'number of survivors, Age 0 Males 'If k1m = 0 Then SummaryYearArray(22, Y) = 9999999999# 'number of survivors,Age 1 Males 'If k2m = 0 Then SummaryYearArray(23, Y) = 9999999999# 'number of survivors,Age 2 Males 'If k3m = 0 Then SummaryYearArray(24, Y) = 9999999999# 'number of survivors,Age 3 Males 'If k4m = 0 Then SummaryYearArray(25, Y) = 9999999999# 'number of survivors,Age 4+ Males 'If k0f = 0 Then SummaryYearArray(26, Y) = 9999999999# 'number of survivors,Age 0 Females 'If k1f = 0 Then SummaryYearArray(27, Y) = 9999999999# 'number of survivors,Age 1 Females 'If k2f = 0 Then SummaryYearArray(28, Y) = 9999999999# 'number of survivors,Age 2 Females 'If k3f = 0 Then SummaryYearArray(29, Y) = 9999999999# 'number of survivors,Age 3 Females 'If k4f = 0 Then SummaryYearArray(30, Y) = 9999999999# 'number of survivors,Age 4+ Females ' 'SummaryYearArray(31, Y) = k0m 'number of Age 0 Males, for age structure 'SummaryYearArray(32, Y) = k1m 'number of Age 1 Males 'SummaryYearArray(33, Y) = k2m 'number of Age 2 Males 'SummaryYearArray(34, Y) = k3m 'number of Age 3 Males 'SummaryYearArray(35, Y) = k4m 'number of Age 4+ Males 'SummaryYearArray(36, Y) = k0f 'number of Age 0 Females 'SummaryYearArray(37, Y) = k1f 'number of Age 1 Females 'SummaryYearArray(38, Y) = k2f 'number of Age 2 Females 'SummaryYearArray(39, Y) = k3f 'number of Age 3 Females 'SummaryYearArray(40, Y) = k4f 'number of Age 4+ Females If NewNFem <= 0 Then MultiRunStats(25, 5 + Run) = Y 'write year crashed to MultiRunStats ExtinctionYear = Y + 1 'extinction is realized next spring Exit Sub 'if there are no females in spring, then population has crashed, so Graph and exit End If 'do the following for YrSurvArray, BreedArray and PediArray: 'Create temporary arrays, sized for next year's population, including immigrants 'Bring info about survivors into temporary arrays 'Destroy temporary arrays 'YrSurvArray ReDim TempYrSurvArray(15, SurvdImm) 'Bring info about survivors into temporary arrays i = 1 For m = 1 To (NPop + NInd + NImm) 'loop through YrSurvArray If YrSurvArray(9, m) = 1 Then 'if bird lived then keep/update it's info TempYrSurvArray(1, i) = Y + 1 'year for next year TempYrSurvArray(2, i) = YrSurvArray(2, m) 'BirdID TempYrSurvArray(3, i) = YrSurvArray(3, m) 'sex TempYrSurvArray(4, i) = YrSurvArray(4, m) 'Fcoef TempYrSurvArray(5, i) = YrSurvArray(5, m) + 1 'age for next year TempYrSurvArray(6, i) = 0 'indep's TempYrSurvArray(7, i) = 0 'recruits (not using this column) TempYrSurvArray(8, i) = YrSurvArray(8, m) 'catagory TempYrSurvArray(9, i) = YrSurvArray(9, m) 'keep survival as 1 TempYrSurvArray(10, i) = YrSurvArray(10, m) 'immigrant? TempYrSurvArray(11, i) = YrSurvArray(11, m) 'SireID TempYrSurvArray(12, i) = YrSurvArray(12, m) 'DamID i = i + 1 End If Next m 'BreedArray ReDim TempBreedArray(6, NewNFem) 'i)Set BirdID=0 in BreedArray if bird died For i = 1 To NPop 'loop through YrSurvArray (excluding juv's and immigrants) 'For i = 1 To (NPop + NInd) 'loop through YrSurvArray (excluding immigrants) If YrSurvArray(3, i) = 1 And YrSurvArray(8, i) = 3 And YrSurvArray(9, i) = 0 Then 'if female, paired holder and died For j = 1 To NFem 'loop through BreedArray to find female breeder who died and make her BirdID=0 If BreedArray(1, j) = YrSurvArray(2, i) Then BreedArray(1, j) = 0 Next j ElseIf YrSurvArray(3, i) = 2 And YrSurvArray(8, i) = 3 And YrSurvArray(9, i) = 0 Then 'if male, paired holder and died For j = 1 To NFem 'loop through BreedArray to find male breeder who died and make his BirdID=0 If BreedArray(2, j) = YrSurvArray(2, i) Then BreedArray(2, j) = 0 Next j End If Next i 'If a polygamous male lived, set MaleBirdID=0 opposite second female For i = 1 To NFem 'loop through BreedArray If BreedArray(2, i) <> 0 Then For j = (i + 1) To NFem If BreedArray(2, i) = BreedArray(2, j) Then BreedArray(2, j) = 0 Next j End If Next i 'ii) move survivors onto TempBreedArray, condensing as you go (set Nind and NRec to zero) 'if BreedArray(1,i)=0 and Breedarray(2,i)=0 then get rid of this row and move everything up - or maybe just search for living birds and move them up if possible 'if BreedArray(1,i)<>0 and BreedArray(2,i)=0 then look for a surviving male to move up to be with this female 'if BreedArray(1,i)=0 and BreedArray(2,i)<>0 then look for a surviving female to move up to be with this male j = 1 'counter for filling in TempBreedArray For i = 1 To NFem 'loop though BreedArray If BreedArray(1, i) <> 0 And BreedArray(2, i) <> 0 Then 'if both members of the pair survived then TempBreedArray(1, j) = BreedArray(1, i) 'FemBirdID TempBreedArray(2, j) = BreedArray(2, i) 'MaleBirdID TempBreedArray(5, j) = BreedArray(5, i) 'FemFcoef TempBreedArray(6, j) = BreedArray(6, i) + 1 'FemAge, updated for next year j = j + 1 ElseIf BreedArray(1, i) <> 0 And BreedArray(2, i) = 0 Then 'if female lived, male died TempBreedArray(1, j) = BreedArray(1, i) 'then bring female to TempBreedArray and TempBreedArray(5, j) = BreedArray(5, i) 'FemFcoef TempBreedArray(6, j) = BreedArray(6, i) + 1 'FemAge, updated for next year For m = i To NFem 'loop through to find a surviving male, if no male found, the male spot stays as zero If BreedArray(2, m) <> 0 Then 'if a live male is found TempBreedArray(2, j) = BreedArray(2, m) 'bring him into the TempBreedArray BreedArray(2, m) = 0 'set male to zero, so he is not used again Exit For End If Next m j = j + 1 ElseIf BreedArray(1, i) = 0 And BreedArray(2, i) <> 0 And j <= NewNFem Then 'if female died, male lived TempBreedArray(2, j) = BreedArray(2, i) 'then bring male to TempBreedArray (if you have not yet filled the TempBreedArray with males) and For m = i To NFem 'loop through to find a surviving female, if no female found, the female spot stays as zero If BreedArray(1, m) <> 0 Then 'if a live female is found TempBreedArray(1, j) = BreedArray(1, m) 'bring her into the TempBreedArray TempBreedArray(5, j) = BreedArray(5, m) 'FemFcoef TempBreedArray(6, j) = BreedArray(6, m) + 1 'FemAge, updated for next year BreedArray(1, m) = 0 'set female to zero, so she is not used again Exit For End If Next m j = j + 1 End If Next i '3. Could add Male immigrants to BreedArray here if I want to increase the chance that a male immigrant breeds '(recall that all females breed, so don't need to add them) 'PediArray ReDim TempPediArray(0 To 1050, 0 To 1050) 'assume that SurvdImm will not be larger than 1050! 'Make use of the fact that birds are in the same order in YrSurvArray and PediArray 'bring in column 0 from PediArray to TempPediArray For i = 0 To 1050 TempPediArray(0, i) = PediArray(0, i) Next i k = 1 For i = 1 To (NPop + NInd + NImm) 'loop through YrSurvArray***Did not have NImm here******* If YrSurvArray(9, i) = 1 Then 'if you find a survivor For j = 0 To (NPop + NInd + NImm) TempPediArray(k, j) = PediArray(i, j) 'bring in the column for that bird Next j k = k + 1 End If Next i ReDim PediArray(0 To 1050, 0 To 1050) 'clears the PediArray 'bring in Row 0 from TempPediArray to PediArray For i = 0 To 1050 PediArray(i, 0) = TempPediArray(i, 0) Next i k = 1 For i = 1 To (NPop + NInd + NImm) 'loop through YrSurvArray If YrSurvArray(9, i) = 1 Then 'if you find a survivor For j = 0 To (NPop + NInd + NImm) PediArray(j, k) = TempPediArray(j, i) 'bring in the row for that bird from TempPediArray which is partially condensed Next j k = k + 1 End If Next i 'now PediArray is fully condensed, TempPediArray is specific to this subroutine and will be lost when the subroutine ends, so no need to clear it. 'Destroy temporary arrays: ReDim YrSurvArray(15, SurvdImm) YrSurvArray = TempYrSurvArray ReDim BreedArray(6, NewNFem) BreedArray = TempBreedArray NPop = SurvdImm 'initialize population size for next year NFem = NewNFem End Sub Sub AnalyseRun() 'anaylse changes in abundance of adult females in SummaryYearArray Dim NZeroCrossings As Integer, i As Integer, PopMean As Double Dim StartAnalYr As Integer, FinishAnalYr As Integer ', Nperiods As Integer, k As Integer Dim Nrows As Long, StartRowX As Integer, StartRowY As Integer, RealFinishAnalYr As Integer Dim OneRunCycleSummary() As Double, j As Integer, N As Integer Dim k0 As Long, k1 As Long, t0 As Double, td As Double, t1 As Double, q As Long Dim k2 As Long, k3 As Long, k4 As Long, t2 As Double, t3 As Double, t4 As Double 'If InSurvInterceptAdjust = 0 Then 'Don't analyse the run if it is just a run to adjust the survival intercepts 'write the female trajectory to MultiRunTrajectory For i = 1 To NYrs 'loop through SummaryYearArray If Run = 1 Then MultiRunTrajectory(1, i) = i 'write year in 1st column MultiRunTrajectory(Run + 1, i) = SummaryYearArray(3, i) Next i 'The Analysis Window StartAnalYr = Val(Form1.Text8.Text) 'read in year to start counting cycles - leave at 30 for now FinishAnalYr = Val(Form1.Text9.Text) 'read in year to finish counting cycles MultiRunStats(26, 5 + Run) = SummaryYearArray(3, FinishAnalYr) 'female pop size at planned FinishAnalYear If ExtinctionYear <> 0 Then 'if the population crashed If ExtinctionYear < FinishAnalYr Then FinishAnalYr = ExtinctionYear ' then analyse from year 30 to crash year 'Exit Sub 'CODE FOR EXCLUDING TRAJECTORIES WHICH WENT EXTINCT End If End If If FinishAnalYr <= StartAnalYr Then Exit Sub MultiRunStats(1, 5 + Run) = Run 'run number 'Basic Statistics for the female population trajectory BasicStats = ColumnNMeanVarMaxMin(SummaryYearArray, 3, StartAnalYr, FinishAnalYr) MultiRunStats(2, 5 + Run) = BasicStats(1) 'years run MultiRunStats(3, 5 + Run) = BasicStats(2) 'Pop mean MultiRunStats(4, 5 + Run) = BasicStats(3) 'Pop Var MultiRunStats(5, 5 + Run) = BasicStats(4) 'Pop max MultiRunStats(6, 5 + Run) = BasicStats(5) 'Pop min PopMean = MultiRunStats(3, 5 + Run) 'Figure Out 25th, 50th, 75th Percentiles 'the nth percentile is the data point below which at least n% of the data lies ReDim SortedPopArray(1, FinishAnalYr - StartAnalYr + 1) For i = StartAnalYr To FinishAnalYr SortedPopArray(1, i - StartAnalYr + 1) = SummaryYearArray(3, i) 'get analysis window of female array Next i SortedPopArray = ArraySorter(SortedPopArray, 1) 'call ArraySorter Function, sorts low to high N = FinishAnalYr - StartAnalYr + 1 'number of observations in trajectory MultiRunStats(27, Run + 5) = SortedPopArray(1, -Int(-(N / 4))) '25th percentile MultiRunStats(28, Run + 5) = SortedPopArray(1, -Int(-(N / 2))) '50th percentile (median) MultiRunStats(29, Run + 5) = SortedPopArray(1, -Int(-(3 * N / 4))) '75th percentile 'Basic Statistics for the FAveAfterWinter (does not include immigrants) BasicStats = ColumnNMeanVarMaxMin(SummaryYearArray, 13, StartAnalYr, FinishAnalYr) MultiRunStats(31, 5 + Run) = BasicStats(2) 'mean MultiRunStats(32, 5 + Run) = BasicStats(3) 'Var MultiRunStats(33, 5 + Run) = BasicStats(4) 'max 'MultiRunStats(6, 5 + Run) = BasicStats(5) 'min (should just be zero) 'Basic Statistics for the FAveFall (just calculate the mean) BasicStats = ColumnNMeanVarMaxMin(SummaryYearArray, 12, StartAnalYr, FinishAnalYr) MultiRunStats(37, 5 + Run) = BasicStats(2) 'mean 'Basic Stats for FAveFall-FAveAfterWinter BasicStats = ColumnNMeanVarMaxMin(SummaryYearArray, 20, StartAnalYr, FinishAnalYr) MultiRunStats(34, 5 + Run) = BasicStats(2) 'mean MultiRunStats(35, 5 + Run) = BasicStats(3) 'Var MultiRunStats(36, 5 + Run) = BasicStats(4) 'max 'MultiRunStats(37, 5 + Run) = BasicStats(5) 'min ReDim SmoothedYearArray(4, NYrs) '5yearAverage,Unsmoothed-smoothed, 5YearAverage-Mean, Zero-Crossings, ReDim OneRunCycleSummary(8, (FinishAnalYr - StartAnalYr + 1)) 'Redim with excessive size because Nzerocrossings is unknown as of yet NZeroCrossings = 0 'fill in the SmoothedYearArray using a 5-year moving window For i = StartAnalYr To FinishAnalYr 'just smooth analysis window If Form1.Option1(0).Value = True Then '3-year smoothing SmoothedYearArray(1, i) = (SummaryYearArray(3, i - 1) + SummaryYearArray(3, i) + SummaryYearArray(3, i + 1)) / 3 ElseIf Form1.Option1(1).Value = True Then '5-year smoothing SmoothedYearArray(1, i) = (SummaryYearArray(3, i - 2) + SummaryYearArray(3, i - 1) + SummaryYearArray(3, i) + SummaryYearArray(3, i + 1) + SummaryYearArray(3, i + 2)) / 5 ElseIf Form1.Option1(2).Value = True Then 'no smoothing SmoothedYearArray(1, i) = SummaryYearArray(3, i) End If SmoothedYearArray(2, i) = ((SummaryYearArray(3, i) - SmoothedYearArray(1, i)) ^ 2) ^ (0.5) 'absolute value of Unsmoothed-smoothed (gives small scale noise) SmoothedYearArray(3, i) = SmoothedYearArray(1, i) - PopMean 'smoothed - PopMean If SmoothedYearArray(3, i - 1) <= 0 And SmoothedYearArray(3, i) > 0 Then SmoothedYearArray(4, i) = i 'first point after zero-crossing = year, all others = 0 NZeroCrossings = NZeroCrossings + 1 'count number of zero-crossings in the whole trajectory OneRunCycleSummary(1, NZeroCrossings) = i 'write 1st year after zero crossing End If Next i If NZeroCrossings < 1 Then Exit Sub ReDim Preserve OneRunCycleSummary(8, NZeroCrossings) 'fill in the OneRunCycleSummary For i = 1 To NZeroCrossings - 1 'loop through OneRunCycleSummary OneRunCycleSummary(2, i) = SummaryYearArray(3, OneRunCycleSummary(1, i)) 'max, default OneRunCycleSummary(3, i) = SummaryYearArray(1, OneRunCycleSummary(1, i)) 'year of max, default OneRunCycleSummary(4, i) = SummaryYearArray(3, OneRunCycleSummary(1, i)) 'min, default OneRunCycleSummary(5, i) = SummaryYearArray(1, OneRunCycleSummary(1, i)) 'year of min, default For j = OneRunCycleSummary(1, i) To OneRunCycleSummary(1, i + 1) - 1 'scan each cycle in SummaryYearArray for max, year of max, min, year of min If SummaryYearArray(3, j) > OneRunCycleSummary(2, i) Then OneRunCycleSummary(2, i) = SummaryYearArray(3, j) 'Max female population level in that cycle OneRunCycleSummary(3, i) = SummaryYearArray(1, j) 'year of max End If If SummaryYearArray(3, j) < OneRunCycleSummary(4, i) Then OneRunCycleSummary(4, i) = SummaryYearArray(3, j) 'Min female population level in that cycle OneRunCycleSummary(5, i) = SummaryYearArray(1, j) 'year of min End If Next j 'Rate of Decline: OneRunCycleSummary(6, i) = Abs(OneRunCycleSummary(5, i) - OneRunCycleSummary(3, i)) 'take absolute value to prevent rare negative numbers 'Percent Decline: OneRunCycleSummary(7, i) = (OneRunCycleSummary(2, i) - OneRunCycleSummary(4, i)) / OneRunCycleSummary(2, i) '(max-min)/max Next i 'fill in Periods For i = 1 To NZeroCrossings - 2 OneRunCycleSummary(8, i) = OneRunCycleSummary(5, i + 1) - OneRunCycleSummary(5, i) 'year of min - year of min Next i 'Periods BasicStats = ColumnNMeanVarMaxMin(OneRunCycleSummary, 8, 1, NZeroCrossings - 2) MultiRunStats(7, 5 + Run) = BasicStats(1) 'N Periods MultiRunStats(8, 5 + Run) = BasicStats(2) 'mean period length MultiRunStats(9, 5 + Run) = BasicStats(3) 'Var period lenth MultiRunStats(10, 5 + Run) = BasicStats(4) 'Max period length MultiRunStats(11, 5 + Run) = BasicStats(5) 'Min period lenght 'Percent Decline BasicStats = ColumnNMeanVarMaxMin(OneRunCycleSummary, 7, 1, NZeroCrossings - 1) MultiRunStats(12, 5 + Run) = BasicStats(1) 'N Percent Decline MultiRunStats(13, 5 + Run) = BasicStats(2) 'Mean Percent Decline MultiRunStats(14, 5 + Run) = BasicStats(3) 'Var Percent Decline MultiRunStats(15, 5 + Run) = BasicStats(4) 'Max Percent Decline MultiRunStats(16, 5 + Run) = BasicStats(5) 'Min Percent Decline 'RateOfDecline BasicStats = ColumnNMeanVarMaxMin(OneRunCycleSummary, 6, 1, NZeroCrossings - 1) MultiRunStats(17, 5 + Run) = BasicStats(1) 'N RateOfDecline MultiRunStats(18, 5 + Run) = BasicStats(2) 'Mean RateOfDecline MultiRunStats(19, 5 + Run) = BasicStats(3) 'Var RateOfDecline MultiRunStats(20, 5 + Run) = BasicStats(4) 'Max RateOfDecline MultiRunStats(21, 5 + Run) = BasicStats(5) 'Min RateOfDecline 'SmallScale BasicStats = ColumnNMeanVarMaxMin(SmoothedYearArray, 2, StartAnalYr, FinishAnalYr) MultiRunStats(22, 5 + Run) = BasicStats(3) 'Var absolute value of SmallScale MultiRunStats(23, 5 + Run) = BasicStats(4) 'Max absolute value of SmallScale MultiRunStats(24, 5 + Run) = BasicStats(5) 'Min absolute value of SmallScale MultiRunStats(30, 5 + Run) = BasicStats(2) 'mean absolute value of SmallScale 'CORRELOGRAM: If ExtinctionYear = 0 Then 'do correlogram only if population did not crash Nrows = CLng(FinishAnalYr - StartAnalYr) 'number of rows to compare 'Nrows = 100 'CLng(FinishAnalYr - StartAnalYr) 'number of rows to compare StartRowX = StartAnalYr For i = 0 To CorrelYrs If Run = 1 Then CorrelArray(1, i) = i 'enter year during 1st run StartRowY = StartRowX + i CorrelArray(Run + 1, i) = CorrelationCoefficient(SummaryYearArray, 3, StartRowX, SummaryYearArray, 3, StartRowY, Nrows) Next i End If 'If ExtinctionYear = 0 Or ExtinctionYear > 30 Then 'record AverageSurvF=0,AverageSurvF=0.125,AverageSurvF=0.25 For Age 1 males only '(use for calculating %ID(delta) and inbreeding load, B) k0 = 0 k1 = 0 k2 = 0 t0 = 0 t1 = 0 t2 = 0 'new section: for age-sex specific survival rates Dim k0m As Long, k1m As Long, k2m As Long, k3m As Long, k4m As Long Dim k0f As Long, k1f As Long, k2f As Long, k3f As Long, k4f As Long Dim k0ms As Long, k1ms As Long, k2ms As Long, k3ms As Long, k4ms As Long Dim k0fs As Long, k1fs As Long, k2fs As Long, k3fs As Long, k4fs As Long Dim TotNFem As Long, TotInd As Long, TotYear As Long k0m = 0: k1m = 0: k2m = 0: k3m = 0: k4m = 0 'recall that : starts a new line; this is a way to save space k0f = 0: k1f = 0: k2f = 0: k3f = 0: k4f = 0 k0ms = 0: k1ms = 0: k2ms = 0: k3ms = 0: k4ms = 0 k0fs = 0: k1fs = 0: k2fs = 0: k3fs = 0: k4fs = 0 TotNFem = 0: TotInd = 0: TotYear = 0 'Could just use analysis window (Same with InterceptAdjust), but this causes difficulties in 'adjusting the intercept if the model crashes early. In reality, this just causes rates to 'be marginally higher due to a higher portion of outbreds near t = 0 for the intercept adjust, but not here because F is a factor. 'Survival rate of Age 1 Males, F = 0, F = 0.125, F = 0.25: For q = 1 To AllYearsBirdCounter 'loop through SummarySurvArray If SummarySurvArray(4, q) = 0 And SummarySurvArray(5, q) = 1 And SummarySurvArray(3, q) = 2 Then 'survival for 1yr old males only k0 = k0 + 1 'count number of outbred birds F = 0 t0 = SummarySurvArray(13, q) + t0 'sum survival rates of outbred birds ElseIf SummarySurvArray(4, q) = 0.125 And SummarySurvArray(5, q) = 1 And SummarySurvArray(3, q) = 2 Then k1 = k1 + 1 'count number of inbred birds (kids of half sibs) F= 0.125 t1 = SummarySurvArray(13, q) + t1 'sum survival rates of inbred birds ElseIf SummarySurvArray(4, q) = 0.25 And SummarySurvArray(5, q) = 1 And SummarySurvArray(3, q) = 2 Then k2 = k2 + 1 'count number of inbred birds (kids of sibs) F = 0.25 t2 = SummarySurvArray(13, q) + t2 'sum survival rates of inbred birds End If If k0 > 0 Then MultiRunStats(38, Run + 5) = t0 / k0 'enter average survival rate for F=0 ElseIf k0 = 0 Then MultiRunStats(38, Run + 5) = 9999999999# 'enter average survival rate for F=0 End If If k1 > 0 Then MultiRunStats(39, Run + 5) = t1 / k1 'enter average survival rate for F=0.125 ElseIf k1 = 0 Then MultiRunStats(39, Run + 5) = 9999999999# 'enter average survival rate for F=0.125 End If If k2 > 0 Then MultiRunStats(40, Run + 5) = t2 / k2 'enter average survival rate for F=0.25 ElseIf k2 = 0 Then MultiRunStats(40, Run + 5) = 9999999999# 'enter average survival rate for F=0.25 End If 'new section: calculate sex-age specific survival rates and IndPerFem If SummarySurvArray(3, q) = 2 Then 'if male If SummarySurvArray(5, q) = 0 Then 'age 0 k0m = k0m + 1 If SummarySurvArray(9, q) = 1 Then k0ms = k0ms + 1 ElseIf SummarySurvArray(5, q) = 1 Then k1m = k1m + 1 If SummarySurvArray(9, q) = 1 Then k1ms = k1ms + 1 ElseIf SummarySurvArray(5, q) = 2 Then k2m = k2m + 1 If SummarySurvArray(9, q) = 1 Then k2ms = k2ms + 1 ElseIf SummarySurvArray(5, q) = 3 Then k3m = k3m + 1 If SummarySurvArray(9, q) = 1 Then k3ms = k3ms + 1 ElseIf SummarySurvArray(5, q) >= 4 Then k4m = k4m + 1 If SummarySurvArray(9, q) = 1 Then k4ms = k4ms + 1 End If ElseIf SummarySurvArray(3, q) = 1 Then 'if female If SummarySurvArray(5, q) = 0 Then 'age 0 k0f = k0f + 1 If SummarySurvArray(9, q) = 1 Then k0fs = k0fs + 1 ElseIf SummarySurvArray(5, q) = 1 Then k1f = k1f + 1 If SummarySurvArray(9, q) = 1 Then k1fs = k1fs + 1 ElseIf SummarySurvArray(5, q) = 2 Then k2f = k2f + 1 If SummarySurvArray(9, q) = 1 Then k2fs = k2fs + 1 ElseIf SummarySurvArray(5, q) = 3 Then k3f = k3f + 1 If SummarySurvArray(9, q) = 1 Then k3fs = k3fs + 1 ElseIf SummarySurvArray(5, q) >= 4 Then k4f = k4f + 1 If SummarySurvArray(9, q) = 1 Then k4fs = k4fs + 1 End If End If If SummarySurvArray(5, q) > 0 And SummarySurvArray(3, q) = 1 Then 'if adult female TotNFem = TotNFem + 1 'sum all female-years TotInd = TotInd + SummarySurvArray(6, q) 'sum all independents produced End If Next q 'how many years does the SummaryYearArray cover? TotYear = SummarySurvArray(1, AllYearsBirdCounter) 'year value of last entry If k0m <> 0 Then MultiRunStats(41, Run + 5) = k0ms / k0m 'Surv Age 0 males If k1m <> 0 Then MultiRunStats(42, Run + 5) = k1ms / k1m 'Surv Age 0 males If k2m <> 0 Then MultiRunStats(43, Run + 5) = k2ms / k2m 'Surv Age 0 males If k3m <> 0 Then MultiRunStats(44, Run + 5) = k3ms / k3m 'Surv Age 0 males If k4m <> 0 Then MultiRunStats(45, Run + 5) = k4ms / k4m 'Surv Age 0 males If k0f <> 0 Then MultiRunStats(46, Run + 5) = k0fs / k0f 'Surv Age 0 females If k1f <> 0 Then MultiRunStats(47, Run + 5) = k1fs / k1f 'Surv Age 0 females If k2f <> 0 Then MultiRunStats(48, Run + 5) = k2fs / k2f 'Surv Age 0 females If k3f <> 0 Then MultiRunStats(49, Run + 5) = k3fs / k3f 'Surv Age 0 females If k4f <> 0 Then MultiRunStats(50, Run + 5) = k4fs / k4f 'Surv Age 0 females MultiRunStats(51, Run + 5) = TotNFem 'total number of adult females in all years MultiRunStats(52, Run + 5) = TotInd 'total number of independents produced in all years MultiRunStats(53, Run + 5) = TotYear + 1 'number of years run. Add 1 for year 0. MultiRunStats(54, Run + 5) = TotNFem / TotYear 'Average number of females MultiRunStats(55, Run + 5) = TotInd / TotNFem 'average number of independents produced per female MultiRunStats(56, Run + 5) = TotInd / TotNFem + 0.04747 * (TotNFem / TotYear) 'intercept for IndPerFem (Average number of independents per female at NFem = 0) MultiRunStats(57, Run + 5) = k0ms / k0m + 0.0048 * (TotNFem / TotYear) 'male intercept for DD recruitment (Average recruitment rate at NFem = 0) MultiRunStats(58, Run + 5) = k0fs / k0f + 0.0048 * (TotNFem / TotYear) 'female intercept for DD recruitment MultiRunStats(59, Run + 5) = TotInd / (TotYear + 1) 'average number of independents per year End Sub Sub MultiRunAverage() Dim j As Integer, Mean As Double, i As Integer, NCrashed As Integer Dim SumYearsCrashed As Double, RealFinishAnalYr As Integer For j = 2 To 24 BasicStats = ColumnNMeanVarMaxMin(MultiRunStats, j, 6, 5 + NRuns) MultiRunStats(j, 1) = BasicStats(1) 'N MultiRunStats(j, 2) = BasicStats(2) 'Mean MultiRunStats(j, 3) = BasicStats(3) 'Var MultiRunStats(j, 4) = BasicStats(4) 'Max MultiRunStats(j, 5) = BasicStats(5) 'Min Next j For j = 27 To 59 '25th, 50th, 75th percentiles, MeanSmallScale BasicStats = ColumnNMeanVarMaxMin(MultiRunStats, j, 6, 5 + NRuns) MultiRunStats(j, 1) = BasicStats(1) 'N MultiRunStats(j, 2) = BasicStats(2) 'Mean MultiRunStats(j, 3) = BasicStats(3) 'Var MultiRunStats(j, 4) = BasicStats(4) 'Max MultiRunStats(j, 5) = BasicStats(5) 'Min Next j 'population size at RealFinishAnalYr BasicStats = ColumnNMeanVarMaxMin(MultiRunStats, 26, 6, 5 + NRuns) MultiRunStats(26, 1) = BasicStats(1) 'N MultiRunStats(26, 2) = BasicStats(2) 'Mean MultiRunStats(26, 3) = BasicStats(3) 'Var MultiRunStats(26, 4) = BasicStats(4) 'Max MultiRunStats(26, 5) = BasicStats(5) 'Min RealFinishAnalYr = Val(Form1.Text9.Text) 'Population number at planned FinishAnalYr from Form NCrashed = 0 SumYearsCrashed = 0 For i = 6 To 5 + NRuns If 0 < MultiRunStats(25, i) And MultiRunStats(25, i) <= RealFinishAnalYr Then 'if the population crashed in the analysis window NCrashed = NCrashed + 1 SumYearsCrashed = SumYearsCrashed + MultiRunStats(25, i) End If Next i MultiRunStats(25, 1) = NCrashed 'number of runs which crashed from y = 0 to RealFinishAnalYr If NCrashed > 0 Then MultiRunStats(25, 2) = SumYearsCrashed / NCrashed 'mean year of crashes End If Form1.Text6.Text = MultiRunStats(3, 2) 'mean pop mean Form1.Text30.Text = MultiRunStats(4, 2) 'mean pop Var Form1.Text7.Text = MultiRunStats(8, 2) 'mean period length Form1.Text27.Text = MultiRunStats(13, 2) 'mean % decline Form1.Text28.Text = MultiRunStats(18, 2) 'mean rate of decline Form1.Text29.Text = MultiRunStats(25, 1) / NRuns '% of runs crashed End Sub Sub GraphIt() 'graph data in SummaryYearArray Dim i As Integer, InitFile As String, MandarteTraj() As Integer, junk As String, Cutoff As Double Dim ChanceSevere As Double Call InitGraphII(Form1.Picture1, 0#, CDbl(NYrs), 0#, 100#) 'population, top of Y-axis shows 80 birds Call InitGraphII(Form1.Picture2, 0#, CDbl(NYrs), 0#, 5#) 'immigration, top of Y-axis shows 5 immigrants Call InitGraphII(Form1.Picture3, 0#, CDbl(NYrs), 0#, 1#) 'winter stress, top of Y-axis shows stress of 1 Call InitGraphII(Form1.Picture5, 0#, CDbl(CorrelYrs), -1#, 1#) 'correlogram, X-axis is 0 to 30 years, Y-axis is r-value(-1 to 1) For i = 0 To (NYrs - 1) Form1.Picture1.Line (i, SummaryYearArray(2, i))-(i + 1, SummaryYearArray(2, i + 1)), RGB(0, 0, 200) 'males Form1.Picture1.Line (i, SummaryYearArray(3, i))-(i + 1, SummaryYearArray(3, i + 1)), RGB(200, 0, 0) 'females Form1.Picture2.DrawWidth = 1.5 Form1.Picture2.Line (i, SummaryYearArray(15, i))-(i + 1, SummaryYearArray(15, i + 1)), RGB(200, 0, 0) 'female immigrants Form1.Picture2.DrawWidth = 1 Form1.Picture2.Line (i, SummaryYearArray(16, i))-(i + 1, SummaryYearArray(16, i + 1)), RGB(0, 0, 200) 'male immigrants Form1.Picture3.Line (i, SummaryYearArray(11, i))-(i + 1, SummaryYearArray(11, i + 1)), RGB(200, 0, 170) 'winter stress Form1.Picture3.Line (i, SummaryYearArray(12, i))-(i + 1, SummaryYearArray(12, i + 1)), RGB(85, 85, 150) 'FAveFall - average Fcoef in fall Form1.Picture3.Line (i, SummaryYearArray(13, i))-(i + 1, SummaryYearArray(13, i + 1)), RGB(0, 200, 0) 'FAveAfterWinter - average Fcoef in spring Form1.Picture1.Line (i, 100 * SummaryYearArray(12, i))-(i + 1, 100 * SummaryYearArray(12, i + 1)), RGB(85, 85, 150) 'FAveFall - average Fcoef in fall Form1.Picture1.Line (i, 100 * SummaryYearArray(13, i))-(i + 1, 100 * SummaryYearArray(13, i + 1)), RGB(0, 200, 0) 'FAveAfterWinter - average Fcoef in spring Next i For i = 0 To (CorrelYrs - 1) If CorrelArray(2, i) = 9999999999# Then Exit For ElseIf CorrelArray(2, i) <> 9999999999# Then Form1.Picture5.Line (i, CorrelArray(2, i))-(i + 1, CorrelArray(2, i + 1)), RGB(100, 0, 100) ' Correlogram for 1st run End If Next i If Form1.Check1.Value = Checked Then 'put Mandarte population trajectory in Picture1 for comparison ReDim MandarteTraj(3, 28) 'year, male, female, by 28 years of data i = 1 InitFile = CurDir + "\MandarteTrajectory.txt" Open InitFile For Input As 1 Line Input #1, junk For i = 1 To 28 Input #1, MandarteTraj(1, i), MandarteTraj(2, i), MandarteTraj(3, i) 'year, females, males Next i Close 1 For i = 1 To 27 Form1.Picture1.DrawWidth = 2 Form1.Picture1.Line (i, MandarteTraj(2, i))-(i + 1, MandarteTraj(2, i + 1)), RGB(230, 0, 1) 'females Form1.Picture1.Line (i, MandarteTraj(3, i))-(i + 1, MandarteTraj(3, i + 1)), RGB(0, 0, 230) 'males Next i End If End Sub Sub ExportSummary() Dim Outfile As String, i As Long, j As Integer, q As Long If Form1.Check5.Value = Checked Then If Run <= 6 Then 'only create SummaryYearArray and SummarySurvArray for 1st 6 runs Outfile = CurDir + "\" + "Output" + "\" + "SummaryYearArray" & Run & ".csv" 'or ".txt" 'makes a file for each run of the model Open Outfile For Output As 1 Write #1, "Year", "NMales", "NFemales", "NTerr", "NPaired", "NSingle", "NFloater", "NImm", "NInd", "NRec", "Winter", "FAveFall", "FAveAfterWinter", "WinterMortality", "FemImm", "MaleImm", "FAveImm", "Suseptible", "FAveBreeders", "FAveFall-FAveAfterWinter", "SurvM0", "SurvM1", "SurvM2", "SurvM3", "SurvM4+", "SurvF0", "SurvF1", "SurvF2", "SurvF3", "SurvF4+", "TotM0", "TotM1", "TotM2", "TotM3", "TotM4+", "TotF0", "TotF1", "TotF2", "TotF3", "TotF4+" For i = 0 To NYrs For j = 1 To 40 Write #1, SummaryYearArray(j, i); Next j Write #1, Next i Close 1 q = UBound(SummarySurvArray, 2) Outfile = CurDir + "\" + "Output" + "\" + "SummarySurvArray" & Run & ".csv" 'or ".txt" Open Outfile For Output As 2 Write #2, "Year", "BirdID", "Sex", "Fcoef", "Age", "IndPrFem", "RecPrFem", "Catagory", "Survd", "Immig", "SireID", "DamID", "YrSurvRate", "Wstress", "NFem" For i = 1 To q For j = 1 To 15 Write #2, SummarySurvArray(j, i); Next j Write #2, Next i Close 2 End If End If If NRuns = 1 Then Outfile = CurDir + "\" + "Output" + "\" + "Correlogram" & ".csv" Open Outfile For Output As 3 Write #3, "Year", "r-value" For i = 0 To CorrelYrs 'row For j = 1 To 2 'column Write #3, CorrelArray(j, i); Next j Write #3, Next i Close 3 End If End Sub Sub ExportMultiRunSummary() Dim Outfile As String, i As Integer, j As Integer, NNruns As Integer 'export MultiRunStats Outfile = CurDir + "\" + "Output" + "\" + "MultRunStats" & Format(ParamValue, "0.000") & ".csv" 'or ".txt" Open Outfile For Output As 4 'Write #1, Outfile Write #4, "Run", "YearsRun", "PopMean", "PopVar", "PopMax", "PopMin", "NPeriods", "MeanPeriods", "VarPeriods", "MaxPeriod", "MinPeriod", "N%Decline", "Mean%Decline", "Var%Decline", "Max%Decline", "Min%Decline", "NRateOfDecline", "MeanRateOfDecline", "VarRateOfDecline", "MaxRateOfDecline", "MinRateOfDecline", "VarSmallScale", "MaxSmallScale", "MinSmallScale", "ExtinctionYear", "FinalPopSize", "25thPercentile", "Median", "75thPercentile", "MeanSmallScale", "AveFAveAfterWinter", "VarFAveAfterWinter", "MaxFAveAfterWinter", "AveFAveFall-AfterWinter", "VarFAveFall-AfterWinter", "MaxFAveFall - AfterWinter", "AveFAveFall", "AveSurvF=0", "AveSurvF=0.125", "AveSurvF=0.25", "SurvM0", "SurvM1", "SurvM2", "SurvM3", "SurvM4+", "SurvF0", "SurvF1", "SurvF2", "SurvF3", "SurvF4+", "TotNFem", "TotInd", "TotYear", "AveNFem", "AveIndPerFem", "InterceptIndPerFem", "InterceptSurvM0", "InterceptSurvF0", "AveIndPerYear" For i = 1 To 5 + NRuns 'rows For j = 1 To 59 'columns Write #4, MultiRunStats(j, i); Next j Write #4, Next i Close 4 If NRuns > 1 Then Outfile = CurDir + "\" + "Output" + "\" + "Correlogram" & Format(ParamValue, "0.000") & ".csv" Open Outfile For Output As 5 Write #5, "Year", "r-value1", "r-value2", "r-value3" For i = 0 To CorrelYrs 'row For j = 1 To NRuns + 1 'column Write #5, CorrelArray(j, i); Next j Write #5, Next i Close 5 Outfile = CurDir + "\" + "Output" + "\" + "MultiRunTrajectory" & Format(ParamValue, "0.000") & ".csv" Open Outfile For Output As 6 Write #6, "Year", "NFem-1", "NFem-2", "NFem-3" For i = 1 To NYrs 'row For j = 1 To NRuns + 1 'column Write #6, MultiRunTrajectory(j, i); Next j Write #6, Next i Close 6 End If End Sub Function GetRandom(ByVal iLo As Long, ByVal iHi As Long) As Long 'returns a random integer between two integers 'if both numbers are the same, it just spits back the number GetRandom = Int(iLo + (Rnd * (iHi - iLo + 1))) End Function Function ColumnNMeanVarMaxMin(ByRef MyArray() As Double, ByVal ColumnNumber As Integer, ByVal StartRow As Integer, ByVal EndRow As Integer) As Double() 'shows that function returns an array Dim i As Integer, N As Double, Mean As Double, Var As Double, Max As Double, Min As Double Dim SumX As Double, SumX2 As Double, Results() As Double 'Std As Double, 'This function calculates the data count (N), Mean, Variance, Max and Min for a column. It does 'not include then number 9999999999# in calculations. Blank arrays should be filled with 9999999999# 'to avoid having zeros incorrectly incorporated into averages etc. If StartRow > EndRow Then 'problem with input data N = 0 Mean = 9999999999# Var = 9999999999# Max = 9999999999# Min = 9999999999# ElseIf StartRow <= EndRow Then SumX = 0 SumX2 = 0 N = 0 Mean = 0 Var = 0 For i = StartRow To EndRow If MyArray(ColumnNumber, i) <> 9999999999# Then Max = MyArray(ColumnNumber, i) Min = MyArray(ColumnNumber, i) Exit For End If Next i For i = StartRow To EndRow If MyArray(ColumnNumber, i) <> 9999999999# Then SumX = SumX + MyArray(ColumnNumber, i) SumX2 = SumX2 + MyArray(ColumnNumber, i) * MyArray(ColumnNumber, i) N = N + 1 If MyArray(ColumnNumber, i) > Max Then Max = MyArray(ColumnNumber, i) If MyArray(ColumnNumber, i) < Min Then Min = MyArray(ColumnNumber, i) End If Next i If N = 0 Then 'can't get any stats if the entire column is blank (ie filled with 9999999999) Var = 9999999999# Mean = 9999999999# Max = 9999999999# Min = 9999999999# ElseIf N = 1 Then Var = 9999999999# 'cant do Var of a single value (dividing by zero) Mean = MyArray(ColumnNumber, StartRow) ElseIf N > 1 Then Mean = SumX / N 'Std = Sqr((SumX2 - SumX * SumX / N) / (N - 1)) Var = (SumX2 - SumX * SumX / N) / (N - 1) End If End If ReDim Results(5) Results(1) = N Results(2) = Mean Results(3) = Var Results(4) = Max Results(5) = Min ColumnNMeanVarMaxMin = Results End Function Function CorrelationCoefficient(ByRef MyXArray() As Double, ByVal ColumnX As Double, ByVal StartRowX As Integer, ByRef MyYArray() As Double, ByVal ColumnY As Double, ByVal StartRowY As Double, ByVal Rows As Long) As Double 'Syntax: 'CorrelationCoefficient(RawDataX, ColumnX,StartRowX, RawDataY, ColumnY, StartRowY, Number of Rows) 'calculates the corelation coefficient from RawData(X, N) against RawData(Y, N) Dim i As Integer Dim SumX As Double Dim SumX2 As Double Dim SumY As Double Dim SumY2 As Double Dim SumXY As Double Dim SumW As Double Dim Numerator As Double Dim Denominator As Double 'On Error GoTo ErrHandler_CorCoef 'initialise SumX = 0 SumX2 = 0 SumY = 0 SumY2 = 0 SumXY = 0 For i = 0 To Rows - 1 SumX = SumX + MyXArray(ColumnX, StartRowX + i) SumX2 = SumX2 + MyXArray(ColumnX, StartRowX + i) * MyXArray(ColumnX, StartRowX + i) SumY = SumY + MyYArray(ColumnY, StartRowY + i) SumY2 = SumY2 + MyYArray(ColumnY, StartRowY + i) * MyYArray(ColumnY, StartRowY + i) SumXY = SumXY + MyXArray(ColumnX, StartRowX + i) * MyYArray(ColumnY, StartRowY + i) Next i 'calculate Numerator and Denominator from correlation coefficient Numerator = SumXY - (SumX * SumY) / Rows Denominator = Sqr((SumX2 - SumX * SumX / Rows) * (SumY2 - SumY * SumY / Rows)) If Denominator = 0 Then CorrelationCoefficient = 0 ElseIf Denominator <> 0 Then CorrelationCoefficient = Numerator / Denominator End If Exit Function 'ErrHandler_CorCoef: ' MsgBox "Error in module CorrelationCoefficient!", vbOKOnly & vbExclamation, "Attention!" End Function Function ArraySorter(ByRef UnsortedArray() As Double, SortColumn As Integer) 'sorts Double arrays 'Dont change the original array, just create a new sorted one. Dim Gap As Integer, Doneflag As Integer, SwapArray() As Double Dim Index As Integer, Col As Integer, SortedArray() As Double 'dimension SwapArray and SortedArray (output) same as UnsortedArray (input) ReDim SwapArray(UBound(UnsortedArray, 1), UBound(UnsortedArray, 2)) ' # column in TestArray, # rows in TestArray ReDim SortedArray(UBound(UnsortedArray, 1), UBound(UnsortedArray, 2)) ' # column in TestArray, # rows in TestArray SortedArray = UnsortedArray 'Work with a copy of UnsortedArray 'Gap is initally half the records, then Gap is halved, and halved again etc. Gap = Int(UBound(UnsortedArray, 2) / 2) 'if total row=9, gap = 4, if total rows=6, gap=3 Do While Gap >= 1 Do Doneflag = 1 For Index = 1 To (UBound(SortedArray, 2) - Gap) 'Compare 1st 1/2 to 2nd 1/2 If SortedArray(SortColumn, Index) > SortedArray(SortColumn, (Index + Gap)) Then 'swap by writing to swap array For Col = 1 To UBound(SwapArray, 1) 'go through columns 'write to SwapArray SwapArray(Col, Index) = SortedArray(Col, Index) SwapArray(Col, Index + Gap) = SortedArray(Col, Index + Gap) Next For Col = 1 To UBound(SwapArray, 1) 'Write back to SortedArray swapped SortedArray(Col, Index) = SwapArray(Col, Index + Gap) SortedArray(Col, Index + Gap) = SwapArray(Col, Index) Next Doneflag = 0 'if you switched rows, reset doneflag to 0 End If Next 'inefficient - loops an extra time! Maybe necessary. Loop Until Doneflag = 1 'loops until it has gone through with that gap size and not made any changes Gap = Int(Gap / 2) Loop ArraySorter = SortedArray End Function Sub InitGraphII(pic As PictureBox, minX As Double, maxX As Double, minY As Double, maxY As Double) 'Initializes a graph by drawing axes 'If overlay = False Then pic.Cls pic.Scale ((minX - 0.02 * (maxX - minX)), (maxY + 0.05 * (maxY - minY)))-((maxX + 0.02 * (maxX - minX)), (minY - 0.05 * (maxY - minY))) 'top left to bottom right pic.DrawWidth = 1 pic.Line (minX, 0)-(maxX, 0), RGB(0, 0, 255) 'draws axes, RedGreenBlue color scale pic.Line (0, minY)-(0, maxY), RGB(0, 0, 255) pic.DrawWidth = 1 'pic.Circle (maxX / 2, maxY / 2), 1 End Sub 'THE FOLLOWING REGRESSION FX IS NOT USED IN THE MODEL, BUT IS FUNCTIONING CODE Function LinearRegression(ByRef MyXArray() As Double, ByVal ColumnX As Double, ByVal StartRowX As Integer, ByRef MyYArray() As Double, ByVal ColumnY As Double, ByVal StartRowY As Double, ByVal Rows As Long) As Double() Dim Results() As Double, CorCoef As Double, LRIntercept As Double, LRSlope As Double 'Syntax: 'CorrelationCoefficient(RawDataX, ColumnX,StartRowX, RawDataY, ColumnY, StartRowY, Number of Rows) 'calculates the corelation coefficient from RawData(X, N) against RawData(Y, N) Dim i As Long Dim SumX As Double Dim SumX2 As Double Dim SumY As Double Dim SumY2 As Double Dim SumXY As Double Dim SumW As Double Dim Numerator As Double Dim Denominator As Double 'On Error GoTo ErrHandler_CorCoef 'initialise SumX = 0 SumX2 = 0 SumY = 0 SumY2 = 0 SumXY = 0 For i = 0 To Rows - 1 SumX = SumX + MyXArray(ColumnX, StartRowX + i) SumX2 = SumX2 + MyXArray(ColumnX, StartRowX + i) * MyXArray(ColumnX, StartRowX + i) SumY = SumY + MyYArray(ColumnY, StartRowY + i) SumY2 = SumY2 + MyYArray(ColumnY, StartRowY + i) * MyYArray(ColumnY, StartRowY + i) SumXY = SumXY + MyXArray(ColumnX, StartRowX + i) * MyYArray(ColumnY, StartRowY + i) Next i 'calculate Numerator and Denominator from correlation coefficient Numerator = SumXY - (SumX * SumY) / Rows Denominator = Sqr((SumX2 - SumX * SumX / Rows) * (SumY2 - SumY * SumY / Rows)) LRSlope = Numerator / (SumX2 - SumX * SumX / Rows) LRIntercept = SumY / Rows - LRSlope * SumX / Rows If Denominator = 0 Then CorCoef = 0 ElseIf Denominator <> 0 Then CorCoef = Numerator / Denominator End If ReDim Results(3) Results(1) = CorCoef Results(2) = LRIntercept Results(3) = LRSlope LinearRegression = Results Exit Function