Integration and Differentiation
Jay Petrulis
Posted below are two functions. One finds the derivative of a
function and the other finds the definite integral of a function.
The interesting part is that the functions can be called from a
worksheet cell almost exactly as one would write them normally. For
instance, any of the following are valid if placed in a cell:
1/x, x^(x^x), sin(x)-(x^3), exp(3*x^2), etc.
The clever bit was posted a long time ago by Alan Linton, in a reply
to a NG question and subsequent discussion with Laurent Longre, Dave
Braden and Dana DeLouis. It was a really nice job. Kudos to Alan!
All I did was use Alan's idea and then 'undo' certain changes he makes
initially.
The derivative function uses Richardson extrapolation for accuracy. I
have commented out but still shown other methods which may be of use.
The integration function requires the user to specify the type of
integration method desired, Midpoint, Simpson's, Trapezium, plus two
volume methods -- rotation about x-axis and y-axis.
Below the code are requests for assistance.
---begin VBA---
Option Explicit
Dim x As Double
Function IntegrateX(func As String, a As Double, b As Double, rule As
String) as Double
Dim i As Long, temp As Long
Dim n As Double, delta As Double, CumulativeArea As Double, xpt As
Double
Dim FunctionVal() As Variant
'change the x variable to xval(), so that VBA can work with the string
'then change the function calls with an x in them back to the original
state
' all adjustments work on 1 function, except for:
' (1) --> exp, index, complex, bin2hex, hex... functions
' (2) --> sumx2my2, sumx2py2, sumxmy2
' (3) --> max and dmax
' Need to pull this out of each function
With Application.WorksheetFunction
func = .Substitute(LCase(func), "x", "xval()")
func = .Substitute(LCase(func), "exval()", "ex") '(1)
func = .Substitute(LCase(func), "xval()irr", "xirr")
func = .Substitute(LCase(func), "xval()npv", "xnpv")
func = .Substitute(LCase(func), "sumxval()", "sumx") '(2)
func = .Substitute(LCase(func), "maxval()", "max") '(3)
func = .Substitute(LCase(func), "steyxval()", "steyx")
End With
'ensure that a,b are in the right order. Could use max, min
If a > b Then
temp = a
a = b
b = temp
End If
'arbitrary number of sections to divide area
'even number of sections so Simpson's rule works correctly
n = WorksheetFunction.Max(Int(b - a) * 200, 1000)
delta = (b - a) / n
ReDim FunctionVal(0 To n)
Select Case UCase(Left(rule, 1))
' Volume of solid of revolution
' integration after rotating about the x-axis
Case Is = "X"
For i = 0 To n
xpt = a + i * delta
FunctionVal(i) = (eval(func, xpt) ^ 2) * delta
CumulativeArea = CumulativeArea + FunctionVal(i)
Next i
IntegrateX = CumulativeArea * WorksheetFunction.Pi
'Y-axis
'volume of solid of revolution using
'cylindrical shells method
Case Is = "Y"
For i = 0 To n
xpt = a + i * delta
FunctionVal(i) = Abs(eval(func, xpt) * xpt * delta)
CumulativeArea = CumulativeArea + FunctionVal(i)
Next i
IntegrateX = CumulativeArea * 2 * WorksheetFunction.Pi
'Integration using Simpson's Rule
Case Is = "S"
For i = 0 To n
xpt = a + i * delta
If (i = 0 Or i = n) Then
FunctionVal(i) = Abs(eval(func, xpt))
ElseIf i Mod 2 = 0 Then
FunctionVal(i) = 2 * Abs(eval(func, xpt))
Else
FunctionVal(i) = 4 * Abs(eval(func, xpt))
End If
CumulativeArea = CumulativeArea + FunctionVal(i)
Next i
IntegrateX = (delta / 3) * CumulativeArea
'Integration using the Trapezoid Rule
Case Is = "T"
For i = 0 To n
xpt = a + i * delta
If (i = 0 Or i = n) Then
FunctionVal(i) = Abs(eval(func, xpt))
Else
FunctionVal(i) = 2 * Abs(eval(func, xpt))
End If
CumulativeArea = CumulativeArea + FunctionVal(i)
Next i
IntegrateX = (delta / 2) * CumulativeArea
'Integration using the Midpoint Rule
Case Is = "M"
For i = 0 To (n - 1)
xpt = ((a + i * delta) + (a + (i + 1) * delta)) / 2
FunctionVal(i) = Abs(eval(func, xpt))
CumulativeArea = CumulativeArea + FunctionVal(i)
Next i
IntegrateX = delta * CumulativeArea
Case Else
IntegrateX = CVErr(xlErrValue)
End Select
End Function
---------------------------
Function DerivativeX(func As String, a As Double) as Double
Const h = 0.0001
Dim n1 As Double, n2 As Double
With Application.WorksheetFunction
func = .Substitute(LCase(func), "x", "xval()")
func = .Substitute(LCase(func), "exval()", "ex")
func = .Substitute(LCase(func), "xval()irr", "xirr")
func = .Substitute(LCase(func), "xval()npv", "xnpv")
func = .Substitute(LCase(func), "sumxval()", "sumx")
func = .Substitute(LCase(func), "maxval()", "max")
func = .Substitute(LCase(func), "steyxval()", "steyx")
End With
'Select Case UCase(Left(rule, 1))
'Case Is = "F" ' Forward differentiation
' DerivativeX = (eval(func, a + h) - eval(func, a)) / h
'Case Is = "B" ' Backward differentiation
' DerivativeX = (eval(func, a) - eval(func, a - h)) / h
'Case Is = "C" ' Central differentiation
' DerivativeX = (eval(func, a + h) - eval(func, a - h)) / (2 * h)
'Case Is = "R" ' Richardson extrapolation method
' n1 = (eval(func, a + (h / 2)) - eval(func, a - (h / 2))) / h
' n2 = (eval(func, a + h) - eval(func, a - h)) / (2 * h)
' DerivativeX = (4 * n1 - n2) / 3
'Case Else
' DerivativeX = CVErr(xlErrValue)
'End Select
n1 = (eval(func, a + (h / 2)) - eval(func, a - (h / 2))) / h
n2 = (eval(func, a + h) - eval(func, a - h)) / (2 * h)
DerivativeX = (4 * n1 - n2) / 3
End Function
------------------------
Function eval(funct As String, xx As Double) As Double
x = xx
eval = Evaluate(funct)
End Function
------------------------
Function xval()
xval = x
End Function
---end VBA---
Example =INTEGRATEX("1/x",1,2,"S") = 0.69147... = equals LN(2).
Both read 'func' as a string, replace all 'x' with 'xval()' and then
redo the 'x' that were incorrectly changed.
Questions:
1. Can anybody help speed these, without sacrificing accuracy?
2. Can you suggest a way to pull out the string manipulation and
insert it into a new function? Then I would not repeat it within each
procedure. Somehow I cannot get it to read/pass the func string
between function calls.
3. Can anybody suggest good ways to handle asymptotes, undefined
values, infinity parameters? All I get are errors (not good!).
Sliding the value a bit may work, but that requires a check at each
point. ????
4. If Dave Braden is reading this, can you please show me how to get
K. Syring's Romberg integration routine to allow for these calls? I
am trying to understand his code, but I don't know enough about
Romberg integration to understand what is happening.
5. Functions x = f(y) can be easily handled, although there will be a
lot more yval() adjustments needed, but how about multiple integration
(XY, X1.X2.X3...,XYZ, etc.)? I am at a loss right now? Any clues?
6. Haven't looked, but if the volume options are chosen, rotation
about anything other than the axes (e.g X=2). Possible? Seems to me
just a translation problem, but any words of caution?
Sorry about the length! Any ideas to some or all of the questions
greatly appreciated.
Thanks in advance,
Jay
Nico Sterk
Although I have a background in Physics I am not an expert in Numerical
Math. Question #2 seems to be easy to solve. I might be mistaken or naive
but at my system (Excel 2000) it runs fine. Replace the string manipulation
by the function call
func = Subst(func) and write Function Subst(func As String) As String
When I have time I will look at your other questions in closer detail.
Yours, Nico Sterk.
*** Begin function ***
Function Subst(func As String) As String
With Application.WorksheetFunction
func = .Substitute(LCase(func), "x", "xval()")
func = .Substitute(LCase(func), "exval()", "ex") '(1)
func = .Substitute(LCase(func), "xval()irr", "xirr")
func = .Substitute(LCase(func), "xval()npv", "xnpv")
func = .Substitute(LCase(func), "sumxval()", "sumx") '(2)
func = .Substitute(LCase(func), "maxval()", "max") '(3)
func = .Substitute(LCase(func), "steyxval()", "steyx")
End With
Subst = func
End Function
*** End function ***
"Jay Petrulis" <john.p...@notes.ntrs.com> wrote in message
news:f7ad450.01102...@posting.google.com...
Alexander Chacin
I have been working about this matter for some time and I use That:
1. Gauss's Quadrature:
Public Function Integral_Gauss_Legendre(Funcion As String, Limite_Inferior
As Double, Limite_Superior As Double, Optional Variable As String = "x") As
Double
Dim Contador As Integer
Dim Inicio As Double
Dim Final As Double
Dim Xd As Double
Dim dx As Double
Dim Valor As Double
Dim Suma_de_Regiones As Double
Dim Valor_Texto As String
Dim Simbolo_Decimal As String
Dim Ecuacion As String
Static Funcion_Cadena As String
Static Funcion_Respaldo As String
Static c(7) As Double
Static x(7) As Double
On Error GoTo Informa_Error
Simbolo_Decimal = Application.International(xlDecimalSeparator)
Inicio = WorksheetFunction.Min(Limite_Inferior, Limite_Superior)
Final = WorksheetFunction.Max(Limite_Inferior, Limite_Superior)
dx = (Final - Inicio) / 2
If Funcion_Respaldo <> Funcion Then
Funcion_Cadena = Convertir_Funcion(Funcion, Variable)
Funcion_Respaldo = Funcion
c(0) = 0.101228536290375
c(1) = 0.222381034453376
c(2) = 0.313706645877886
c(3) = 0.362683783378363
c(4) = c(3)
c(5) = c(2)
c(6) = c(1)
c(7) = c(0)
x(7) = 0.960289856497537
x(6) = 0.796666477413626
x(5) = 0.525532409916329
x(4) = 0.18343464249565
x(3) = -x(4)
x(2) = -x(5)
x(1) = -x(6)
x(0) = -x(7)
End If
Suma_de_Regiones = 0
For Contador = 0 To 7
Valor = ((Final + Inicio) + (Final - Inicio) * x(Contador)) / 2
Valor_Texto = CStr(Valor)
Valor_Texto = "(" & Replace(Valor_Texto, Simbolo_Decimal, ".") &
")"
Ecuacion = Replace(Funcion_Cadena, UCase(Variable), Valor_Texto)
Suma_de_Regiones = Suma_de_Regiones + c(Contador) *
Evaluate(Ecuacion)
Next Contador
Integral_Gauss_Legendre = Suma_de_Regiones * dx
Exit Function
Informa_Error:
Funcion_Cadena = ""
Integral_Gauss_Legendre = "#ĄVALOR!"
End Function
2. I use Static Variables as you can see
b 1/a
3. You could use a variable change like this x = 1/t => Int f(x) dx
= Int (1/t)^2 f(1/t) dt.
a 1/b
4. Sorry I'm working on it.
5. This is my code for more than one variable, in fact this is the code I
alwais use.
Public Function Convertir_Funcion(Funcion As String, ParamArray Variables()
As Variant) As String
Dim Posicion As Integer
Dim Terminos As Integer
Dim Contador As Integer
Dim Simbolo_Decimal As String
Dim Simbolo_Anterior As String
Dim Simbolo_Siguiente As String
Dim Funcion_Cadena As String
Dim Arreglo_de_Variables() As String
Dim Variable As Variant
Simbolo_Anterior = "^/*-+("
Simbolo_Siguiente = "^/*-+)"
Simbolo_Decimal = Application.International(xlDecimalSeparator)
Funcion_Cadena = LCase(Replace(Funcion, Simbolo_Decimal, "."))
Funcion_Cadena = Replace(Funcion_Cadena, " ", "")
Terminos = 0
For Contador = 0 To UBound(Variables)
If IsObject(Variables(Contador)) Then
For Each Variable In Variables(Contador)
ReDim Preserve Arreglo_de_Variables(Terminos)
Arreglo_de_Variables(Terminos) = Variable
Terminos = 1 + Terminos
Next Variable
Else
ReDim Preserve Arreglo_de_Variables(Terminos)
Arreglo_de_Variables(Terminos) = Variables(Contador)
Terminos = 1 + Terminos
End If
Next Contador
For Contador = 0 To UBound(Arreglo_de_Variables)
Posicion = 0
Do While InStr(Posicion + 1, Funcion_Cadena,
LCase(Arreglo_de_Variables(Contador)), vbTextCompare) > 0
Posicion = InStr(Posicion + 1, Funcion_Cadena,
LCase(Arreglo_de_Variables(Contador)), vbTextCompare)
If Posicion = 1 Then
If InStr(1, Simbolo_Siguiente, Mid(Funcion_Cadena, Posicion
+ Len(Arreglo_de_Variables(Contador)), 1), vbTextCompare) > 0 Then
Funcion_Cadena = Left(Funcion_Cadena, Posicion - 1) &
UCase(Arreglo_de_Variables(Contador)) & Mid(Funcion_Cadena, Posicion +
Len(Arreglo_de_Variables(Contador)))
End If
ElseIf Posicion = Len(Funcion_Cadena) Then
If InStr(1, Simbolo_Anterior, Mid(Funcion_Cadena, Posicion -
1, 1), vbTextCompare) > 0 Then
Funcion_Cadena = Left(Funcion_Cadena, Posicion - 1) &
UCase(Arreglo_de_Variables(Contador)) & Mid(Funcion_Cadena, Posicion +
Len(Arreglo_de_Variables(Contador)))
End If
Else
If InStr(1, Simbolo_Anterior, Mid(Funcion_Cadena, Posicion -
1, 1), vbTextCompare) > 0 And InStr(1, Simbolo_Siguiente,
Mid(Funcion_Cadena, Posicion + Len(Arreglo_de_Variables(Contador)), 1),
vbTextCompare) > 0 Then
Funcion_Cadena = Left(Funcion_Cadena, Posicion - 1) &
UCase(Arreglo_de_Variables(Contador)) & Mid(Funcion_Cadena, Posicion +
Len(Arreglo_de_Variables(Contador)))
End If
End If
Loop
Next Contador
Funcion_Cadena = Replace(Funcion_Cadena, Simbolo_Decimal, ".")
Convertir_Funcion = Funcion_Cadena
End Function
If you need more accuracity try tris, but remember sometimes it could be
realy slow.
Public Function Integral_GL(Funcion As String, Limite_Inferior As Double,
Limite_Superior As Double, Optional Variable As String = "x", Optional
Presicion As Integer = 9) As Double
Dim Epsilon As Double
Dim Integral As Double
Dim Integral_I As Double
Dim Integral_II As Double
Dim Intervalo As Double
Dim Inicio As Double
Dim Final As Double
Epsilon = 1 / (10 ^ Presicion)
Inicio = WorksheetFunction.Min(Limite_Inferior, Limite_Superior)
Final = WorksheetFunction.Max(Limite_Inferior, Limite_Superior)
Intervalo = Abs(Final - Inicio) / 2
Integral = Integral_Gauss_Legendre(Funcion, Inicio, Final, Variable)
Integral_I = Integral_Gauss_Legendre(Funcion, Inicio, Inicio +
Intervalo, Variable)
Integral_II = Integral_Gauss_Legendre(Funcion, Inicio + Intervalo,
Final, Variable)
If Abs(Integral - Integral_I - Integral_II) > Epsilon Then
Integral_I = Integral_GL(Funcion, Inicio, Inicio + Intervalo,
Variable)
Integral_II = Integral_GL(Funcion, Inicio + Intervalo, Final,
Variable)
End If
Integral_GL = Integral_I + Integral_II
End Function
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
<<<<<<<
"Jay Petrulis" <john.p...@notes.ntrs.com> escribió en el mensaje
news:f7ad450.01102...@posting.google.com...
Jay Petrulis
Many, many thanks! I am going to pore over your ideas and code in
more detail, but this looks terrific.
Always great to share ideas and have others come back with improved
versions or better routes.
Thanks a bunch.
Jay
---snip---
David J. Braden
the server has been messed up in the last day or so. What did
Alexander post? Could you plz repost it so that we might see it?
TIA
Dave Braden
In article <f7ad450.01110...@posting.google.com>, Jay
Petrulis <john.p...@notes.ntrs.com> wrote:
--
E-mail (ROT-13'ed): qoe...@ebpurfgre.ee.pbz
Alexander Chacin
last post.
"David J. Braden" <no...@ugotta.bekidding.com> escribió en el mensaje
news:031120010058153810%no...@ugotta.bekidding.com...
Messaje
Alexander Chacin
integration too a few time ago, but I have problems in controling the code,
but I post the code as soon I fix it.
Regards
Alexander Chacin
"Jay Petrulis" <john.p...@notes.ntrs.com> escribió en el mensaje
news:f7ad450.01110...@posting.google.com...
Gert Breij
very much interested to be informed about it.
In the past I did something with Quick Basic (yes in DOS) and now I'm just
on my first steps in programming with VBA.
I remark that checking of the code is more difficult, but may be I do it the
wrong way.
My special interest is making new functions whith several
"complex"calculations, So the Item you mention looks quite good to me
Gert Breij
"Alexander Chacin" <ale...@cantv.net> schreef in bericht
news:eov0HDkZBHA.1968@tkmsftngp05...
Jay Petrulis
Hang in there. Hopefully some good code can be posted soon. I think
Nico Sterk may be playing around with this a bit, too, or at least
doing something that may transfer over well. I think Alexander is on
to something, though I am still trying to translate it all to test
fully. Maybe whatever we can come up with will be taken by others and
really extended. That would be great.
I don't know exactly what it would take to handle complex arguments,
so that might be version 2.0, with a rollout shortly after version 1.0
is available. <g>
If you have any specific ideas, possibly from your previous work,
please share. Who knows what can be of use?
Jay
"Gert Breij" <g.b...@hccnet.nl> wrote in message news:<9s9hlg$i03$1...@news.hccnet.nl>...
Alexander Chacin
you missed something let me know. I think you are going to do a big jump, in
fact I started with QB too so I know what you mind. I recomnend you to see
this page http://www.beyondtechnology.com/home.shtml in order to get some
advice, it´s helpful either its links .
Gert, what are you interesting in? I mean, especificaly. I have some rutines
which could be good for you, but I don´t know what are you looking for,
please tell me what is your interest area and let me check up.
Regards
Alexander Chacin
"Gert Breij" <g.b...@hccnet.nl> escribió en el mensaje
news:9s9hlg$i03$1...@news.hccnet.nl...
Alexander Chacin
The firt one "Integral_Doble_Gauss_Legendre" is a double integration
function, the second one "Convertir_Funcion " is the string tranformer whit
has no change from last post and the last one is a function for accuracy.
Note you can solve integrals like this:
a c=f(x)
Int Int H(x,y) dy dx
b d=g(x)
Regards
Alexander Chacin
Public Function Integral_Doble_Gauss_Legendre(Funcion_a_Integrar As String,
Limite_Inferior_Externo As Double, Limite_Superior_Externo As Double,
Limite_Inferior_Interno As String, Limite_Superior_Interno As String,
Optional Variable_Externa As String = "x", Optional Variable_Interna As
String = "y") As Double
Dim I As Integer
Dim J As Integer
Dim dx As Double
Dim dy As Double
Dim Inicio_x As Double
Dim Final_x As Double
Dim Final_y_Valor As Double
Dim Inicio_y_Valor As Double
Dim Valor_x As Double
Dim Valor_y As Double
Dim Evaluacion_y_Final As Double
Dim Evaluacion_y_Inicial As Double
Dim Suma_de_Regiones_x As Double
Dim Suma_de_Regiones_y As Double
Dim Inicio_y_Funcion As String
Dim Final_y_Funcion As String
Dim Valor_Texto_x As String
Dim Valor_Texto_y As String
Dim Ecuacion_x As String
Dim Ecuacion_y As String
Dim Funcion_Cadena As String
Static Funcion_Respaldo As String
Static Inicio_y_Respaldo As String
Static Final_y_Respaldo As String
Static c(7) As Double
Static x(7) As Double
On Error GoTo ManejaError:
Inicio_x = WorksheetFunction.Min(Limite_Inferior_Externo,
Limite_Superior_Externo)
Final_x = WorksheetFunction.Max(Limite_Inferior_Externo,
Limite_Superior_Externo)
dx = (Final_x - Inicio_x) / 2
If Funcion_Respaldo = "" Then
c(0) = 0.101228536290375
c(1) = 0.222381034453376
c(2) = 0.313706645877886
c(3) = 0.362683783378363
c(4) = c(3)
c(5) = c(2)
c(6) = c(1)
c(7) = c(0)
x(7) = 0.960289856497537
x(6) = 0.796666477413626
x(5) = 0.525532409916329
x(4) = 0.18343464249565
x(3) = -x(4)
x(2) = -x(5)
x(1) = -x(6)
x(0) = -x(7)
End If
If Left(Funcion_a_Integrar, 8) = "Llamada:" Then
Funcion_Cadena = Mid(Funcion_a_Integrar, 9)
Inicio_y_Funcion = Limite_Inferior_Interno
Final_y_Funcion = Limite_Superior_Interno
Funcion_Respaldo = Funcion_Cadena
Else
If LCase(Funcion_a_Integrar) <> LCase(Funcion_Respaldo) Then
Funcion_Respaldo = Convertir_Funcion(Funcion_a_Integrar,
Variable_Externa, Variable_Interna)
End If
If LCase(Inicio_y_Respaldo) <> LCase(Limite_Inferior_Interno) Then
Inicio_y_Respaldo = Convertir_Funcion(Limite_Inferior_Interno,
Variable_Externa)
End If
If LCase(Final_y_Respaldo) <> LCase(Limite_Superior_Interno) And
LCase(Funcion_a_Integrar) <> "Llamada" Then
Final_y_Respaldo = Convertir_Funcion(Limite_Superior_Interno,
Variable_Externa)
End If
Funcion_Cadena = Funcion_Respaldo
Inicio_y_Funcion = Inicio_y_Respaldo
Final_y_Funcion = Final_y_Respaldo
End If
Suma_de_Regiones_x = 0
For I = 0 To 7
Valor_x = ((Final_x + Inicio_x) + (Final_x - Inicio_x) * x(I)) /
2
Valor_Texto_x = CStr(Valor_x)
Valor_Texto_x = "(" & Replace(Valor_Texto_x,
Application.International(xlDecimalSeparator), ".") & ")"
Ecuacion_x = Replace(Funcion_Cadena, UCase(Variable_Externa),
Valor_Texto_x)
Evaluacion_y_Inicial = Evaluate(Replace(Inicio_y_Funcion,
UCase(Variable_Externa), Valor_Texto_x))
Evaluacion_y_Final = Evaluate(Replace(Final_y_Funcion,
UCase(Variable_Externa), Valor_Texto_x))
Inicio_y_Valor = WorksheetFunction.Min(Evaluacion_y_Inicial,
Evaluacion_y_Final)
Final_y_Valor = WorksheetFunction.Max(Evaluacion_y_Inicial,
Evaluacion_y_Final)
dy = (Final_y_Valor - Inicio_y_Valor) / 2
Suma_de_Regiones_y = 0
For J = 0 To 7
Valor_y = ((Final_y_Valor + Inicio_y_Valor) +
(Final_y_Valor - Inicio_y_Valor) * x(J)) / 2
Valor_Texto_y = CStr(Valor_y)
Valor_Texto_y = "(" & Replace(Valor_Texto_y,
Application.International(xlDecimalSeparator), ".") & ")"
Ecuacion_y = Replace(Ecuacion_x, UCase(Variable_Interna),
Valor_Texto_y)
Suma_de_Regiones_y = Suma_de_Regiones_y + c(J) *
Evaluate(Ecuacion_y)
Next J
Suma_de_Regiones_x = Suma_de_Regiones_x + Suma_de_Regiones_y *
dy * c(I)
Next I
Integral_Doble_Gauss_Legendre = Suma_de_Regiones_x * dx
Exit Function
ManejaError:
Funcion_Respaldo = ""
Inicio_y_Respaldo = ""
Final_y_Respaldo = ""
Integral_Doble_Gauss_Legendre = "#ĄVALOR!"
End Function
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
<<<<<<<
End If
Loop
Next Contador
Convertir_Funcion = Funcion_Cadena
End Function
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
<<<<<
Public Function Integral_Doble_GLX(Funcion_a_Integrar As String,
Limite_Inferior_Externo As Double, Limite_Superior_Externo As Double,
Limite_Inferior_Interno As String, Limite_Superior_Interno As String,
Optional Variable_Externa As String = "x", Optional Variable_Interna As
String = "y") As Double
Dim Epsilon As Double
Dim Integral As Double
Dim Integral_I As Double
Dim Integral_II As Double
Dim Integral_III As Double
Dim Integral_IV As Double
Dim Factor_Superior_1 As Double
Dim Factor_Superior_2 As Double
Dim Factor_Inferior_1 As Double
Dim Factor_Inferior_2 As Double
Dim Factor_Medio As Double
Dim Inicio_Clave As String
Dim Final_Clave As String
Dim Medio_Clave As String
Dim Inicio_x As Double
Dim Final_x As Double
Dim Medio_x As Double
Dim Limite_Valor As Double
Dim Inicio_y As String
Dim Final_y As String
Dim Medio_y As String
Dim Ecuacion As String
Static Funcion_Respaldo As String
Static Funcion_Limite_Inf As String
Static Funcion_Limite_Sup As String
On Error GoTo Informa_Error
Epsilon = 1 / (10 ^ Presicion)
Inicio_x = WorksheetFunction.Min(Limite_Inferior_Externo,
Limite_Superior_Externo)
Final_x = WorksheetFunction.Max(Limite_Inferior_Externo,
Limite_Superior_Externo)
Medio_x = (Final_x + Inicio_x) / 2
If InStr(1, Limite_Inferior_Interno, "A", vbTextCompare) <> 0 And
InStr(1, Limite_Superior_Interno, "B", vbTextCompare) <> 0 Then
Factor_Inferior_1 = Val(Mid(Limite_Inferior_Interno, InStr(1,
Limite_Inferior_Interno, "A", vbTextCompare) + 1))
Factor_Inferior_2 = Val(Mid(Limite_Inferior_Interno, InStr(1,
Limite_Inferior_Interno, "B", vbTextCompare) + 1))
Factor_Superior_1 = Val(Mid(Limite_Superior_Interno, InStr(1,
Limite_Superior_Interno, "A", vbTextCompare) + 1))
Factor_Superior_2 = Val(Mid(Limite_Superior_Interno, InStr(1,
Limite_Superior_Interno, "B", vbTextCompare) + 1))
Factor_Medio_Inferior = (Factor_Inferior_1 + Factor_Superior_1) /
2
Factor_Medio_Superior = (Factor_Inferior_2 + Factor_Superior_2) /
2
Inicio_Clave = Limite_Inferior_Interno
Final_Clave = Limite_Superior_Interno
Medio_Clave = Replace("A" & Factor_Medio_Inferior & "B" &
Factor_Medio_Superior, Application.International(xlDecimalSeparator), ".")
Inicio_y = Replace("(" & CStr(Factor_Inferior_1) & ")*(" &
Funcion_Limite_Inf & ")+(" & CStr(Factor_Inferior_2) & ")*(" &
Funcion_Limite_Sup & ")", Application.International(xlDecimalSeparator),
".")
Final_y = Replace("(" & CStr(Factor_Superior_1) & ")*(" &
Funcion_Limite_Inf & ")+(" & CStr(Factor_Superior_2) & ")*(" &
Funcion_Limite_Sup & ")", Application.International(xlDecimalSeparator),
".")
Medio_y = Replace("(" & CStr(Factor_Medio_Inferior) & ")*(" &
Funcion_Limite_Inf & ")+(" & CStr(Factor_Medio_Superior) & ")*(" &
Funcion_Limite_Sup & ")", Application.International(xlDecimalSeparator),
".")
Else
Inicio_Clave = "A1B0"
Final_Clave = "A0B1"
Medio_Clave = "A0.5B0.5"
Funcion_Respaldo = Convertir_Funcion(Funcion_a_Integrar,
Variable_Externa, Variable_Interna)
Funcion_Limite_Inf = Convertir_Funcion(Limite_Inferior_Interno,
Variable_Externa)
Funcion_Limite_Sup = Convertir_Funcion(Limite_Superior_Interno,
Variable_Externa)
Inicio_y = Funcion_Limite_Inf
Final_y = Funcion_Limite_Sup
Medio_y = "(0.5)*(" & Funcion_Limite_Inf & ")+(0.5)*(" &
Funcion_Limite_Sup & ")"
End If
Ecuacion = "Llamada:" & Funcion_Respaldo
Integral = Integral_Doble_Gauss_Legendre(Ecuacion, Inicio_x, Final_x,
Inicio_y, Final_y, Variable_Externa, Variable_Interna)
Integral_I = Integral_Doble_Gauss_Legendre(Ecuacion, Inicio_x,
Medio_x, Inicio_y, Medio_y, Variable_Externa, Variable_Interna)
Integral_II = Integral_Doble_Gauss_Legendre(Ecuacion, Medio_x,
Final_x, Inicio_y, Medio_y, Variable_Externa, Variable_Interna)
Integral_III = Integral_Doble_Gauss_Legendre(Ecuacion, Inicio_x,
Medio_x, Medio_y, Final_y, Variable_Externa, Variable_Interna)
Integral_IV = Integral_Doble_Gauss_Legendre(Ecuacion, Medio_x,
Final_x, Medio_y, Final_y, Variable_Externa, Variable_Interna)
If Abs(Integral / (Integral_I + Integral_II + Integral_III +
Integral_IV)) < 1 - Epsilon Or Abs(Integral / (Integral_I + Integral_II +
Integral_III + Integral_IV)) > 1 + Epsilon Then
Integral_I = Integral_Doble_GLX(Ecuacion, Inicio_x, Medio_x,
Inicio_Clave, Medio_Clave, Variable_Externa, Variable_Interna)
Integral_II = Integral_Doble_GLX(Ecuacion, Medio_x, Final_x,
Inicio_Clave, Medio_Clave, Variable_Externa, Variable_Interna)
Integral_III = Integral_Doble_GLX(Ecuacion, Inicio_x, Medio_x,
Medio_Clave, Final_Clave, Variable_Externa, Variable_Interna)
Integral_IV = Integral_Doble_GLX(Ecuacion, Medio_x, Final_x,
Medio_Clave, Final_Clave, Variable_Externa, Variable_Interna)
End If
Integral_Doble_GLX = Integral_I + Integral_II + Integral_III +
Integral_IV
Exit Function
Informa_Error:
Limite_Inferior = ""
Limite_Superior = ""
Integral_Doble_GLX = "#ĄVALOR!"
End Function
<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
<<<<<<<<
"Jay Petrulis" <john.p...@notes.ntrs.com> escribió en el mensaje
news:f7ad450.01102...@posting.google.com...