Attribute VB_Name = "modMainSELDM" Option Compare Database Option Explicit ' Makes the programmer declare all variables Option Base 0 ' Explicitly sets the lower bound of arrays to zero Dim lngTotalNumberofStorms As Long ' Total Number of Storms in an analysis ' Upstream flow duration ' Highway Runoff duration ' Highway Runoff with BMP duration ' *************** BMP Stats Redim Arrays to lngTotalNumberofStorms ************** Dim dURNBMPFlowReduction() As Double ' Uniform Random Number BMP flow reduction Dim dBMPOutFlow() As Double ' BMP Outflow Volume Dim dURNBMPOutFlowExtension() As Double ' Uniform Random Number for BMP Outflow hydrograph extension Public Sub MainSELDM(lngNumberofYears As Long, lngNumberOfStorms As Long, lngMasterSeed As Long, _ lngSeedSequence As Long, intWhat As Integer, intPP As Integer, intSELDMErr As Integer) ' ' Purpose: To run the SELDM Analysis and generate the output ' History: 01/15/2009 by Gregory E. Granato ' Arguments: ' lngNumberofYears As Long ' Total Number of Years in an analysis ' lngNumberOfStorms As Long ' Total Number of storms in an analysis ' lngMasterSeed As Long ' Master random seed ' lngSeedSequence As Long ' Master random seed sequence number ' intwhat As Integer What are we doing 0 highway only 1 Stream Basin Output, 2 Stream and Lake Basin Output, 3 Lake Only ' intPP As Integer plotting-position formula 0:Blom 1:Cunnane 2:Gringorten 3:Hazen 4:Median 5:Weibull ' intSELDMErr As Integer problem flag ' Dim bCheckMe As Boolean Dim strMsgStr As String Dim lngStepNumber As Long ' Index number of current step Dim intErr As Integer Dim lngStep As Long Dim lngSteps As Long Dim strStatus As String Dim intHighwayQWCheck As Integer ' Sum highway QW error = 1 codes Dim intUpstreamQWCheck As Integer ' Sum Upstream QW error = 1 codes Dim strSeed As String On Error GoTo MainSELDM_Err: intSELDMErr = 0 intErr = 0 lngStepNumber = 0 If intWhat = 0 Then lngSteps = 11 ElseIf intWhat = 1 Or intWhat = 2 Then lngSteps = 14 Else lngSteps = 11 End If '***************** Empty All Output Tables **************************** 'Step 1 lngStepNumber = lngStepNumber + 1 strStatus = "Clearing Output Tables" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 5, 100, "tbStatus", strStatus, 200) Call EmptyOutPutTables(intErr) If intErr > 0 Then intSELDMErr = CInt(lngStepNumber * 1000) + intErr 'Empty Output Tables error Exit Sub End If '***************** Initialize Random Seed Sequence Number ************* ' Get Master Seed 'Step 2 lngStepNumber = lngStepNumber + 1 strStatus = "Initialize Random Seed Sequence Number" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 10, 100, "tbStatus", strStatus, 200) lngMasterSeed = fnlngGetAnalysisMasterSeed(lMyAnalysis) bCheckMe = fnbIsSeedIDinTable(lngMasterSeed) If bCheckMe = False Then intSELDMErr = CInt(lngStepNumber * 10) ' 2: Random seed error Exit Sub End If '***************** Calculate The Minimum Number of Storms ************************* 'Step 3 lngStepNumber = lngStepNumber + 1 strStatus = "Calculate The Minimum Number of Storms" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 15, 100, "tbStatus", strStatus, 200) lngNumberOfStorms = fnLngMinNumberOfStorms(lMyAnalysis) If lngNumberOfStorms <= 0 Then intSELDMErr = CInt(lngStepNumber * 10) ' 3: Number of storms error Exit Sub End If Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, lngStepNumber, lngSteps, "tbStatus", strStatus, 200) '***************** Get/Set Precipitation-Event Statistics ************************* 'Step 4 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Precipitation-Event Statistics" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 20, 100, "tbStatus", strStatus, 200) lngSeedSequence = 0 Call GenerateStorms(lngMasterSeed, lngSeedSequence, lngNumberOfStorms, lngNumberofYears, intErr) If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If ' ** Get plotting positions strSeed = "Storms: " & lngSeedSequence & vbCrLf ' ** Get plotting positions Call SetPlottingPosition("dPrecipitationDelta", "dPrecipitationDeltaPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dPrecipitationVolume", "dPrecipitationVolumePP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dPrecipitationDuration", "dPrecipitationDurationPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) '***************** Get/Set PreStorm Streamflows ************************* 'Step 5 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set PreStorm Streamflows" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 25, 100, "tbStatus", strStatus, 200) Call GeneratePreStormQs(lngMasterSeed, lngSeedSequence, lngNumberOfStorms, intErr) If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If strSeed = strSeed & "Pre-Storm Q: " & lngSeedSequence & vbCrLf ' ** Get plotting positions Call SetPlottingPosition("dUpstreamFlowRate", "dUpstreamFlowRatePP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) '***************** Get/Set Total Highway & Basin Runoff ************************* 'Step 6 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Highway and Upstream Basin Runoff Flows" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 30, 100, "tbStatus", strStatus, 200) Call GenerateTotalRunoff(lngMasterSeed, lngSeedSequence, lngNumberOfStorms, intErr) strSeed = strSeed & "GenerateTotalRunoff: " & lngSeedSequence & vbCrLf ' ** Get plotting positions Call SetPlottingPosition("dUpstreamRunoff", "dUpstreamRunoffPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dHighwayRunoff", "dHighwayRunoffPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dStormRvUpstream", "dStormRvUpstreamPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dStormRvHighway", "dStormRvHighwayPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) '***************** BMP Flow Reduction ************************* 'Step 7 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set BMP Volume Reduction" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 35, 100, "tbStatus", strStatus, 200) Call GenerateBMPRunoff(lngMasterSeed, lngSeedSequence, lngNumberOfStorms, intErr) strSeed = strSeed & "GenerateBMPRunoff: " & lngSeedSequence & vbCrLf If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If ' ** Get plotting positions Call SetPlottingPosition("dHighwayBMPDischarge", "dHighwayBMPDischargePP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) '***************** Populate Concurrent Runoff Statistics ************************* 'Step 8 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Concurrent Runoff Volumes" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 40, 100, "tbStatus", strStatus, 200) Call GenerateConcurrentRunoff(lngMasterSeed, lngSeedSequence, lngNumberOfStorms, intErr) strSeed = strSeed & "GenerateConcurrentRunoff: " & lngSeedSequence & vbCrLf If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If ' ** Get plotting positions Call SetPlottingPosition("dUpstreamStormDischarge", "dUpstreamStormDischargePP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dUpstreamConcurrentFlow", "dUpstreamConcurrentFlowPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dDilutionFactor", "dDilutionFactorPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dBMPDilutionFactor", "dBMPDilutionFactorPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) Call SetPlottingPosition("dUpstreamBMPConcurrentQ", "dUpstreamBMPConcurrentQPP", "tblOutputStormEvent", lngNumberOfStorms, intPP, True, False) '***************** Populate Lake Streamflows? If so reserve Seed ************************* If bIsLakeBasin = True Then ' Reserve lngSeedSequence = For Lake Basin Flux Volumes (daily Streamflows) lngSeedSequence = lngSeedSequence + 1 strSeed = strSeed & "Reserve Lake: " & lngSeedSequence & vbCrLf End If '***************** Populate Highway Runoff Concentrations ************************* intHighwayQWCheck = 0 ' Sum highway QW error = 1 codes '***************** Populate Random Highway Runoff Concentrations ************************* 'Step: 9 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Random Highway Runoff Concentrations and Loads" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 45, 100, "tbStatus", strStatus, 200) Call GenerateRandomQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 0, intErr) strSeed = strSeed & "GenerateRandomQW (Hwy): " & lngSeedSequence & vbCrLf If intErr = 1 Then ' No random values this can be ok intHighwayQWCheck = intHighwayQWCheck + 1 ElseIf intErr > 1 Then intHighwayQWCheck = intHighwayQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If '***************** Populate dependent highway-runoff water-quality concentrations ************************* 'Step: 10 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Dependent Highway-Runoff Concentrations and Loads" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 50, 100, "tbStatus", strStatus, 200) Call GenerateDependentCurveQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 0, intErr) strSeed = strSeed & "GenerateDependentCurveQW (Hwy): " & lngSeedSequence & vbCrLf If intErr = 1 Then ' No dependent values this can be ok intHighwayQWCheck = intHighwayQWCheck + 1 ElseIf intErr > 1 Then intHighwayQWCheck = intHighwayQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If If intHighwayQWCheck = 2 Then ' No random or dependent values this cannot be ok intSELDMErr = 170 Exit Sub Else ' ** Get highay water-quality output plotting positions Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dRunoffConcentration", "dRunoffConcentrationPP", _ "tblOutputHighwayQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dRunoffLoad", "dRunoffLoadPP", _ "tblOutputHighwayQW", lngNumberOfStorms, intPP, True, False) ' ** Get BMP discharge water-quality output plotting positions Call GetBMPWaterQuality(lMyAnalysis, lngMasterSeed, lngSeedSequence, lngNumberOfStorms, intErr) ' ** Get BMP discharge water-quality output plotting positions Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dDischargeConcentration", "dDischargeConcentrationPP", _ "tblOutputHighwayQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dDischargeLoad", "dDischargeLoadPP", _ "tblOutputHighwayQW", lngNumberOfStorms, intPP, True, False) End If '***************** Calculate Annual Highway-Runoff Values ************************* 'Step: 11 Call GetAnnualHighwayLoads(lngNumberofYears, intPP, intErr) If intWhat = 0 Or intWhat = 3 Then '****** Finalize Bar/Message ********** strStatus = "Done" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 55, 100, "tbStatus", strStatus, 200) Exit Sub End If '***************** Populate Upstream Runoff Concentrations ************************* intUpstreamQWCheck = 0 ' Sum Upstream QW error = 1 codes '***************** Populate Random Upstream Runoff Concentrations ************************* 'Step: 12 strStatus = "Get/Set Random Upstream Runoff Concentrations and Loads" lngStepNumber = lngStepNumber + 1 Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 60, 100, "tbStatus", strStatus, 200) Call GenerateRandomQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 1, intErr) strSeed = strSeed & "GenerateRandomQW (US): " & lngSeedSequence & vbCrLf If intErr = 1 Then ' No random values this can be ok intUpstreamQWCheck = intUpstreamQWCheck + 1 ElseIf intErr > 1 Then intUpstreamQWCheck = intUpstreamQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If '***************** Populate Upstream Transport Curve Runoff Concentrations ************************* 'Step: 13 strStatus = "Get/Set Upstream Water-Quality Transport-Curve Concentrations and Loads" lngStepNumber = lngStepNumber + 1 Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 65, 100, "tbStatus", strStatus, 200) Call GenerateDependentCurveQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 1, intErr) strSeed = strSeed & "Transport Curve (US): " & lngSeedSequence & vbCrLf If intErr = 1 Then ' No Transport Curve values this can be ok intUpstreamQWCheck = intUpstreamQWCheck + 1 ElseIf intErr > 1 Then intUpstreamQWCheck = intUpstreamQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If '***************** Populate Upstream Dependent Concentrations ************************* 'Step: 14 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Upstream Dependent Runoff Concentrations and Loads" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 70, 100, "tbStatus", strStatus, 200) Call GenerateDependentCurveQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 2, intErr) strSeed = strSeed & "Dependent Concentrations (US): " & lngSeedSequence & vbCrLf If intErr = 1 Then ' No Dependent values this can be ok intUpstreamQWCheck = intUpstreamQWCheck + 1 ElseIf intErr > 1 Then intUpstreamQWCheck = intUpstreamQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If If intUpstreamQWCheck = 3 Then ' No random, Transport Curve, or Dependent values this cannot be ok intSELDMErr = 180 Exit Sub Else ' ***************** Get Upstream water-quality output plotting positions ***************** Call SetQWPlottingPosition("UpstreamWaterQuality_ID", "dConcurrentConcentration", "dConcurrentConcentrationPP", _ "tblOutputUpstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("UpstreamWaterQuality_ID", "dConcurrentLoad", "dConcurrentLoadPP", _ "tblOutputUpstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("UpstreamWaterQuality_ID", "dConcurrentBMPLoad", "dConcurrentBMPLoadPP", _ "tblOutputUpstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("UpstreamWaterQuality_ID", "dTotalConcentration", "dTotalConcentrationPP", _ "tblOutputUpstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("UpstreamWaterQuality_ID", "dTotalLoad", "dTotalLoadPP", _ "tblOutputUpstreamQW", lngNumberOfStorms, intPP, True, False) End If '***************** Populate Downstream Concentrations ************************* 'Step: 15 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Downstream Concentrations and Loads" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 75, 100, "tbStatus", strStatus, 200) Call GenerateDownstreamQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, intErr) strSeed = strSeed & "GenerateDownstreamQW (US): " & lngSeedSequence & vbCrLf If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dConcentration", "dConcentrationPP", _ "tblOutputDownstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dAEConcentration", "dAEConcentrationPP", _ "tblOutputDownstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dDownstreamStormQ", "dDownstreamStormQPP", _ "tblOutputDownstreamQW", lngNumberOfStorms, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dLoad", "dLoadPP", _ "tblOutputDownstreamQW", lngNumberOfStorms, intPP, True, False) '****** Finalize Bar/Message ********** strStatus = "Finished Storm-Event Analysis" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 80, 100, "tbStatus", strStatus, 200) Exit Sub MainSELDM_Err: intSELDMErr = -9999 MsgBox Err.Description, vbCritical, "Main SELDM Module Error:" Exit Sub End Sub Public Sub SELDMLake(lngNumberofYears As Long, lngNumberOfStorms As Long, lngMasterSeed As Long, _ lngSeedSequence As Long, intPP As Integer, intSELDMErr As Integer) ' ' Purpose: To run the SELDM Analysis and generate the output ' History: 01/15/2009 by Gregory E. Granato ' Arguments: ' lngNumberofYears As Long ' Total Number of Years in an analysis ' lngNumberOfStorms As Long ' Total Number of storms in an analysis ' lngMasterSeed As Long ' Master random seed ' lngSeedSequence As Long ' Master random seed sequence number ' intPP As Integer plotting-position formula 0:Blom 1:Cunnane 2:Gringorten 3:Hazen 4:Median 5:Weibull ' intSELDMErr As Integer ' Problem flag ' Dim intUpstreamQWCheck As Integer ' Sum Upstream QW error = 1 codes Dim bCheckMe As Boolean Dim strMsgStr As String Dim lngStepNumber As Long ' Index number of current step Dim intErr As Integer Dim lngStep As Long Dim lngSteps As Long Dim strStatus As String On Error GoTo SELDMLake_Err: intSELDMErr = 0 intErr = 0 lngStepNumber = 0 lngSteps = 6 ' Step 1 start lngStepNumber = lngStepNumber + 1 strStatus = "Lake Analysis" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) '***************** Get/Set Lake Basin Flux Volumes ************************* 'Step 2 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Lake Basin Flux Volumes" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) Call GenerateDailyLakeFlux(lngMasterSeed, 5, lngNumberofYears, intErr) ' 6 is reserved seed in sequence If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If '***************** Populate Random Lake Basin Flux Concentrations ************************* ' Step 3 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Random Lake Basin Flux Concentrations" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) Call GenerateRandomQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 2, intErr) If intErr = 1 Then ' No random values this can be ok intUpstreamQWCheck = intUpstreamQWCheck + 1 ElseIf intErr > 1 Then intUpstreamQWCheck = intUpstreamQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If '***************** Populate Transport Curve Lake Basin Flux Concentrations ************************* ' Step 4 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Transport-Curve Based Lake Basin Flux Volumes" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) Call GenerateDependentCurveQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 3, intErr) If intErr = 1 Then ' No Transport Curve values this can be ok intUpstreamQWCheck = intUpstreamQWCheck + 1 ElseIf intErr > 1 Then intUpstreamQWCheck = intUpstreamQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If '***************** Populate Dependent Lake Basin Flux Concentrations ************************* ' Step 5 lngStepNumber = lngStepNumber + 1 strStatus = "Get/Set Dependent Lake Basin Flux Volumes" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) Call GenerateDependentCurveQW(lngMasterSeed, lngSeedSequence, lMyAnalysis, lngNumberOfStorms, 4, intErr) If intErr = 1 Then ' No Dependent values this can be ok intUpstreamQWCheck = intUpstreamQWCheck + 1 ElseIf intErr > 1 Then intUpstreamQWCheck = intUpstreamQWCheck + 1 intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If If intUpstreamQWCheck = 3 Then ' No random, Transport Curve, or Dependent values this cannot be ok intSELDMErr = 180 Exit Sub End If '***************** Calculate Annual Lake Basin Flux Concentrations ************************* ' Step 6 lngStepNumber = lngStepNumber + 1 strStatus = "Calculate Annual Lake Basin Flux Concentrations" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) Call GenerateAnnualLakeConcentrations(lMyAnalysis, intErr) If intErr <> 0 Then intSELDMErr = CInt(lngStepNumber * 10) + intErr Exit Sub End If ' Step 7 lngStepNumber = lngStepNumber + 1 strStatus = "Calculate Plotting Positions" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, (lngStepNumber - 1), lngSteps, "tbStatus", strStatus, 200) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dTotalLakeFlux", "dTotalLakeFluxPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dTotalLakeLoad", "dTotalLakeLoadPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dLakeBasinFlux", "dLakeBasinFluxPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dLakeBasinLoad", "dLakeBasinLoadPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dHighwayFlux", "dHighwayFluxPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dHighwayLoad", "dHighwayLoadPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dLakeConcentration", "dLakeConcentrationPP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) Call SetQWPlottingPosition("DownstreamWaterQuality_ID", "dLakeDetentionTime", "dLakeDetentionTimePP", "tblOutputLakeAnalysis", lngNumberofYears, intPP, True, False) '****** Finalize Bar/Message ********** strStatus = "Finished Lake Analysis" Call modPublicInterface.UpdateProgressBar("frmRunAnalysis", "tbProgress", 114, 99, 100, "tbStatus", strStatus, 200) Exit Sub SELDMLake_Err: intSELDMErr = -9999 MsgBox Err.Description, vbCritical, "Main SELDM Lake Module Error:" Exit Sub End Sub Public Sub RerunEmpty() ' Purpose: To delete any entries in all the output table from the Re-run SELDM button ' ' History: Created October 2009 by Gregory E. Granato Dim intErr As Integer Call EmptyOutPutTables(intErr) End Sub Private Sub EmptyOutPutTables(intErr As Integer) ' ' Purpose: To delete any entries in all the output table ' ' History: Created January 24 2009 by Gregory E. Granato Dim intClearTableErr As Integer On Error GoTo EmptyOutPutTables_Err: intErr = 0 'Delete in backwards order ' Highway/Stream Water-Quality Analysis Call ClearTableEntries("tblOutputHighwayQW", intClearTableErr) intErr = intErr + intClearTableErr Call ClearTableEntries("tblOutputUpstreamQW", intClearTableErr) intErr = intErr + intClearTableErr Call ClearTableEntries("tblOutputDownstreamQW", intClearTableErr) intErr = intErr + intClearTableErr ' Storm-event Analysis Call ClearTableEntries("tblOutputStormEvent", intClearTableErr) ' Storm event Precipitation and flow table intErr = intErr + intClearTableErr ' Annual load analysis Call ClearTableEntries("tblOutputHighwayAnnual", intClearTableErr) intErr = intErr + intClearTableErr ' Lake analysis Call ClearTableEntries("tadOutputLakeFluxConcentration", intClearTableErr) intErr = intErr + intClearTableErr Call ClearTableEntries("tblOutputLakeFlux", intClearTableErr) intErr = intErr + intClearTableErr Call ClearTableEntries("tblOutputLakeAnalysis", intClearTableErr) intErr = intErr + intClearTableErr Exit Sub EmptyOutPutTables_Err: intErr = 77 Exit Sub End Sub Private Sub ClearTableEntries(strTableToClear As String, intOutErr As Integer) ' ' Purpose: To delete any entries in the selected table ' ' strTableToClear As String The name of the table to be emptied ' ' History: Created June 2005 by Gregory E. Granato ' Revised Aug 14 2009 by Gregory E. Granato ' Note: Access can't process more than 7000-10,000 values (not sure ofthreshold) ' So I split the set into groups of 6000 ' ' Arguments Dim bHasdata As Boolean ' has data Dim rstTableToClear As ADODB.Recordset Dim lngNumberofRecords As Long Dim lngNumber2Kill As Long Dim lngI As Long On Error GoTo ClearTableEntries_Err: intOutErr = 0 DoSomeMore: 'Reference an ADO Recordset Set rstTableToClear = New ADODB.Recordset ' Open existing Record set rstTableToClear.Open strTableToClear, CurrentProject.Connection, adOpenStatic, adLockOptimistic ' Check values bHasdata = False If rstTableToClear.BOF And rstTableToClear.EOF Then bHasdata = False ElseIf IsNull(rstTableToClear.Fields(0).Value) = False Then If IsEmpty(rstTableToClear.Fields(0).Value) = False Then bHasdata = True ' There are sites for this project End If If bHasdata = False Then GoTo CleanUp: ' There is no data exit rstTableToClear.MoveFirst rstTableToClear.MoveLast lngNumberofRecords = rstTableToClear.RecordCount If lngNumberofRecords >= 6000 Then lngNumber2Kill = 6000 Else lngNumber2Kill = lngNumberofRecords End If rstTableToClear.MoveFirst For lngI = 1 To lngNumber2Kill rstTableToClear.Delete rstTableToClear.MoveNext Next lngI CleanUp: If rstTableToClear.State = adStateOpen Then rstTableToClear.Close 'IF Recordset is open, close it Set rstTableToClear = Nothing If lngNumber2Kill < lngNumberofRecords Then GoTo DoSomeMore: Exit Sub ClearTableEntries_Err: MsgBox Err.Description intOutErr = intOutErr + 1 If intOutErr < 2 Then Resume CleanUp: Exit Sub End Sub Private Function fnLngMinNumberOfStorms(lngInputAnalysis As Long) As Long ' ' Purpose: To get the minimum number of storms for an analysis ' The minimum number of storms is intercept + Slope * Storms/yr ' History: 01/15/2009 by Gregory E. Granato ' lngInputAnalysis As Long the current analysis number ' Arguments: Dim bHasdata As Boolean ' test data Dim dIntercept As Double ' Storm calculation intercept Dim dSlope As Double ' Storm calculation slope Dim lngTempStorms As Long ' Temporary number of years Dim strSQL As String ' Query String Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo fnLngMinNumberOfStorms_Err: intErr = 0 ' **** Set equation Parameters ' The intercept is chosen as 725 storms, the slope is chosen as 17 ' this combination results in a range of about 800-2400 storms ' for the current precipitation-station statistics dataset dIntercept = 725# dSlope = 17# ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset strSQL = "SELECT tblPrecipSelection.dAvgAnnStorm " & _ "FROM tblPrecipSelection INNER JOIN tblHighwayAnalysis ON " & _ "tblPrecipSelection.PrecipEventStatistics_ID = tblHighwayAnalysis.PrecipEventStatistics_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngInputAnalysis & "));" 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' There is no data for this analysis fnLngMinNumberOfStorms = -9999 Else lngTempStorms = CLng(dIntercept + (dSlope * (rstMyRecordset.Fields(0).Value))) fnLngMinNumberOfStorms = lngTempStorms End If CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Function fnLngMinNumberOfStorms_Err: intErr = intErr + 1 fnLngMinNumberOfStorms = -9999 'error condition If intErr < 2 Then GoTo CleanUp: Exit Function End Function Public Function fndPairedSiteRvRho(lMyAnalysis As Long, dHighwaySiteImp As Double, dUpstreamBasinImp As Double) As Double ' ' Purpose: To calculate the rank correlation between the highway site RV's and the ' Upstream basin site Rvs based on the imperviousness of each area ' In theory, sites with similar impervious fractions would have higher ' correlations and corelations would improve with increasing average imperviousness. ' ' This routine, however, is a purely theoretical construction ' ' Arguments ' lMyAnalysis current analysis ' dUpstreamBasinImp Upstream Impervious Fraction ' dHighwaySiteImp Highway Impervious Fraction ' ' History: 09/14/2010 by Gregory E. Granato ' ' Arguments: Dim RhoC0 As Double ' Spearman's rho at the Ceiling when the impervious fraction = 0, Dim RhoC1 As Double ' Spearman's rho at the Ceiling when the impervious fraction = 1, Dim RhoCH As Double ' Local value of the ceiling given HIF, and Dim RhoCU As Double ' Local value of the ceiling given UIF. Dim RhoF0 As Double ' Spearman's rho at the Floor when the impervious fraction = 0, Dim RhoF1 As Double ' Spearman's rho at the Floor when the impervious fraction = 1, Dim RhoFH As Double ' Local value of the Floor given HIF, and Dim RhoFU As Double ' Local value of the Floor given UIF. On Error GoTo fndPairedSiteRvRho_Err: ' ******************************************** ' Get values from the analysis table ' ******************************************** Call GetRhoRvVariables(lMyAnalysis, RhoC0, RhoC1, RhoF0, RhoF1) ' Calculate ceiling values ' *************************** RhoCH = RhoC0 + (RhoC1 - RhoC0) * dHighwaySiteImp RhoCU = RhoC0 + (RhoC1 - RhoC0) * dUpstreamBasinImp ' Calculate floor values ' *************************** RhoFH = RhoF0 + (RhoF1 - RhoF0) * dHighwaySiteImp RhoFU = RhoF0 + (RhoF1 - RhoF0) * dUpstreamBasinImp ' Calculate Spearman's Rho given the Impervious fractions ' ******************************************** If dHighwaySiteImp = dUpstreamBasinImp Then ' Rho = ceiling value fndPairedSiteRvRho = RhoCH Else fndPairedSiteRvRho = ((RhoCH - (RhoCH - RhoFH) * Abs(dHighwaySiteImp - dUpstreamBasinImp)) + _ (RhoCU - (RhoCU - RhoFU) * Abs(dHighwaySiteImp - dUpstreamBasinImp))) / 2# End If Exit Function fndPairedSiteRvRho_Err: fndPairedSiteRvRho = 0.5 'error condition Exit Function End Function Private Sub GetRhoRvVariables(lMyAnalysis As Long, dMyRhoC0 As Double, dMyRhoC1 As Double, dMyRhoF0 As Double, dMyRhoF1 As Double) ' ' Purpose to get the runoff coefficient Rv equations ' ' History: Created October 2010 by Gregory E. Granato ' October 10 2010 ' ' Arguments ' lMyAnalysis current analysis ' dMyRhoC0 Spearman's rho at the Ceiling when the impervious fraction = 0, ' dMyRhoC1 Spearman's rho at the Ceiling when the impervious fraction = 1, ' dMyRhoF0 Spearman's rho at the Floor when the impervious fraction = 0, ' dMyRhoF1 Spearman's rho at the Floor when the impervious fraction = 1, Dim rstMyRecordset As ADODB.Recordset ' recordset Dim strSQL As String ' query string Dim bHasdata As Boolean ' test data Dim intOutErr As Integer ' Error flag On Error GoTo GetRhoRvVariables_Err: intOutErr = 0 ' ************************************************************** ' Get values from tblHighwayAnalysis ' ************************************************************** 'Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset ' set query string strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, " & _ "tblHighwayAnalysis.dRvCorrelationC0, tblHighwayAnalysis.dRvCorrelationC1, " & _ "tblHighwayAnalysis.dRvCorrelationF0, tblHighwayAnalysis.dRvCorrelationF1 " & _ "FROM tblHighwayAnalysis " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lMyAnalysis & "));" 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False ' There is no Upstream water-quality If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no record bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are data End If If bHasdata = True Then dMyRhoC0 = IIf(IsNull(rstMyRecordset.Fields("dRvCorrelationC0").Value), 0.5, rstMyRecordset.Fields("dRvCorrelationC0").Value) dMyRhoC1 = IIf(IsNull(rstMyRecordset.Fields("dRvCorrelationC1").Value), 0.975, rstMyRecordset.Fields("dRvCorrelationC1").Value) dMyRhoF0 = IIf(IsNull(rstMyRecordset.Fields("dRvCorrelationF0").Value), 0.25, rstMyRecordset.Fields("dRvCorrelationF0").Value) dMyRhoF1 = IIf(IsNull(rstMyRecordset.Fields("dRvCorrelationF1").Value), 0.5, rstMyRecordset.Fields("dRvCorrelationF1").Value) End If CleanUp: ' Clean up recordset If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetRhoRvVariables_Err: intOutErr = intOutErr + 1 dMyRhoC0 = 0.5 dMyRhoC1 = 0.9875 dMyRhoF0 = 0.25 dMyRhoF1 = 0.5 If intOutErr < 2 Then Resume CleanUp: End Sub Private Function fndBasinLag(lngInputAnalysis As Long, intWhat As Integer) As Double ' ' Purpose: To calculate the basin lag ' ' History: 05/22/2009 by Gregory E. Granato 06/06/2010 added basin-lag equation option ' Version 1.1 by Gregory E. Granato 08/12/2011 Added new basin lag equations ' ' lngInputAnalysis As Long the current analysis number ' intWhat 0 = highway 1 = upstream basin ' ' Arguments: Dim bHasdata As Boolean ' test data Dim dLength As Double ' Length convert ft to mi Dim dSlope As Double ' Basin slope in ft/mi Dim lngBDF As Long ' Basin development factor 0-12 Dim dImpervious As Double ' Basin Impervious Fraction Dim dArea As Double ' Basin Area If highway Acres if basin square miles Dim intBasinLagEq As Integer ' Basin Lag equation 0= USGS Urban WSP 2207 Dim strSQL As String ' Query String Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo fndBasinLag_Err: intErr = 0 If intWhat = 0 Then 'Highway: strSQL = "SELECT tblHighwaySite.dDrainageLength, tblHighwaySite.dDrainageMeanSlope, " & _ "tblHighwaySite.lngBasinDevelopmentFactor, tblHighwaySite.dImperviousFraction, " & _ "tblHighwaySite.dDrainageArea " & _ "FROM tblHighwaySite INNER JOIN tblHighwayAnalysis ON " & _ "tblHighwaySite.HighwaySite_ID = tblHighwayAnalysis.HighwaySite_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngInputAnalysis & "));" Else 'Upstream ' strSQL = "SELECT tblUpstreamBasin.dBasinLength, tblUpstreamBasin.dBasinMeanSlope, " & _ "tblUpstreamBasin.lngBasinDevelopmentFactor, tblUpstreamBasin.dBasinImperviousFraction, " & _ "tblUpstreamBasin.dBasinDrainageArea " & _ "FROM tblUpstreamBasin INNER JOIN tblHighwayAnalysis ON " & _ "tblUpstreamBasin.UpstreamBasin_ID = tblHighwayAnalysis.UpstreamBasin_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngInputAnalysis & "));" End If ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = True Then If Nz(rstMyRecordset.Fields(0).Value, 0#) <= 0# Then bHasdata = False ' length must be > 0 If Nz(rstMyRecordset.Fields(1).Value, 0#) <= 0# Then bHasdata = False ' slope must be > 0 If Nz(rstMyRecordset.Fields(2).Value, -1) < -2 Or Nz(rstMyRecordset.Fields(2).Value, 0) > 12 Then bHasdata = False If Nz(rstMyRecordset.Fields(3).Value, -1) < 0 Or Nz(rstMyRecordset.Fields(3).Value, 0) > 1 Then bHasdata = False If Nz(rstMyRecordset.Fields(4).Value, 0#) <= 0# Then bHasdata = False ' Area must be > 0 End If If bHasdata = False Then ' There is no data for this analysis fndBasinLag = -9999# Else dLength = rstMyRecordset.Fields(0).Value / 5280# ' Length convert ft to mi dSlope = rstMyRecordset.Fields(1).Value ' Basin slope in ft/mi lngBDF = rstMyRecordset.Fields(2).Value ' Basin development factor 0-12 dImpervious = rstMyRecordset.Fields(3).Value ' Basin impervious Fraction dArea = rstMyRecordset.Fields(4).Value ' Basin if highway Acres if basin square miles If intWhat = 0 Then 'Highway: dArea = 1# * dArea / 640# ' Acres per square mile ' Else 'Upstream is square miles ' End If ' ***************************** ' Select Lag equation: ' If lngBDF >= 0 And lngBDF <= 12 Then intBasinLagEq = 1 'Granato 2012 lag factor and BDF equation (primary dataset N=493 sites) ElseIf lngBDF = -1 Then intBasinLagEq = 2 'Granato 2012 lag factor and TIA equation (secondary dataset N=896 sites) ElseIf lngBDF = -2 Then intBasinLagEq = 3 'Granato 2012 drainage area and TIA equation (secondary dataset N=896 sites) Else intBasinLagEq = 4 End If ' See If intBasinLagEq = 0 Then ' USGS Urban WSP 2207 ' Ref: ' Sauer, V.B., Thomas, W.O., Jr., Stricker, V.A., and Wilson, K.V., 1983, ' Flood characteristics of urban watersheds in the United States: ' U.S. Geological Survey Water-Supply Paper 2207, 63 p. If dSlope > 70# Then dSlope = 70# ' WSP lag in 2207 is rain centroid to runoff centroid fndBasinLag = 0.85 * ((dLength / (dSlope ^ 0.5)) ^ 0.62) * (13 - lngBDF) ^ 0.47 ElseIf intBasinLagEq = 1 Then 'Granato lag factor and BDF equation RE07 (primary dataset N=493 sites) ' Ref: Granato 2012 Basin Lag Equations OFR 2012-XXXX fndBasinLag = 1.272 * 0.76 * ((dLength / (dSlope ^ 0.5)) ^ 0.571) * (13 - lngBDF) ^ 0.681 ElseIf intBasinLagEq = 2 Then 'Granato lag factor and TIA equation RE13 (secondary dataset N=896 sites) ' Ref: ' Granato, G.E., 2012, Estimating basin lagtime and hydrograph-timing indexes used to characterize stormflows ' for runoff-quality analysis: U.S. Geological Survey Scientific Investigations Report 2012–5110, 47 p., ' with digital media at http://pubs.usgs.gov/sir/2012/5110/. fndBasinLag = 1.306 * 0.382 * ((dLength / (dSlope ^ 0.5)) ^ 0.601) * ((100# - 0.99 * (dImpervious * 100#)) ^ 0.443) ElseIf intBasinLagEq = 3 Then 'Granato drainage area and TIA equation RE11 (secondary dataset N=896 sites) ' Ref: ' Granato, G.E., 2012, Estimating basin lagtime and hydrograph-timing indexes used to characterize stormflows ' for runoff-quality analysis: U.S. Geological Survey Scientific Investigations Report 2012–5110, 47 p., ' with digital media at http://pubs.usgs.gov/sir/2012/5110/. fndBasinLag = 1.334 * 0.493 * (dArea ^ 0.437) * ((100# - 0.99 * (dImpervious * 100#)) ^ 0.179) Else 'Drainage area equation RE10 (secondary dataset N=896 sites) ' Ref: ' Granato, G.E., 2012, Estimating basin lagtime and hydrograph-timing indexes used to characterize stormflows ' for runoff-quality analysis: U.S. Geological Survey Scientific Investigations Report 2012–5110, 47 p., ' with digital media at http://pubs.usgs.gov/sir/2012/5110/. fndBasinLag = 1.34 * 1.039 * (dArea ^ 0.46) End If End If CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Function fndBasinLag_Err: intErr = intErr + 1 fndBasinLag = -9999# 'error condition If intErr < 2 Then GoTo CleanUp: Exit Function End Function Private Sub GenerateStorms(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngIONumberOfStorms As Long, lngOutNumberofYears As Long, intProblem As Integer) ' ' Purpose: ' To generate a poisson process using the exponentially distributed time between storm ' centers to generate a population of storms and precipitation statistics for a set of ' years so that the total number of storms is greater than or equal to the minimum number of storms ' and the number of storms per year are a poisson distribution. ' ' History: ' Version 1.0 January 24 2009 by Gregory E. Granato' ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngIONumberOfStorms as long Input minimum number of storms output total number of storms ' lngOutNumberofYears as long output number of years in the analysis ' intProblem as integer if zero ok if 1 Bad precip stats if 2 error in this subroutine ' ' Arguments Dim bOnEvenYear As Boolean ' Yes = we have just completed an even year No = still working on storms per year Dim dMeanPrecipDelta As Double ' Mean time between storm midpoints Dim dMinPrecipDelta As Double ' Minimum time between storm midpoints Dim dPrecipDelta As Double ' Current time between storm midpoints Dim dPrecipDeltaPP As Double ' Current plotting position (U01) of the time between storm midpoints Dim dSumPrecipDelta As Double ' Sum of current time between storm midpoints ' Recordset Dim rstPrecipitationRecordset As ADODB.Recordset Dim intStart As Integer ' Random Seeds Dim dPrecipDeltaSeed10 As Double Dim dPrecipDeltaSeed11 As Double Dim dPrecipDeltaSeed12 As Double Dim dPrecipDeltaSeed20 As Double Dim dPrecipDeltaSeed21 As Double Dim dPrecipDeltaSeed22 As Double ' Dim dMeanPrecipVolume As Double ' Mean storm-event precipitation volume Dim dMinPrecipVolume As Double ' Minimum storm-event precipitation volume Dim dPrecipVolume As Double ' Current storm-event precipitation volume Dim dPrecipVolumePP As Double ' Current plotting position (U01) of the precipitation volume ' Random Seeds Dim dPrecipVolumeSeed10 As Double Dim dPrecipVolumeSeed11 As Double Dim dPrecipVolumeSeed12 As Double Dim dPrecipVolumeSeed20 As Double Dim dPrecipVolumeSeed21 As Double Dim dPrecipVolumeSeed22 As Double ' Dim dMeanPrecipDuration As Double ' Mean storm-event precipitation duration Dim dMinPrecipDuration As Double ' Minimum storm-event precipitation duration Dim dPrecipDuration As Double ' Current storm-event precipitation duration Dim dPrecipDurationPP As Double ' Current plotting position (U01) of the precipitation duration ' Random Seeds Dim dPrecipDurationSeed10 As Double Dim dPrecipDurationSeed11 As Double Dim dPrecipDurationSeed12 As Double Dim dPrecipDurationSeed20 As Double Dim dPrecipDurationSeed21 As Double Dim dPrecipDurationSeed22 As Double ' Dim dTimePeriod As Double ' The number of hours in a year (365.25 days X 24 hours) Dim lngCurrentYear As Long ' Index for the current year number Dim lngStormNumber As Long ' Index for the current storm Dim intStormErr As Integer Dim dPrecipitationU01 As Double ' Precipitation random Uniform Variate 0-1 On Error GoTo GenerateStorms_Err: intStormErr = 0 intProblem = 0 Call GetPrecipStats(lMyAnalysis, dMeanPrecipVolume, dMinPrecipVolume, _ dMeanPrecipDuration, dMinPrecipDuration, dMeanPrecipDelta, dMinPrecipDelta) If dMeanPrecipVolume <= 0# Or dMeanPrecipDuration <= 0# Or dMeanPrecipDelta <= 0# Or _ dMinPrecipVolume < 0# Or dMinPrecipDuration < 0# Or dMinPrecipDelta < 0# Then intProblem = 1 Exit Sub End If ' Set initial values dTimePeriod = 8760# dSumPrecipDelta = 0# lngCurrentYear = 1 lngStormNumber = 1 bOnEvenYear = False ' we have not completed a year ' **********Get initial seeds from seed table based on master seed sequence number ' dPrecipDelta is sequence #1 lngInSeedSequence = 1 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dPrecipDeltaSeed10, dPrecipDeltaSeed20) ' dPrecipVolume is sequence #2 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dPrecipVolumeSeed10, dPrecipVolumeSeed20) ' dPrecipDuration is sequence #3 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dPrecipDurationSeed10, dPrecipDurationSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dPrecipitationU01, dPrecipDeltaSeed10, dPrecipDeltaSeed11, dPrecipDeltaSeed12, _ dPrecipDeltaSeed20, dPrecipDeltaSeed21, dPrecipDeltaSeed22) Call modStatistics.MRG32k3a(dPrecipitationU01, dPrecipVolumeSeed10, dPrecipVolumeSeed11, dPrecipVolumeSeed12, _ dPrecipVolumeSeed20, dPrecipVolumeSeed21, dPrecipVolumeSeed22) Call modStatistics.MRG32k3a(dPrecipitationU01, dPrecipDurationSeed10, dPrecipDurationSeed11, dPrecipDurationSeed12, _ dPrecipDurationSeed20, dPrecipDurationSeed21, dPrecipDurationSeed22) Next intStart ' Set and open tblOutputStormEvent record set ' Reference an ADO Recordset Set rstPrecipitationRecordset = New ADODB.Recordset rstPrecipitationRecordset.Open "tblOutputStormEvent", CurrentProject.Connection, adOpenKeyset, adLockOptimistic Do While lngStormNumber < lngIONumberOfStorms ' Get Precipitation Statistics ' Delta Time between storm mid points (hours) Call modStatistics.MRG32k3a(dPrecipDeltaPP, dPrecipDeltaSeed10, dPrecipDeltaSeed11, dPrecipDeltaSeed12, _ dPrecipDeltaSeed20, dPrecipDeltaSeed21, dPrecipDeltaSeed22) dPrecipDelta = modStatistics.fndUniform01ToExponential(dPrecipDeltaPP, dMeanPrecipDelta, dMinPrecipDelta) ' Volume (inches) Call modStatistics.MRG32k3a(dPrecipVolumePP, dPrecipVolumeSeed10, dPrecipVolumeSeed11, dPrecipVolumeSeed12, _ dPrecipVolumeSeed20, dPrecipVolumeSeed21, dPrecipVolumeSeed22) dPrecipVolume = modStatistics.fndUniform01ToExponential(dPrecipVolumePP, dMeanPrecipVolume, dMinPrecipVolume) ' Duration (hours) Call modStatistics.MRG32k3a(dPrecipDurationPP, dPrecipDurationSeed10, dPrecipDurationSeed11, dPrecipDurationSeed12, _ dPrecipDurationSeed20, dPrecipDurationSeed21, dPrecipDurationSeed22) dPrecipDuration = modStatistics.fndUniform01ToExponential(dPrecipDurationPP, dMeanPrecipDuration, dMinPrecipDuration) ' Add up current period dSumPrecipDelta = dSumPrecipDelta + dPrecipDelta ' Add new data to table tblOutputStormEvent With rstPrecipitationRecordset .AddNew .Fields("lngStormNumber") = lngStormNumber .Fields("lngYearNumber") = lngCurrentYear .Fields("dPrecipitationDeltaPP") = dPrecipDeltaPP .Fields("dPrecipitationDelta") = dPrecipDelta .Fields("dPrecipitationVolumePP") = dPrecipVolumePP .Fields("dPrecipitationVolume") = dPrecipVolume .Fields("dPrecipitationDurationPP") = dPrecipDurationPP .Fields("dPrecipitationDuration") = dPrecipDuration .Update End With ' Check and update year If dSumPrecipDelta >= dTimePeriod Then ' We have exceeded a year, advance year number bOnEvenYear = True lngCurrentYear = lngCurrentYear + 1 dSumPrecipDelta = dSumPrecipDelta - dTimePeriod If lngCurrentYear Mod 4 = 0 Then ' Every 4th year has 366 days dTimePeriod = 8784# Else dTimePeriod = 8760# End If Else bOnEvenYear = False End If lngStormNumber = lngStormNumber + 1 ' advance storm number If lngStormNumber >= lngIONumberOfStorms And bOnEvenYear = False Then lngIONumberOfStorms = lngIONumberOfStorms + 1 End If If lngStormNumber > 10000 Then Exit Do Loop lngOutNumberofYears = lngCurrentYear - 1 lngIONumberOfStorms = lngIONumberOfStorms - 1 CleanUp: If rstPrecipitationRecordset.State = adStateOpen Then rstPrecipitationRecordset.Close 'IF Recordset is open, close it Set rstPrecipitationRecordset = Nothing 'Free memory Exit Sub GenerateStorms_Err: intProblem = 2 intStormErr = intStormErr + 1 If intStormErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GeneratePreStormQs(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngNumberOfStorms As Long, intProblem As Integer) ' ' Purpose: ' To generate a population of prestorm flows for a set number of storms ' ' History: ' Version 1.0 April 13 2009 by Gregory E. Granato' ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngInputAnalysis As Long current analysis ID ' lngNumberOfStorms as long total number of storms ' intProblem as integer if zero ok if 1 Bad stats if 2 error in this subroutine ' ' Arguments Dim dMeanStreamQ As Double ' Mean prestorm streamflow Dim dStDevStreamQ As Double ' Standard deviation of the prestorm streamflow Dim dSkewStreamQ As Double ' Skew Coefficient of the prestorm streamflow Dim dZedStreamQ As Double ' Proportion of zero prestorm streamflows Dim dStreamQPP As Double ' Current plotting position (U01) of the prestorm streamflow Streamflow random Uniform Variate 0-1 Dim dAdjustedQPP As Double ' Streamflow random Uniform Variate 0-1 rescaled for the proportion of zero flows Dim dStreamQ As Double ' Streamflow value Dim dStreamKN As Double ' Streamflow frequency factor Dim dStreamKs As Double ' Streamflow frequency factor Dim dMyDrainageArea As Double ' Basin Drainage Area Dim dLog10 As Double Dim lngStormNumber As Long ' Index for the current storm ' Recordset Dim rstStormRecordset As ADODB.Recordset Dim strSQL As String Dim intStart As Integer ' Random Seeds Dim dStreamQSeed10 As Double Dim dStreamQSeed11 As Double Dim dStreamQSeed12 As Double Dim dStreamQSeed20 As Double Dim dStreamQSeed21 As Double Dim dStreamQSeed22 As Double ' Wilson Hilferty factors Dim dWHA As Double Dim dWHB As Double Dim dWHG As Double Dim dWHH As Double ' As 241 Factors Dim dA0 As Double, dA1 As Double, dA2 As Double, dA3 As Double, dA4 As Double, dA5 As Double, dA6 As Double, dA7 As Double Dim dB1 As Double, dB2 As Double, dB3 As Double, dB4 As Double, dB5 As Double, dB6 As Double, dB7 As Double Dim dC0 As Double, dC1 As Double, dC2 As Double, dC3 As Double, dC4 As Double, dC5 As Double, dC6 As Double, dC7 As Double Dim dD1 As Double, dD2 As Double, dD3 As Double, dD4 As Double, dD5 As Double, dD6 As Double, dD7 As Double Dim dE0 As Double, dE1 As Double, dE2 As Double, dE3 As Double, dE4 As Double, dE5 As Double, dE6 As Double, dE7 As Double Dim dF1 As Double, dF2 As Double, dF3 As Double, dF4 As Double, dF5 As Double, dF6 As Double, dF7 As Double Dim intStormErr As Integer On Error GoTo GeneratePreStormQs_Err: intStormErr = 0 intProblem = 0 ' Get/test Basin Drainage Area dMyDrainageArea = fndGetDrainageFeature(lMyAnalysis, 2) If dMyDrainageArea <= 0# Then intProblem = 1 Exit Sub End If ' Inverse of Log10 to convert LN to commonLog dLog10 = 0.434294481903252 ' Get/test Streamflow Stats Call GetStreamflowStats(lMyAnalysis, dZedStreamQ, dMeanStreamQ, dStDevStreamQ, dSkewStreamQ) If dMeanStreamQ <= -9999# Or dStDevStreamQ <= -9999# Or dSkewStreamQ <= -9999# Or _ dStreamQPP > 1# Then intProblem = 2 Exit Sub End If ' Prime the Adjusted Wilson Hilferty approximation Call PrimeWilsonHilfertyKirby(dSkewStreamQ, dWHA, dWHB, dWHG, dWHH) ' Prime the AS241 approximation Call PrimeAS241(dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, _ dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, _ dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, _ dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' Adjust for basin Area dMeanStreamQ = dMeanStreamQ * dMyDrainageArea ' **********Get initial seeds from seed table based on master seed sequence number ' dStreamflow is sequence #4 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dStreamQSeed10, dStreamQSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dStreamQPP, dStreamQSeed10, dStreamQSeed11, dStreamQSeed12, _ dStreamQSeed20, dStreamQSeed21, dStreamQSeed22) Next intStart ' Set and open tblOutputStormEvent record set strSQL = "SELECT tblOutputStormEvent.dUpstreamFlowRate, tblOutputStormEvent.dUpstreamFlowRatePP " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" ' Reference an ADO Recordset Set rstStormRecordset = New ADODB.Recordset rstStormRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstStormRecordset.MoveFirst lngStormNumber = 1 Do While lngStormNumber <= lngNumberOfStorms ' Get Streamflow Statistics Call modStatistics.MRG32k3a(dStreamQPP, dStreamQSeed10, dStreamQSeed11, dStreamQSeed12, _ dStreamQSeed20, dStreamQSeed21, dStreamQSeed22) If dZedStreamQ >= 0.00011 Then ' if proportion Dry is greater than 1 day in 25 years adjust If dStreamQPP <= dZedStreamQ Then dStreamQ = 0# Else dAdjustedQPP = fndCensorUniform01Rescale(dStreamQPP, dZedStreamQ, 0) dStreamKN = fndUniform01ToNormalAS241(dAdjustedQPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) dStreamKs = fndAdjustedWilsonHilfertyK(dSkewStreamQ, dStreamKN, dWHA, dWHB, dWHG, dWHH) dStreamQ = 10# ^ ((Log(dMeanStreamQ) * dLog10) + (Log(dStDevStreamQ) * dLog10) * dStreamKs) End If Else dAdjustedQPP = dStreamQPP dStreamKN = fndUniform01ToNormalAS241(dAdjustedQPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) dStreamKs = fndAdjustedWilsonHilfertyK(dSkewStreamQ, dStreamKN, dWHA, dWHB, dWHG, dWHH) dStreamQ = 10# ^ ((Log(dMeanStreamQ) * dLog10) + (Log(dStDevStreamQ) * dLog10) * dStreamKs) End If ' Add new data to table tblOutputStormEvent for existing storms With rstStormRecordset .Fields("dUpstreamFlowRatePP") = dStreamQPP .Fields("dUpstreamFlowRate") = dStreamQ .Update End With rstStormRecordset.MoveNext lngStormNumber = lngStormNumber + 1 Loop CleanUp: If rstStormRecordset.State = adStateOpen Then rstStormRecordset.Close 'IF Recordset is open, close it Set rstStormRecordset = Nothing 'Free memory Exit Sub GeneratePreStormQs_Err: intProblem = 3 intStormErr = intStormErr + 1 If intStormErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GenerateTotalRunoff(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngNumberOfStorms As Long, intProblem As Integer) ' ' Purpose: ' To generate a population of total-runoff flows for a set number of storms ' ' History: ' Version 1.0 April 17 2009 by Gregory E. Granato' ' Added dMySitesRvRho Oct/Nov 2010 by Gregory E. Granato ' Updated k value handling 01/16/2013 ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngNumberOfStorms as long total number of storms ' intProblem as integer if zero ok if 1 Bad streamflow stats if 2 error in this subroutine ' ' Arguments Dim lngStormNumber As Long ' Index for the current storm ' Recordset Dim rstStormRecordset As ADODB.Recordset Dim strSQL As String Dim intStart As Integer Dim lngTries As Long ' Drainage Properties Dim dMyBasinDrainageArea As Double ' Basin Drainage Area Dim dMyBasinImpervFraction As Double ' Basin Impervious Fraction Dim dMyBasinRv As Double ' Basin Rv Dim dMyBasinRvPP As Double ' Basin Rv plotting position Dim dMyBasinRvK As Double ' Dim dMyBasinRO As Double ' Basin Runoff Dim dMyHighwayDrainageArea As Double ' Highway Drainage Area Dim dMyHighwayImpervFraction As Double ' Highway Impervious Fraction Dim dMyHighwayRv As Double ' Highway Rv Dim dMyHighwayRvPP As Double ' Highway Rv plotting position Dim dMyHighwayRvK As Double ' Highway Rv variate Dim dMyHighwayRO As Double ' Highway Runoff Dim dMySitesRvRho As Double ' Rank correlation coefficient of Rv between sites ' Rv Stats Dim dHighwayRvAverage As Double, dHighwayRvStandardDeviation As Double, dHighwayRvSkew As Double Dim dUpstreamRvAverage As Double, dUpstreamRvStandardDeviation As Double, dUpstreamRvSkew As Double Dim dRvRankCorrelation As Double Dim dMinHighwayRvK As Double, dMaxHighwayRvK As Double Dim dMinBasinRvK As Double, dMaxBasinRvK As Double Dim intHiLowNeutral As Integer ' Existing Storm Properties Dim dMyStormPVolume As Double Dim dMyPreStormQPP As Double ' Highway Random Seeds Dim dRoadRvSeed10 As Double Dim dRoadRvSeed11 As Double Dim dRoadRvSeed12 As Double Dim dRoadRvSeed20 As Double Dim dRoadRvSeed21 As Double Dim dRoadRvSeed22 As Double ' Upsream BasinRandom Seeds Dim dBasinRvSeed10 As Double Dim dBasinRvSeed11 As Double Dim dBasinRvSeed12 As Double Dim dBasinRvSeed20 As Double Dim dBasinRvSeed21 As Double Dim dBasinRvSeed22 As Double ' Wilson Hilferty factors Dim dWHA As Double Dim dWHB As Double Dim dWHG As Double Dim dWHH As Double ' As 241 Factors Dim dA0 As Double, dA1 As Double, dA2 As Double, dA3 As Double, dA4 As Double, dA5 As Double, dA6 As Double, dA7 As Double Dim dB1 As Double, dB2 As Double, dB3 As Double, dB4 As Double, dB5 As Double, dB6 As Double, dB7 As Double Dim dC0 As Double, dC1 As Double, dC2 As Double, dC3 As Double, dC4 As Double, dC5 As Double, dC6 As Double, dC7 As Double Dim dD1 As Double, dD2 As Double, dD3 As Double, dD4 As Double, dD5 As Double, dD6 As Double, dD7 As Double Dim dE0 As Double, dE1 As Double, dE2 As Double, dE3 As Double, dE4 As Double, dE5 As Double, dE6 As Double, dE7 As Double Dim dF1 As Double, dF2 As Double, dF3 As Double, dF4 As Double, dF5 As Double, dF6 As Double, dF7 As Double Dim intStormErr As Integer On Error GoTo GenerateTotalRunoff_Err: intStormErr = 0 intProblem = 0 ' *********** Get Information **************** ' Get/test Highway Drainage Area dMyHighwayDrainageArea = fndGetDrainageFeature(lMyAnalysis, 0) If dMyHighwayDrainageArea <= 0# Then ' Highway Site Problem intProblem = 1 Exit Sub End If ' Convert acres to square feet (43560) and inches of rain to feet of rain 1/12 dMyHighwayDrainageArea = dMyHighwayDrainageArea * (43560# / 12#) ' Get/test Highway Impervious fraction dMyHighwayImpervFraction = fndGetDrainageFeature(lMyAnalysis, 1) If dMyHighwayImpervFraction < 0# Or dMyHighwayImpervFraction > 1# Then ' Highway Site Problem intProblem = 2 Exit Sub End If ' Get/test Basin Drainage Area dMyBasinDrainageArea = fndGetDrainageFeature(lMyAnalysis, 2) If dMyBasinDrainageArea <= 0# Then ' Basin Problem intProblem = 3 Exit Sub End If ' Convert square miles to square feet (27878400) and inches of rain to feet of rain 1/12 dMyBasinDrainageArea = dMyBasinDrainageArea * (27878400# / 12#) ' Get/test Basin Impervious fraction dMyBasinImpervFraction = fndGetDrainageFeature(lMyAnalysis, 3) If dMyBasinImpervFraction < 0# Or dMyBasinImpervFraction > 1# Then ' Basin Site Problem intProblem = 4 Exit Sub End If ' Get/test Rv Stats Call GetRvStats(lMyAnalysis, dHighwayRvAverage, dHighwayRvStandardDeviation, dHighwayRvSkew, _ dUpstreamRvAverage, dUpstreamRvStandardDeviation, dUpstreamRvSkew, dRvRankCorrelation) If dHighwayRvAverage <= 0 Or dHighwayRvAverage > 1# Or dHighwayRvStandardDeviation < 0 Then ' Highway Site Problem intProblem = 5 Exit Sub End If If dUpstreamRvAverage <= 0 Or dUpstreamRvAverage > 1# Or dUpstreamRvStandardDeviation < 0 Then ' Basin Problem intProblem = 6 Exit Sub End If ' Calculate highway K values that will result in (almost) zero or 1 dMinHighwayRvK = -1# * (dHighwayRvAverage / dHighwayRvStandardDeviation) dMinHighwayRvK = dMinHighwayRvK - (dMinHighwayRvK * 10# ^ -10#) dMaxHighwayRvK = (1# - dHighwayRvAverage) / dHighwayRvStandardDeviation dMaxHighwayRvK = dMaxHighwayRvK - (dMaxHighwayRvK * 10# ^ -10#) ' Calculate upstream K values that will result in (almost) zero or 1 dMinBasinRvK = -1# * (dUpstreamRvAverage / dUpstreamRvStandardDeviation) dMinBasinRvK = dMinBasinRvK - (dMinBasinRvK * 10# ^ -10#) dMaxBasinRvK = (1# - dUpstreamRvAverage) / dUpstreamRvStandardDeviation dMaxBasinRvK = dMaxBasinRvK - (dMaxBasinRvK * 10# ^ -10#) ' Rv between Upstream Rv and prestorm flow If dRvRankCorrelation < 0# Then dRvRankCorrelation = 0# If Abs(dRvRankCorrelation) > 1 Then dRvRankCorrelation = 0# ' Calculate Highway/Basin Rv Rho ' Public variable lMyAnalysis is current analysis Call GetPutRhoRv(1, lMyAnalysis, dMySitesRvRho) If dMySitesRvRho < 0# Or dMySitesRvRho > 1# Then dMySitesRvRho = fndPairedSiteRvRho(lMyAnalysis, dMyHighwayImpervFraction, dMyBasinImpervFraction) If dMySitesRvRho < 0# Then dMySitesRvRho = 1# / 4# If Abs(dMySitesRvRho) > 1 Then dMySitesRvRho = 1# / 4# Call GetPutRhoRv(0, lMyAnalysis, dMySitesRvRho) End If ' *********** Set Variables **************** ' Prime the AS241 approximation Call PrimeAS241(dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, _ dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, _ dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, _ dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' **********Get initial seeds from seed table based on master seed sequence number ' dHighwayRv is sequence #5 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dRoadRvSeed10, dRoadRvSeed20) ' dUpstreamRv is sequence #6 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dBasinRvSeed10, dBasinRvSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dMyHighwayRvPP, dRoadRvSeed10, dRoadRvSeed11, dRoadRvSeed12, _ dRoadRvSeed20, dRoadRvSeed21, dRoadRvSeed22) Call modStatistics.MRG32k3a(dMyBasinRvPP, dBasinRvSeed10, dBasinRvSeed11, dBasinRvSeed12, _ dBasinRvSeed20, dBasinRvSeed21, dBasinRvSeed22) Next intStart strSQL = "SELECT tblOutputStormEvent.dPrecipitationVolume, " & _ "tblOutputStormEvent.dUpstreamFlowRatePP, tblOutputStormEvent.dUpstreamRunoff, " & _ "tblOutputStormEvent.dHighwayRunoff, " & _ "tblOutputStormEvent.dStormRvHighwayPP, tblOutputStormEvent.dStormRvHighway, " & _ "tblOutputStormEvent.dStormRvUpstreamPP, tblOutputStormEvent.dStormRvUpstream " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" ' Reference an ADO Recordset Set rstStormRecordset = New ADODB.Recordset rstStormRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstStormRecordset.MoveFirst lngStormNumber = 1 Do While lngStormNumber <= lngNumberOfStorms ' Get Streamflow Statistics dMyStormPVolume = Nz(rstStormRecordset.Fields("dPrecipitationVolume"), 0#) dMyPreStormQPP = Nz(rstStormRecordset.Fields("dUpstreamFlowRatePP"), 0#) ' Get the Upstream Runoff ' ********************** ' Get Uniform Variate lngTries = 0 intHiLowNeutral = 0 ReTryUpstreamRv: Call modStatistics.GetRankCorrelation(dRvRankCorrelation, dMyPreStormQPP, dMyBasinRvPP, _ dBasinRvSeed10, dBasinRvSeed11, dBasinRvSeed12, dBasinRvSeed20, dBasinRvSeed21, dBasinRvSeed22) ' Get Normal Variate dMyBasinRvK = fndUniform01ToNormalAS241(dMyBasinRvPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' Get Pearson Type III Variate ' Prime the Adjusted Wilson Hilferty approximation Call PrimeWilsonHilfertyKirby(dUpstreamRvSkew, dWHA, dWHB, dWHG, dWHH) dMyBasinRvK = fndAdjustedWilsonHilfertyK(dUpstreamRvSkew, dMyBasinRvK, dWHA, dWHB, dWHG, dWHH) ' Calculate Runoff coefficient (adjust K to reject values outside the 0-1 bound) If intHiLowNeutral < 0 Then dMyBasinRvK = Abs(dMyBasinRvK) * -1# ' take from lower half If dMyBasinRvK < dMinBasinRvK Then intHiLowNeutral = -1 If lngTries < 11 Then lngTries = lngTries + 1 GoTo ReTryUpstreamRv: Else dMyBasinRvK = dMinBasinRvK + Abs(dMinBasinRvK) * (dMyBasinRvPP / 100#) End If End If lngTries = 0 intHiLowNeutral = 0 dMyBasinRv = dUpstreamRvAverage + dUpstreamRvStandardDeviation * dMyBasinRvK ' Reject values outside 0-1 If dMyBasinRv >= 1# Then dMyBasinRv = 1# If dMyBasinRv <= 0# Then dMyBasinRv = 0# + (dMyBasinRvPP / 1000#) ' Calculate total runoff dMyBasinRO = dMyBasinRv * dMyStormPVolume * dMyBasinDrainageArea ' Get the Highway Runoff ' ********************** lngTries = 0 intHiLowNeutral = 0 ReTryHighwayRv: ' Get Uniform Variate Call modStatistics.GetRankCorrelation(dMySitesRvRho, dMyBasinRvPP, dMyHighwayRvPP, _ dRoadRvSeed10, dRoadRvSeed11, dRoadRvSeed12, dRoadRvSeed20, dRoadRvSeed21, dRoadRvSeed22) ' Get Normal Variate dMyHighwayRvK = fndUniform01ToNormalAS241(dMyHighwayRvPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' Get Pearson Type III Variate ' Prime the Adjusted Wilson Hilferty approximation Call PrimeWilsonHilfertyKirby(dHighwayRvSkew, dWHA, dWHB, dWHG, dWHH) dMyHighwayRvK = fndAdjustedWilsonHilfertyK(dHighwayRvSkew, dMyHighwayRvK, dWHA, dWHB, dWHG, dWHH) ' Calculate Runoff coefficient (adjust K to reject values outside the 0-1 bound) If intHiLowNeutral < 0 Then dMyHighwayRvK = Abs(dMyHighwayRvK) * -1# ' take from lower half If dMyHighwayRvK < dMinHighwayRvK Then intHiLowNeutral = -1 If lngTries < 21 Then lngTries = lngTries + 1 GoTo ReTryHighwayRv: Else dMyHighwayRvK = dMinHighwayRvK + Abs(dMinHighwayRvK) * (dMyHighwayRvPP / 100#) End If End If lngTries = 0 intHiLowNeutral = 0 dMyHighwayRv = dHighwayRvAverage + dHighwayRvStandardDeviation * dMyHighwayRvK ' Reject values outside 0-1 If dMyHighwayRv >= 1# Then dMyHighwayRv = 1# If dMyHighwayRv <= 0# Then dMyHighwayRv = 0# + (dMyHighwayRvPP / 1000#) ' Calculate total runoff dMyHighwayRO = dMyHighwayRv * dMyStormPVolume * dMyHighwayDrainageArea ' Add new data to table tblOutputStormEvent for existing storms With rstStormRecordset .Fields("dHighwayRunoff") = dMyHighwayRO .Fields("dUpstreamRunoff") = dMyBasinRO '.Fields("dStormRvUpstreamPP") = dMyBasinRvPP .Fields("dStormRvUpstream") = dMyBasinRv '.Fields("dStormRvHighwayPP") = dMyHighwayRvPP .Fields("dStormRvHighway") = dMyHighwayRv .Update End With rstStormRecordset.MoveNext lngStormNumber = lngStormNumber + 1 Loop CleanUp: If rstStormRecordset.State = adStateOpen Then rstStormRecordset.Close 'IF Recordset is open, close it Set rstStormRecordset = Nothing 'Free memory Exit Sub GenerateTotalRunoff_Err: intProblem = 7 intStormErr = intStormErr + 1 If intStormErr < 2 Then GoTo CleanUp: Exit Sub End Sub Public Sub GetPutRhoRv(intWhat As Integer, lMyAnalysis As Long, dMyRhoRv As Double, Optional dMyBaseflowRho As Double) ' ' Purpose to Put the runoff coefficient ' ' History: Created October 2010 by Gregory E. Granato ' October 03 2010 ' ' Arguments ' intWhat 0 = put, 1 = get ' lMyAnalysis current analysis ' dMyRhoRv Spearman's rho for Rv's in current analysis Dim rstMyRecordset As ADODB.Recordset ' recordset Dim strSQL As String ' query string Dim bHasdata As Boolean ' test data Dim intOutErr As Integer ' Error flag On Error GoTo GetPutRhoRv_Err: intOutErr = 0 ' ************************************************************** ' Get values from tblHighwayAnalysis dRvRankCorrelation ' ************************************************************** 'Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset ' set query string strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tblHighwayAnalysis.dRvRho, " & _ "tblHighwayAnalysis.dRvRankCorrelation " & _ "FROM tblHighwayAnalysis " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lMyAnalysis & "));" 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenDynamic, adLockOptimistic ' Check values bHasdata = False ' There is no analysis If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no record bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There are data End If If bHasdata = True Then If intWhat = 0 Then 'Put values With rstMyRecordset .Fields(1).Value = dMyRhoRv .Update End With Else 'Get values dMyRhoRv = Nz(rstMyRecordset.Fields(1).Value, 0#) dMyBaseflowRho = Nz(rstMyRecordset.Fields(2).Value, 0#) End If End If CleanUp: ' Clean up recordset If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetPutRhoRv_Err: intOutErr = intOutErr + 1 If intOutErr < 2 Then Resume CleanUp: End Sub Private Sub GenerateBMPRunoff(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngNumberOfStorms As Long, intProblem As Integer) ' ' Purpose: ' To generate a population of total-runoff flows for a set number of storms ' ' History: ' Version 1.0 April 17 2009 by Gregory E. Granato' ' Version 1.1 Aug 21 2010 by Gregory E. Granato Changed so that it is flow ratio outflow/inflow ' Allow negative trap stats but no neg values 10/10/2011 ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngNumberOfStorms as long total number of storms ' intProblem as integer if zero ok if 1 Bad streamflow stats if 2 error in this subroutine ' ' Arguments Dim lngStormNumber As Long ' Index for the current storm ' Recordset Dim rstStormRecordset As ADODB.Recordset Dim strSQL As String Dim intStart As Integer Dim dMyHighwayRO As Double ' Highway Runoff Dim dMyHighwayROPP As Double ' Highway Runoff Dim dMyBMPFlowPP As Double ' Highway Runoff Discharge (post BMP) plotting position Dim dMyHighwayQ As Double ' Highway Runoff Discharge (post BMP) Dim dMyHEPP As Double ' BMP Hydrograph Extension Dim dMyHE As Double ' BMP Hydrograph Extension, in hours ' BMP flow (volume) reduction Dim bFlowReduction As Boolean ' Is there BMP flow (volume) reduction Dim dMinFlowReduction As Double ' Minimum BMP flow (volume) ratio outflow/inflow Dim dLBMPVFlowReduction As Double ' Lower most probable value BMP flow (volume) ratio outflow/inflow Dim dUBMPVFlowReduction As Double ' Upper most probable value BMP flow (volume) ratio outflow/inflow Dim dMaxFlowReduction As Double ' Maximum BMP flow (volume) ratio outflow/inflow Dim dFRRankCorrelationToFlow As Double ' Correlation to inflow Dim dBMPFlowReductionF As Double ' BMP flow (volume) reduction factor ' BMP Hydrograph Extension Dim bHydrographExtension As Boolean ' Is there BMP Hydrograph Extension Dim dMinHydrographExtension As Double ' Minimum BMP Hydrograph Extension (HE) Dim dLBMPVHydrographExtension As Double ' Lower most probable value BMP HE Dim dUBMPVHydrographExtension As Double ' Upper most probable value BMP HE Dim dMaxHydrographExtension As Double ' Maximum BMP Hydrograph Extension (HE) Dim dHERankCorrelationToFlow As Double ' Correlation to inflow Dim dBMPHydrographExtensionF As Double ' BMP Hydrograph Extension factor ' BMP Flow Reduction Seeds Dim dBMPFlowSeed10 As Double Dim dBMPFlowSeed11 As Double Dim dBMPFlowSeed12 As Double Dim dBMPFlowSeed20 As Double Dim dBMPFlowSeed21 As Double Dim dBMPFlowSeed22 As Double ' BMP Flow Reduction Seeds Dim dBMPHESeed10 As Double Dim dBMPHESeed11 As Double Dim dBMPHESeed12 As Double Dim dBMPHESeed20 As Double Dim dBMPHESeed21 As Double Dim dBMPHESeed22 As Double Dim intStormErr As Integer On Error GoTo GenerateBMPRunoff_Err: intStormErr = 0 intProblem = 0 ' *********** Get Information **************** ' Get the BMP Flow reduction & Hydrograph Extension parameters Call GetBMPFlowModification(lMyAnalysis, bFlowReduction, _ dMinFlowReduction, dLBMPVFlowReduction, dUBMPVFlowReduction, _ dMaxFlowReduction, dFRRankCorrelationToFlow, _ bHydrographExtension, dMinHydrographExtension, dLBMPVHydrographExtension, _ dUBMPVHydrographExtension, dMaxHydrographExtension, dHERankCorrelationToFlow) ' Check for errors If bFlowReduction = True And dMaxFlowReduction = 2# ^ (-10#) Then intProblem = 1 Exit Sub End If ' Check for errors If bHydrographExtension = True And dMaxHydrographExtension = 2# ^ (-10#) Then intProblem = 2 Exit Sub End If ' Highway Runoff Reduction by BMP is sequence #7 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dBMPFlowSeed10, dBMPFlowSeed20) ' Highway Runoff Hydrograph Extension by BMP is sequence #87 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dBMPHESeed10, dBMPHESeed20) ' Warm up Rng Seeds For intStart = 1 To 3 If bFlowReduction = True Then Call modStatistics.MRG32k3a(dMyBMPFlowPP, dBMPFlowSeed10, dBMPFlowSeed11, dBMPFlowSeed12, _ dBMPFlowSeed20, dBMPFlowSeed21, dBMPFlowSeed22) End If If bHydrographExtension = True Then Call modStatistics.MRG32k3a(dMyHEPP, dBMPHESeed10, dBMPHESeed11, dBMPHESeed12, _ dBMPHESeed20, dBMPHESeed21, dBMPHESeed22) End If Next intStart strSQL = "SELECT tblOutputStormEvent.dHighwayRunoffPP, tblOutputStormEvent.dHighwayRunoff, " & _ "tblOutputStormEvent.dHighwayBMPDischarge, tblOutputStormEvent.dBMPFlowExtension " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" ' Reference an ADO Recordset Set rstStormRecordset = New ADODB.Recordset rstStormRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstStormRecordset.MoveFirst lngStormNumber = 1 Do While lngStormNumber <= lngNumberOfStorms ' Get Streamflow Statistics dMyHighwayROPP = Nz(rstStormRecordset.Fields("dHighwayRunoffPP"), 0.5) dMyHighwayRO = Nz(rstStormRecordset.Fields("dHighwayRunoff"), 0#) ' Get the Highway Discharge (Post BMP) ' ********************** If bFlowReduction = False Then dMyHighwayQ = dMyHighwayRO ' Highway Runoff Discharge (No BMP)= Highway Runoff Else 'Get Uniform Variate Call modStatistics.GetRankCorrelation(dFRRankCorrelationToFlow, dMyHighwayROPP, dMyBMPFlowPP, _ dBMPFlowSeed10, dBMPFlowSeed11, dBMPFlowSeed12, dBMPFlowSeed20, dBMPFlowSeed21, dBMPFlowSeed22) ' Get Reduction Factor dBMPFlowReductionF = fndUniform01ToTrapezoid(dMyBMPFlowPP, dMinFlowReduction, _ dLBMPVFlowReduction, dUBMPVFlowReduction, dMaxFlowReduction) ' Allow negative trap stats but no neg values 10/10/2011 If dBMPFlowReductionF <= 0# Then dBMPFlowReductionF = dMaxFlowReduction * ((10#) ^ (-4#)) 'dMyHighwayQ = dMyHighwayRO * (1 - dBMPFlowReductionF) dMyHighwayQ = dMyHighwayRO * (dBMPFlowReductionF) ' 0 = no outflow 1 = complete pass through > 1 extra from BMP End If ' Get the Flow Extension ' ********************** If bHydrographExtension = False Then dBMPHydrographExtensionF = 0# ' Highway Runoff Discharge (No BMP)= Highway Runoff Else 'Get Uniform Variate Call modStatistics.GetRankCorrelation(dHERankCorrelationToFlow, dMyHighwayROPP, dMyHEPP, _ dBMPHESeed10, dBMPHESeed11, dBMPHESeed12, dBMPHESeed20, dBMPHESeed21, dBMPHESeed22) ' Get Extension Factor dBMPHydrographExtensionF = fndUniform01ToTrapezoid(dMyHEPP, dMinHydrographExtension, _ dLBMPVHydrographExtension, dUBMPVHydrographExtension, dMaxHydrographExtension) End If ' Allow negative trap stats but no neg values 10/10/2011 If dBMPHydrographExtensionF < 0# Then dBMPHydrographExtensionF = 0# ' Add new data to table tblOutputStormEvent for existing storms With rstStormRecordset .Fields("dHighwayBMPDischarge") = dMyHighwayQ .Fields("dBMPFlowExtension") = dBMPHydrographExtensionF .Update End With rstStormRecordset.MoveNext lngStormNumber = lngStormNumber + 1 Loop CleanUp: If rstStormRecordset.State = adStateOpen Then rstStormRecordset.Close 'IF Recordset is open, close it Set rstStormRecordset = Nothing 'Free memory Exit Sub GenerateBMPRunoff_Err: intProblem = 3 intStormErr = intStormErr + 1 If intStormErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GenerateConcurrentRunoff(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngNumberOfStorms As Long, intProblem As Integer) ' ' Purpose: ' To generate a population of runoff flows concurrent for the highway & upstream ' for a set number of storms ' ' History: ' Version 1.0 April 22 2009 by Gregory E. Granato' ' Version 1.0.1 September 17 2011 by Gregory E. Granato ' >>>Calculate upstream time to centroid using Lag and time to peak as TP = (3*TC)/((TimeFalling/TimePeak)+2) ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngNumberOfStorms as long total number of storms ' intProblem as integer if zero ok if 1 Bad stormflow stats if 2 error in this subroutine ' ' Arguments Dim lngStormNumber As Long ' Index for the current storm ' Recordset Dim rstStormRecordset As ADODB.Recordset Dim strSQL As String Dim intStart As Integer Dim dPrecipitationDuration As Double ' Basin Lag, in hours ' Upstream Drainage/flow Dim dMyBasinLag As Double ' Basin Lag, in hours Dim dUpstreamFlowRate As Double ' Prestorm flow rate, cfs Dim dUpstreamRunoff As Double ' Basin total stormflow Dim dUpstreamStormFlowDuration As Double ' Basin runoff duration, in hours Dim dUpstreamRecessionFactor As Double ' Basin runoff recession factor, in hours Dim dUpstreamRecessionFactorPP As Double ' Basin runoff recession factor plotting position Dim dUpstreamStormDischarge As Double ' Total upstream stormflow + baseflow during storm, in cubic feet Dim dUpstreamConcurrentFlow As Double ' Total upstream stormflow + baseflow during ' concurrent runoff period, in cubic feet Dim dUpstreamBMPConcurrentFlow As Double ' Total upstream stormflow + baseflow during ' concurrent runoff period, in cubic feet Dim dMinRecessionFactor As Double Dim dMPVRecessionFactor As Double Dim dMaxRecessionFactor As Double Dim dDilutionFactor As Double Dim dBMPDilutionFactor As Double ' Highway Drainage/flow Dim dMyHighwayLag As Double ' Basin Lag, in hours Dim dBMPFlowExtension As Double ' Highway BMP Discharge extension, in hours Dim dHighwayStormFlowDuration As Double ' Highway runoff duration (PreBMP), in hours Dim dHighwayDischargeDuration As Double ' Highway runoff duration (Post BMP), in hours Dim dHighwayBMPDischarge As Double ' Highway BMP Discharge to stream Dim dHighwayRunoff As Double ' Highway Discharge to stream without BMP Dim dMyHighwayTP As Double ' time to peak Dim dMyBasinTC As Double ' time to centroid Dim dMyBasinTP As Double ' time to peak Dim dMyBasinFlowFactor As Double ' Concurrent flow factor Dim dMyBasinBMPFlowFactor As Double ' Concurrent flow factor Dim dMyBasinR As Double ' Hydrograph recession factor ' Upstream Recession Factor Random Seeds Dim dRecessionFactorSeed10 As Double Dim dRecessionFactorSeed11 As Double Dim dRecessionFactorSeed12 As Double Dim dRecessionFactorSeed20 As Double Dim dRecessionFactorSeed21 As Double Dim dRecessionFactorSeed22 As Double Dim intStormErr As Integer On Error GoTo GenerateTotalRunoff_Err: intStormErr = 0 intProblem = 0 ' *********** Get Information **************** ' Get/test Highway Basin Lag dMyHighwayLag = fndBasinLag(lMyAnalysis, 0) If dMyHighwayLag < 0# Then ' Highway Site Problem intProblem = 1 Exit Sub End If ' Get/test Upstream Basin Lag dMyBasinLag = fndBasinLag(lMyAnalysis, 1) If dMyBasinLag < 0# Then ' Upstream Site Problem intProblem = 2 Exit Sub End If ' Get/test Recession factors Call GetHydrographRecession(lMyAnalysis, dMinRecessionFactor, dMPVRecessionFactor, dMaxRecessionFactor) If dMinRecessionFactor < 1 Or dMPVRecessionFactor < 1 Or dMaxRecessionFactor <= dMinRecessionFactor Then intProblem = 3 Exit Sub End If ' **********Get initial seeds from seed table based on master seed sequence number ' Basin Recession Factor is sequence #5 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dRecessionFactorSeed10, dRecessionFactorSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dUpstreamRecessionFactorPP, dRecessionFactorSeed10, dRecessionFactorSeed11, _ dRecessionFactorSeed12, dRecessionFactorSeed20, dRecessionFactorSeed21, dRecessionFactorSeed22) Next intStart strSQL = "SELECT tblOutputStormEvent.dPrecipitationDuration, " & _ "tblOutputStormEvent.dUpstreamFlowRate, tblOutputStormEvent.dUpstreamRunoff, " & _ "tblOutputStormEvent.dHighwayRunoff, " & _ "tblOutputStormEvent.dHighwayBMPDischarge, tblOutputStormEvent.dBMPFlowExtension, " & _ "tblOutputStormEvent.dUpstreamStormFlowDuration, tblOutputStormEvent.dHighwayStormFlowDuration, " & _ "tblOutputStormEvent.dHighwayDischargeDuration, tblOutputStormEvent.dUpstreamStormDischarge, " & _ "tblOutputStormEvent.dUpstreamConcurrentFlow, tblOutputStormEvent.dDilutionFactor, " & _ "tblOutputStormEvent.dUpstreamBMPConcurrentQ, tblOutputStormEvent.dBMPDilutionFactor " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" ' Reference an ADO Recordset Set rstStormRecordset = New ADODB.Recordset rstStormRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstStormRecordset.MoveFirst lngStormNumber = 1 Do While lngStormNumber <= lngNumberOfStorms ' Get Streamflow Statistics dPrecipitationDuration = Nz(rstStormRecordset.Fields("dPrecipitationDuration"), 1#) dUpstreamFlowRate = Nz(rstStormRecordset.Fields("dUpstreamFlowRate"), 0#) dUpstreamRunoff = Nz(rstStormRecordset.Fields("dUpstreamRunoff"), 0#) dHighwayRunoff = Nz(rstStormRecordset.Fields("dHighwayRunoff"), 0#) dHighwayBMPDischarge = Nz(rstStormRecordset.Fields("dHighwayBMPDischarge"), 0#) dBMPFlowExtension = Nz(rstStormRecordset.Fields("dBMPFlowExtension"), 0#) ' Get the Highway Runoff ' ********************** dMyHighwayTP = (dPrecipitationDuration / 2#) + dMyHighwayLag dHighwayStormFlowDuration = (2# * dMyHighwayTP) If dHighwayStormFlowDuration < dPrecipitationDuration Then dHighwayStormFlowDuration = dPrecipitationDuration dHighwayDischargeDuration = dHighwayStormFlowDuration + dBMPFlowExtension If dHighwayDischargeDuration < dHighwayStormFlowDuration Then dHighwayDischargeDuration = dHighwayStormFlowDuration ' Get the Upstream Runoff ' ********************** dMyBasinTC = (dPrecipitationDuration / 2#) + dMyBasinLag ' Get Uniform Variate Call modStatistics.MRG32k3a(dUpstreamRecessionFactorPP, dRecessionFactorSeed10, dRecessionFactorSeed11, _ dRecessionFactorSeed12, dRecessionFactorSeed20, dRecessionFactorSeed21, dRecessionFactorSeed22) dMyBasinR = fndUniform01ToTrapezoid(dUpstreamRecessionFactorPP, dMinRecessionFactor, _ dMPVRecessionFactor, dMPVRecessionFactor, dMaxRecessionFactor) If dMyBasinR < 1# Then dMyBasinR = 1# ' Recession cannot be less than time to peak ' Calculate time to peak dMyBasinTP = (3# * dMyBasinTC) / (dMyBasinR + 2) dUpstreamStormFlowDuration = dMyBasinTP + dMyBasinTP * dMyBasinR ' Storm hydrograph base time If dUpstreamStormFlowDuration < dPrecipitationDuration Then dUpstreamStormFlowDuration = dPrecipitationDuration ' Get the Concurrent Flows ' ********************** ' Get concurrent Highway stormflow factor If dHighwayStormFlowDuration >= dUpstreamStormFlowDuration Then dMyBasinFlowFactor = 1# Else If dHighwayStormFlowDuration < dMyBasinTP Then dMyBasinFlowFactor = (dHighwayStormFlowDuration ^ 2#) / (dUpstreamStormFlowDuration * dMyBasinTP) Else dMyBasinFlowFactor = 1# - (((dUpstreamStormFlowDuration - dHighwayStormFlowDuration) ^ 2#) / _ (dUpstreamStormFlowDuration * (dUpstreamStormFlowDuration - dMyBasinTP))) End If End If ' Get concurrent BMP stormflow factor If dHighwayDischargeDuration >= dUpstreamStormFlowDuration Then dMyBasinBMPFlowFactor = 1# Else If dHighwayDischargeDuration < dMyBasinTP Then dMyBasinBMPFlowFactor = (dHighwayDischargeDuration ^ 2#) / (dUpstreamStormFlowDuration * dMyBasinTP) Else dMyBasinBMPFlowFactor = 1# - (((dUpstreamStormFlowDuration - dHighwayDischargeDuration) ^ 2#) / _ (dUpstreamStormFlowDuration * (dUpstreamStormFlowDuration - dMyBasinTP))) End If End If ' calculate basin flows ' ********************** ' All upstream storm flows dUpstreamStormDischarge = dUpstreamRunoff + dUpstreamStormFlowDuration * dUpstreamFlowRate * 3600# dUpstreamConcurrentFlow = dMyBasinFlowFactor * dUpstreamRunoff + dHighwayStormFlowDuration * dUpstreamFlowRate * 3600# dUpstreamBMPConcurrentFlow = dMyBasinBMPFlowFactor * dUpstreamRunoff + dHighwayDischargeDuration * dUpstreamFlowRate * 3600# ' calculate the dilution Factor DF = dHighwayBMPDischarge / (dHighwayBMPDischarge + dUpstreamConcurrentFlow) ' ********************** If dHighwayRunoff = 0# And dUpstreamConcurrentFlow = 0# Then dDilutionFactor = -9999# Else dDilutionFactor = dHighwayRunoff / (dHighwayRunoff + dUpstreamConcurrentFlow) End If If dHighwayBMPDischarge = 0# And dUpstreamBMPConcurrentFlow = 0# Then dBMPDilutionFactor = -9999# Else dBMPDilutionFactor = dHighwayBMPDischarge / (dHighwayBMPDischarge + dUpstreamBMPConcurrentFlow) End If ' Add new data to table tblOutputStormEvent for existing storms With rstStormRecordset .Fields("dUpstreamStormFlowDuration") = dUpstreamStormFlowDuration .Fields("dHighwayStormFlowDuration") = dHighwayStormFlowDuration .Fields("dHighwayDischargeDuration") = dHighwayDischargeDuration .Fields("dUpstreamStormDischarge") = dUpstreamStormDischarge .Fields("dUpstreamConcurrentFlow") = dUpstreamConcurrentFlow .Fields("dUpstreamBMPConcurrentQ") = dUpstreamBMPConcurrentFlow .Fields("dDilutionFactor") = dDilutionFactor .Fields("dBMPDilutionFactor") = dBMPDilutionFactor .Update End With rstStormRecordset.MoveNext lngStormNumber = lngStormNumber + 1 Loop CleanUp: If rstStormRecordset.State = adStateOpen Then rstStormRecordset.Close 'IF Recordset is open, close it Set rstStormRecordset = Nothing 'Free memory Exit Sub GenerateTotalRunoff_Err: intProblem = 7 intStormErr = intStormErr + 1 If intStormErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetPrecipStats(lngMyInputAnalysis As Long, dMeanPVolume As Double, dMinPVolume As Double, _ dMeanPDuration As Double, dMinPDuration As Double, _ dMeanPDelta As Double, dMinPDelta As Double) ' ' Purpose: To get 2-Parameter Exponential Precipitation Statistics for the analysis ' History: 01/24/2009 by Gregory E. Granato ' ' lngMyInputAnalysis as long Input Highway runoff analysis identification number ' dMeanPVolume as double Output mean storm-event precipitation volume ' dMinPVolume as double Output minimum storm-event precipitation volume ' dMeanPDuration as double Output mean storm-event precipitation duration ' dMinPDuration as double Output minimum storm-event precipitation duration currently fixed as 1 hour ' dMeanPDelta as double Output mean storm-event delta (time between storm midpoints) ' dMinPDelta as double Output minimum storm-event delta (time between storm midpoints) ' Arguments: Dim bHasdata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo GetPrecipStats_Err: intErr = 0 ' initialize to error dMeanPVolume = -9999# dMinPVolume = -9999# dMeanPDuration = -9999# dMinPDuration = 1# dMeanPDelta = -9999# dMinPDelta = -9999# ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset strSQL = "SELECT tblPrecipSelection.dAvgStormVolume, tblPrecipSelection.dMinStormVol, " & _ "tblPrecipSelection.dAvgStormDuration, tblPrecipSelection.dAvgStormDelta, tblPrecipSelection.dIntereventTime " & _ "FROM tblPrecipSelection INNER JOIN tblHighwayAnalysis ON " & _ "tblPrecipSelection.PrecipEventStatistics_ID = tblHighwayAnalysis.PrecipEventStatistics_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo CleanUp: ' There is no data for this analysis dMeanPVolume = Nz(rstMyRecordset.Fields("dAvgStormVolume").Value, -9999#) dMinPVolume = Nz(rstMyRecordset.Fields("dMinStormVol").Value, -9999#) dMeanPDuration = Nz(rstMyRecordset.Fields("dAvgStormDuration").Value, -9999#) dMinPDuration = 1# dMeanPDelta = Nz(rstMyRecordset.Fields("dAvgStormDelta").Value, -9999#) 'dMinPDelta + 1 added by GEG on 11/18/2011 + 1 because delta is center to center dMinPDelta = Nz(rstMyRecordset.Fields("dIntereventTime").Value, -9999#) + 1 CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetPrecipStats_Err: dMeanPVolume = -9999# dMinPVolume = -9999# dMeanPDuration = -9999# dMinPDuration = -9999# dMeanPDelta = -9999# dMinPDelta = -9999# intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetHydrographRecession(lngMyInputAnalysis As Long, dMinRecessionFactor As Double, _ dMPVRecessionFactor As Double, dMaxRecessionFactor As Double) ' ' Purpose: To get log10 streamflow statistics for the analysis ' History: 01/31/2009 by Gregory E. Granato ' ' lngMyInputAnalysis as long input Highway runoff analysis identification number ' dMinRecessionFactor output upstream basin minimum recession factor ' dMPVRecessionFactor output upstream basin most probable value recession factor ' dMaxRecessionFactor output upstream basin maximum recession factor ' Arguments: Dim bHasdata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo GetStreamflowStats_Err: intErr = 0 'initialize to error dMinRecessionFactor = -9999# dMPVRecessionFactor = -9999# dMaxRecessionFactor = -9999# strSQL = "SELECT tblUpstreamBasin.dMinRecessionFactor, tblUpstreamBasin.dMPVRecessionFactor, " & _ "tblUpstreamBasin.dMaxRecessionFactor " & _ "FROM tblUpstreamBasin INNER JOIN tblHighwayAnalysis ON " & _ "tblUpstreamBasin.UpstreamBasin_ID = tblHighwayAnalysis.UpstreamBasin_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo CleanUp: ' There is no data for this analysis dMinRecessionFactor = Nz(rstMyRecordset.Fields("dMinRecessionFactor").Value, -9999#) dMPVRecessionFactor = Nz(rstMyRecordset.Fields("dMPVRecessionFactor").Value, -9999#) dMaxRecessionFactor = Nz(rstMyRecordset.Fields("dMaxRecessionFactor").Value, -9999#) CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetStreamflowStats_Err: intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetStreamflowStats(lngMyInputAnalysis As Long, dProportionZero As Double, dLog10Mean As Double, _ dLog10StandardDeviation As Double, dLog10SkewQ As Double) ' ' Purpose: To get log10 streamflow statistics for the analysis ' History: 01/31/2009 by Gregory E. Granato ' ' lngMyInputAnalysis as long Input Highway runoff analysis identification number ' dProportionZero As Double Output proportion of zero streamflows ' dLog10Mean As Double Output mean of the logs of streamflow ' dLog10StandardDeviation As Double Output standard deviation of the logs of streamflow ' dLog10SkewQ As Double Output skew of the logs of streamflow ' Arguments: Dim bHasdata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo GetStreamflowStats_Err: intErr = 0 ' initialize to error dProportionZero = 0# dLog10Mean = -9999# dLog10StandardDeviation = -9999# dLog10SkewQ = -9999# ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tblStreamflowSelection.dProportionZero, " & _ "tblStreamflowSelection.dLog10MeanQ, tblStreamflowSelection.dLog10StandardDeviationQ, " & _ "tblStreamflowSelection.dLog10SkewQ " & _ "FROM tblStreamflowSelection INNER JOIN tblHighwayAnalysis ON tblStreamflowSelection.StreamflowSelection_ID = " & _ "tblHighwayAnalysis.StreamflowSelection_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo CleanUp: ' There is no data for this analysis dProportionZero = Nz(rstMyRecordset.Fields("dProportionZero").Value, 0#) dLog10Mean = Nz(rstMyRecordset.Fields("dLog10MeanQ").Value, -9999#) dLog10StandardDeviation = Nz(rstMyRecordset.Fields("dLog10StandardDeviationQ").Value, -9999#) dLog10SkewQ = Nz(rstMyRecordset.Fields("dLog10SkewQ").Value, -9999#) CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetStreamflowStats_Err: dProportionZero = 0# dLog10Mean = -9999# dLog10StandardDeviation = -9999# dLog10SkewQ = -9999# intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetRvStats(lngMyInputAnalysis As Long, _ dHighwayRvAverage As Double, dHighwayRvStandardDeviation As Double, dHighwayRvSkew As Double, _ dUpstreamRvAverage As Double, dUpstreamRvStandardDeviation As Double, dUpstreamRvSkew As Double, _ dRvRankCorrelation As Double) ' ' Purpose: To get Runoff coefficient statistics for the analysis ' History: 01/31/2009 by Gregory E. Granato ' ' lngMyInputAnalysis as long Input Highway runoff analysis identification number ' dHighwayRvAverage As Double Output mean of the runoff coefficients ' dHighwayRvStandardDeviation As Double Output standard deviation of the runoff coefficients ' dHighwayRvSkew As Double Output skew of the runoff coefficients ' dUpstreamRvAverage As Double Output mean of the runoff coefficients ' dUpstreamRvStandardDeviation As Double Output standard deviation of the runoff coefficients ' dUpstreamRvSkew As Double Output skew of the runoff coefficients ' dRvRankCorrelation As Double Output rank correlation coefficient between prestorm flow and Rv ' ' Arguments: Dim bHasdata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo GetRvStats_Err: intErr = 0 dHighwayRvAverage = 0# dHighwayRvStandardDeviation = 0# dHighwayRvSkew = 0# dUpstreamRvAverage = 0# dUpstreamRvStandardDeviation = 0# dUpstreamRvSkew = 0# dRvRankCorrelation = 0# ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tblHighwayAnalysis.dHighwayRvAverage, " & _ "tblHighwayAnalysis.dHighwayRvStandardDeviation, tblHighwayAnalysis.dHighwayRvSkew, " & _ "tblHighwayAnalysis.dUpstreamRvAverage, tblHighwayAnalysis.dUpstreamRvStandardDeviation, " & _ "tblHighwayAnalysis.dUpstreamRvSkew, tblHighwayAnalysis.dRvRankCorrelation " & _ "FROM tblHighwayAnalysis " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo CleanUp: ' There is no data for this analysis dHighwayRvAverage = Nz(rstMyRecordset.Fields("dHighwayRvAverage").Value, 0#) dHighwayRvStandardDeviation = Nz(rstMyRecordset.Fields("dHighwayRvStandardDeviation").Value, 0#) dHighwayRvSkew = Nz(rstMyRecordset.Fields("dHighwayRvSkew").Value, 0#) dUpstreamRvAverage = Nz(rstMyRecordset.Fields("dUpstreamRvAverage").Value, 0#) dUpstreamRvStandardDeviation = Nz(rstMyRecordset.Fields("dUpstreamRvStandardDeviation").Value, 0#) dUpstreamRvSkew = Nz(rstMyRecordset.Fields("dUpstreamRvSkew").Value, 0#) dRvRankCorrelation = Nz(rstMyRecordset.Fields("dRvRankCorrelation").Value, 0#) CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetRvStats_Err: dHighwayRvAverage = 0# dHighwayRvStandardDeviation = 0# dHighwayRvSkew = 0# dUpstreamRvAverage = 0# dUpstreamRvStandardDeviation = 0# dUpstreamRvSkew = 0# dRvRankCorrelation = 0# intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Function fnlngGetAnalysisMasterSeed(lngMyInputAnalysis As Long) As Long ' ' Purpose to Get the preselected Master Seed from the analysis table ' ' History: Created Feb. 8 2005 by Gregory E. Granato ' ' Arguments Dim bHasdata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMySeedRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo fnlngGetAnalysisMasterSeed_Err: intErr = 0 ' Reference an ADO Recordset Set rstMySeedRecordset = New ADODB.Recordset strSQL = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tblHighwayAnalysis.lMasterRandomSeed " & _ "FROM tblHighwayAnalysis " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" 'Populate Recordset rstMySeedRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMySeedRecordset.BOF And rstMySeedRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMySeedRecordset.Fields(0).Value) = False Then If IsEmpty(rstMySeedRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then fnlngGetAnalysisMasterSeed = -9999 Else fnlngGetAnalysisMasterSeed = rstMySeedRecordset.Fields("lMasterRandomSeed").Value End If CleanUp: If rstMySeedRecordset.State = adStateOpen Then rstMySeedRecordset.Close 'IF Recordset is open, close it Set rstMySeedRecordset = Nothing 'Free memory Exit Function fnlngGetAnalysisMasterSeed_Err: fnlngGetAnalysisMasterSeed = -9999 intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Function End Function Private Function fndGetDrainageFeature(lngMyInputAnalysis As Long, intWhat As Integer) As Double ' ' Purpose to Get the Drainage Area Highway or upstream using the analysis number ' ' lngMyInputAnalysis is the current analysis number ' intWhat indicates the data we need ' History: Created April 17 2009 by Gregory E. Granato ' ' Arguments Dim bHasdata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMyDARecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag On Error GoTo fndGetDrainageFeature_Err: intErr = 0 ' Reference an ADO Recordset Set rstMyDARecordset = New ADODB.Recordset If intWhat = 0 Then ' Highway site Drainage area strSQL = "SELECT tblHighwaySite.dDrainageArea " & _ "FROM tblHighwaySite INNER JOIN tblHighwayAnalysis ON " & _ "tblHighwaySite.HighwaySite_ID = tblHighwayAnalysis.HighwaySite_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" ElseIf intWhat = 1 Then ' Highway site Impervious Fraction strSQL = "SELECT tblHighwaySite.dImperviousFraction " & _ "FROM tblHighwaySite INNER JOIN tblHighwayAnalysis ON " & _ "tblHighwaySite.HighwaySite_ID = tblHighwayAnalysis.HighwaySite_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" ElseIf intWhat = 2 Then ' Upstream Drainage area strSQL = "SELECT tblUpstreamBasin.dBasinDrainageArea " & _ "FROM tblUpstreamBasin INNER JOIN tblHighwayAnalysis ON " & _ "tblUpstreamBasin.UpstreamBasin_ID = tblHighwayAnalysis.UpstreamBasin_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" ElseIf intWhat = 3 Then ' Upstream Impervious Fraction strSQL = "SELECT tblUpstreamBasin.dBasinImperviousFraction " & _ "FROM tblUpstreamBasin INNER JOIN tblHighwayAnalysis ON " & _ "tblUpstreamBasin.UpstreamBasin_ID = tblHighwayAnalysis.UpstreamBasin_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" ElseIf intWhat = 4 Then ' Lake-Basin Drainage area strSQL = "SELECT tblLakeBasin.dLakeBasinDrainageArea " & _ "FROM tblLakeBasin INNER JOIN tblHighwayAnalysis ON " & _ "tblLakeBasin.LakeDrainageBasin_ID = tblHighwayAnalysis.LakeDrainageBasin_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" End If 'Populate Recordset rstMyDARecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyDARecordset.BOF And rstMyDARecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyDARecordset.Fields(0).Value) = False Then If IsEmpty(rstMyDARecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then fndGetDrainageFeature = -9999# Else fndGetDrainageFeature = rstMyDARecordset.Fields(0).Value End If CleanUp: If rstMyDARecordset.State = adStateOpen Then rstMyDARecordset.Close 'IF Recordset is open, close it Set rstMyDARecordset = Nothing 'Free memory Exit Function fndGetDrainageFeature_Err: fndGetDrainageFeature = -9999# intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Function End Function Private Sub GetStartSeed(lngInMasterSeed As Long, lngInSeedSequence As Long, dOutSeed010 As Double, dOutSeed020 As Double) ' ' Purpose: To get starting seed values from from tblURNSeeds with the master seed and ' a sequence number or to generate a seed from the MSRandom (Rnd()) function ' History: Version 1.0 April 10 2009 by G.E. Granato ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' dOutSeed010 As Double first random seed for random number generator ' dOutSeed020 As Double second random seed for random number generator ' ' Arguments Dim bIsSeedValid As Boolean Dim intSubroutineError As Integer Dim lngMySubMinSeed As Long Dim lngMySubMaxSeed As Long Dim lngMySubCountSeed As Long Dim lngMaxTries As Long Dim lngTrySeed As Long Dim lngI As Long Dim dMySeed010 As Double Dim dMySeed011 As Double Dim dMySeed012 As Double Dim dMySeed020 As Double Dim dMySeed021 As Double Dim dMySeed022 As Double Dim dMySubU01 As Double On Error GoTo GetStartSeed_Err: ' check master seed ' ****************** bIsSeedValid = modPublicInterface.fnbIsSeedIDinTable(lngInMasterSeed) If bIsSeedValid = False Then ' Use MS rnd() values for seeds Call UseMSRand(lngInMasterSeed, lngInSeedSequence, dOutSeed010, dOutSeed020) lngInSeedSequence = lngInSeedSequence + 1 Exit Sub End If ' check master seed table ' *********************** intSubroutineError = 0 Call modStatistics.SeedTableStatistics(lngMySubMaxSeed, lngMySubMinSeed, lngMySubCountSeed, _ intSubroutineError) If intSubroutineError <> 0 Then ' Use MS rnd() values for seeds Call UseMSRand(lngInMasterSeed, lngInSeedSequence, dOutSeed010, dOutSeed020) lngInSeedSequence = lngInSeedSequence + 1 Exit Sub End If ' Get uniform numbers up to lngInSeedSequence ' *********************** Call GetTableSeeds(lngInMasterSeed, dOutSeed010, dOutSeed020, intSubroutineError) If intSubroutineError <> 0 Or dOutSeed010 = 0 Or dOutSeed010 = 0 Then Call UseMSRand(lngInMasterSeed, lngInSeedSequence, dOutSeed010, dOutSeed020) lngInSeedSequence = lngInSeedSequence + 1 Exit Sub End If For lngI = 1 To lngInSeedSequence + 3 Call MRG32k3a(dMySubU01, dOutSeed010, dMySeed011, dMySeed012, dOutSeed020, dMySeed021, dMySeed022) Next lngI ' Get output seeds ' *********************** 'Convert the value to a long integer in the seed number interval lngTrySeed = CLng(Round((lngMySubMinSeed + (lngMySubMaxSeed - lngMySubMinSeed) * dMySubU01), 0)) Call GetTableSeeds(lngTrySeed, dOutSeed010, dOutSeed020, intSubroutineError) If intSubroutineError = 0 Then lngInSeedSequence = lngInSeedSequence + 1 Exit Sub ' Ok we have what we need End If ' Try other seed numbers (up to 65) ' *********************** If intSubroutineError <> 0 Then ' Houstin we still have a problem For lngI = 1 To 65 ' give it up to 65 tries to get a good seed in the table lngInSeedSequence = lngInSeedSequence + 1 Call MRG32k3a(dMySubU01, dMySeed010, dMySeed011, dMySeed012, dMySeed020, dMySeed021, dMySeed022) 'Convert the value to a long integer in the seed number interval lngTrySeed = CLng(Round((lngMySubMinSeed + (lngMySubMaxSeed - lngMySubMinSeed) * dMySubU01), 0)) Call GetTableSeeds(lngTrySeed, dOutSeed010, dOutSeed020, intSubroutineError) If intSubroutineError = 0 Then lngInSeedSequence = lngInSeedSequence + 1 Exit Sub End If Next lngI End If ' Use MS rnd() values for seeds because of problems ' *********************** Call UseMSRand(lngInMasterSeed, lngInSeedSequence, dOutSeed010, dOutSeed020) lngInSeedSequence = lngInSeedSequence + 1 Exit Sub GetStartSeed_Err: MsgBox Err.Description, vbCritical, "GetStartSeed" Exit Sub End Sub Private Sub UseMSRand(lngInMasterSeed, lngInSeedSequence, dOutSeed010 As Double, dOutSeed020 As Double) ' ' Purpose: To get starting seed values using the MSRandom (Rnd()) function ' History: Version 1.0 April 10 2009 by G.E. Granato ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' dOutSeed010 As Double first random seed for random number generator ' dOutSeed020 As Double second random seed for random number generator ' ' Arguments Dim dTemp As Double Dim lngI As Long If lngInSeedSequence <= 0 Then lngInSeedSequence = 1 ' Initialize to lngInMasterSeed dTemp = Rnd(Abs(lngInMasterSeed)) For lngI = 1 To lngInSeedSequence dTemp = Rnd() Next lngI dOutSeed010 = CLng(10000# + (1000000# - 10000#) * dTemp) For lngI = lngInSeedSequence To lngInSeedSequence + 77 dTemp = Rnd() Next lngI dOutSeed020 = CLng(100000# + (10000000# - 100000#) * dTemp) Exit Sub GetStartSeed_Err: MsgBox Err.Description, vbCritical, "GetStartSeed" Exit Sub End Sub Private Sub GetTableSeeds(lngInputSeedID As Long, dOutputSeed01 As Double, dOutputSeed02 As Double, intTryErr As Integer) ' ' Purpose: To get the seed values from from tblURNSeeds for an input ID ' ' History: Version 1.0 Feburary 7 2009 by G.E. Granato ' Dim bHasdata As Boolean Dim rstMySeedRecordset As ADODB.Recordset ' recordset Dim strSQL As String ' Query text Dim intErr As Integer ' problem flag On Error GoTo GetInitialSeeds_Err: intErr = 0 intTryErr = 0 strSQL = "SELECT tblURNSeeds.dURNSeed01, tblURNSeeds.dURNSeed02 " & _ "FROM tblURNSeeds " & _ "WHERE (((tblURNSeeds.URNSeed_ID)=" & lngInputSeedID & "));" ' Reference an ADO Recordset Set rstMySeedRecordset = New ADODB.Recordset 'Populate Recordset rstMySeedRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMySeedRecordset.BOF And rstMySeedRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMySeedRecordset.Fields(0).Value) = False Then If IsEmpty(rstMySeedRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no seeds intTryErr = -1 ElseIf Nz(rstMySeedRecordset.Fields(0).Value, 0#) = 0# Or Nz(rstMySeedRecordset.Fields(1).Value, 0#) = 0# Then intTryErr = -1 Else dOutputSeed01 = rstMySeedRecordset.Fields("dURNSeed01").Value dOutputSeed02 = rstMySeedRecordset.Fields("dURNSeed02").Value intTryErr = 0 End If CleanUp: If rstMySeedRecordset.State = adStateOpen Then rstMySeedRecordset.Close 'IF Recordset is open, close it Set rstMySeedRecordset = Nothing 'Free memory Exit Sub GetInitialSeeds_Err: intTryErr = -1 intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetBMPFlowModification(lngMyInputAnalysis As Long, bFlowReduction As Boolean, _ dMinFlowReduction As Double, dLBMPVFlowReduction As Double, dUBMPVFlowReduction As Double, _ dMaxFlowReduction As Double, dFRRankCorrelationToFlow As Double, _ bHydrographExtension As Boolean, dMinHydrographExtension As Double, dLBMPVHydrographExtension As Double, _ dUBMPVHydrographExtension As Double, dMaxHydrographExtension As Double, dHERankCorrelationToFlow As Double) ' ' Purpose: To get the highway BMP Flow Reduction and hydrograph extension values ' ' History: Version 1.0 April 19 2009 by G.E. Granato ' Allow negative trap stats but no neg values 10/10/2011 ' Dim bHasdata As Boolean Dim rstMySeedRecordset As ADODB.Recordset ' recordset Dim strSQL As String ' Query text Dim intErr As Integer ' problem flag On Error GoTo GetBMPFlowModification_Err: intErr = 0 ' Initialize Reduction variables bFlowReduction = False dMinFlowReduction = 0# dLBMPVFlowReduction = 0# dUBMPVFlowReduction = 0# dMaxFlowReduction = 2# ^ (-10#) dFRRankCorrelationToFlow = 0# ' Initialize Extension variables bHydrographExtension = False dMinHydrographExtension = 0# dLBMPVHydrographExtension = 0# dUBMPVHydrographExtension = 0# dMaxHydrographExtension = 2# ^ (-10#) dHERankCorrelationToFlow = 0# strSQL = "SELECT tblBMPHydraulics.bFlowReduction, tblBMPHydraulics.dMinFlowReduction, tblBMPHydraulics.dLBMPVFlowReduction, " & _ "tblBMPHydraulics.dUBMPVFlowReduction, tblBMPHydraulics.dMaxFlowReduction, tblBMPHydraulics.dFRRankCorrelationToFlow, " & _ "tblBMPHydraulics.bHydrographExtension, tblBMPHydraulics.dMinHydrographExtension, tblBMPHydraulics.dLBMPVHydrographExtension, " & _ "tblBMPHydraulics.dUBMPVHydrographExtension, tblBMPHydraulics.dMaxHydrographExtension, tblBMPHydraulics.dHERankCorrelationToFlow " & _ "FROM tblBMPHydraulics INNER JOIN tblHighwayAnalysis ON tblBMPHydraulics.BMP_ID = tblHighwayAnalysis.BMP_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & "));" ' Reference an ADO Recordset Set rstMySeedRecordset = New ADODB.Recordset 'Populate Recordset rstMySeedRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMySeedRecordset.BOF And rstMySeedRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMySeedRecordset.Fields(0).Value) = False Then If IsEmpty(rstMySeedRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values Exit Sub ' False choice already set Else ' Flow Reduction ' **** bFlowReduction = Nz(rstMySeedRecordset.Fields("bFlowReduction").Value, CBool("False")) dMinFlowReduction = Nz(rstMySeedRecordset.Fields("dMinFlowReduction").Value, 0#) dLBMPVFlowReduction = Nz(rstMySeedRecordset.Fields("dLBMPVFlowReduction").Value, 0#) dUBMPVFlowReduction = Nz(rstMySeedRecordset.Fields("dUBMPVFlowReduction").Value, 0#) dMaxFlowReduction = Nz(rstMySeedRecordset.Fields("dMaxFlowReduction").Value, 0#) ' Make sure we don't have a problem with the trapezoid values If dLBMPVFlowReduction < dMinFlowReduction Then dLBMPVFlowReduction = dMinFlowReduction If dUBMPVFlowReduction < dLBMPVFlowReduction Then dUBMPVFlowReduction = dLBMPVFlowReduction If dUBMPVFlowReduction = 0# And dMaxFlowReduction <= dUBMPVFlowReduction Then _ dUBMPVFlowReduction = dMaxFlowReduction = 2# ^ (-10#) If dMaxFlowReduction < dUBMPVFlowReduction Then If dUBMPVFlowReduction > dMinFlowReduction Then dMaxFlowReduction = dUBMPVFlowReduction Else dMaxFlowReduction = dUBMPVFlowReduction + 2# ^ (-10#) End If End If dFRRankCorrelationToFlow = Nz(rstMySeedRecordset.Fields("dFRRankCorrelationToFlow").Value, 0#) ' bHydrographExtension ' **** bHydrographExtension = Nz(rstMySeedRecordset.Fields("bHydrographExtension").Value, CBool("False")) dMinHydrographExtension = Nz(rstMySeedRecordset.Fields("dMinHydrographExtension").Value, 0#) dLBMPVHydrographExtension = Nz(rstMySeedRecordset.Fields("dLBMPVHydrographExtension").Value, 0#) dUBMPVHydrographExtension = Nz(rstMySeedRecordset.Fields("dUBMPVHydrographExtension").Value, 0#) dMaxHydrographExtension = Nz(rstMySeedRecordset.Fields("dMaxHydrographExtension").Value, 0#) ' Make sure we don't have a problem with the trapezoid values If dLBMPVHydrographExtension < dMinHydrographExtension Then dLBMPVHydrographExtension = dMinHydrographExtension If dUBMPVHydrographExtension < dLBMPVHydrographExtension Then dUBMPVHydrographExtension = dLBMPVHydrographExtension If dUBMPVHydrographExtension = 0# And dMaxHydrographExtension <= dUBMPVHydrographExtension Then _ dUBMPVHydrographExtension = dMaxHydrographExtension = 2# ^ (-6#) If dMaxHydrographExtension < dUBMPVHydrographExtension Then If dUBMPVHydrographExtension > dMinHydrographExtension Then dMaxHydrographExtension = dUBMPVHydrographExtension Else dMaxHydrographExtension = dUBMPVHydrographExtension + 2# ^ (-6#) End If End If dHERankCorrelationToFlow = Nz(rstMySeedRecordset.Fields("dHERankCorrelationToFlow").Value, 0#) End If CleanUp: If rstMySeedRecordset.State = adStateOpen Then rstMySeedRecordset.Close 'IF Recordset is open, close it Set rstMySeedRecordset = Nothing 'Free memory Exit Sub GetBMPFlowModification_Err: intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub SetPlottingPosition(strValueVariable As String, strPPVariable As String, strTable As String, _ lngCount As Long, Optional intPPFormula As Integer = 1, Optional bSortAscending As Boolean = True, _ Optional bPercentage As Boolean = False) ' ' Purpose: to Calculate plotting positions (pp) from a user-defined query ' History: Version 1.0 April 20 2009 by Gregory E. Granato ' ' Function arguments ' ' strValueVariable as string the variable name being sorted and assigned a pp ' strPPVariable as string the plotting position variable name in the table ' strTable as string the table of interest ' lngCount As Long the total number of values in the sample ' intPPFormula As Integer the type of plotting poisition formula ' bSortAscending As Boolean True (default) = Sort ascending False = Sort descending ' bPercentage As Boolean True (default) = percentage (0 1# Then intProblem = 2 Exit Sub End If ' Prime the Adjusted Wilson Hilferty approximation Call PrimeWilsonHilfertyKirby(dSkewStreamQ, dWHA, dWHB, dWHG, dWHH) ' Prime the AS241 approximation Call PrimeAS241(dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, _ dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, _ dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, _ dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' Adjust for basin Area dMeanStreamQ = dMeanStreamQ * dLakeBasinArea ' Set initial values lngSequenceYear = 1 ' **********Get initial seeds from seed table based on master seed sequence number ' dPrecipDelta is sequence #1 lngInSeedSequence = 1 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dDailyFlow10, dDailyFlow20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dStreamQPP, dDailyFlow10, dDailyFlow11, dDailyFlow12, _ dDailyFlow20, dDailyFlow21, dDailyFlow22) Next intStart ' Set and open tblOutputStormEvent record set ' Reference an ADO Recordset Set rstLakeFluxRecordset = New ADODB.Recordset rstLakeFluxRecordset.Open "tblOutputLakeFlux", CurrentProject.Connection, adOpenKeyset, adLockOptimistic ' Calculate the daily flux values lngSequenceDay = 0 For lngSequenceYear = 1 To lngInNumberofYears If lngSequenceYear Mod 4 = 0 Then lngMaxDayJ = 366 Else lngMaxDayJ = 365 End If For lngJ = 1 To lngMaxDayJ lngSequenceDay = lngSequenceDay + 1 Call modStatistics.MRG32k3a(dStreamQPP, dDailyFlow10, dDailyFlow11, dDailyFlow12, _ dDailyFlow20, dDailyFlow21, dDailyFlow22) If dZedStreamQ >= 0.00011 Then ' if proportion Dry is greater than 1 day in 25 years adjust If dStreamQPP <= dZedStreamQ Then dStreamQ = 0# Else dAdjustedQPP = fndCensorUniform01Rescale(dStreamQPP, dZedStreamQ, 0) dStreamKN = fndUniform01ToNormalAS241(dAdjustedQPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) dStreamKs = fndAdjustedWilsonHilfertyK(dSkewStreamQ, dStreamKN, dWHA, dWHB, dWHG, dWHH) dStreamQ = 10# ^ ((Log(dMeanStreamQ) * dLog10) + (Log(dStDevStreamQ) * dLog10) * dStreamKs) End If Else dAdjustedQPP = dStreamQPP dStreamKN = fndUniform01ToNormalAS241(dAdjustedQPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) dStreamKs = fndAdjustedWilsonHilfertyK(dSkewStreamQ, dStreamKN, dWHA, dWHB, dWHG, dWHH) dStreamQ = 10# ^ ((Log(dMeanStreamQ) * dLog10) + (Log(dStDevStreamQ) * dLog10) * dStreamKs) End If dStreamQ = dStreamQ * 86400# ' Add new data to table tblOutputLakeFlux With rstLakeFluxRecordset .AddNew .Fields("lngDayNumber") = lngSequenceDay .Fields("lngAnnualSequenceNumber") = lngSequenceYear .Fields("dDailyUpstreamFlow") = dStreamQ .Update End With Next lngJ Next lngSequenceYear CleanUp: If rstLakeFluxRecordset.State = adStateOpen Then rstLakeFluxRecordset.Close 'IF Recordset is open, close it Set rstLakeFluxRecordset = Nothing 'Free memory ' Get/Set annual storm-volume ranks ReDim lngLakeTotal(lngInNumberofYears) As Long ' Rank of Annual sum of daily streamflows Call GetLakeFluxStormYear(lngLakeTotal, lngInNumberofYears, 0, intDayErr) If intDayErr <> 0 Then intProblem = 4 Exit Sub End If ReDim lngPrecipitationTotal(lngInNumberofYears) As Long ' Annual sum of storm-event precipitation Call GetLakeFluxStormYear(lngPrecipitationTotal, lngInNumberofYears, 1, intDayErr) If intDayErr <> 0 Then intProblem = 5 Exit Sub End If ' Assign ranks to storm totals For lngJ = 0 To (lngInNumberofYears - 1) lnglakeYear = lngLakeTotal(lngJ) lngStormyear = lngPrecipitationTotal(lngJ) Call SetLakeFluxStormYear(lnglakeYear, lngStormyear, intDayErr) Next lngJ Exit Sub CleanUp2: If rstLakeFluxRecordset.State = adStateOpen Then rstLakeFluxRecordset.Close 'IF Recordset is open, close it Set rstLakeFluxRecordset = Nothing 'Free memory GenerateDailyLakeFlux_Err: intProblem = 7 intStormErr = intStormErr + 1 If intStormErr < 2 Then GoTo CleanUp2: Exit Sub End Sub Private Sub SetLakeFluxStormYear(lnglakeYear As Long, lngStormyear As Long, intOutErr As Integer) ' ' Purpose: to match random lake year to the storm year, which is sorted by volume ' History: Version 1.0 April 30 2009 by Gregory E. Granato ' ' Arguments Dim rstMyRecordset As ADODB.Recordset Dim strSQL As String Dim intErr As Integer ' problem flag Dim bHasdata As Boolean ' test data On Error GoTo SetPlottingPosition_Err: intErr = 0 intOutErr = 0 strSQL = "SELECT tblOutputLakeFlux.lngDayNumber, tblOutputLakeFlux.lngAnnualSequenceNumber, " & _ "tblOutputLakeFlux.lngYearNumber " & _ "FROM tblOutputLakeFlux " & _ "WHERE (((tblOutputLakeFlux.lngAnnualSequenceNumber)=" & lnglakeYear & ")) " & _ "ORDER BY tblOutputLakeFlux.lngDayNumber;" ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then intOutErr = 1 GoTo CleanUp: ' There is no data for this analysis End If rstMyRecordset.MoveFirst With rstMyRecordset Do While Not .EOF .Fields("lngYearNumber") = lngStormyear .Update .MoveNext Loop End With CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub SetPlottingPosition_Err: intOutErr = 2 intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetLakeFluxStormYear(lnglakeYear() As Long, lngCountYear As Long, intWhat As Integer, intOutErr As Integer) ' ' Purpose: to match random lake year to the storm year sorted by volume ' History: Version 1.0 April 30 2009 by Gregory E. Granato ' ' intwhat as integer 0 = lake year 1= storm year ' ' Arguments Dim rstMyRecordset As ADODB.Recordset Dim strSQL As String Dim intErr As Integer ' problem flag Dim bHasdata As Boolean ' test data Dim lngI As Long On Error GoTo SetPlottingPosition_Err: intErr = 0 intOutErr = 0 ReDim lnglakeYear(lngCountYear) As Long If intWhat = 0 Then ' Lake strSQL = "SELECT tblOutputLakeFlux.lngAnnualSequenceNumber, " & _ "Sum(tblOutputLakeFlux.dDailyUpstreamFlow) AS SumOfdDailyUpstreamFlow " & _ "FROM tblOutputLakeFlux " & _ "GROUP BY tblOutputLakeFlux.lngAnnualSequenceNumber " & _ "ORDER BY Sum(tblOutputLakeFlux.dDailyUpstreamFlow);" Else ' storm event strSQL = "SELECT tblOutputStormEvent.lngYearNumber, " & _ "Sum(tblOutputStormEvent.dPrecipitationVolume) AS SumOfdPrecipitationVolume " & _ "FROM tblOutputStormEvent " & _ "GROUP BY tblOutputStormEvent.lngYearNumber " & _ "ORDER BY Sum(tblOutputStormEvent.dPrecipitationVolume); " End If ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then intOutErr = 1 GoTo CleanUp: ' There is no data for this analysis End If rstMyRecordset.MoveFirst For lngI = 0 To (lngCountYear - 1) lnglakeYear(lngI) = rstMyRecordset.Fields(0).Value If rstMyRecordset.EOF = False Then rstMyRecordset.MoveNext Next lngI CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub SetPlottingPosition_Err: intOutErr = 2 intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GetStormFlows(dFlowArray() As Double, intWhat As Integer, lngNumberOfStorms As Long, intErr As Integer) ' ' Purpose: To get Storm Flows from intWhat = 0: Highway/Pavement Runoff; 1: Bmp Discharge; 2: Total Upstream Storm Discharge ' 3: Concurrent Upstream Storm Discharge; and 4: Sum of Highway Discharge & Concurrent Upstream Storm Discharge ' ' History: Version 1.0 May 04 2009 by G.E. Granato ' Dim bHasdata As Boolean Dim rstMyRecordset As ADODB.Recordset ' recordset Dim strSQL As String ' Query text Dim lngI As Long Dim strField As String On Error GoTo GetStormFlows_Err: intErr = 0 Select Case intWhat Case 0 ' Highway/Pavement Runoff strField = "dHighwayRunoff" Case 1 ' Highway/Pavement (Bmp) Discharge to Stream strField = "dHighwayBMPDischarge" Case 2 ' Total Upstream Storm Discharge strField = "dUpstreamStormDischarge" Case 3 ' Concurrent Upstream Storm Discharge strField = "dUpstreamConcurrentFlow" Case 4 ' Sum of Highway Discharge & Concurrent Upstream Storm Discharge strField = "[tblOutputStormEvent]![dHighwayBMPDischarge]+[tblOutputStormEvent]![dUpstreamConcurrentFlow] AS DownstreamQ" End Select strSQL = "SELECT tblOutputStormEvent.lngStormNumber, tblOutputStormEvent." & strField & " " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset 'Populate Recordset rstMyRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intErr = 1 Exit Sub ' False choice already set End If For lngI = 0 To lngNumberOfStorms - 1 dFlowArray(lngI) = Nz(rstMyRecordset.Fields(0).Value, -9999#) If dFlowArray(lngI) = -9999# Then intErr = 1 Next lngI CleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetStormFlows_Err: intErr = intErr + 1 If intErr < 2 Then GoTo CleanUp: Exit Sub End Sub Private Sub GenerateRandomQW(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngInputAnalysis As Long, lngNumberOfStorms As Long, intWhat As Integer, intProblem As Integer) ' ' Purpose: ' To generate a population of random highway-runoff quality or upstream quality values for a set number of storms ' ' History: ' Version 1.0.0 May 04 2009 by Gregory E. Granato' ' Version 1.0.1 Aug 26 2009 by Gregory E. Granato -- Added Lake concentrations ' ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngInputAnalysis As Long current analysis ID ' lngNumberOfStorms as long total number of storms ' intWhat as integer 0 = highway, 1 = upstream, and 2 = Lake Basin ' intProblem as integer if zero ok if 1 Bad stats if 2 error in this subroutine ' ' Arguments Dim bHasdata As Boolean ' test data Dim bhasGooddata As Boolean ' test data Dim strQWSql As String ' Query String Dim strStormflowSQL As String ' Stormflow Query String Dim strOutputSQL As String ' output table name Dim rstMyQWRecordset As ADODB.Recordset ' recordset Dim intQWErr As Integer ' problem flag Dim intFlowErr As Integer ' null flow counter Dim lngStormNumber As Long ' Index for the current storm Dim lngConstituents As Long ' Number of constituents Dim lngQW As Long ' Index for the current constituent ' Water-Quality Arguments Dim lngMyWaterQualityID() As Long Dim lngMyParameterID() As Long Dim lngQWTransformID() As Long Dim dQWMean() As Double Dim dQWSD() As Double Dim dQWSkew() As Double Dim dSkew As Double Dim lngNumerator() As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngDenominator() As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngMyNumerator As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngMyDenominator As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngFlowCount As Long ' Stormflow Arguments Dim dStormflow01() As Double Dim dStormflow02() As Double Dim dStormflow03() As Double Dim dStormLoad01 As Double Dim dStormLoad02 As Double Dim dStormLoad03 As Double ' Stochastic Arguments Dim dQWPP As Double ' Random (U01) Uniform Variate 0-1 Dim dQWKN As Double ' Normal(lognormal) frequency factor Dim dQWKs As Double ' Skewed frequency factor Dim dConcentration As Double Dim dLoadMultiplier As Double Dim dLoad1 As Double Dim dLoad2 As Double ' Random Seeds Dim dQWSeed10 As Double Dim dQWSeed11 As Double Dim dQWSeed12 As Double Dim dQWSeed20 As Double Dim dQWSeed21 As Double Dim dQWSeed22 As Double ' Wilson Hilferty factors Dim dWHA As Double Dim dWHB As Double Dim dWHG As Double Dim dWHH As Double ' As 241 Factors Dim dA0 As Double, dA1 As Double, dA2 As Double, dA3 As Double, dA4 As Double, dA5 As Double, dA6 As Double, dA7 As Double Dim dB1 As Double, dB2 As Double, dB3 As Double, dB4 As Double, dB5 As Double, dB6 As Double, dB7 As Double Dim dC0 As Double, dC1 As Double, dC2 As Double, dC3 As Double, dC4 As Double, dC5 As Double, dC6 As Double, dC7 As Double Dim dD1 As Double, dD2 As Double, dD3 As Double, dD4 As Double, dD5 As Double, dD6 As Double, dD7 As Double Dim dE0 As Double, dE1 As Double, dE2 As Double, dE3 As Double, dE4 As Double, dE5 As Double, dE6 As Double, dE7 As Double Dim dF1 As Double, dF2 As Double, dF3 As Double, dF4 As Double, dF5 As Double, dF6 As Double, dF7 As Double ' Adjustment for zero or negative untransformed Dim dW As Double 'lognormal SD Dim dCOV As Double 'Coefficient of variation Dim dU As Double ' lognormal avg Dim intStormErr As Integer Dim intStart As Integer On Error GoTo GenerateRandomQW_Err: intQWErr = 0 intProblem = 0 ' ************************************************************** ' Get the SQL statements for 0= highway or 1= upstream ' ************************************************************** If intWhat = 0 Then strQWSql = "SELECT tasAnalysisHighwayQW.HighwayAnalysis_ID, tblQWHighway.QWMethod_ID, " & _ "tblQWHighway.HighwayWaterQuality_ID, tblQWHighway.QWTransform_ID, tdsUSEPAParameterCodes.Parameter_ID, " & _ "tblQWHighway.dHwyQWMean, tblQWHighway.dHwyQWSD, tblQWHighway.dHwyQWSkew, " & _ "tdsUSEPAParameterCodes.lngNumerator, tdsUSEPAParameterCodes.lngDenominator " & _ "FROM (tdsUSEPAParameterCodes INNER JOIN tblQWHighway ON tdsUSEPAParameterCodes.Parameter_ID = tblQWHighway.Parameter_ID) " & _ "INNER JOIN tasAnalysisHighwayQW ON tblQWHighway.HighwayWaterQuality_ID = tasAnalysisHighwayQW.HighwayWaterQuality_ID " & _ "WHERE (((tasAnalysisHighwayQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ") AND ((tblQWHighway.QWMethod_ID)=1)) " & _ "ORDER BY tdsUSEPAParameterCodes.tPcode;" strStormflowSQL = "SELECT tblOutputStormEvent.lngStormNumber, " & _ "tblOutputStormEvent.dHighwayRunoff, tblOutputStormEvent.dHighwayBMPDischarge " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" strOutputSQL = "SELECT tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputHighwayQW.lngStormNumber, " & _ "tblOutputHighwayQW.lngNumerator, tblOutputHighwayQW.lngDenominator, " & _ "tblOutputHighwayQW.dRunoffConcentration, tblOutputHighwayQW.dRunoffLoad, " & _ "tblOutputHighwayQW.dDischargeConcentration, tblOutputHighwayQW.dDischargeLoad " & _ "FROM tblOutputHighwayQW;" ElseIf intWhat = 1 Then strQWSql = "SELECT tasAnalysisUpstreamQW.HighwayAnalysis_ID, tblQWUpstream.QWMethod_ID, " & _ "tblQWUpstream.UpstreamWaterQuality_ID, tblQWUpstream.QWTransform_ID, tdsUSEPAParameterCodes.Parameter_ID, " & _ "tblQWUpstream.dUpstreamQWMean, tblQWUpstream.dUpstreamQWSD, tblQWUpstream.dUpstreamQWSkew, " & _ "tdsUSEPAParameterCodes.lngNumerator, tdsUSEPAParameterCodes.lngDenominator " & _ "FROM (tdsUSEPAParameterCodes INNER JOIN tblQWUpstream ON tdsUSEPAParameterCodes.Parameter_ID = tblQWUpstream.Parameter_ID) " & _ "INNER JOIN tasAnalysisUpstreamQW ON tblQWUpstream.UpstreamWaterQuality_ID = tasAnalysisUpstreamQW.UpstreamWaterQuality_ID " & _ "WHERE (((tasAnalysisUpstreamQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ") AND ((tblQWUpstream.QWMethod_ID)=1)) " & _ "ORDER BY tdsUSEPAParameterCodes.tPcode;" strStormflowSQL = "SELECT tblOutputStormEvent.lngStormNumber, " & _ "tblOutputStormEvent.dUpstreamConcurrentFlow, tblOutputStormEvent.dUpstreamStormDischarge, " & _ "tblOutputStormEvent.dUpstreamBMPConcurrentQ " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" strOutputSQL = "SELECT tblOutputUpstreamQW.UpstreamWaterQuality_ID, tblOutputUpstreamQW.lngStormNumber, " & _ "tblOutputUpstreamQW.lngNumerator, tblOutputUpstreamQW.lngDenominator, " & _ "tblOutputUpstreamQW.dConcurrentConcentration, tblOutputUpstreamQW.dConcurrentLoad, " & _ "tblOutputUpstreamQW.dTotalConcentration, tblOutputUpstreamQW.dTotalLoad, " & _ "tblOutputUpstreamQW.dConcurrentBMPLoad " & _ "FROM tblOutputUpstreamQW;" Else ' Lake strQWSql = "SELECT tasAnalysisUpstreamQW.HighwayAnalysis_ID, tblQWUpstream.QWMethod_ID, " & _ "tblQWUpstream.UpstreamWaterQuality_ID, tblQWUpstream.QWTransform_ID, tdsUSEPAParameterCodes.Parameter_ID, " & _ "tblQWUpstream.dUpstreamQWMean, tblQWUpstream.dUpstreamQWSD, tblQWUpstream.dUpstreamQWSkew, " & _ "tdsUSEPAParameterCodes.lngNumerator, tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.tPcode " & _ "FROM (tdsUSEPAParameterCodes INNER JOIN (tblQWUpstream INNER JOIN tasAnalysisUpstreamQW ON " & _ "tblQWUpstream.UpstreamWaterQuality_ID = tasAnalysisUpstreamQW.UpstreamWaterQuality_ID) ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWUpstream.Parameter_ID) INNER JOIN tblQWDownstream ON " & _ "(tdsUSEPAParameterCodes.Parameter_ID = tblQWDownstream.Parameter_ID) AND " & _ "(tblQWUpstream.UpstreamWaterQuality_ID = tblQWDownstream.UpstreamWaterQuality_ID) " & _ "GROUP BY tasAnalysisUpstreamQW.HighwayAnalysis_ID, tblQWUpstream.QWMethod_ID, " & _ "tblQWUpstream.UpstreamWaterQuality_ID, tblQWUpstream.QWTransform_ID, tdsUSEPAParameterCodes.Parameter_ID, " & _ "tblQWUpstream.dUpstreamQWMean, tblQWUpstream.dUpstreamQWSD, tblQWUpstream.dUpstreamQWSkew, " & _ "tdsUSEPAParameterCodes.lngNumerator, tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.tPcode, " & _ "tblQWDownstream.bLakeAnalysis " & _ "HAVING (((tasAnalysisUpstreamQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ") AND " & _ "((tblQWUpstream.QWMethod_ID)=1) AND ((tblQWDownstream.bLakeAnalysis)=True)) " & _ "ORDER BY tdsUSEPAParameterCodes.tPcode;" strStormflowSQL = "SELECT tblOutputLakeFlux.lngDayNumber, tblOutputLakeFlux.dDailyUpstreamFlow " & _ "FROM tblOutputLakeFlux " & _ "ORDER BY tblOutputLakeFlux.lngDayNumber;" strOutputSQL = "SELECT tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID, " & _ "tadOutputLakeFluxConcentration.lngDayNumber, " & _ "tadOutputLakeFluxConcentration.dLakeBasinConcentration, tadOutputLakeFluxConcentration.dLakeBasinLoad " & _ "FROM tadOutputLakeFluxConcentration;" End If ' ************************************************************** ' Get concentration statistics ' ************************************************************** ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strQWSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 1 GoTo FinalCleanUp: ' End If rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngConstituents = rstMyQWRecordset.RecordCount ReDim lngMyWaterQualityID(lngConstituents) As Long ReDim lngMyParameterID(lngConstituents) As Long ReDim lngQWTransformID(lngConstituents) As Long ReDim dQWMean(lngConstituents) As Double ReDim dQWSD(lngConstituents) As Double ReDim dQWSkew(lngConstituents) As Double ReDim lngNumerator(lngConstituents) As Long ReDim lngDenominator(lngConstituents) As Long rstMyQWRecordset.MoveFirst bhasGooddata = False For lngQW = 0 To lngConstituents - 1 lngMyWaterQualityID(lngQW) = Nz(rstMyQWRecordset.Fields(2).Value, -9999) lngMyParameterID(lngQW) = Nz(rstMyQWRecordset.Fields(4).Value, -9999) lngQWTransformID(lngQW) = Nz(rstMyQWRecordset.Fields(3).Value, -9999) dQWMean(lngQW) = Nz(rstMyQWRecordset.Fields(5).Value, -9999#) dQWSD(lngQW) = Nz(rstMyQWRecordset.Fields(6).Value, -9999#) dQWSkew(lngQW) = Nz(rstMyQWRecordset.Fields(7).Value, -9999#) lngNumerator(lngQW) = Nz(rstMyQWRecordset.Fields(8).Value, 0) lngDenominator(lngQW) = Nz(rstMyQWRecordset.Fields(9).Value, 0) If dQWMean(lngQW) > -9999# And dQWSD(lngQW) > -9999# And dQWSkew(lngQW) > -9999# Then bhasGooddata = True rstMyQWRecordset.MoveNext Next lngQW FirstCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If bhasGooddata = False Then ' We have no good values intProblem = 2 Exit Sub ' End If ' ************************************************************** ' Get stormflow values ' ************************************************************** ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strStormflowSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 3 GoTo FinalCleanUp: ' End If If intWhat <> 2 Then lngFlowCount = lngNumberOfStorms ReDim dStormflow01(lngFlowCount) As Double ' Concurrent flow ReDim dStormflow02(lngFlowCount) As Double ' Total flow If intWhat = 1 Then ReDim dStormflow03(lngFlowCount) As Double ' BMP concurrent flow Else rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngFlowCount = rstMyQWRecordset.RecordCount ReDim dStormflow01(lngFlowCount) As Double ' Concurrent flow End If intFlowErr = 0 rstMyQWRecordset.MoveFirst For lngStormNumber = 0 To (lngFlowCount - 1) dStormflow01(lngStormNumber) = Nz(rstMyQWRecordset.Fields(1).Value, -9999#) 'Highway runoff, upstream concurrent If intWhat <> 2 Then dStormflow02(lngStormNumber) = Nz(rstMyQWRecordset.Fields(2).Value, -9999#) ' Highway BMP Q, upstream concurrent If dStormflow01(lngStormNumber) = -9999# Or dStormflow02(lngStormNumber) = -9999# Then intFlowErr = intFlowErr + 1 If intWhat = 1 Then dStormflow03(lngStormNumber) = Nz(rstMyQWRecordset.Fields(3).Value, -9999#) ' If dStormflow03(lngStormNumber) = -9999# Then intFlowErr = intFlowErr + 1 End If Else If dStormflow01(lngStormNumber) = -9999# Then intFlowErr = intFlowErr + 1 End If rstMyQWRecordset.MoveNext Next lngStormNumber SecondCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intFlowErr <> 0 Then intProblem = 4 Exit Sub ' End If ' ************************************************************** ' Calculate concentrations and loads ' ************************************************************** ' Prime the AS241 approximation Call PrimeAS241(dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, _ dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, _ dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, _ dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' Open the QW table ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset rstMyQWRecordset.Open strOutputSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic For lngQW = 0 To lngConstituents - 1 ' Constituent loop If dQWMean(lngQW) <= -9999# Or dQWSD(lngQW) <= -9999# Or dQWSkew(lngQW) <= -9999# Then 'skip this one GoTo SkipMe: End If 'Get load multiplier lngMyNumerator = lngNumerator(lngQW) lngMyDenominator = lngDenominator(lngQW) dLoadMultiplier = fndLoadMultiplier(lngMyNumerator, lngMyDenominator) ' ************************************************** ' Prime the Adjusted Wilson Hilferty approximation dSkew = dQWSkew(lngQW) Call PrimeWilsonHilfertyKirby(dSkew, dWHA, dWHB, dWHG, dWHH) ' **********Get initial seeds from seed table based on master seed sequence number ' Random QW Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dQWSeed10, dQWSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dQWPP, dQWSeed10, dQWSeed11, dQWSeed12, _ dQWSeed20, dQWSeed21, dQWSeed22) Next intStart For lngStormNumber = 0 To (lngFlowCount - 1) ' Get QW Statistics Call modStatistics.MRG32k3a(dQWPP, dQWSeed10, dQWSeed11, dQWSeed12, _ dQWSeed20, dQWSeed21, dQWSeed22) ' Normal(lognormal) frequency factor dQWKN = fndUniform01ToNormalAS241(dQWPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) ' Skewed Wilson-Hilferty frequency factor dQWKs = fndAdjustedWilsonHilfertyK(dSkew, dQWKN, dWHA, dWHB, dWHG, dWHH) ' 1: Get Value dConcentration = dQWMean(lngQW) + dQWSD(lngQW) * dQWKs ' 2: Adjust for transformation If lngQWTransformID(lngQW) = 1 Then If dConcentration <= 0# Then 'Use lognormal lower tail if possible ' Deal with odd statistics If dQWMean(lngQW) <= 0 Then dQWMean(lngQW) = 0.2 If dQWSD(lngQW) <= 0 Then dQWSD(lngQW) = dQWMean(lngQW) * 3# ' Change to lognormal lower tail dCOV = ((dQWSD(lngQW) / dQWMean(lngQW)) ^ 2#) dW = Sqr(Log(1 + dCOV)) dU = Log(dQWMean(lngQW) / (Sqr(1# + dCOV))) dConcentration = Exp(dU + dW * dQWKN) End If ElseIf lngQWTransformID(lngQW) = 2 Then dConcentration = 10# ^ dConcentration ElseIf lngQWTransformID(lngQW) = 3 Then dConcentration = Exp(dConcentration) End If ' 3: Calculate loads If lngMyDenominator = 7 And lngMyNumerator = 11 Then 'pH ' dStormLoad01 = dStormflow01(lngStormNumber) * dLoadMultiplier * _ 10# ^ (-1# * dConcentration) * 19.02331 ' Hwy All, US Concurrent ' use atomic weight g/mol of H3O+ If intWhat <> 2 Then dStormLoad02 = dStormflow02(lngStormNumber) * dLoadMultiplier * _ 10# ^ (-1# * dConcentration) * 19.02331 ' Hwy BMP, US Total ' atomic weight g/mol of H3O+ End If If intWhat = 1 Then dStormLoad03 = dStormflow03(lngStormNumber) * dLoadMultiplier * _ 10# ^ (-1# * dConcentration) * 19.02331 ' Hwy BMP, US Total ' atomic weight g/mol of H3O+ End If Else dStormLoad01 = dStormflow01(lngStormNumber) * dLoadMultiplier * dConcentration ' Hwy All, US Concurrent If intWhat <> 2 Then dStormLoad02 = dStormflow02(lngStormNumber) * dLoadMultiplier * dConcentration ' Hwy BMP, US Total If intWhat = 1 Then dStormLoad03 = dStormflow03(lngStormNumber) * dLoadMultiplier * dConcentration ' load concurrent to BMP End If End If ' Add new data to table tblOutputStormEvent for existing storms With rstMyQWRecordset .AddNew If intWhat <> 2 Then .Fields(0) = lngMyWaterQualityID(lngQW) ' WaterQuality_ID .Fields(1) = lngStormNumber + 1 ' lngStormNumber .Fields(2) = lngMyNumerator ' lngMyNumerator .Fields(3) = lngMyDenominator ' lngMyDenominator .Fields(4) = dConcentration ' Hwy untreated, US Concurrent Concentration .Fields(5) = dStormLoad01 ' Hwy untreated, US Concurrent load .Fields(6) = dConcentration ' Hwy treated, US Total Concentration .Fields(7) = dStormLoad02 ' Hwy BMP treated, US Total load If intWhat = 1 Then .Fields(8) = dStormLoad03 ' Upstream load concurrent to Hwy BMP Else .Fields(0) = lngMyWaterQualityID(lngQW) ' WaterQuality_ID .Fields(1) = lngStormNumber + 1 ' lngStormNumber .Fields(2) = dConcentration ' lake-basin concentration .Fields(3) = dStormLoad01 ' lake-basin load End If .Update End With rstMyQWRecordset.MoveNext Next lngStormNumber SkipMe: Next lngQW FinalCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory Exit Sub GenerateRandomQW_Err: MsgBox Err.Description, vbCritical, "Generate Random QW" intProblem = 7 intQWErr = intQWErr + 1 If intQWErr < 2 Then GoTo FinalCleanUp: Exit Sub End Sub Private Sub GenerateDependentCurveQW(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngInputAnalysis As Long, lngNumberOfStorms As Long, intWhat As Integer, intProblem As Integer) ' ' Purpose: ' To generate a population of upstream quality values for a set number of storms ' ' History: ' Version 1.0 Aug 05 2009 by Gregory E. Granato' ' Version 1.0.1 Aug 26 2009 by Gregory E. Granato -- Added Lake concentrations ' ' Version 1.0.2 02-02-2010 by Gregory E. Granato --Deal with possibility of <=0 ' Version 1.0.3 03-18-2012 by Gregory E. Granato --Change output for conc. <=0 so that all are = 0.002 ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngInputAnalysis As Long current analysis ID ' lngNumberOfStorms as long total number of storms ' intWhat as integer 0 = highway, 1 = upstream Transport, 2 = upstream dependent, ' 3 = Lake Basin Transport and 4 = Lake Basin dependent ' intProblem as integer if zero ok if 1 Bad stats if 2 error in this subroutine ' ' Arguments Dim bHasdata As Boolean ' test data Dim bhasGooddata As Boolean ' test data Dim strQWSql As String ' Query String Dim strStormflowSQL As String ' Stormflow Query String Dim strExplanatorySQL As String ' Explanatory Water-Quality Query String Dim strOutputSQL As String ' output table name Dim rstMyQWRecordset As ADODB.Recordset ' recordset Dim rstMyXRecordset As ADODB.Recordset ' recordset Dim intQWErr As Integer ' problem flag Dim intFlowErr As Integer ' null flow counter Dim lngStormNumber As Long ' Index for the current storm Dim lngConstituents As Long ' Number of constituents Dim lngQW As Long ' Index for the current constituent ' Water-Quality Arguments Dim lngMyWaterQualityID() As Long Dim lngMyParameterYID() As Long Dim lngQWTransformYID() As Long Dim lngMyParameterXID() As Long Dim lngQWTransformXID() As Long Dim lngNumerator() As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngDenominator() As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngMyNumerator As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngMyDenominator As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngMyQWMethod As Long Dim strXVariable As String Dim lngFlowCount As Long Dim lngUpstreamQWSegments() As Long Dim dXValue() As Double Dim dSlope01() As Double Dim dIntercept01() As Double Dim dMAD01() As Double Dim dMAX01() As Double Dim dSlope02() As Double Dim dIntercept02() As Double Dim dMAD02() As Double Dim dMAX02() As Double Dim dSlope03() As Double Dim dIntercept03() As Double Dim dMAD03() As Double Dim dMAX03() As Double Dim dMADRatio As Double ' Stormflow Arguments Dim dStormflow01() As Double ' whole flow Dim dStormDurationWhole() As Double Dim dStormflow02() As Double ' concurrent flow Dim dStormDurationConcurrent() As Double Dim dStormflow03() As Double ' BMP concurrent 'BMPConcurrent Dim dLakeDuration As Double Dim dExplanatoryX As Double Dim dStormLoad01 As Double ' whole flow Dim dStormLoad02 As Double ' concurrent flow Dim dStormLoad03 As Double ' concurrent flow Dim dStormflowConversion As Double ' Stochastic Arguments Dim dQWPP As Double ' Random (U01) Uniform Variate 0-1 Dim dQWKN As Double ' Normal(lognormal) frequency factor Dim dConcentration As Double Dim dLoadMultiplier As Double Dim dLoad1 As Double Dim dLoad2 As Double Dim dLoad3 As Double ' Random Seeds Dim dQWSeed10 As Double Dim dQWSeed11 As Double Dim dQWSeed12 As Double Dim dQWSeed20 As Double Dim dQWSeed21 As Double Dim dQWSeed22 As Double ' As 241 Factors Dim dA0 As Double, dA1 As Double, dA2 As Double, dA3 As Double, dA4 As Double, dA5 As Double, dA6 As Double, dA7 As Double Dim dB1 As Double, dB2 As Double, dB3 As Double, dB4 As Double, dB5 As Double, dB6 As Double, dB7 As Double Dim dC0 As Double, dC1 As Double, dC2 As Double, dC3 As Double, dC4 As Double, dC5 As Double, dC6 As Double, dC7 As Double Dim dD1 As Double, dD2 As Double, dD3 As Double, dD4 As Double, dD5 As Double, dD6 As Double, dD7 As Double Dim dE0 As Double, dE1 As Double, dE2 As Double, dE3 As Double, dE4 As Double, dE5 As Double, dE6 As Double, dE7 As Double Dim dF1 As Double, dF2 As Double, dF3 As Double, dF4 As Double, dF5 As Double, dF6 As Double, dF7 As Double Dim intStormErr As Integer Dim intStart As Integer On Error GoTo GenerateDependentCurveQW_Err: intQWErr = 0 intProblem = 0 ' ************************************************************** ' Get the SQL statements ' ************************************************************** If intWhat = 0 Then '0 = highway dependent strQWSql = "SELECT tasAnalysisHighwayQW.HighwayAnalysis_ID, tblQWHighway.QWMethod_ID, " & _ "tblQWHighway.HighwayWaterQuality_ID, tblQWHighway.Parameter_ID, tblQWHighway.HwyYT_ID, " & _ "tblQWHighway.HwyXQW_ID, tblQWHighway.HwyXT_ID, tblQWHighway.lngHwyQWSegments, " & _ "tblQWHighway.dHwyQWIntercept01, tblQWHighway.dHwyQWSlope01, tblQWHighway.dHwyQWMAD01, tblQWHighway.dHwyQWMax01, " & _ "tblQWHighway.dHwyQWIntercept02, tblQWHighway.dHwyQWSlope02, tblQWHighway.dHwyQWMAD02, tblQWHighway.dHwyQWMax02, " & _ "tblQWHighway.dHwyQWIntercept03, tblQWHighway.dHwyQWSlope03, tblQWHighway.dHwyQWMAD03, tblQWHighway.dHwyQWMax03, " & _ "tdsUSEPAParameterCodes.tPcode, tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.lngNumerator " & _ "FROM tdsUSEPAParameterCodes INNER JOIN (tblQWHighway INNER JOIN tasAnalysisHighwayQW ON " & _ "tblQWHighway.HighwayWaterQuality_ID = tasAnalysisHighwayQW.HighwayWaterQuality_ID) ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWHighway.Parameter_ID " & _ "WHERE (((tasAnalysisHighwayQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ") AND " & _ "((tblQWHighway.QWMethod_ID)=3)) " & _ "ORDER BY tdsUSEPAParameterCodes.tPcode;" strStormflowSQL = "SELECT tblOutputStormEvent.lngStormNumber, " & _ "tblOutputStormEvent.dHighwayRunoff, tblOutputStormEvent.dHighwayBMPDischarge, " & _ "tblOutputStormEvent.dHighwayStormFlowDuration, tblOutputStormEvent.dHighwayDischargeDuration " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" strOutputSQL = "SELECT tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputHighwayQW.lngStormNumber, " & _ "tblOutputHighwayQW.lngNumerator, tblOutputHighwayQW.lngDenominator, " & _ "tblOutputHighwayQW.dRunoffConcentration, tblOutputHighwayQW.dRunoffLoad, " & _ "tblOutputHighwayQW.dDischargeConcentration, tblOutputHighwayQW.dDischargeLoad " & _ "FROM tblOutputHighwayQW;" ElseIf intWhat > 0 Then '1 = upstream Transport '2 = upstream dependent If intWhat = 1 Or intWhat = 3 Then lngMyQWMethod = 2 ' Transport strXVariable = "tblQWUpstream.UpstreamX_ID, " ElseIf intWhat = 2 Or intWhat = 4 Then lngMyQWMethod = 3 ' Dependent strXVariable = "tblQWUpstream.UpstreamXQW_ID, " End If If intWhat = 1 Or intWhat = 2 Then ' Upstream strQWSql = "SELECT tasAnalysisUpstreamQW.HighwayAnalysis_ID, tblQWUpstream.QWMethod_ID, " & _ "tblQWUpstream.UpstreamWaterQuality_ID, tblQWUpstream.Parameter_ID, tblQWUpstream.UpstreamYT_ID, " & _ strXVariable & "tblQWUpstream.UpstreamXT_ID, tblQWUpstream.lngUpstreamQWSegments, " & _ "tblQWUpstream.dUSQWIntercept01, tblQWUpstream.dUSQWSlope01, tblQWUpstream.dUSQWMAD01, tblQWUpstream.dUSQWMax01, " & _ "tblQWUpstream.dUSQWIntercept02, tblQWUpstream.dUSQWSlope02, tblQWUpstream.dUSQWMAD02, tblQWUpstream.dUSQWMax02, " & _ "tblQWUpstream.dUSQWIntercept03, tblQWUpstream.dUSQWSlope03, tblQWUpstream.dUSQWMAD03, tblQWUpstream.dUSQWMax03, " & _ "tdsUSEPAParameterCodes.tPcode, tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.lngNumerator " & _ "FROM tdsUSEPAParameterCodes INNER JOIN (tblQWUpstream INNER JOIN tasAnalysisUpstreamQW ON " & _ "tblQWUpstream.UpstreamWaterQuality_ID = tasAnalysisUpstreamQW.UpstreamWaterQuality_ID) ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWUpstream.Parameter_ID " & _ "WHERE (((tasAnalysisUpstreamQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ") AND " & _ "((tblQWUpstream.QWMethod_ID)=" & lngMyQWMethod & ")) " & _ "ORDER BY tdsUSEPAParameterCodes.tPcode;" strStormflowSQL = "SELECT tblOutputStormEvent.lngStormNumber, " & _ "tblOutputStormEvent.dUpstreamConcurrentFlow, tblOutputStormEvent.dUpstreamStormDischarge, " & _ "tblOutputStormEvent.dHighwayDischargeDuration, tblOutputStormEvent.dUpstreamStormFlowDuration, " & _ "tblOutputStormEvent.dUpstreamBMPConcurrentQ " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" strOutputSQL = "SELECT tblOutputUpstreamQW.UpstreamWaterQuality_ID, tblOutputUpstreamQW.lngStormNumber, " & _ "tblOutputUpstreamQW.lngNumerator, tblOutputUpstreamQW.lngDenominator, " & _ "tblOutputUpstreamQW.dConcurrentConcentration, tblOutputUpstreamQW.dConcurrentLoad, " & _ "tblOutputUpstreamQW.dTotalConcentration, tblOutputUpstreamQW.dTotalLoad, " & _ "tblOutputUpstreamQW.dConcurrentBMPLoad " & _ "FROM tblOutputUpstreamQW;" Else ' Lake Basin strQWSql = "SELECT tasAnalysisUpstreamQW.HighwayAnalysis_ID, tblQWUpstream.QWMethod_ID, " & _ "tblQWUpstream.UpstreamWaterQuality_ID, tblQWUpstream.Parameter_ID, tblQWUpstream.UpstreamYT_ID, " & _ strXVariable & "tblQWUpstream.UpstreamXT_ID, tblQWUpstream.lngUpstreamQWSegments, " & _ "tblQWUpstream.dUSQWIntercept01, tblQWUpstream.dUSQWSlope01, tblQWUpstream.dUSQWMAD01, tblQWUpstream.dUSQWMax01, " & _ "tblQWUpstream.dUSQWIntercept02, tblQWUpstream.dUSQWSlope02, tblQWUpstream.dUSQWMAD02, tblQWUpstream.dUSQWMax02, " & _ "tblQWUpstream.dUSQWIntercept03, tblQWUpstream.dUSQWSlope03, tblQWUpstream.dUSQWMAD03, tblQWUpstream.dUSQWMax03, " & _ "tdsUSEPAParameterCodes.tPcode, tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.lngNumerator, " & _ "tblQWDownstream.bLakeAnalysis " & _ "FROM (tdsUSEPAParameterCodes INNER JOIN (tblQWUpstream INNER JOIN tasAnalysisUpstreamQW ON " & _ "tblQWUpstream.UpstreamWaterQuality_ID = tasAnalysisUpstreamQW.UpstreamWaterQuality_ID) ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWUpstream.Parameter_ID) INNER JOIN tblQWDownstream ON " & _ "(tdsUSEPAParameterCodes.Parameter_ID = tblQWDownstream.Parameter_ID) AND " & _ "(tblQWUpstream.UpstreamWaterQuality_ID = tblQWDownstream.UpstreamWaterQuality_ID) " & _ "GROUP BY tasAnalysisUpstreamQW.HighwayAnalysis_ID, tblQWUpstream.QWMethod_ID, " & _ "tblQWUpstream.UpstreamWaterQuality_ID, tblQWUpstream.Parameter_ID, tblQWUpstream.UpstreamYT_ID, " & _ strXVariable & "tblQWUpstream.UpstreamXT_ID, tblQWUpstream.lngUpstreamQWSegments, " & _ "tblQWUpstream.dUSQWIntercept01, tblQWUpstream.dUSQWSlope01, tblQWUpstream.dUSQWMAD01, tblQWUpstream.dUSQWMax01, " & _ "tblQWUpstream.dUSQWIntercept02, tblQWUpstream.dUSQWSlope02, tblQWUpstream.dUSQWMAD02, tblQWUpstream.dUSQWMax02, " & _ "tblQWUpstream.dUSQWIntercept03, tblQWUpstream.dUSQWSlope03, tblQWUpstream.dUSQWMAD03, tblQWUpstream.dUSQWMax03, " & _ "tdsUSEPAParameterCodes.tPcode, tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.lngNumerator, " & _ "tblQWDownstream.bLakeAnalysis " & _ "HAVING (((tasAnalysisUpstreamQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ") AND " & _ "((tblQWUpstream.QWMethod_ID)=" & lngMyQWMethod & ") AND " & _ "((tblQWDownstream.bLakeAnalysis)=True)) " & _ "ORDER BY tdsUSEPAParameterCodes.tPcode;" strStormflowSQL = "SELECT tblOutputLakeFlux.lngDayNumber, tblOutputLakeFlux.dDailyUpstreamFlow " & _ "FROM tblOutputLakeFlux " & _ "ORDER BY tblOutputLakeFlux.lngDayNumber;" strOutputSQL = "SELECT tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID, " & _ "tadOutputLakeFluxConcentration.lngDayNumber, " & _ "tadOutputLakeFluxConcentration.dLakeBasinConcentration, tadOutputLakeFluxConcentration.dLakeBasinLoad " & _ "FROM tadOutputLakeFluxConcentration;" End If End If ' ************************************************************** ' Get concentration statistics ' ************************************************************** ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strQWSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 1 GoTo FinalCleanUp: ' End If rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngConstituents = rstMyQWRecordset.RecordCount ' Water-Quality Arguments ReDim lngMyWaterQualityID(lngConstituents) As Long ReDim lngMyParameterYID(lngConstituents) As Long ReDim lngQWTransformYID(lngConstituents) As Long ReDim lngMyParameterXID(lngConstituents) As Long ReDim lngQWTransformXID(lngConstituents) As Long ReDim lngUpstreamQWSegments(lngConstituents) As Long ReDim lngNumerator(lngConstituents) As Long 'Unit conversion index from tdsUSEPAParameterCodes ReDim lngDenominator(lngConstituents) As Long 'Unit conversion index from tdsUSEPAParameterCodes ReDim dSlope01(lngConstituents) As Double ReDim dIntercept01(lngConstituents) As Double ReDim dMAD01(lngConstituents) As Double ReDim dMAX01(lngConstituents) As Double ReDim dSlope02(lngConstituents) As Double ReDim dIntercept02(lngConstituents) As Double ReDim dMAD02(lngConstituents) As Double ReDim dMAX02(lngConstituents) As Double ReDim dSlope03(lngConstituents) As Double ReDim dIntercept03(lngConstituents) As Double ReDim dMAD03(lngConstituents) As Double ReDim dMAX03(lngConstituents) As Double rstMyQWRecordset.MoveFirst bhasGooddata = False For lngQW = 0 To lngConstituents - 1 lngMyWaterQualityID(lngQW) = Nz(rstMyQWRecordset.Fields(2).Value, -9999) lngMyParameterYID(lngQW) = Nz(rstMyQWRecordset.Fields(3).Value, -9999) lngQWTransformYID(lngQW) = Nz(rstMyQWRecordset.Fields(4).Value, -9999) lngMyParameterXID(lngQW) = Nz(rstMyQWRecordset.Fields(5).Value, -9999) lngQWTransformXID(lngQW) = Nz(rstMyQWRecordset.Fields(6).Value, -9999) lngUpstreamQWSegments(lngQW) = Nz(rstMyQWRecordset.Fields(7).Value, -9999) ' First segment dIntercept01(lngQW) = Nz(rstMyQWRecordset.Fields(8).Value, -9999#) dSlope01(lngQW) = Nz(rstMyQWRecordset.Fields(9).Value, -9999#) dMAD01(lngQW) = Nz(rstMyQWRecordset.Fields(10).Value, -9999#) dMAX01(lngQW) = Nz(rstMyQWRecordset.Fields(11).Value, -9999#) ' 2nd segment If lngUpstreamQWSegments(lngQW) > 1 Then dIntercept02(lngQW) = Nz(rstMyQWRecordset.Fields(12).Value, -9999#) dSlope02(lngQW) = Nz(rstMyQWRecordset.Fields(13).Value, -9999#) dMAD02(lngQW) = Nz(rstMyQWRecordset.Fields(14).Value, -9999#) dMAX02(lngQW) = Nz(rstMyQWRecordset.Fields(15).Value, -9999#) Else ' use previous for safety dIntercept02(lngQW) = dIntercept01(lngQW) dSlope02(lngQW) = dSlope01(lngQW) dMAD02(lngQW) = dMAD01(lngQW) dMAX02(lngQW) = dMAX01(lngQW) End If If lngUpstreamQWSegments(lngQW) > 2 Then dIntercept03(lngQW) = Nz(rstMyQWRecordset.Fields(16).Value, -9999#) dSlope03(lngQW) = Nz(rstMyQWRecordset.Fields(17).Value, -9999#) dMAD03(lngQW) = Nz(rstMyQWRecordset.Fields(18).Value, -9999#) dMAX03(lngQW) = Nz(rstMyQWRecordset.Fields(19).Value, -9999#) Else ' use previous for safety dIntercept03(lngQW) = dIntercept02(lngQW) dSlope03(lngQW) = dSlope02(lngQW) dMAD03(lngQW) = dMAD02(lngQW) dMAX03(lngQW) = dMAX02(lngQW) End If lngDenominator(lngQW) = Nz(rstMyQWRecordset.Fields(21).Value, -9999) lngNumerator(lngQW) = Nz(rstMyQWRecordset.Fields(22).Value, -9999) If dIntercept01(lngQW) > -9999# And dSlope01(lngQW) > -9999# And dMAD01(lngQW) > -9999# And _ dMAX01(lngQW) > -9999# Then bhasGooddata = True rstMyQWRecordset.MoveNext Next lngQW FirstCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If bhasGooddata = False Then ' We have no good values intProblem = 2 Exit Sub ' End If ' ************************************************************** ' Get stormflow values ' ************************************************************** ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strStormflowSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 3 GoTo FinalCleanUp: ' End If ' Stormflow Arguments If intWhat < 3 Then lngFlowCount = lngNumberOfStorms ReDim dStormflow01(lngFlowCount) As Double ' Concurrent flow ReDim dStormflow02(lngFlowCount) As Double ' Total flow If intWhat = 1 Or intWhat = 2 Then ReDim dStormflow03(lngFlowCount) As Double ReDim dStormDurationConcurrent(lngFlowCount) As Double ReDim dStormDurationWhole(lngFlowCount) As Double Else rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngFlowCount = rstMyQWRecordset.RecordCount ReDim dStormflow01(lngFlowCount) As Double ' Concurrent flow dLakeDuration = (86400#) End If intFlowErr = 0 rstMyQWRecordset.MoveFirst For lngStormNumber = 0 To (lngFlowCount - 1) dStormflow01(lngStormNumber) = Nz(rstMyQWRecordset.Fields(1).Value, -9999#) ' concurrent flow If intWhat < 3 Then dStormflow02(lngStormNumber) = Nz(rstMyQWRecordset.Fields(2).Value, -9999#) ' total flow dStormDurationWhole(lngStormNumber) = Nz(rstMyQWRecordset.Fields(3).Value, -9999#) dStormDurationConcurrent(lngStormNumber) = Nz(rstMyQWRecordset.Fields(4).Value, -9999#) If dStormflow01(lngStormNumber) = -9999# Or dStormflow02(lngStormNumber) = -9999# Then intFlowErr = intFlowErr + 1 If dStormDurationWhole(lngStormNumber) = -9999# Or dStormDurationConcurrent(lngStormNumber) = -9999# Then _ intFlowErr = intFlowErr + 1 If intWhat = 1 Or intWhat = 2 Then dStormflow03(lngStormNumber) = Nz(rstMyQWRecordset.Fields(5).Value, -9999#) If dStormflow03(lngStormNumber) = -9999# Then intFlowErr = intFlowErr + 1 End If Else If dStormflow01(lngStormNumber) = -9999# Then intFlowErr = intFlowErr + 1 End If rstMyQWRecordset.MoveNext Next lngStormNumber SecondCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intFlowErr <> 0 Then intProblem = 4 Exit Sub ' End If ' ************************************************************** ' Calculate concentrations and loads ' ************************************************************** ' Prime the AS241 approximation Call PrimeAS241(dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, _ dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, _ dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, _ dF1, dF2, dF3, dF4, dF5, dF6, dF7) For lngQW = 0 To lngConstituents - 1 ' Constituent loop ' test for good line If dIntercept01(lngQW) = -9999# Or dSlope01(lngQW) = -9999# Or dMAD01(lngQW) = -9999# Then GoTo SkipMe: End If ' ***************************************************************************************** ' Get Independent Variable ' ***************************************************************************************** If intWhat = 0 Then ' Highway dependent ReDim dXValue(lngNumberOfStorms) As Double strExplanatorySQL = "SELECT tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputHighwayQW.lngStormNumber, " & _ "tblOutputHighwayQW.dRunoffConcentration " & _ "FROM tblOutputHighwayQW " & _ "WHERE (((tblOutputHighwayQW.HighwayWaterQuality_ID)=" & lngMyParameterXID(lngQW) & ")) " & _ "ORDER BY tblOutputHighwayQW.lngStormNumber;" ' Reference an ADO Recordset Set rstMyXRecordset = New ADODB.Recordset rstMyXRecordset.Open strExplanatorySQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstMyXRecordset.MoveFirst For lngStormNumber = 0 To (lngNumberOfStorms - 1) dXValue(lngStormNumber) = Nz(rstMyXRecordset.Fields(2).Value, -9999#) rstMyXRecordset.MoveNext Next lngStormNumber If rstMyXRecordset.State = adStateOpen Then rstMyXRecordset.Close 'IF Recordset is open, close it Set rstMyXRecordset = Nothing 'Free memory ElseIf intWhat = 1 Or intWhat = 3 Then ' upstream transport If lngMyParameterXID(lngQW) = 1 Then ' flow in cfsm dStormflowConversion = 1# / fndGetDrainageFeature(lngInputAnalysis, 2) ' drainage area (sq mi) ElseIf lngMyParameterXID(lngQW) = 34 Or lngMyParameterXID(lngQW) = 35 Or _ lngMyParameterXID(lngQW) = 5749 Or lngMyParameterXID(lngQW) = 5750 Then ' flow in cfs dStormflowConversion = 1# ElseIf lngMyParameterXID(lngQW) = 1364 Or lngMyParameterXID(lngQW) = 1365 Then ' flow in cms dStormflowConversion = 0.0283168504 Else ' not a flow-based transport curve skip this one GoTo SkipMe: End If ElseIf intWhat = 2 Or intWhat = 4 Then ' upstream or lake dependent ReDim dXValue(lngFlowCount) As Double If intWhat = 2 Then strExplanatorySQL = "SELECT tblOutputUpstreamQW.UpstreamWaterQuality_ID, " & _ "tblOutputUpstreamQW.lngStormNumber, " & _ "tblOutputUpstreamQW.dTotalConcentration " & _ "FROM tblOutputUpstreamQW " & _ "WHERE (((tblOutputUpstreamQW.UpstreamWaterQuality_ID)=" & lngMyParameterXID(lngQW) & ")) " & _ "ORDER BY tblOutputUpstreamQW.lngStormNumber;" Else strExplanatorySQL = "SELECT tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID, " & _ "tadOutputLakeFluxConcentration.lngDayNumber, " & _ "tadOutputLakeFluxConcentration.dLakeBasinConcentration " & _ "FROM tadOutputLakeFluxConcentration " & _ "WHERE (((tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID) =" & lngMyParameterXID(lngQW) & ")) " & _ "ORDER BY tadOutputLakeFluxConcentration.lngDayNumber;" End If ' Reference an ADO Recordset Set rstMyXRecordset = New ADODB.Recordset rstMyXRecordset.Open strExplanatorySQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstMyXRecordset.MoveFirst For lngStormNumber = 0 To (lngFlowCount - 1) dXValue(lngStormNumber) = Nz(rstMyXRecordset.Fields(2).Value, -9999#) rstMyXRecordset.MoveNext Next lngStormNumber If rstMyXRecordset.State = adStateOpen Then rstMyXRecordset.Close 'IF Recordset is open, close it Set rstMyXRecordset = Nothing 'Free memory End If ' ***************************************************************************************** ' Open the output water-quality table ' ***************************************************************************************** ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset rstMyQWRecordset.Open strOutputSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic 'Get load multiplier lngMyNumerator = lngNumerator(lngQW) lngMyDenominator = lngDenominator(lngQW) dLoadMultiplier = fndLoadMultiplier(lngMyNumerator, lngMyDenominator) ' Transport Curve QW Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dQWSeed10, dQWSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dQWPP, dQWSeed10, dQWSeed11, dQWSeed12, _ dQWSeed20, dQWSeed21, dQWSeed22) Next intStart For lngStormNumber = 0 To (lngFlowCount - 1) ' Get Water-quality Statistics Call modStatistics.MRG32k3a(dQWPP, dQWSeed10, dQWSeed11, dQWSeed12, _ dQWSeed20, dQWSeed21, dQWSeed22) ' Normal(lognormal) frequency factor dQWKN = fndUniform01ToNormalAS241(dQWPP, _ dA0, dA1, dA2, dA3, dA4, dA5, dA6, dA7, dB1, dB2, dB3, dB4, dB5, dB6, dB7, _ dC0, dC1, dC2, dC3, dC4, dC5, dC6, dC7, dD1, dD2, dD3, dD4, dD5, dD6, dD7, _ dE0, dE1, dE2, dE3, dE4, dE5, dE6, dE7, dF1, dF2, dF3, dF4, dF5, dF6, dF7) If intWhat = 0 Or intWhat = 2 Or intWhat = 4 Then ' 0: Highway dependent 2: ' Upstream dependent 4: Lake dependent dExplanatoryX = dXValue(lngStormNumber) ElseIf intWhat = 1 Then ' upstream transport ' Calculate C via transport curve ' Get flow dExplanatoryX = (dStormflow02(lngStormNumber) / ((dStormDurationWhole(lngStormNumber) * 3600#)) * dStormflowConversion) ElseIf intWhat = 3 Then ' lake-basin transport dExplanatoryX = dStormflow01(lngStormNumber) / (86400# * dStormflowConversion) End If ' Transform explanatory variable ' If it is zero and using log make very small ' If lngQWTransformXID(lngQW) = 2 Or lngQWTransformXID(lngQW) = 3 And dExplanatoryX = 0# Then ' dExplanatoryX = 0.00000002 ' End If If dExplanatoryX <= 0# Then dExplanatoryX = (2# ^ (-10#)) End If If lngQWTransformXID(lngQW) = 2 Then dExplanatoryX = (Log(dExplanatoryX)) / (Log(10#)) If lngQWTransformXID(lngQW) = 3 Then dExplanatoryX = (Log(dExplanatoryX)) dMADRatio = 1# ' if normal 1.5 but we use instantaneous data vs storm avg or daily average If lngUpstreamQWSegments(lngQW) = 1 Then ' 1 segment dConcentration = dIntercept01(lngQW) + dSlope01(lngQW) * dExplanatoryX + (dMADRatio * dMAD01(lngQW) * dQWKN) ElseIf lngUpstreamQWSegments(lngQW) = 2 Then ' 2 segment If dExplanatoryX < dMAX01(lngQW) Then dConcentration = dIntercept01(lngQW) + dSlope01(lngQW) * dExplanatoryX + (dMADRatio * dMAD01(lngQW) * dQWKN) Else dConcentration = dIntercept02(lngQW) + dSlope02(lngQW) * dExplanatoryX + (dMADRatio * dMAD02(lngQW) * dQWKN) End If ElseIf lngUpstreamQWSegments(lngQW) = 3 Then ' 3 segment If dExplanatoryX < dMAX01(lngQW) Then dConcentration = dIntercept01(lngQW) + dSlope01(lngQW) * dExplanatoryX + (dMADRatio * dMAD01(lngQW) * dQWKN) ElseIf dExplanatoryX < dMAX02(lngQW) Then dConcentration = dIntercept02(lngQW) + dSlope02(lngQW) * dExplanatoryX + (dMADRatio * dMAD02(lngQW) * dQWKN) Else dConcentration = dIntercept03(lngQW) + dSlope03(lngQW) * dExplanatoryX + (dMADRatio * dMAD03(lngQW) * dQWKN) End If End If ' Retransform concentration ' 2: Adjust for transformation If lngQWTransformYID(lngQW) = 1 And dConcentration <= 0# Then 'If dConcentration <> -9999# Then dConcentration = Abs(dConcentration) 'changed 03-18-2012 'If dConcentration = 0# Then dConcentration = 0.002 'changed 03-18-2012 If dConcentration <> -9999# Then dConcentration = 0.002 'changed 03-18-2012 ElseIf lngQWTransformYID(lngQW) = 2 Then dConcentration = 10# ^ dConcentration ElseIf lngQWTransformYID(lngQW) = 3 Then dConcentration = Exp(dConcentration) End If ' 3: Calculate loads If lngMyDenominator = 7 And lngMyNumerator = 11 Then 'pH ' dStormLoad01 = dStormflow01(lngStormNumber) * dLoadMultiplier * _ 10# ^ (-1# * dConcentration) * 19.02331 ' Hwy All, US Concurrent ' use atomic weight g/mol of H3O+ If intWhat < 3 Then dStormLoad02 = dStormflow02(lngStormNumber) * dLoadMultiplier * _ 10# ^ (-1# * dConcentration) * 19.02331 ' Hwy BMP, US Total ' atomic weight g/mol of H3O+ If intWhat = 1 Or intWhat = 2 Then dStormLoad03 = dStormflow03(lngStormNumber) * dLoadMultiplier * _ 10# ^ (-1# * dConcentration) * 19.02331 ' Hwy BMP, US Total ' atomic weight g/mol of H3O+ End If End If Else dStormLoad01 = dStormflow01(lngStormNumber) * dLoadMultiplier * dConcentration ' Hwy All, US Concurrent If intWhat < 3 Then dStormLoad02 = dStormflow02(lngStormNumber) * dLoadMultiplier * dConcentration ' Hwy BMP, US Total If intWhat = 1 Or intWhat = 2 Then dStormLoad03 = dStormflow03(lngStormNumber) * dLoadMultiplier * dConcentration ' load concurrent to BMP End If End If End If ' Add new data to table tblOutputStormEvent for existing storms With rstMyQWRecordset .AddNew If intWhat < 3 Then .Fields(0) = lngMyWaterQualityID(lngQW) ' WaterQuality_ID .Fields(1) = lngStormNumber + 1 ' lngStormNumber .Fields(2) = lngMyNumerator ' lngMyNumerator .Fields(3) = lngMyDenominator ' lngMyDenominator .Fields(4) = dConcentration ' Hwy untreated, US Concurrent Concentration .Fields(5) = dStormLoad01 ' Hwy untreated, US Concurrent load .Fields(6) = dConcentration ' Hwy treated, US Total Concentration .Fields(7) = dStormLoad02 ' Hwy BMP treated, US Total load If intWhat = 1 Or intWhat = 2 Then .Fields(8) = dStormLoad03 ' Hwy BMP treated, US BMP concurrent load End If .Update Else .Fields(0) = lngMyWaterQualityID(lngQW) ' WaterQuality_ID .Fields(1) = lngStormNumber + 1 ' lngStormNumber .Fields(2) = dConcentration ' lake-basin concentration .Fields(3) = dStormLoad01 ' lake-basin load End If .Update End With rstMyQWRecordset.MoveNext Next lngStormNumber SkipMe: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory Next lngQW Exit Sub FinalCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory Exit Sub GenerateDependentCurveQW_Err: MsgBox Err.Description, vbCritical, "Generate Dependent Water Quality" intProblem = 7 intQWErr = intQWErr + 1 If intQWErr < 2 Then GoTo FinalCleanUp: Exit Sub End Sub Private Sub GetBMPWaterQuality(lngMyInputAnalysis As Long, lngInMasterSeed As Long, _ lngInSeedSequence As Long, lngNumberOfStorms As Long, intProblem As Integer) ' ' Purpose: to calculate BMP water-quality modification and apply it to highway ' discharge concentrations and loads ' History: Version 1.0 August 18 2009 by Gregory E. Granato ' Allow negative trap stats but no neg values 10/10/2011 ' Fix call to BMP id without BMP ID in first SQL uses lngMyInputAnalysis 11/01/2011 ' ' Function arguments ' lngMyInputAnalysis The current analysis ' lngInMasterSeed The starting seed of the whole random-seed sequence ' lngInSeedSequence The current seed in the whole random-seed sequence ' lngNumberOfStorms The Long the number of storms in this analysis ' intProblem The error flag ' ' BMP Water-Quality Modification Arguments Dim bHasdata As Boolean ' test data Dim strSQLTreat As String ' Query String BMP QW modification Dim strSQLHasTreatment As String ' Query String Highway constituents with BMP modification Dim strSQLWriteTreat As String ' Query String Write BMP modification Dim rstMyRecordset As ADODB.Recordset ' recordset Dim intErr As Integer ' problem flag 'Dim intMissing As Integer ' problem flag Dim intStart As Integer ' Start Random seed loop Dim lngBMPCount As Long Dim lngQWIDCount As Long Dim lngMyBMPParameterID() As Long Dim dIrreducibleMinConcentration() As Double Dim dMinConcentrationRatio() As Double Dim dLBConcentrationRatio() As Double Dim dUBConcentrationRatio() As Double Dim dMaxConcentrationRatio() As Double Dim dRankCorrelation() As Double Dim lngHighwayQWIDCount As Long Dim lngHighwayQWID() As Long ' Stochastic Arguments Dim dOutU01 As Double ' Correlated Uniform Variate 0-1 Dim dQWPP As Double ' Random (U01) Uniform Variate 0-1 ' BMP Modification Seeds Dim dBMPSeed10 As Double Dim dBMPSeed11 As Double Dim dBMPSeed12 As Double Dim dBMPSeed20 As Double Dim dBMPSeed21 As Double Dim dBMPSeed22 As Double Dim dHighwayRunoffCPP As Double ' Runoff Concentration plotting position Dim dHighwayRunoffConc As Double ' Runoff Concentration Dim dHighwayBMPConc As Double ' BMP discharge Concentration Dim dHighwayBMPLoad As Double ' BMP discharge Load Dim dRatio As Double ' BMP modification ratio Dim lngI As Long Dim lngJ As Long Dim lngK As Long On Error GoTo GetBMPWaterQuality_Err: intErr = 0 ' **************************** ' Get BMP modification criteria ' **************************** strSQLTreat = "SELECT tblHighwayAnalysis.HighwayAnalysis_ID, tadBMPTreatment.Parameter_ID, " & _ "tadBMPTreatment.dIrreducibleMinConcentration, tadBMPTreatment.dMinConcentrationRatio, " & _ "tadBMPTreatment.dLBConcentrationRatio, tadBMPTreatment.dUBConcentrationRatio, " & _ "tadBMPTreatment.dMaxConcentrationRatio, tadBMPTreatment.dRankCorrelation " & _ "FROM (tblBMPHydraulics INNER JOIN tadBMPTreatment ON " & _ "tblBMPHydraulics.BMP_ID = tadBMPTreatment.BMP_ID) " & _ "INNER JOIN tblHighwayAnalysis ON " & _ "tblBMPHydraulics.BMP_ID = tblHighwayAnalysis.BMP_ID " & _ "WHERE (((tblHighwayAnalysis.HighwayAnalysis_ID)=" & lngMyInputAnalysis & ")) " & _ "ORDER BY tadBMPTreatment.Parameter_ID;" ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset rstMyRecordset.Open strSQLTreat, CurrentProject.Connection, adOpenKeyset, adLockOptimistic ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo FirstCleanUp: ' There is no data for this analysis rstMyRecordset.MoveFirst rstMyRecordset.MoveLast lngBMPCount = rstMyRecordset.RecordCount If lngBMPCount <= 0 Then GoTo SecondCleanUp: ReDim lngMyBMPParameterID(lngBMPCount) As Long ReDim dIrreducibleMinConcentration(lngBMPCount) As Double ReDim dMinConcentrationRatio(lngBMPCount) As Double ReDim dLBConcentrationRatio(lngBMPCount) As Double ReDim dUBConcentrationRatio(lngBMPCount) As Double ReDim dMaxConcentrationRatio(lngBMPCount) As Double ReDim dRankCorrelation(lngBMPCount) As Double 'intMissing = 0 rstMyRecordset.MoveFirst For lngI = 0 To lngBMPCount - 1 lngMyBMPParameterID(lngI) = Nz(rstMyRecordset.Fields(1).Value, -9999) dIrreducibleMinConcentration(lngI) = Nz(rstMyRecordset.Fields(2).Value, 0#) dMinConcentrationRatio(lngI) = Nz(rstMyRecordset.Fields(3).Value, 0#) dLBConcentrationRatio(lngI) = Nz(rstMyRecordset.Fields(4).Value, 0#) dUBConcentrationRatio(lngI) = Nz(rstMyRecordset.Fields(5).Value, 0#) dMaxConcentrationRatio(lngI) = Nz(rstMyRecordset.Fields(6).Value, (dUBConcentrationRatio(lngI) + (2#) ^ (-8#))) dRankCorrelation(lngI) = Nz(rstMyRecordset.Fields(7).Value, 0#) rstMyRecordset.MoveNext Next lngI FirstCleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory If bHasdata = False Then intErr = 1 Exit Sub End If bHasdata = False For lngI = 0 To lngBMPCount - 1 ' ********************************************************* ' Get Highway Water Quality for a BMP modification criteria ' ********************************************************* strSQLHasTreatment = "SELECT tblQWHighway.Parameter_ID, " & _ "tblQWHighway.HighwayWaterQuality_ID, " & _ "tdsUSEPAParameterCodes.lngDenominator, tdsUSEPAParameterCodes.lngNumerator " & _ "FROM tdsUSEPAParameterCodes INNER JOIN tblQWHighway ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWHighway.Parameter_ID " & _ "WHERE (((tblQWHighway.Parameter_ID)=" & lngMyBMPParameterID(lngI) & ")) " & _ "ORDER BY tblQWHighway.HighwayWaterQuality_ID;" ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset rstMyRecordset.Open strSQLHasTreatment, CurrentProject.Connection, adOpenKeyset, adLockOptimistic ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo SecondCleanUp: ' There is no data for this analysis rstMyRecordset.MoveFirst rstMyRecordset.MoveLast lngQWIDCount = rstMyRecordset.RecordCount ReDim lngHighwayQWID(lngQWIDCount) As Long rstMyRecordset.MoveFirst For lngJ = 0 To lngQWIDCount - 1 lngHighwayQWID(lngJ) = Nz(rstMyRecordset.Fields(1).Value, -9999) rstMyRecordset.MoveNext Next lngJ SecondCleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory For lngJ = 0 To lngQWIDCount - 1 If lngHighwayQWID(lngJ) > 0 Then ' **************************** ' Get Treated QW ID's ' **************************** strSQLWriteTreat = "SELECT tblOutputHighwayQW.HighwayWaterQuality_ID, tblQWHighway.Parameter_ID, " & _ "tblOutputHighwayQW.lngStormNumber, " & _ "tblOutputHighwayQW.dRunoffConcentrationPP, tblOutputHighwayQW.dRunoffConcentration, " & _ "tblOutputHighwayQW.dDischargeConcentration, tblOutputHighwayQW.dDischargeLoad " & _ "FROM tblOutputHighwayQW INNER JOIN tblQWHighway ON " & _ "tblOutputHighwayQW.HighwayWaterQuality_ID = tblQWHighway.HighwayWaterQuality_ID " & _ "WHERE (((tblOutputHighwayQW.HighwayWaterQuality_ID)=" & lngHighwayQWID(lngJ) & ") AND " & _ "((tblQWHighway.Parameter_ID)=" & lngMyBMPParameterID(lngI) & ")) " & _ "ORDER BY tblOutputHighwayQW.lngStormNumber;" ' Reference an ADO Recordset Set rstMyRecordset = New ADODB.Recordset rstMyRecordset.Open strSQLWriteTreat, CurrentProject.Connection, adOpenKeyset, adLockOptimistic ' Check values bHasdata = False If rstMyRecordset.BOF And rstMyRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then GoTo ThirdCleanUp: ' There is no data for this analysis ' **********Get initial seeds from seed table based on master seed sequence number ' Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dBMPSeed10, dBMPSeed20) ' Warm up Rng Seeds For intStart = 1 To 3 Call modStatistics.MRG32k3a(dOutU01, dBMPSeed10, dBMPSeed11, dBMPSeed12, _ dBMPSeed20, dBMPSeed21, dBMPSeed22) Next intStart rstMyRecordset.MoveFirst For lngK = 0 To lngNumberOfStorms - 1 dHighwayRunoffCPP = Nz(rstMyRecordset.Fields(3).Value, -9999#) dHighwayRunoffConc = Nz(rstMyRecordset.Fields(4).Value, -9999#) dHighwayBMPConc = Nz(rstMyRecordset.Fields(5).Value, -9999#) dHighwayBMPLoad = Nz(rstMyRecordset.Fields(6).Value, -9999#) If dHighwayRunoffCPP < 0# Then dHighwayRunoffCPP = Abs(dHighwayRunoffCPP / 100#) If dHighwayRunoffCPP = 0# Then dHighwayRunoffCPP = dHighwayRunoffCPP + 0.00135 If dHighwayRunoffCPP > 1# Then dHighwayRunoffCPP = dHighwayRunoffCPP / 100# If dHighwayRunoffConc = dHighwayBMPConc Then 'they have not been modified so do it If Abs(dRankCorrelation(lngI)) > 0.9975 Then ' for all intents and purposes they are on the 1:1 line dOutU01 = dQWPP If dRankCorrelation(lngI) < 0# Then dOutU01 = 1# - dOutU01 ElseIf Abs(dRankCorrelation(lngI)) < 0.075 Then ' for all intents and purposes they are independent Call modStatistics.MRG32k3a(dOutU01, dBMPSeed10, dBMPSeed11, dBMPSeed12, _ dBMPSeed20, dBMPSeed21, dBMPSeed22) Else Call modStatistics.GetRankCorrelation(dRankCorrelation(lngI), dHighwayRunoffCPP, dOutU01, _ dBMPSeed10, dBMPSeed11, dBMPSeed12, dBMPSeed20, dBMPSeed21, dBMPSeed22) End If dRatio = fndUniform01ToTrapezoid(dOutU01, dMinConcentrationRatio(lngI), dLBConcentrationRatio(lngI), _ dUBConcentrationRatio(lngI), dMaxConcentrationRatio(lngI)) ' Allow negative trap stats but no neg values 10/10/2011 If dRatio <= 0# Then dRatio = dMaxConcentrationRatio(lngI) * ((10#) ^ (-4#)) If (dHighwayRunoffConc * dRatio) >= dIrreducibleMinConcentration(lngI) Then dHighwayBMPConc = dHighwayBMPConc * dRatio dHighwayBMPLoad = dHighwayBMPLoad * dRatio Else dHighwayBMPConc = dIrreducibleMinConcentration(lngI) dHighwayBMPLoad = dHighwayBMPLoad * (dIrreducibleMinConcentration(lngI) / dHighwayRunoffConc) End If rstMyRecordset.Fields(5).Value = dHighwayBMPConc rstMyRecordset.Fields(6).Value = dHighwayBMPLoad rstMyRecordset.MoveNext End If Next lngK ThirdCleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory End If ' If bhasdata = True Then Next lngJ Next lngI Exit Sub FinalCleanUp: If rstMyRecordset.State = adStateOpen Then rstMyRecordset.Close 'IF Recordset is open, close it Set rstMyRecordset = Nothing 'Free memory Exit Sub GetBMPWaterQuality_Err: MsgBox Err.Description, vbCritical, "BMP Water-Quality Modification Error" intProblem = 7 intErr = intErr + 1 If intErr < 2 Then GoTo FinalCleanUp: Exit Sub End Sub Private Sub GenerateDownstreamQW(lngInMasterSeed As Long, lngInSeedSequence As Long, _ lngInputAnalysis As Long, lngNumberOfStorms As Long, intProblem As Integer) ' ' Purpose: ' To generate a population of downstream concentrations and loads for a set number of storms ' ' History: ' Version 1.0 Aug 22 2009 by Gregory E. Granato' ' ' lngInMasterSeed As Long database master seed ID ' lngInSeedSequence As Long current seed ' lngInputAnalysis As Long current analysis ID ' lngNumberOfStorms as long total number of storms ' intProblem as integer if zero ok if 1 Bad stats if 2 error in this subroutine ' ' Arguments Dim bHasdata As Boolean ' test data Dim bhasGooddata As Boolean ' test data Dim strSQL As String ' Query String Dim rstMyQWRecordset As ADODB.Recordset ' recordset Dim intQWErr As Integer ' null flow counter Dim lngStormNumber As Long ' Index for the current storm Dim lngConstituents As Long ' Number of downstream-pair constituents Dim lngQW As Long ' Index for the current downstream-pair constituent Dim DownstreamWaterQualityID() As Long Dim HighwayWaterQualityID() As Long Dim UpstreamWaterQualityID() As Long Dim bBMPModification() As Boolean Dim bAdverseEffectFraction() As Boolean Dim dMinAdverseEffectFraction() As Double Dim dLBAdverseEffectFraction() As Double Dim dUBAdverseEffectFraction() As Double Dim dMaxAdverseEffectFraction() As Double ' Upstream Recession Factor Random Seeds Dim dAdverseEffectPP As Double Dim dAdverseEffectSeed10 As Double Dim dAdverseEffectSeed11 As Double Dim dAdverseEffectSeed12 As Double Dim dAdverseEffectSeed20 As Double Dim dAdverseEffectSeed21 As Double Dim dAdverseEffectSeed22 As Double Dim dMyAdverseEffectFraction As Double Dim dHighwayRunoff() As Double Dim dHighwayBMPDischarge() As Double Dim dUpstreamConcurrentFlow() As Double Dim dUpstreamBMPConcurrentQ() As Double Dim lngMyNumerator As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim lngMyDenominator As Long 'Unit conversion index from tdsUSEPAParameterCodes Dim dInputHighwayLoad() As Double Dim dInputUpstreamLoad() As Double Dim dOutputDownstreamLoad() As Double Dim dOutputDownstreamConc() As Double Dim dOutputDownstreamAEConc() As Double On Error GoTo GenerateDownstreamQW_Err: intProblem = 0 intQWErr = 0 '************************************* ' Get Downstream Pair Information '************************************* strSQL = "SELECT tblQWDownstream.DownstreamWaterQuality_ID, " & _ "tblQWDownstream.HighwayWaterQuality_ID, tblQWDownstream.UpstreamWaterQuality_ID, " & _ "tblQWDownstream.bBMPModification, tblQWDownstream.bAdverseEffectFraction, " & _ "tblQWDownstream.dMinAdverseEffectFraction, tblQWDownstream.dLBAdverseEffectFraction, " & _ "tblQWDownstream.dUBAdverseEffectFraction, tblQWDownstream.dMaxAdverseEffectFraction " & _ "FROM tblQWDownstream INNER JOIN tasAnalysisDownstreamQW ON " & _ "tblQWDownstream.DownstreamWaterQuality_ID = tasAnalysisDownstreamQW.DownstreamWaterQuality_ID " & _ "WHERE (((tasAnalysisDownstreamQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ")) " & _ "ORDER BY tblQWDownstream.DownstreamWaterQuality_ID;" ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no Pair values intProblem = 1 GoTo FinalCleanUp: ' End If rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngConstituents = rstMyQWRecordset.RecordCount ReDim DownstreamWaterQualityID(lngConstituents) As Long ReDim HighwayWaterQualityID(lngConstituents) As Long ReDim UpstreamWaterQualityID(lngConstituents) As Long ReDim bBMPModification(lngConstituents) As Boolean ReDim bAdverseEffectFraction(lngConstituents) As Boolean ReDim dMinAdverseEffectFraction(lngConstituents) As Double ReDim dLBAdverseEffectFraction(lngConstituents) As Double ReDim dUBAdverseEffectFraction(lngConstituents) As Double ReDim dMaxAdverseEffectFraction(lngConstituents) As Double rstMyQWRecordset.MoveFirst For lngQW = 0 To lngConstituents - 1 DownstreamWaterQualityID(lngQW) = Nz(rstMyQWRecordset.Fields("DownstreamWaterQuality_ID").Value, -9999) HighwayWaterQualityID(lngQW) = Nz(rstMyQWRecordset.Fields("HighwayWaterQuality_ID").Value, -9999) UpstreamWaterQualityID(lngQW) = Nz(rstMyQWRecordset.Fields("UpstreamWaterQuality_ID").Value, -9999) bBMPModification(lngQW) = Nz(rstMyQWRecordset.Fields("bBMPModification").Value, "False") bAdverseEffectFraction(lngQW) = Nz(rstMyQWRecordset.Fields("bAdverseEffectFraction").Value, "False") dMinAdverseEffectFraction(lngQW) = Nz(rstMyQWRecordset.Fields("dMinAdverseEffectFraction").Value, -9999#) dLBAdverseEffectFraction(lngQW) = Nz(rstMyQWRecordset.Fields("dLBAdverseEffectFraction").Value, -9999#) dUBAdverseEffectFraction(lngQW) = Nz(rstMyQWRecordset.Fields("dUBAdverseEffectFraction").Value, -9999#) dMaxAdverseEffectFraction(lngQW) = Nz(rstMyQWRecordset.Fields("dMaxAdverseEffectFraction").Value, -9999#) If DownstreamWaterQualityID(lngQW) = -9999 Or HighwayWaterQualityID(lngQW) = -9999 Or _ HighwayWaterQualityID(lngQW) = -9999 Then intQWErr = intQWErr + 1 rstMyQWRecordset.MoveNext Next lngQW FirstCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then 'We have Bad Pair Values intProblem = 2 Exit Sub ' End If '************************************* ' Get Stormflows '************************************* strSQL = "SELECT tblOutputStormEvent.lngStormNumber, " & _ "tblOutputStormEvent.dHighwayRunoff, tblOutputStormEvent.dHighwayBMPDischarge, " & _ "tblOutputStormEvent.dUpstreamConcurrentFlow, tblOutputStormEvent.dUpstreamBMPConcurrentQ " & _ "FROM tblOutputStormEvent " & _ "ORDER BY tblOutputStormEvent.lngStormNumber;" ReDim dHighwayRunoff(lngNumberOfStorms) As Double ReDim dHighwayBMPDischarge(lngNumberOfStorms) As Double ReDim dUpstreamConcurrentFlow(lngNumberOfStorms) As Double ReDim dUpstreamBMPConcurrentQ(lngNumberOfStorms) As Double ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no stormflow values intProblem = 3 GoTo FinalCleanUp: ' End If intQWErr = 0 rstMyQWRecordset.MoveFirst For lngStormNumber = 0 To (lngNumberOfStorms - 1) dHighwayRunoff(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dHighwayRunoff").Value, -9999#) 'Highway runoff, upstream concurrent dHighwayBMPDischarge(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dHighwayBMPDischarge").Value, -9999#) ' Highway BMP Q, upstream concurrent dUpstreamConcurrentFlow(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dUpstreamConcurrentFlow").Value, -9999#) ' upstream Q during hwy runoff dUpstreamBMPConcurrentQ(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dUpstreamBMPConcurrentQ").Value, -9999#) ' upstream Q during BMP discharge If dHighwayRunoff(lngStormNumber) = -9999# Or dHighwayBMPDischarge(lngStormNumber) = -9999# Or _ dUpstreamConcurrentFlow(lngStormNumber) = -9999# Or dUpstreamBMPConcurrentQ(lngStormNumber) = -9999# Then intQWErr = intQWErr + 1 rstMyQWRecordset.MoveNext Next lngStormNumber SecondCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then ' Bad stormflow values intProblem = 4 Exit Sub ' End If '************************************* ' Calculate Output Concentrations & Loads '************************************* For lngQW = 0 To lngConstituents - 1 ' Redimension/clear array ReDim dInputHighwayLoad(lngNumberOfStorms) As Double ReDim dInputUpstreamLoad(lngNumberOfStorms) As Double ReDim dOutputDownstreamFlow(lngNumberOfStorms) As Double ReDim dOutputDownstreamLoad(lngNumberOfStorms) As Double ReDim dOutputDownstreamConc(lngNumberOfStorms) As Double ReDim dOutputDownstreamAEConc(lngNumberOfStorms) As Double '************************************* ' Get Highway Loads '************************************* strSQL = "SELECT tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputHighwayQW.lngStormNumber, " & _ "tblOutputHighwayQW.lngNumerator, tblOutputHighwayQW.lngDenominator, " & _ "tblOutputHighwayQW.dRunoffLoad, tblOutputHighwayQW.dDischargeLoad " & _ "FROM tblOutputHighwayQW " & _ "WHERE (((tblOutputHighwayQW.HighwayWaterQuality_ID)=" & HighwayWaterQualityID(lngQW) & ")) " & _ "ORDER BY tblOutputHighwayQW.lngStormNumber;" 'Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no highway-quality values intProblem = 5 GoTo FinalCleanUp: ' End If intQWErr = 0 rstMyQWRecordset.MoveFirst If bBMPModification(lngQW) = True Then For lngStormNumber = 0 To (lngNumberOfStorms - 1) dInputHighwayLoad(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dDischargeLoad").Value, -9999#) ' Highway BMP discharge lngMyNumerator = Nz(rstMyQWRecordset.Fields("lngNumerator").Value, -9999) lngMyDenominator = Nz(rstMyQWRecordset.Fields("lngDenominator").Value, -9999) If dInputHighwayLoad(lngStormNumber) = -9999# Then intQWErr = intQWErr + 1 rstMyQWRecordset.MoveNext Next lngStormNumber Else For lngStormNumber = 0 To (lngNumberOfStorms - 1) dInputHighwayLoad(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dRunoffLoad").Value, -9999#) ' Highway lngMyNumerator = Nz(rstMyQWRecordset.Fields("lngNumerator").Value, -9999) lngMyDenominator = Nz(rstMyQWRecordset.Fields("lngDenominator").Value, -9999) If dInputHighwayLoad(lngStormNumber) = -9999# Then intQWErr = intQWErr + 1 rstMyQWRecordset.MoveNext Next lngStormNumber End If ThirdCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then ' Skip this one GoTo SkipThislngQW: 'Next lngQW End If '************************************* ' Get Upstream Loads '************************************* strSQL = "SELECT tblOutputUpstreamQW.UpstreamWaterQuality_ID, " & _ "tblOutputUpstreamQW.lngStormNumber, " & _ "tblOutputUpstreamQW.dConcurrentLoad, " & _ "tblOutputUpstreamQW.dConcurrentBMPLoad " & _ "FROM tblOutputUpstreamQW " & _ "WHERE (((tblOutputUpstreamQW.UpstreamWaterQuality_ID)=" & UpstreamWaterQualityID(lngQW) & ")) " & _ "ORDER BY tblOutputUpstreamQW.lngStormNumber;" 'Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset 'Populate Recordset rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly 'Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 6 GoTo FinalCleanUp: ' End If intQWErr = 0 rstMyQWRecordset.MoveFirst If bBMPModification(lngQW) = True Then For lngStormNumber = 0 To (lngNumberOfStorms - 1) dInputUpstreamLoad(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dConcurrentBMPLoad").Value, -9999#) ' upstream load 'Proportion to longer upstream flow hydrograph with BMP hydrograph extension. 'dInputUpstreamLoad(lngStormNumber) = dInputUpstreamLoad(lngStormNumber) * _ ' (dUpstreamBMPConcurrentQ(lngStormNumber) / dUpstreamConcurrentFlow(lngStormNumber)) rstMyQWRecordset.MoveNext Next lngStormNumber Else For lngStormNumber = 0 To (lngNumberOfStorms - 1) dInputUpstreamLoad(lngStormNumber) = Nz(rstMyQWRecordset.Fields("dConcurrentLoad").Value, -9999#) ' Highway rstMyQWRecordset.MoveNext Next lngStormNumber End If FourthCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then ' Skip this one GoTo SkipThislngQW: End If '************************************* ' Calculate downstream Loads & Concentations '************************************* If bAdverseEffectFraction(lngQW) = True Then If dMinAdverseEffectFraction(lngQW) >= dMaxAdverseEffectFraction(lngQW) Or _ dLBAdverseEffectFraction(lngQW) < dMinAdverseEffectFraction(lngQW) Or _ dLBAdverseEffectFraction(lngQW) > dUBAdverseEffectFraction(lngQW) Or _ dLBAdverseEffectFraction(lngQW) > dMaxAdverseEffectFraction(lngQW) Or _ dUBAdverseEffectFraction(lngQW) > dMaxAdverseEffectFraction(lngQW) Then bAdverseEffectFraction(lngQW) = False End If If bAdverseEffectFraction(lngQW) = True Then ' **********Get initial seeds from seed table based on master seed sequence number ' Basin Recession Factor is sequence #5 Call GetStartSeed(lngInMasterSeed, lngInSeedSequence, dAdverseEffectSeed10, dAdverseEffectSeed20) End If If bBMPModification(lngQW) = True Then For lngStormNumber = 0 To (lngNumberOfStorms - 1) dOutputDownstreamFlow(lngStormNumber) = dHighwayBMPDischarge(lngStormNumber) + dUpstreamBMPConcurrentQ(lngStormNumber) dOutputDownstreamLoad(lngStormNumber) = dInputHighwayLoad(lngStormNumber) + dInputUpstreamLoad(lngStormNumber) dOutputDownstreamConc(lngStormNumber) = (dOutputDownstreamLoad(lngStormNumber) / dOutputDownstreamFlow(lngStormNumber)) _ * 1# / (fndLoadMultiplier(lngMyNumerator, lngMyDenominator)) If lngMyDenominator = 7 And lngMyNumerator = 11 Then 'pH convert back from g/L of H3O' If dOutputDownstreamConc(lngStormNumber) <= 0# Then dOutputDownstreamConc(lngStormNumber) = 1.90233E-13 dOutputDownstreamConc(lngStormNumber) = (-1# * (Log(dOutputDownstreamConc(lngStormNumber) / 19.02331) / Log(10#))) End If ' *********************** ' calculate adverse effect concentration ' *********************** If bAdverseEffectFraction(lngQW) = True Then 'Get Uniform Variate Call modStatistics.MRG32k3a(dAdverseEffectPP, dAdverseEffectSeed10, dAdverseEffectSeed11, _ dAdverseEffectSeed12, dAdverseEffectSeed20, dAdverseEffectSeed21, dAdverseEffectSeed22) dMyAdverseEffectFraction = fndUniform01ToTrapezoid(dAdverseEffectPP, dMinAdverseEffectFraction(lngQW), _ dLBAdverseEffectFraction(lngQW), dUBAdverseEffectFraction(lngQW), dMaxAdverseEffectFraction(lngQW)) dOutputDownstreamAEConc(lngStormNumber) = dOutputDownstreamConc(lngStormNumber) * dMyAdverseEffectFraction Else 'adverse effect concentration is not calculated dOutputDownstreamAEConc(lngStormNumber) = dOutputDownstreamConc(lngStormNumber) End If Next lngStormNumber Else ' BMP Modification is not true For lngStormNumber = 0 To (lngNumberOfStorms - 1) dOutputDownstreamFlow(lngStormNumber) = dHighwayRunoff(lngStormNumber) + dUpstreamConcurrentFlow(lngStormNumber) dOutputDownstreamLoad(lngStormNumber) = dInputHighwayLoad(lngStormNumber) + dInputUpstreamLoad(lngStormNumber) dOutputDownstreamConc(lngStormNumber) = (dOutputDownstreamLoad(lngStormNumber) / dOutputDownstreamFlow(lngStormNumber)) _ * 1# / (fndLoadMultiplier(lngMyNumerator, lngMyDenominator)) If lngMyDenominator = 7 And lngMyNumerator = 11 Then 'pH convert back from g/L of H3O' If dOutputDownstreamConc(lngStormNumber) <= 0# Then dOutputDownstreamConc(lngStormNumber) = 1.90233E-13 dOutputDownstreamConc(lngStormNumber) = (-1# * (Log(dOutputDownstreamConc(lngStormNumber) / 19.02331) / Log(10#))) End If ' *********************** ' calculate adverse effect concentration ? ' *********************** If bAdverseEffectFraction(lngQW) = True Then 'Get Uniform Variate Call modStatistics.MRG32k3a(dAdverseEffectPP, dAdverseEffectSeed10, dAdverseEffectSeed11, _ dAdverseEffectSeed12, dAdverseEffectSeed20, dAdverseEffectSeed21, dAdverseEffectSeed22) dMyAdverseEffectFraction = fndUniform01ToTrapezoid(dAdverseEffectPP, dMinAdverseEffectFraction(lngQW), _ dLBAdverseEffectFraction(lngQW), dUBAdverseEffectFraction(lngQW), dMaxAdverseEffectFraction(lngQW)) dOutputDownstreamAEConc(lngStormNumber) = dOutputDownstreamConc(lngStormNumber) * dMyAdverseEffectFraction Else 'adverse effect concentration is not calculated dOutputDownstreamAEConc(lngStormNumber) = dOutputDownstreamConc(lngStormNumber) End If Next lngStormNumber End If '************************************* ' Write downstream Loads & Concentations '************************************* strSQL = "SELECT tblOutputDownstreamQW.DownstreamWaterQuality_ID, tblOutputDownstreamQW.lngStormNumber, " & _ "tblOutputDownstreamQW.dConcentration, tblOutputDownstreamQW.dAEConcentration, " & _ "tblOutputDownstreamQW.dDownstreamStormQ, tblOutputDownstreamQW.dLoad " & _ "FROM tblOutputDownstreamQW " & _ "ORDER BY tblOutputDownstreamQW.lngStormNumber;" 'Open the tblOutputDownstreamQW ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset rstMyQWRecordset.Open strSQL, CurrentProject.Connection, adOpenKeyset, adLockOptimistic For lngStormNumber = 0 To (lngNumberOfStorms - 1) 'Add new data to table tblOutputDownstreamQW for existing storms With rstMyQWRecordset .AddNew .Fields(0) = DownstreamWaterQualityID(lngQW) ' WaterQuality_ID .Fields(1) = lngStormNumber + 1 ' lngStormNumber .Fields(2) = dOutputDownstreamConc(lngStormNumber) ' Downstream Concentration .Fields(3) = dOutputDownstreamAEConc(lngStormNumber) ' Downstream Adverse Effect Concentration .Fields(4) = dOutputDownstreamFlow(lngStormNumber) ' Downstream flow .Fields(5) = dOutputDownstreamLoad(lngStormNumber) ' Downstream load .Update End With rstMyQWRecordset.MoveNext Next lngStormNumber FifthCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory SkipThislngQW: Next lngQW Exit Sub FinalCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory Exit Sub GenerateDownstreamQW_Err: MsgBox Err.Description, vbCritical, "Generate Downstream Water Quality" intProblem = 7 intQWErr = intQWErr + 1 If intQWErr < 2 Then GoTo FinalCleanUp: Exit Sub End Sub Private Function fndLoadMultiplier(lngNumerator As Long, lngDenominator As Long) As Double ' ' Purpose: To calculate a concentration to load conversion factor based on the Numerator and Denominator ' ' History: 05/06/2009 by Gregory E. Granato ' ' Arguments: Dim dNumerator As Double Dim dDenominator As Double ' If bad value make it a big negative load If lngNumerator = -9999 Or lngNumerator = -9999 Then fndLoadMultiplier = -9999# Exit Function End If ' Calculate Numerator value if possible convert value to pounds If lngNumerator = 1 Then ' milligrams dNumerator = 2.204622476 * 10# ^ -6# 'Pounds/MilliGram ElseIf lngNumerator = 2 Then ' micrograms dNumerator = 2.204622476 * 10# ^ -9# 'Pounds/MicroGram ElseIf lngNumerator = 3 Then ' grams dNumerator = 2.204622476 * 10# ^ -3# 'Pounds/Gram Else dNumerator = 1# End If ' Calculate denominator value if possible convert value to cubic foot If lngDenominator = 1 Then ' per liter dDenominator = 0.0353146625 'cubic foot/liter ElseIf lngDenominator = 2 Then ' per milliliter dDenominator = 0.0353146625 * 10# ^ -3# 'cubic foot/milliliter Else dDenominator = 1# End If ' Calculate denominator value If lngDenominator = 7 And lngNumerator = 11 Then 'pH dNumerator = 2.204622476 * 10# ^ -3# 'Pounds/Gram dDenominator = 0.0353146625 'cubic foot/liter End If fndLoadMultiplier = dNumerator / dDenominator Exit Function End Function Private Sub SetQWPlottingPosition(strIDVariable As String, strValueVariable As String, strPPVariable As String, strTable As String, _ lngCount As Long, Optional intPPFormula As Integer = 1, Optional bSortAscending As Boolean = True, _ Optional bPercentage As Boolean = False) ' ' Purpose: to Calculate plotting positions (pp) from a user-defined query ' History: Version 1.0 August 11 2009 by Gregory E. Granato ' ' Function arguments ' ' strIDVariable As String the water-quality ID variablename for the output table ' strValueVariable as string the variable name being sorted and assigned a pp ' strPPVariable as string the plotting position variable name in the table ' strTable as string the table of interest ' lngCount As Long the total number of values in the sample ' intPPFormula As Integer the type of plotting poisition formula ' bSortAscending As Boolean True (default) = Sort ascending False = Sort descending ' bPercentage As Boolean True (default) = percentage (0 -9999# And dLakeSurfaceArea > -9999# And dLakeBasinDrainageArea > -9999# Then bhasGooddata = True dLakeVolume = dLakeAverageDepth * (dLakeSurfaceArea * 43560#) ' Convert Acres to Ft^2 * ft = ft^3 FirstCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If bhasGooddata = False Then ' We have no good values intProblem = 1 Exit Sub ' End If ' ************************************************************** ' Get the Water-Quality Constituent Information ' ************************************************************** strConstituentSql = "SELECT tblQWDownstream.DownstreamWaterQuality_ID, " & _ "tblQWDownstream.bBMPModification, tdsUSEPAParameterCodes.lngNumerator, " & _ "tdsUSEPAParameterCodes.lngDenominator, tblQWDownstream.dLakeRemovalFactor " & _ "FROM (tdsUSEPAParameterCodes INNER JOIN tblQWDownstream ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWDownstream.Parameter_ID) INNER JOIN tasAnalysisDownstreamQW ON " & _ "tblQWDownstream.DownstreamWaterQuality_ID = tasAnalysisDownstreamQW.DownstreamWaterQuality_ID " & _ "WHERE (((tblQWDownstream.bLakeAnalysis)=True) AND ((tasAnalysisDownstreamQW.HighwayAnalysis_ID)=" & lngInputAnalysis & ")) " & _ "ORDER BY tblQWDownstream.DownstreamWaterQuality_ID;" ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset ' Populate Recordset rstMyQWRecordset.Open strConstituentSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 2 GoTo FinalCleanUp: ' End If rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngConstituents = rstMyQWRecordset.RecordCount ReDim lngDownstreamQWIDLake(lngConstituents) As Long ' Input downstream ID ReDim lngNumerator(lngConstituents) As Long ' Water-quality unit information ReDim lngDenominator(lngConstituents) As Long ' Water-quality unit information ReDim dLakeRemovalFactor(lngConstituents) As Double ' Input 1st Order lake removal factor ' per year ReDim bBMPModification(lngConstituents) As Boolean ' Input BMP modification 0 = No -1 = yes intQWErr = 0 rstMyQWRecordset.MoveFirst For lngI = 0 To (lngConstituents - 1) lngDownstreamQWIDLake(lngI) = Nz(rstMyQWRecordset.Fields(0).Value, -9999) bBMPModification(lngI) = Nz(rstMyQWRecordset.Fields(1).Value, False) lngNumerator(lngI) = Nz(rstMyQWRecordset.Fields(2).Value, -9999) lngDenominator(lngI) = Nz(rstMyQWRecordset.Fields(3).Value, -9999) dLakeRemovalFactor(lngI) = Nz(rstMyQWRecordset.Fields(4).Value, -9999#) If lngDownstreamQWIDLake(lngI) = -9999 Or lngNumerator(lngI) = -9999 Or lngDenominator(lngI) = -9999 Or _ dLakeRemovalFactor(lngI) = -9999# Then intQWErr = intQWErr + 1 rstMyQWRecordset.MoveNext Next lngI SecondCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then intProblem = 2 Exit Sub ' End If ' ************************************************************** ' Loop through constituents ' ************************************************************** For lngI = 0 To (lngConstituents - 1) ' ************************************************************** ' Get the lake-basin Loads and Flux ' ************************************************************** strLakeQWSql = "SELECT tblQWDownstream.DownstreamWaterQuality_ID, tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID, " & _ "tblOutputLakeFlux.lngYearNumber, Sum(tadOutputLakeFluxConcentration.dLakeBasinLoad) AS SumOfdLakeBasinLoad, " & _ "Sum(tblOutputLakeFlux.dDailyUpstreamFlow) AS SumOfdDailyUpstreamFlow " & _ "FROM tblOutputLakeFlux INNER JOIN (tblQWDownstream INNER JOIN tadOutputLakeFluxConcentration ON " & _ "tblQWDownstream.UpstreamWaterQuality_ID = tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID) ON " & _ "tblOutputLakeFlux.lngDayNumber = tadOutputLakeFluxConcentration.lngDayNumber " & _ "GROUP BY tblQWDownstream.DownstreamWaterQuality_ID, tadOutputLakeFluxConcentration.UpstreamWaterQuality_ID, " & _ "tblOutputLakeFlux.lngYearNumber " & _ "HAVING (((tblQWDownstream.DownstreamWaterQuality_ID)=" & lngDownstreamQWIDLake(lngI) & ")) " & _ "ORDER BY tblOutputLakeFlux.lngYearNumber;" ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset ' Populate Recordset rstMyQWRecordset.Open strLakeQWSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 3 GoTo FinalCleanUp: ' End If rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngLakeDataCount = rstMyQWRecordset.RecordCount ReDim lngLakeYearNumber(lngLakeDataCount) As Long ReDim dLakeLoadIn(lngLakeDataCount) As Double ' Input Upstream basin load in pounds ReDim dLakeFluxIn(lngLakeDataCount) As Double ' Input Lake-basin flux in cubic feet per year intQWErr = 0 rstMyQWRecordset.MoveFirst For lngJ = 0 To (lngLakeDataCount - 1) lngLakeYearNumber(lngJ) = Nz(rstMyQWRecordset.Fields("lngYearNumber").Value, -9999) dLakeLoadIn(lngJ) = Nz(rstMyQWRecordset.Fields("SumOfdLakeBasinLoad").Value, -9999#) dLakeFluxIn(lngJ) = Nz(rstMyQWRecordset.Fields("SumOfdDailyUpstreamFlow").Value, -9999#) If lngLakeYearNumber(lngI) = -9999 Or dLakeLoadIn(lngI) = -9999# Or dLakeFluxIn(lngI) = -9999# Then intQWErr = intQWErr + 1 rstMyQWRecordset.MoveNext Next lngJ ThirdCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then GoTo SkipMe: End If ' ************************************************************** ' Get the Highway Runoff Loads and Flux ' ************************************************************** strHighwayQWSql = "SELECT tblQWDownstream.DownstreamWaterQuality_ID, tblQWHighway.HighwayWaterQuality_ID, " & _ "tblOutputStormEvent.lngYearNumber, " & _ "Sum(tblOutputHighwayQW.dRunoffLoad) AS SumOfdRunoffLoad, Sum(tblOutputStormEvent.dHighwayRunoff) AS SumOfdHighwayRunoff, " & _ "Sum(tblOutputHighwayQW.dDischargeLoad) AS SumOfdDischargeLoad, Sum(tblOutputStormEvent.dHighwayBMPDischarge) AS SumOfdHighwayBMPDischarge " & _ "FROM ((tblOutputHighwayQW INNER JOIN tblQWHighway ON " & _ "tblOutputHighwayQW.HighwayWaterQuality_ID = tblQWHighway.HighwayWaterQuality_ID) INNER JOIN tblOutputStormEvent ON " & _ "tblOutputHighwayQW.lngStormNumber = tblOutputStormEvent.lngStormNumber) INNER JOIN " & _ "tblQWDownstream ON tblQWHighway.HighwayWaterQuality_ID = tblQWDownstream.HighwayWaterQuality_ID " & _ "GROUP BY tblQWDownstream.DownstreamWaterQuality_ID, tblQWHighway.HighwayWaterQuality_ID, tblOutputStormEvent.lngYearNumber " & _ "HAVING (((tblQWDownstream.DownstreamWaterQuality_ID)=" & lngDownstreamQWIDLake(lngI) & ")) " & _ "ORDER BY tblOutputStormEvent.lngYearNumber;" ' Reference an ADO Recordset Set rstMyQWRecordset = New ADODB.Recordset ' Populate Recordset rstMyQWRecordset.Open strHighwayQWSql, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Check values bHasdata = False If rstMyQWRecordset.BOF And rstMyQWRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMyQWRecordset.Fields(0).Value) = False Then If IsEmpty(rstMyQWRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then ' We have no values intProblem = 3 GoTo FinalCleanUp: ' End If rstMyQWRecordset.MoveFirst rstMyQWRecordset.MoveLast lngHighwayDataCount = rstMyQWRecordset.RecordCount If lngHighwayDataCount <> lngLakeDataCount Then intQWErr = 1 GoTo FourthCleanUp: End If ' Highway Values ReDim lngHwyYearNumber(lngHighwayDataCount) As Long ReDim dRoadLoadIn(lngHighwayDataCount) As Double ReDim dRoadFlowIn(lngHighwayDataCount) As Double ReDim dBMPLoadIn(lngHighwayDataCount) As Double ReDim dBMPFlowIn(lngHighwayDataCount) As Double intQWErr = 0 rstMyQWRecordset.MoveFirst For lngJ = 0 To (lngLakeDataCount - 1) lngHwyYearNumber(lngJ) = Nz(rstMyQWRecordset.Fields("lngYearNumber").Value, -9999) dRoadLoadIn(lngJ) = Nz(rstMyQWRecordset.Fields("SumOfdRunoffLoad").Value, -9999#) dRoadFlowIn(lngJ) = Nz(rstMyQWRecordset.Fields("SumOfdHighwayRunoff").Value, -9999#) dBMPLoadIn(lngJ) = Nz(rstMyQWRecordset.Fields("SumOfdDischargeLoad").Value, -9999#) dBMPFlowIn(lngJ) = Nz(rstMyQWRecordset.Fields("SumOfdHighwayBMPDischarge").Value, -9999#) If bBMPModification(lngI) = True Then If dBMPLoadIn(lngJ) = -9999# Or dBMPFlowIn(lngJ) = -9999# Then intQWErr = intQWErr + 1 Else If dRoadLoadIn(lngJ) = -9999# Or dRoadFlowIn(lngJ) = -9999# Then intQWErr = intQWErr + 1 End If rstMyQWRecordset.MoveNext Next lngJ FourthCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory If intQWErr <> 0 Then GoTo SkipMe: End If ' ************************************************************** ' Calculate and write Lake-Basin Loads, Flux, and Concentrations ' ************************************************************** 'Get load multiplier lngMyNumerator = lngNumerator(lngI) lngMyDenominator = lngDenominator(lngI) dLoadMultiplier = fndLoadMultiplier(lngMyNumerator, lngMyDenominator) Set rstMyQWRecordset = New ADODB.Recordset rstMyQWRecordset.Open "tblOutputLakeAnalysis", CurrentProject.Connection, adOpenKeyset, adLockOptimistic For lngJ = 0 To (lngLakeDataCount - 1) If bBMPModification(lngI) = True Then dLakeLoad = dLakeLoadIn(lngJ) + dBMPLoadIn(lngJ) dLakeFlux = dLakeFluxIn(lngJ) + dBMPFlowIn(lngJ) Else dLakeLoad = dLakeLoadIn(lngJ) + dRoadLoadIn(lngJ) dLakeFlux = dLakeFluxIn(lngJ) + dRoadFlowIn(lngJ) End If ' Calculate detention time dLakeDetentionTime = dLakeVolume / dLakeFlux ' Calculate Raw concentration dLakeConcentration = (dLakeLoad / dLakeFlux) / (1# + dLakeRemovalFactor(lngI) * dLakeDetentionTime) ' Convert units to concentration dLakeConcentration = dLakeConcentration * 1# / dLoadMultiplier If lngMyDenominator = 7 And lngMyNumerator = 11 Then 'pH convert back from grams of H3O' If dLakeConcentration <= 0# Then dLakeConcentration = 1.90233E-13 dLakeConcentration = -1# * (Log(dLakeConcentration / 19.02331) / Log(10#)) End If ' Add new data to table tblOutputLakeAnalysis for existing storms With rstMyQWRecordset .AddNew .Fields("DownstreamWaterQuality_ID") = lngDownstreamQWIDLake(lngI) .Fields("lngYearNumber") = (lngJ + 1) .Fields("dTotalLakeFlux") = dLakeFlux .Fields("dTotalLakeLoad") = dLakeLoad .Fields("dLakeBasinFlux") = dLakeFluxIn(lngJ) .Fields("dLakeBasinLoad") = dLakeLoadIn(lngJ) If bBMPModification(lngI) = True Then .Fields("dHighwayFlux") = dBMPFlowIn(lngJ) .Fields("dHighwayLoad") = dBMPLoadIn(lngJ) Else .Fields("dHighwayFlux") = dRoadFlowIn(lngJ) .Fields("dHighwayLoad") = dRoadLoadIn(lngJ) End If .Fields("dLakeConcentration") = dLakeConcentration .Fields("dLakeDetentionTime") = dLakeDetentionTime .Update End With Next lngJ FifthCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory SkipMe: Next lngI Exit Sub FinalCleanUp: If rstMyQWRecordset.State = adStateOpen Then rstMyQWRecordset.Close 'IF Recordset is open, close it Set rstMyQWRecordset = Nothing 'Free memory Exit Sub GenerateAnnualLakeConcentrations_Err: MsgBox Err.Description, vbCritical, "Generate Lake Concentrations" intProblem = 7 intQWErr = intQWErr + 1 If intQWErr < 2 Then GoTo FinalCleanUp: Exit Sub End Sub Private Sub GetAnnualHighwayLoads(lngMyNumberofYears As Long, intMyPP As Integer, intProblem As Integer) ' Purpose: To getAnnual highway loads and populate table ' History: Version 1.0 Dec 02 2009 by G.E. Granato ' Dim bHasdata As Boolean Dim rstMySQLRecordset As ADODB.Recordset ' recordset Dim rstMyTableRecordset As ADODB.Recordset ' recordset Dim strSQL As String ' Query text Dim intErrCount As Integer Dim dMyHighwayDrainageArea As Double On Error GoTo GetAnnualHighwayLoads_Err: intProblem = 0 intErrCount = 0 ' Get/test Highway Drainage Area dMyHighwayDrainageArea = fndGetDrainageFeature(lMyAnalysis, 0) If dMyHighwayDrainageArea <= 0# Then ' Highway Site Problem intProblem = 1 Exit Sub End If ' Runoff in ft^3 * 1/Highway Acres * 1 Acre/43560 ft^2 * 12"/ft = runoff in watershed inches dMyHighwayDrainageArea = (1# / dMyHighwayDrainageArea) * (12# / 43560#) ' Query to calculate annual values strSQL = "SELECT tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputStormEvent.lngYearNumber, " & _ "tdsUSEPAParameterCodes.lngNumerator, tdsUSEPAParameterCodes.lngDenominator, " & _ "Sum(tblOutputStormEvent.dPrecipitationVolume) AS SumOfdPrecipitationVolume, " & _ "Sum(tblOutputStormEvent.dHighwayRunoff) AS SumOfdHighwayRunoff, Sum(tblOutputHighwayQW.dRunoffLoad) AS SumOfdRunoffLoad, " & _ "Sum(tblOutputStormEvent.dHighwayBMPDischarge) AS SumOfdHighwayBMPDischarge, Sum(tblOutputHighwayQW.dDischargeLoad) AS SumOfdDischargeLoad " & _ "FROM tdsUSEPAParameterCodes INNER JOIN ((tblOutputHighwayQW INNER JOIN tblOutputStormEvent ON " & _ "tblOutputHighwayQW.lngStormNumber = tblOutputStormEvent.lngStormNumber) INNER JOIN tblQWHighway ON " & _ "tblOutputHighwayQW.HighwayWaterQuality_ID = tblQWHighway.HighwayWaterQuality_ID) ON " & _ "tdsUSEPAParameterCodes.Parameter_ID = tblQWHighway.Parameter_ID " & _ "GROUP BY tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputStormEvent.lngYearNumber, " & _ "tdsUSEPAParameterCodes.lngNumerator, tdsUSEPAParameterCodes.lngDenominator " & _ "ORDER BY tblOutputHighwayQW.HighwayWaterQuality_ID, tblOutputStormEvent.lngYearNumber;" ' Open record sets ' Reference ADO Recordsets Set rstMyTableRecordset = New ADODB.Recordset Set rstMySQLRecordset = New ADODB.Recordset 'Populate Recordset rstMyTableRecordset.Open "tblOutputHighwayAnnual", CurrentProject.Connection, adOpenKeyset, adLockOptimistic rstMySQLRecordset.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockReadOnly ' Ensure that rstMySQLRecordset.Open has data ' Check values bHasdata = False If rstMySQLRecordset.BOF And rstMySQLRecordset.EOF Then ' There is no data for this analysis bHasdata = False ElseIf IsNull(rstMySQLRecordset.Fields(0).Value) = False Then If IsEmpty(rstMySQLRecordset.Fields(0).Value) = False Then bHasdata = True ' There is no data for this analysis End If If bHasdata = False Then intProblem = 2 GoTo CleanUp01: ' There is no data for this analysis End If rstMySQLRecordset.MoveFirst Do While Not rstMySQLRecordset.EOF ' Add new data to table tblOutputHighwayAnnual With rstMyTableRecordset .AddNew .Fields("HighwayWaterQuality_ID") = Nz(rstMySQLRecordset.Fields("HighwayWaterQuality_ID").Value, 0) .Fields("lngYearNumber") = Nz(rstMySQLRecordset.Fields("lngYearNumber").Value, 0) .Fields("lngNumerator") = Nz(rstMySQLRecordset.Fields("lngNumerator").Value, 1) .Fields("lngDenominator") = Nz(rstMySQLRecordset.Fields("lngDenominator").Value, 1) .Fields("dAnnualPrecipitation") = Nz(rstMySQLRecordset.Fields("SumOfdPrecipitationVolume").Value, 0#) .Fields("dHighwayFlux") = Nz(rstMySQLRecordset.Fields("SumOfdHighwayRunoff").Value, 0#) .Fields("dHighwayFluxWI") = (Nz(rstMySQLRecordset.Fields("SumOfdHighwayRunoff").Value, 0#)) * dMyHighwayDrainageArea .Fields("dHighwayLoad") = Nz(rstMySQLRecordset.Fields("SumOfdRunoffLoad").Value, 0#) .Fields("dHighwayDischargeFlux") = Nz(rstMySQLRecordset.Fields("SumOfdHighwayBMPDischarge").Value, 0#) .Fields("dHighwayDischargeFluxWI") = (Nz(rstMySQLRecordset.Fields("SumOfdHighwayBMPDischarge").Value, 0#)) * dMyHighwayDrainageArea .Fields("dHighwayDischargeLoad") = Nz(rstMySQLRecordset.Fields("SumOfdDischargeLoad").Value, 0#) .Update End With rstMySQLRecordset.MoveNext Loop CleanUp01: If rstMyTableRecordset.State = adStateOpen Then rstMyTableRecordset.Close 'IF Recordset is open, close it Set rstMyTableRecordset = Nothing 'Free memory CleanUp02: If rstMySQLRecordset.State = adStateOpen Then rstMySQLRecordset.Close 'IF Recordset is open, close it Set rstMySQLRecordset = Nothing 'Free memory ' Get Annual plotting positions Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dAnnualPrecipitation", "dAnnualPrecipitationPP", "tblOutputHighwayAnnual", _ lngMyNumberofYears, intMyPP, True, False) Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dHighwayFlux", "dHighwayFluxPP", "tblOutputHighwayAnnual", lngMyNumberofYears, intMyPP, True, False) Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dHighwayLoad", "dHighwayLoadPP", "tblOutputHighwayAnnual", lngMyNumberofYears, intMyPP, True, False) Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dHighwayDischargeFlux", "dHighwayDischargeFluxPP", "tblOutputHighwayAnnual", _ lngMyNumberofYears, intMyPP, True, False) Call SetQWPlottingPosition("HighwayWaterQuality_ID", "dHighwayDischargeLoad", "dHighwayDischargeLoadPP", "tblOutputHighwayAnnual", _ lngMyNumberofYears, intMyPP, True, False) Exit Sub GetAnnualHighwayLoads_Err: GetStormFlows_Err: intErrCount = intErrCount + 1 If intErrCount = 1 Then GoTo CleanUp01: If intErrCount < 3 Then GoTo CleanUp02: Exit Sub End Sub