Attribute VB_Name = "Hi_Precision_Math_Module"
Option Explicit
' Higher Precision Advanced Math Functions for Special Applications
' Author: Jay Tanner
'
' For MS Visual BASIC v5/6
'
' Any bugs or suggestions
' E-Mail:
' Jay@NeoProgrammics.com
'
' ====================================================================
' These functions use the 29 digit precision decimal data type.
'
' Potential accuracy: Up to ± 0.000000000000000000000000001
' The potential accuracy may sometimes be a tiny bit less
' due to the inexact nature of trancendental functions and the
' internal rounding errors inherent in digital computations.
'
' -----------------------------------------------------------
' The higher precision functions in this implementation are:
'
' Sine(x) - Circular sine for degree arguments
' Cosine(x) - Circular cosine for degree arguments
' Tangent(x) - Circular tangent for degree arguments
'
' ExpF(x) - Natural exponential function
' LogE(x) - Natural logarithm function
' Log10(x) - Base 10 logarithm function
' AntiLog - Base 10 antilog function
' Sinh(x) - Hyperbolic sine function
' Cosh(x) - Hyperbolic cosine function
' Tanh(x) - Hyperbolic tangent function
' ArcSinh(x) - Hyperbolic arc sine function
' ArcCosh(x) - Hyperbolic arc cosine function
' ArcTanh(x) - Hyperbolic arc tangent function
'
' Square_Root(x) - High precision square root function
' Cube_Root(x) - High precision cube root function
'
' ====================================================================
' High precision square root function
'
' Valid (X) argument range: > 0
'
' If an error is detected, then an empty result is returned.
'
Public Function Square_Root(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim A As Variant ' Current approximation
Dim B As Variant ' Previous approximation
Dim k As Integer ' Safety counter to prevent infinite loop
k = 0
' Read input argument
X = Trim(X_Arg): If X = "" Or X = "-" Then X = 0
' Return empty string if non-numeric argument.
If Not IsNumeric(X) Then Square_Root = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Return zero if X = 0
If X = 0 Then Square_Root = 0: Exit Function
' Return empty string if negative argument.
If X < 0 Then Square_Root = "": Exit Function
' Initialize loop variables
A = Sqr(X) ' 1st approximation = Normal VB Sqr(x) function
A = CDec(A)
B = CDec(1)
ITERATE:
B = (A + X / A) / 2 ' Compute next approx (B) from (A)
' Check if finished
If (B = A) Or (k >= 20) Then Square_Root = B: Exit Function
' Update approximation and iteration loop counter
A = B
k = k + 1
GoTo ITERATE
Exit Function
ERROR_HANDLER:
Square_Root = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision cube root function
'
' Valid (X) argument range: ± X
'
' If an error is detected, then an empty result is returned.
'
Public Function Cube_Root(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim A As Variant ' Current approximation
Dim B As Variant ' Previous approximation
Dim NegFlag As Boolean ' Negative argument flag
Dim k As Integer ' Safety counter to prevent infinite loop
k = 0
' Read input argument
X = Trim(X_Arg): If X = "" Or X = "-" Then X = 0
' Return empty string if non-numeric argument.
If Not IsNumeric(X) Then Cube_Root = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Return zero if X = 0
If X = 0 Then Cube_Root = 0: Exit Function
' Account for negative argument, if indicated.
If X < 0 Then
NegFlag = True
X = Abs(X)
Else
NegFlag = False
End If
' Initialize loop variables
A = X ^ (1 / 3) ' 1st approximation = Normal VB X^(1/3) function
A = CDec(A)
B = CDec(1)
ITERATE:
B = ((2 * A) + X / (A * A)) / 3 ' Compute next approx (B) from (A)
' Check if finished
If (B = A) Or (k >= 20) Then
If NegFlag = True Then B = -B
Cube_Root = B
Exit Function
End If
' Update approximation and iteration loop counter
A = B
k = k + 1
GoTo ITERATE
Exit Function
ERROR_HANDLER:
Cube_Root = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision exponential function
'
' Valid (X) argument range: 0 to ±65
'
' If an error is detected, then an empty result is returned.
'
Public Function ExpF(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim FactX As Variant ' Factorial seed
Dim Term As Variant ' Current series term value
Dim PwrX As Variant ' Power of X
Dim S As Variant ' Series summation accumulator
Dim NegFlag As Boolean ' Negative argument flag
' Error tolerance limit for series
Dim ET As Variant
ET = 1E-29
' 65.37052415368304665919611913
' Read input argument
X = Trim(X_Arg): If X = "" Then X = 0
' Return empty string for non-numeric argument or if numeric
' argument is not in the valid range.
If Not IsNumeric(X) Then ExpF = "": Exit Function
If Abs(X) > CDec("65.37052415368304665919611913") Then
ExpF = ""
Exit Function
End If
If X < 0 Then NegFlag = True Else NegFlag = False
X = CDec(X)
X = Abs(X)
' Initialize series variables
FactX = CDec(1)
PwrX = X
Term = CDec(1)
S = CDec(0)
' Exponential series summation loop
While Term > ET
Term = Term * X / FactX
S = S + Term
FactX = FactX + 1
Wend
' Add 1 to summation result to finish
S = 1 + S
' Return exponential function value of series
If NegFlag = True Then ExpF = 1 / S Else ExpF = S
Exit Function
ERROR_HANDLER:
ExpF = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision natural logarithm function.
'
' This is a core routine used by the Ln(x) and Log10(x) functions.
' The Ln(x) function computes Log10(x) and converts it into the
' natural logarithm equivalent to speed up the computation process,
' especially for larger arguments.
'
' Valid argument range: X > 0
'
' If an error is detected, then an empty result is returned.
'
Public Function LogE(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim FactX As Variant ' Factorial seed value
Dim Term As Variant ' Value of current series term
Dim PwrX As Variant ' Power of X argument
Dim S As Variant ' Series summation accumulator
Dim W As Variant ' Temp work
Dim FracFlag As Boolean ' Flag for fractional value (0 < X < 1)
' Error tolerance limit for series
Dim ET As Variant
ET = 1E-29
' Read input argument
X = Trim(X_Arg)
' Return empty string if non-numeric argument.
If X = "" Or X = "-" Then LogE = "": Exit Function
If Not IsNumeric(X) Then LogE = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Return empty string if negative or zero argument.
If X <= 0 Then LogE = "": Exit Function
' Return zero if X = 1
If X = 1 Then LogE = 0: Exit Function
' Account for fractional X (0 < X < 1), if indicated.
If X < 1 Then
FracFlag = True
X = 1 / X
Else
FracFlag = False
End If
' Initialize series variables
FactX = CDec(1)
Term = CDec(1)
PwrX = CDec(1)
S = CDec(0)
W = (X - 1) / X
' Natural logarithm series summation loop
While Abs(Term) > ET
Term = PwrX * W / FactX
S = S + Term
PwrX = PwrX * W
FactX = FactX + 1
Wend
' Account for fractional X value, if indicated.
If FracFlag = True Then S = -S
' Return computed LogE(X) value
LogE = S
Exit Function
ERROR_HANDLER:
LogE = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision hyperbolic sine function
'
' Valid (X) argument range: 0 to ±65
'
' If an error is detected, then an empty result is returned.
'
Public Function Sinh(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
Dim NegFlag As Boolean ' Negative argument flag
' Read input argument
X = Trim(X_Arg): If X = "" Then X = 0
' Return empty string if non-numeric argument
If Not IsNumeric(X) Then Sinh = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Check sign of argument
If X < 0 Then NegFlag = True Else NegFlag = False
X = Abs(X)
' Return empty string if numeric argument outside valid range
If Abs(X) > CDec("65.37052415368304665919611913") Then
Sinh = ""
Exit Function
End If
' Call high-precision exponential function as first step
W = ExpF(X)
' Return empty string if error detected
If Not IsNumeric(W) Then Sinh = "": Exit Function
' Complete the Sinh(X) computation
W = (W - (1 / W)) / 2
' Account for sign
If NegFlag = True Then W = -W
' Return the Sinh(X) value
Sinh = W
Exit Function
ERROR_HANDLER:
Sinh = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision hyperbolic cosine function
'
' Valid (X) argument range: 0 to ±65
'
' If an error is detected, then an empty result is returned.
'
Public Function Cosh(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
' Read input argument
X = Trim(X_Arg): If X = "" Then X = 0
X = Abs(CDec(X))
' Return empty string for non-numeric argument or if numeric
' argument is not in the valid range.
If Not IsNumeric(X) Then Cosh = "": Exit Function
If Abs(X) > CDec("65.37052415368304665919611913") Then
Cosh = ""
Exit Function
End If
' Call exponential function as first step
W = ExpF(X)
' Return an empty string if error detected
If Not IsNumeric(W) Then Cosh = "": Exit Function
' Return the computed cosh(x) value
Cosh = (W + (1 / W)) / 2
Exit Function
ERROR_HANDLER:
Cosh = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision hyperbolic tangent function. This function calls
' the Sinh() and Cosh() functions.
'
' Valid (X) argument range: 0 to ±65
'
' If an error is detected, then an empty result is returned.
'
Public Function Tanh(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
' Read input argument
X = Trim(X_Arg): If X = "" Then X = 0
' Return empty string for non-numeric argument.
If Not IsNumeric(X) Then Tanh = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Return empty string if numeric argument out of valid range.
If Abs(X) > CDec("65.37052415368304665919611913") Then
Tanh = ""
Exit Function
End If
' Return computed Tanh(x) value.
Tanh = Sinh(X) / Cosh(X)
Exit Function
ERROR_HANDLER:
Tanh = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision inverse hyperbolic sine function
'
' Valid (X) argument range: ± X
'
' If an error is detected, then an empty result is returned.
'
Public Function ArcSinh(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
' Read input argument
X = Trim(X_Arg): If X = "" Or X = "-" Then X = 0
' Return empty string if non-numeric argument.
If Not IsNumeric(X) Then ArcSinh = "": Exit Function
' Convert argument to decimal data type.
X = CDec(X)
' Compute the ArcSinh(x) value
W = X + Square_Root(X * X + 1)
W = Ln(W)
' Return empty string if error detected.
If Not IsNumeric(W) Then ArcSinh = "": Exit Function
' Return computed ArcSinh value
ArcSinh = W
Exit Function
ERROR_HANDLER:
ArcSinh = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision inverse hyperbolic cosine function
'
' Valid (X) argument range: X >= 1
'
' If an error is detected, then an empty result is returned.
'
Public Function ArcCosh(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
' Read input argument
X = Trim(X_Arg): If X = "" Or X = "-" Then X = 0
' Return empty string if non-numeric argument.
If Not IsNumeric(X) Then ArcCosh = "": Exit Function
' Convert argument to decimal data type.
X = CDec(X)
' Return empty string if numeric argument is not in the valid range.
If X < 1 Then ArcCosh = "": Exit Function
' Compute the ArcCosh(x) value
W = X + Square_Root(X * X - 1)
W = Ln(W)
' Return empty string if error detected.
If Not IsNumeric(W) Then ArcCosh = "": Exit Function
' Return computed ArcSinh value
ArcCosh = W
Exit Function
ERROR_HANDLER:
ArcCosh = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision inverse hyperbolic tangent function
'
' Valid (X) argument range: -1 < X < +1
'
' If an error is detected, then an empty result is returned.
'
Public Function ArcTanh(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
Dim SignFlag As Boolean ' Negative argument flag
' Read input argument
X = Trim(X_Arg): If X = "" Or X = "-" Then X = 0
' Return empty string if non-numeric argument.
If Not IsNumeric(X) Then ArcTanh = "": Exit Function
' Convert argument to decimal data type.
X = CDec(X)
' Account for sign of argument
If X < 0 Then SignFlag = True Else SignFlag = False
X = Abs(X)
' Return empty string if numeric argument is not in the valid range.
If Abs(X) >= 1 Then ArcTanh = "": Exit Function
' Compute the ArcTanh(x) value
W = (1 + X) / (1 - X)
W = Ln(W)
' Return empty string if error detected.
If Not IsNumeric(W) Then ArcTanh = "": Exit Function
' Compute ArcTanh(x) value
W = W / 2
' Account for sign
If SignFlag = True Then W = -W
' Return computed ArcSinh value
ArcTanh = W
Exit Function
ERROR_HANDLER:
ArcTanh = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision circular sine function for degree arguments
Public Function Sine(Deg_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim FactX As Variant ' Factorial seed value
Dim Term As Variant ' Value of current series term
Dim PwrX As Variant ' Power of X argument
Dim S As Variant ' Series summation accumulator
Dim W As Variant ' Temp work
Dim NegFlag As Boolean ' Flag for negative argument
Dim i As Variant ' Sign control
i = -1
Dim Pi As Variant ' Value of Pi constant
Pi = CDec("3.14159265358979323846264338327950288")
' Error tolerance limit for series
Dim ET As Variant
ET = 1E-29
' Read input argument
X = Trim(Deg_Arg)
' Return empty string if non-numeric argument.
If X = "" Or X = "-" Then Sine = "": Exit Function
If Not IsNumeric(X) Then Sine = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Account for sign
If X < 0 Then NegFlag = True Else NegFlag = False
X = Abs(X)
' If >= 360 degrees, then subtract 360
If X >= 360 Then X = X - 360
' Account for special exact values.
If X = 0 Then Sine = 0: Exit Function
If X = 90 Then Sine = 1: Exit Function
If X = 180 Then Sine = 0: Exit Function
If X = 270 Then Sine = -1: Exit Function
' Convert X degrees to radians
X = X * Pi / 180
' Initialize series variables
FactX = CDec(3)
Term = CDec(X)
S = X
' Circular sine series summation loop
While Abs(Term) > ET
Term = Term * X / FactX * X / (FactX - 1)
S = S + Term * i
FactX = FactX + 2
i = -i
Wend
' Account for sign, as indicated.
If NegFlag = True Then S = -S
' Return computed Sine(X) value
Sine = S
Exit Function
ERROR_HANDLER:
Sine = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision circular cosine function for degree arguments
Public Function Cosine(Deg_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim FactX As Variant ' Factorial seed value
Dim Term As Variant ' Value of current series term
Dim PwrX As Variant ' Power of X argument
Dim S As Variant ' Series summation accumulator
Dim W As Variant ' Temp work
Dim NegFlag As Boolean ' Flag for negative argument
Dim i As Variant ' Sign control
i = -1
Dim Pi As Variant ' Value of Pi constant
Pi = CDec("3.14159265358979323846264338327950288")
' Error tolerance limit for series
Dim ET As Variant
ET = 1E-29
' Read input argument
X = Trim(Deg_Arg)
' Return empty string if non-numeric argument.
If X = "" Or X = "-" Then Cosine = "": Exit Function
If Not IsNumeric(X) Then Cosine = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
X = Abs(X)
' If x >= 360 degrees, then subtract 360
If X >= 360 Then X = X - 360
' Account for special exact values.
If X = 0 Then Cosine = 1: Exit Function
If X = 90 Or X = 270 Then Cosine = 0: Exit Function
If X = 180 Then Cosine = -1: Exit Function
' Convert X degrees to radians
X = X * Pi / 180
' Initialize series variables
FactX = CDec(2)
Term = CDec(1)
S = 1
' Circular cosine series summation loop
While Abs(Term) > ET
Term = Term * X / FactX * X / (FactX - 1)
S = S + Term * i
FactX = FactX + 2
i = -i
Wend
' Return computed Cosine(X) value
Cosine = S
Exit Function
ERROR_HANDLER:
Cosine = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision circular Tangent(x) function for degree arguments.
' This function calls the Sine() and Cosine() functions.
Public Function Tangent(X_Arg)
On Error GoTo ERROR_HANDLER
Dim V As Variant ' Temp work
Dim W As Variant ' Temp work
Dim X As Variant ' The input argument
X = Trim(X_Arg)
' Return empty string if non-numeric argument.
If X = "" Or X = "-" Then Tangent = "": Exit Function
If Not IsNumeric(X) Then Tangent = "": Exit Function
' Return empty string if error detected
V = Sine(X)
W = Cosine(X)
If V = "" Or W = "" Then Tangent = "": Exit Function
' Return empty string if infinite result
If W = 0 Then Tangent = "": Exit Function
' Return computed Tangent(x) value
Tangent = V / W
Exit Function
ERROR_HANDLER:
Tangent = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ====================================================================
' High precision base 10 logarithm function
' If an error is detected, then an empty string is returned.
Public Function Log10(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
Dim Ip As Variant ' Integer part of X argument
Dim Dp As Variant ' Decimal part of X argument
Dim LowFlag As Boolean ' Special low value flag for X < 1
Dim V As Variant ' Natural logarithm of 10
V = CDec("2.30258509299404568401799145468")
' Read the input argument
X = Trim(X_Arg)
' Return empty result if non-numeric argument
If X = "" Or X = "-" Then Log10 = "": Exit Function
If Not IsNumeric(X) Then Log10 = "": Exit Function
X = CDec(X)
' Account for special case where 0 < X < 1
If X > 0 And X < 1 Then LowFlag = True: X = 1 / X
Ip = 0
' For large numbers, split X argument into integer and fractional
' parts. This algorithm was included to speed up the process based
' on the rules of base 10 logarithms. Without this adjustment, the
' computation of logarithms of large numbers would take much longer.
If X >= 10 Then
If Right(X, 1) = "." Then X = X & "0"
W = InStr(X, ".")
If W = 0 Then X = X & ".0"
W = InStr(X, ".")
Ip = Left(X, W - 1)
Dp = Mid(X, W + 1, Len(X))
X = Left(Ip, 1) & "." & Mid(Ip, 2, Len(Ip)) & Dp
Ip = CDec(Len(Ip)) - 1
End If
' Compute the natural logarithm of the X argument
W = LogE(X): If W = "" Then Log10 = "": Exit Function
' Compute Log10(x) value
W = Ip + (W / V)
If LowFlag = True Then W = -W
' Return computed Log10(x) value
Log10 = W
Exit Function
ERROR_HANDLER:
Log10 = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function
' ==============================================================================
' Base 10 antilog function. This function is the opposite of the
' base 10 logarithm function.
Public Function AntiLog(X_Arg)
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
Dim V As Variant ' Natural logarithm of 10
V = CDec("2.30258509299404568401799145468")
' Read input argument
X = Trim(X_Arg)
' Return empty result if non-numeric argument
If X = "" Or X = "-" Then AntiLog = "": Exit Function
If Not IsNumeric(X) Then AntiLog = "": Exit Function
' Convert argument to decimal data type
X = CDec(X)
' Handle special case of integer arguments from ±1 to ±28
If Right(X, 1) = "." Then X = Left(X, Len(X) - 1)
If InStr(X, ".") = 0 And Abs(X) < 29 Then
W = 1 & String(Abs(X), "0")
If X < 0 Then AntiLog = 1 / W Else AntiLog = W
Exit Function
End If
' Compute antilog value
W = ExpF(X * V)
' Return empty result if error detected.
If W = "" Then AntiLog = "": Exit Function
' Return computed antilog value
AntiLog = W
End Function
' ====================================================================
' Natural logarithm function shell for the LogE(x) function.
'
' This function computes the base 10 logarithm to speed up the process
' of computing the natural logarithms of larger arguments. It first
' computes the base 10 value and then converts it into the natural
' logarithm equivalent by multiplying by a conversion constant which
' is simply the natural logarithm of 10.
'
' If an error is detected, then an empty result is returned.
Public Function Ln(X_Arg)
On Error GoTo ERROR_HANDLER
Dim X As Variant ' The input argument
Dim W As Variant ' Temp work
Dim Ip As Variant ' Integer part of X argument
Dim Dp As Variant ' Decimal part of X argument
Dim LowFlag As Boolean ' Low value flag for arguments < 1
Dim V As Variant ' Natural logarithm of 10
V = CDec("2.30258509299404568401799145468")
' Read the input argument
X = Trim(X_Arg)
' Return empty result if non-numeric argument
If X = "" Or X = "-" Then Ln = "": Exit Function
If Not IsNumeric(X) Then Ln = "": Exit Function
X = CDec(X)
' Account for special case where 0 < X < 1
If X > 0 And X < 1 Then LowFlag = True: X = 1 / X
Ip = 0
' For large numbers, split X argument into integer and fractional
' parts. This algorithm was included to speed up the process based
' on the rules of base 10 logarithms. Without this adjustment, the
' computation of logarithms of large numbers would take much longer.
If X >= 10 Then
If Right(X, 1) = "." Then X = X & "0"
W = InStr(X, ".")
If W = 0 Then X = X & ".0"
W = InStr(X, ".")
Ip = Left(X, W - 1)
Dp = Mid(X, W + 1, Len(X))
X = Left(Ip, 1) & "." & Mid(Ip, 2, Len(Ip)) & Dp
Ip = CDec(Len(Ip)) - 1
End If
' Compute the natural logarithm of the X argument
W = LogE(X): If W = "" Then Ln = "": Exit Function
' Compute natural logarithm value
W = Ip * V + W
' Return computed LogE(x) value
If LowFlag = True Then W = -W
Ln = W
Exit Function
ERROR_HANDLER:
Ln = ""
MsgBox Error$, vbCritical, " PROGRAM ERROR"
End Function