libspcal.bas

本系统是给大庆油田做的一个示例程序

Attribute VB_Name = "LibSpCal"

Option Explicit
Rem 推算气油比
Sub Sp_Cal(Pb_Well As Single, SprPump As Single, ps As Single, pd As Single, S0 As Single, _
           nw As Single, SCrudeOil As Single, TWell As Single, SPumpSuction As Single, _
           SPumpDischarge As Single, Sp_Calculation As Single)
    Dim Xstart As Single, Xend As Single, Deta As Single, Eps As Single, Rootx As Single
    Dim sp_min As Single
    
    Xstart = 1#
    Xend = 2000
    Deta = 0.01
    Eps = 0.1
    Call Root_Sp_Cal(Pb_Well, SprPump, ps, pd, S0, nw, SCrudeOil, TWell, SPumpSuction, _
                      SPumpDischarge, Xstart, Xend, Deta, Eps, Rootx)
    Sp_Calculation = Rootx
End Sub
Sub Root_Sp_Cal(Pb_Well As Single, SprPump As Single, ps As Single, pd As Single, S0 As Single, _
                nw As Single, SCrudeOil As Single, TWell As Single, SPumpSuction As Single, SPumpDischarge As Single, _
                Xstart As Single, Xend As Single, Deta As Single, Eps As Single, Rootx As Single)
    
    Dim XX As Single
    Dim X1 As Single, X2 As Single, F1 As Single, F2 As Single
    Dim X0 As Single, f0 As Single
    Dim ITimes As Single
    
    X1 = Xstart
    Call Func_Sp_Cal(Pb_Well, SprPump, ps, pd, S0, nw, SCrudeOil, TWell, SPumpSuction, SPumpDischarge, X1, F1)
    
    X2 = Xend
    Call Func_Sp_Cal(Pb_Well, SprPump, ps, pd, S0, nw, SCrudeOil, TWell, SPumpSuction, SPumpDischarge, X2, F2)
       
    If F1 * F2 >= 0 Then
        Rootx = 0
        Exit Sub
    End If
    
    ITimes = 0
    Do
        ITimes = ITimes + 1
        
        If Abs(F1) <= Eps Then
            Rootx = X1
            Exit Sub
        End If
        
        If Abs(F2) <= Eps Then
            Rootx = X2
            Exit Sub
        End If
        
        If ITimes = 3000 Then
            Rootx = X0
            Exit Sub
        End If
        
        X0 = (X1 + X2) / 2
        Call Func_Sp_Cal(Pb_Well, SprPump, ps, pd, S0, nw, SCrudeOil, TWell, SPumpSuction, SPumpDischarge, X0, f0)
            
        If Abs(X0 - X2) <= Deta Or Abs(f0) <= Eps Then
            Rootx = X0
            Exit Do
        ElseIf F1 * f0 > 0 Then
            F1 = f0
            X1 = X0
        ElseIf F1 * F2 < 0 Then
            X2 = X0
            F2 = f0
        End If
    Loop
End Sub

Sub Func_Sp_Cal(Pb_Well As Single, SprPump As Single, ps As Single, pd As Single, S0 As Single, _
                nw As Single, SCrudeOil As Single, TWell As Single, _
                SPumpSuction As Single, SPumpDischarge As Single, XX As Single, Fx As Single)
    
    Dim SpX As Single
    Dim LoPs As Single, LoPd As Single
    Dim S00 As Single
    
    SpX = XX
    Call Lopt_Cal(Pb_Well, ps, TWell, nw, SpX, SCrudeOil, LoPs)
    Call Lopt_Cal(Pb_Well, pd, TWell, nw, SpX, SCrudeOil, LoPd)
    
     Fx = LoPs * (S0 + SprPump) - LoPd * (S0 + SprPump * SPumpDischarge)
    'Fx = LoPd * S0 - LoPs * (S0 + SprPump * (1 - SPumpSuction))
End Sub