I have a for loop (the last loop in the code below) which fills some arrays with values through some computations.
However, for some reason, once i=5 it jumps back up to the top of the loop (the x+h part) without going through the rest of the loop.
While x < xmax
If x + h < xmax Then 'If the step is going to overshoot the desired xmax
x = x + h 'make h adequately smalller
Else
h = xmax - x
x = xmax
End If
'k(Order #, equation #)
For j = 1 To 6 'First to 6th order
'temp=riddersmethodT(temp) 'Calculate temperature of mixture
FT = 0
rho(0) = 0 'Setting FT and rho_av to 0 to be re-calculated
For i = 1 To 7
rho(0) = rho(0) + rho(i) * Y4(i) 'Calculate average density of mixture
FT = FT + Y4(i)
vol_F = vol_F + Y4(i) * MW(i) / rho(i) 'Calculating the total volumetric flowrate (m^3/s)
Next i
rho(0) = rho(0) / FT
For i = 1 To 8 'Calculating all of the k(1) values for eq 1 to 8
k(j, i) = AllODES(x, Y4, i, j, k, h, temp, diameter, vol_F, rho(0))
Next i
Next j
For i = 1 To 8
Y4Old(i) = Y4(i) 'Saving old y4 values to calc delta0
Y4(i) = Y4(i) + h * (k(1, i) * (37 / 378) + k(3, i) * (250 / 621) + k(4, i) * (125 / 594) + k(6, i) * (512 / 1771))
Y5(i) = Y4(i) + h * (k(1, i) * (2825 / 27648) + k(3, i) * (18575 / 48384) + k(4, i) * (13525 / 55296) + k(5, i) * (277 / 14336) + k(6, i) * (0.25))
delta0(i) = error
delta1(i) = Abs(Y5(i) - Y4(i))
delRatio(i) = Abs(delta0(i) / delta1(i)) 'Ratio of errors; careful of getting zeroes!
Next i
I don't understand how this can be possible seeing as i is not being manipulated within that loop. If you have any insight, please let me know!
My guess is that your final loop over i has a divide by zero somewhere. You could handle errors in your loop using something like the following:
Sub yourSub()
For i = 1 To 8
On Error GoTo ErrorHandler:
Y4Old(i) = Y4(i)
'Saving old y4 values to calc delta0
Y4(i) = Y4(i) + h * (k(1, i) * (37 / 378) + k(3, i) * (250 / 621) + k(4, i) * (125 / 594) + k(6, i) * (512 / 1771))
Y5(i) = Y4(i) + h * (k(1, i) * (2825 / 27648) + k(3, i) * (18575 / 48384) + k(4, i) * (13525 / 55296) + k(5, i) * (277 / 14336) + k(6, i) * (0.25))
delta0(i) = error
delta1(i) = Abs(Y5(i) - Y4(i))
delRatio(i) = Abs(delta0(i) / delta1(i)
Next i
Cleanup:
' do cleanup here
Exit Sub
ErrorHandler:
' handle error here
Resume Cleanup
End Sub
But it would be best to fix your match which is allowing a division by zero in the first place.
Related
The question to be done
I have tried this out.
I have created few functions. I am confused in the remaining ones.
I have made the first function and stored the values of upper, lower and main matrix in my spreadsheet.
Function createFEMatrixDirichlet(a, C, Nx, h, dt)
Dim k As Integer
'Main
For k = 0 To Nx - 1
Cells(k + 2, 2).Value = 1 - dt * (((2 * a) / (h * h)) + x)
Next k
'Lower
For k = 0 To Nx - 2
Cells(k + 2, 1).Value = dt * (a / (h * h))
Next k
'Upper
For k = 0 To Nx - 3
Cells(k + 2, 3).Value = dt * (a / (h * h))
Next k
End Function
Nodes are generated similar way.
Function nodeGeneration(xa, xb, Nx, column)
Dim k As Integer
'Find h
h = (xb - xa) / Nx
'Generate Node
For k = 0 To Nx
Cells(k + 2, column).Value = xa + k * h
Next k
End Function
Initial condition are applied:
Function applyInitialCondition(Nx, column)
Dim k As Integer
For k = 0 To Nx
Cells(k + 2, column).Value = ((Cells(k + 2, 4)) + 2) / 2
Next k
End Function
Now to multiply I am a bit confused. My implementation is that I am trying to make the entire matrix and then multiply. However, there is no luck. Some or the other error pops up.
Also, I have no idea on how to implement the FETimeStep and then create a new subroutine to run the entire code.
Any leads?
Sample Input
I want to give the other parameters that are mentioned in the function, and get a solution for a (the angle), but I get error: "invalid procedure call or argument" Run-time error 5.
I need to call the function in excel worksheet. It is a pretty long equation. Also, it could be that I enter a infinite loop but I don't know how to avoid that.
Function calculateangle(r, h, C, g, d, m, t, x, y As Single) As Single
Dim a As Single
a = 0
While y <> (d + r - r * Cos(a) + (x - (t - r + r * Sin(a))) * Tan(a) - (g
/ (2 * ((((C * m * (2 * g * (h - (d + r - r * Cos(a)))) ^
(1 / 2)) + m * (2 * g * (h - (d + r - r * Cos(a)))) ^ (1 / 2)) / (m +
0.04593)) ^ 2) * (Cos(a)) ^ 2)) * (x - (t - r + r * Sin(a))) ^ 2)
a = a + 0.01
Wend
MsgBox Round(a, 2)
End Function
One obvious issue is that you are using a Function but not returning a value.
This really is a complex piece of spaghetti! However, I suggest an approach like below which will help separate out various bits and thus make it easier to do debugging
Function calculateangle(<...all the bits ...>) As Double
Dim a As Double
Dim tTolerance as Double
dim f1 as Double ' sub sections to help untangle the spaghetti
Dim f2 as Double
Dim f3 as Double
Dim fFinal as Double
Dim tWithinTolerance as Boolean
tWithinTolerance = false
a = 0
tTolerance = 0.01
While not tWithinTolerance
f1 = d + r - r * Cos(a)
f2 = m*2*g*(h - f1)
f3 = x - (t - r + r * Sin(a))
fFinal = (f1 + f3 * Tan(a) - (g / (2 * ((((C * f2) ^
(1 / 2)) + f2 ^ (1 / 2)) / (m + 0.04593)) ^ 2) * (Cos(a)) ^ 2)) * f3 ^ 2)
tWithinTolerance = (Abs(y - fFinal) < tTolerance)
a = a + 0.01
Wend
Calculateangle = a ' note how this sets a return value for the function
End Function
I have left the rounding (which is a presentation issue) to the code that calls this function - this way you can display the answer to whatever level of detail you want!
(apologies if I have mangled any of the calculation on the way through - but you get the concept!)
For the author and those who want to deal with his solitaire. I hope I did not confuse anything in parentheses and simplifications.
Do
vCosA = Cos(a)
vCosADR = d + r * (1 - vCosA) ' d + r - r * vCosA '
vCosMGHADR = m * (2 * g * (h - vCosADR))
vSinAXTR = (x - (t - r * (1 - Sin(a)))) ' - r + r * Sin(a)
'((C * vCosMGHADR) + vCosMGHADR) == ((C + 1) * vCosMGHADR)
If (y = _
(vCosADR + vSinAXTR * Tan(a) - _
(g / _
(2 * _
( _
( _
((C + 1) * vCosMGHADR) / _
(m + 0.04593) _
) ^ 2 _
) * (vCosA ^ 2) _
) _
) * vSinAXTR ^ 2 _
)) Then Exit Do ' *** EXIT DO ***
a = a + 0.01
Loop
So I have a "main" function (SolveSixODES) that calls a secondary function (AllODEs). And when it does this, the x value in the main function gets modified. I don't understand how this can be possible, seeing as it is not a global variable.
Here is the code, my inputs I used are as follows:
x=0, xmax=3, y=0-6, h=0.1, error=0.1
Public Function SolveSixODE(x As Double, xmax As Double, Y As Range, h As Double, error As Double) 'Weird bug: You must leave the first y4 value blank
Dim i As Integer, k(7, 7) As Double, j As Integer, m As Integer 'k(Order #, equation #)
Dim Y5(7) As Double, Y4(7) As Double, Y4Old(7) As Double
Dim delta0(7) As Double, delta1(7) As Double, delRatio(7) As Double, Rmin As Double
For i = 1 To 6 'Moving the input data so it can acutally be used
Y4(i) = Y(i)
Next i
While x < xmax
If x + h < xmax Then
x = x + h
Else
h = xmax - x
x = xmax
End If
For j = 1 To 6 'j is the order i is equation number
For i = 1 To 6 'Calculating all of the k(1) values for eq 1 to 6
k(j, i) = AllODES(x, Y4, i, j, k, h) '!!!!!SOME HOW THIS LOOP MAKES X negative...!!!!!!!
Next i
Next j
For i = 1 To 6
Y4Old(i) = Y4(i) 'Saving old y4 value to calc delta0
Y4(i) = Y4(i) + h * (k(1, i) * (37 / 378) + k(3, i) * (250 / 621) + k(4, i) * (125 / 594) + k(6, i) * (512 / 1771))
Y5(i) = Y4(i) + h * (k(1, i) * (2825 / 27648) + k(3, i) * (18575 / 48384) + k(4, i) * (13525 / 55296) + k(5, i) * (277 / 14336) + k(6, i) * (0.25))
delta0(i) = error * (Abs(Y4Old(i)) + Abs(h * AllODES(x, Y4Old, i, 1, k, h))) 'First order because we don't want to use the k vals
delta1(i) = Abs(Y5(i) - Y4(i))
delRatio(i) = Abs(delta0(i) / delta1(i)) 'Ratio of errors
Next i
Rmin = delRatio(1)
For i = 2 To 6
If delRatio(i) < Rmin Then
Rmin = delRatio(i) 'Determine the smallest error ratio
End If
Next i
If Rmin < 1 Then 'If this is true then the step size was too big must repeat step
x = x - h 'Set x and y's back to previous values
For i = 1 To 6
Y4(i) = Y4Old(i)
Next i
h = 0.9 * h * Rmin ^ 0.25 'adjust h value; 0.9 is a safety factor
Else
h = 0.9 * h * Rmin ^ 0.2 'Otherwise, we march on
End If
m = m + 1
Wend
SolveSixODE = Y4
End Function
Public Function AllODES(x As Double, Y() As Double, EqNumber As Integer, order As Integer, k() As Double, h As Double) As Double
Dim conc(7) As Double, i As Integer, j As Integer
If order = 1 Then
x = x - h
For i = 1 To 6 'Movin the data so I can use it
conc(i) = Y(i) 'also adjusting the x and y values for RK4 (Cash Karp values)
Next i
ElseIf order = 2 Then
x = x - h + h * 0.2
For i = 1 To 6
conc(i) = Y(i) + h * k(1, i) * 0.2
Next i
ElseIf order = 3 Then
x = x - h + 0.3 * h
For i = 1 To 6
conc(i) = Y(i) + h * (0.075 * k(1, i) + 0.225 * k(2, i))
Next i
ElseIf order = 4 Then
x = x - h + 0.6 * h
For i = 1 To 6
conc(i) = Y(i) + h * (0.3 * k(1, i) - 0.9 * k(2, i) + 1.2 * k(3, i))
Next i
ElseIf order = 5 Then
x = x - h + h
For i = 1 To 6
conc(i) = Y(i) + h * ((-11 / 54) * k(1, i) + 2.5 * k(2, i) - (70 / 27) * k(3, i) + (35 / 27) * k(4, i))
Next i
ElseIf order = 6 Then
x = x - h + 0.875 * h
For i = 1 To 6
conc(i) = Y(i) + h * ((1631 / 55296) * k(1, i) + (175 / 512) * k(2, i) + (575 / 13824) * k(3, i) + (44275 / (110592) * k(4, i) + (253 / 4096) * k(5, i)))
Next i
Else
MsgBox ("error")
End If
If EqNumber = 1 Then 'These are the actual equations
AllODES = x + Y(1)
ElseIf EqNumber = 2 Then
AllODES = x
ElseIf EqNumber = 3 Then
AllODES = Y(3)
ElseIf EqNumber = 4 Then
AllODES = 2 * x
ElseIf EqNumber = 5 Then
AllODES = 2 * Y(2)
ElseIf EqNumber = 6 Then
AllODES = 3 * x
Else
MsgBox ("You entered an Eq Number that was dumb")
End If
End Function
It's possible that it is something really trivial that I missed but this seems to contradict my knowledge of how variables work. So if you understand how the function is able to manipulate a variable from another function in this case, I would appreciate any advice and/or explanation!
Thanks in advance!
the x value in the main function gets modified. I don't understand how this can be possible, seeing as it is not a global variable
This is normal because you are passing x by reference to the function AllODES and you do change it there. When the keyword ByVal is not explicitly specified in the function/sub prototype, the default passing mechanism is ByRef, that is, by reference.
Public Function AllODES(x As Double, ...
means
Public Function AllODES(ByRef x As Double, ....
We observe that x is manipulated in this function, so the change will appear in the caller. If you want that the change of x does not report back in the caller's scope, pass x by value:
Public Function AllODES(ByVal x As Double, ....
' ^^^^^
Only in this case the x of the caller and the x of the callee will be two different variables.
Ok here's the deal: I need to do a comprehensive check in a .csv file (comparing the one in my current sheet to an external one). I decided to divide the list into 10 equal sections (deciles). In each decile I choose a random value belonging to that section and use that row number to compare the two sets of data.
Where things fall apart is inside the FOR function. I am looking for a way to go through each decile (starting from rand0) and have VBA check whether the values of the .csv and the Data sheet in this workbook are equal. If they are not - a function (called get_param) is to be executed.
I dont quite understand how to have VBA go through the FOR function from Dec = 0 to 9 - so in essence from row number rand0 to row number rand9 and perform the inequality check (in the second IF function). The rand & Dec part does not work. I am looking for clues on how to fix this or on a new implementation to do the same thing.
A few more details:
n is the number of rows in the .csv file (equal to a couple of thousand).
np is the number of rows in this file (should be equal to n - if not, execute function). ParamLocation is designated automatically - it should be located in a specific location.
Sub check_changes_param()
Dim Dec As Integer
Call public_dims
Call deciles
Set ParamBook = Workbooks.Open(ParamLocation)
'==========CHECKS IF PARAMETERS.xlsm EXISTS IN THE CORRECT LOCATION==========
If ParamLocation = "" Then
MsgBox "The Parameters.xlsm file does not exist or is in the incorrect location. Please ensure it is located in " & ParamLocation
Else
For Dec = 0 To Dec = 9
If ThisWorkbook.Sheets("Data").Cells(rand & Dec, 11) <> ParamBook.Sheets("Data").Cells(rand & Dec, 11) Or n <> np Then
Call get_param
Exit For
End If
Next Dec
End If
End Sub
Public Sub deciles()
rand0 = Int((n / 10) * 1) * Rnd + 1
rand1 = Int((n / 10) * 2 - (n / 10) * 1 + 1) * Rnd + (n / 10) * 1
rand2 = Int((n / 10) * 3 - (n / 10) * 2 + 1) * Rnd + (n / 10) * 2
rand3 = Int((n / 10) * 4 - (n / 10) * 3 + 1) * Rnd + (n / 10) * 3
rand4 = Int((n / 10) * 5 - (n / 10) * 4 + 1) * Rnd + (n / 10) * 4
rand5 = Int((n / 10) * 6 - (n / 10) * 5 + 1) * Rnd + (n / 10) * 5
rand6 = Int((n / 10) * 7 - (n / 10) * 6 + 1) * Rnd + (n / 10) * 6
rand7 = Int((n / 10) * 8 - (n / 10) * 7 + 1) * Rnd + (n / 10) * 7
rand8 = Int((n / 10) * 9 - (n / 10) * 8 + 1) * Rnd + (n / 10) * 8
rand9 = Int(n - (n / 10) * 9 + 1) * Rnd + (n / 10) * 9
End Sub
Try this instead:
Sub check_changes_param()
Dim Dec As Integer
Call public_dims
Dim deciles As Variant
deciles = decilesArray()
Set ParamBook = Workbooks.Open(ParamLocation)
'==========CHECKS IF PARAMETERS.xlsm EXISTS IN THE CORRECT LOCATION==========
If ParamLocation = "" Then
MsgBox "The Parameters.xlsm file does not exist or is in the incorrect location. Please ensure it is located in " & ParamLocation
Else
For Dec = 0 To UBound(deciles)
If ThisWorkbook.Sheets("Data").Cells(deciles(Dec), 11) <> ParamBook.Sheets("Data").Cells(deciles(Dec), , 11) Or n <> np Then
Call get_param
Exit For
End If
Next Dec
End If
End Sub
Public Function decilesArray() As Variant
randomize()
rand0 = Int((n / 10) * 1) * Rnd + 1
rand1 = Int((n / 10) * 2 - (n / 10) * 1 + 1) * Rnd + (n / 10) * 1
rand2 = Int((n / 10) * 3 - (n / 10) * 2 + 1) * Rnd + (n / 10) * 2
rand3 = Int((n / 10) * 4 - (n / 10) * 3 + 1) * Rnd + (n / 10) * 3
rand4 = Int((n / 10) * 5 - (n / 10) * 4 + 1) * Rnd + (n / 10) * 4
rand5 = Int((n / 10) * 6 - (n / 10) * 5 + 1) * Rnd + (n / 10) * 5
rand6 = Int((n / 10) * 7 - (n / 10) * 6 + 1) * Rnd + (n / 10) * 6
rand7 = Int((n / 10) * 8 - (n / 10) * 7 + 1) * Rnd + (n / 10) * 7
rand8 = Int((n / 10) * 9 - (n / 10) * 8 + 1) * Rnd + (n / 10) * 8
rand9 = Int(n - (n / 10) * 9 + 1) * Rnd + (n / 10) * 9
decilesArray= Array(rand0,rand1,rand2,rand3,rand4,rand5,rand6,rand7,rand8,rand9)
End Sub
I propose this correction,
public dim statements should be defined outside sub or functions.
use an array instead of concatenation to refer to a variable, rand & dec is not a correct VBA syntax to address rand0, ... rand9 variables.
Dim rand(9)
Sub check_changes_param()
Dim Dec As Integer, n
' Call public_dims ' put dim instructions as first instructions of this module
n = 10 'modify 10 to reflect correct value
Call deciles(n)
Set ParamBook = Workbooks.Open(ParamLocation)
'==========CHECKS IF PARAMETERS.xlsm EXISTS IN THE CORRECT LOCATION==========
If ParamLocation = "" Then
MsgBox "The Parameters.xlsm file does not exist or is in the incorrect location. Please ensure it is located in " & ParamLocation
Else
For Dec = 0 To 9
If ThisWorkbook.Sheets("Data").Cells(rand(Dec), 11) <> ParamBook.Sheets("Data").Cells(rand(Dec), 11) Or n <> np Then
Call get_param
Exit For
End If
Next Dec
End If
End Sub
Public Sub deciles(n)
rand(0) = Int((n / 10) * 1) * Rnd + 1
For i = 1 To 8
rand(i) = Int((n / 10) * (i + 1) - (n / 10) * (i + 1) + 1) * Rnd + (n / 10) * i
Next
rand(9) = Int(n - (n / 10) * 9 + 1) * Rnd + (n / 10) * 9
End Sub
I have a function that only call the spline function when something happens..in this case when a division is less than zero..the inputs for the function is the same that for the spline function(called CUBIC), the spline was tested and works well when I call it direct! someone can help me?...follows a party of the code
Function NDF6(T As Variant, dias As Variant, taxas As Variant)
If T <= dias(1) Then
NDF6 = taxas(1)
Exit Function
End If
If T >= dias(tam) Then
NDF6 = taxas(tam)
Exit Function
End If
For i = 1 To tam
If T <= dias(i) Then
If taxas(i) / taxas(i - 1) < 0 Then
Call CUBIC(T, dias, taxas)
Else
i0 = ((taxas(i - 1) * dias(i - 1)) / 360) + 1
i1 = ((taxas(i - 1) * dias(i - 1)) / 360) + 1
irel = i1 / i0
i2 = irel ^ ((T - dias(i - 1)) / (dias(i) - dias(i - 1)))
i2rel = i2 * i0
i2real = i2rel - 1
NDF6 = i2real * (360 / T)
End If
Public Function CUBIC(x As Variant, input_column As Variant, output_column As Variant)
The function returns a zero value when I call the cubic function. The inputs are a cell with a value with a value equivalent a day and two arrays(DUONOFF and ONOFF) equivalent a days and rates, I call the function like:
NDF6(512,DUONOFF,ONOFF)
follows the CUBIC function
Public Function CUBIC(x As Variant, input_column As Variant, output_column As Variant)
'Purpose: Given a data set consisting of a list of x values
' and y values, this function will smoothly interpolate
' a resulting output (y) value from a given input (x) value
' This counts how many points are in "input" and "output" set of data
Dim input_count As Integer
Dim output_count As Integer
input_count = input_column.Rows.Count
output_count = output_column.Rows.Count
Next check to be sure that "input" # points = "output" # points
If input_count <> output_count Then
CUBIC = "Something's messed up! The number of indeces number of output_columnues don't match!"
GoTo out
End If
ReDim xin(input_count) As Single
ReDim yin(input_count) As Single
Dim c As Integer
For c = 1 To input_count
xin(c) = input_column(c)
yin(c) = output_column(c)
Next c
values are populated
Dim N As Integer 'n=input_count
Dim i, k As Integer 'these are loop counting integers
Dim p, qn, sig, un As Single
ReDim u(input_count - 1) As Single
ReDim yt(input_count) As Single 'these are the 2nd deriv values
N = input_count
yt(1) = 0
u(1) = 0
For i = 2 To N - 1
sig = (xin(i) - xin(i - 1)) / (xin(i + 1) - xin(i - 1))
p = sig * yt(i - 1) + 2
yt(i) = (sig - 1) / p
u(i) = (yin(i + 1) - yin(i)) / (xin(i + 1) - xin(i)) - (yin(i) - yin(i - 1)) / (xin(i) - xin(i - _1))
u(i) = (6 * u(i) / (xin(i + 1) - xin(i - 1)) - sig * u(i - 1)) / p
Next i
qn = 0
un = 0
yt(N) = (un - qn * u(N - 1)) / (qn * yt(N - 1) + 1)
For k = N - 1 To 1 Step -1
yt(k) = yt(k) * yt(k + 1) + u(k)
Next k
now eval spline at one point
Dim klo, khi As Integer
Dim h, b, a As Single
first find correct interval
klo = 1
khi = N
Do
k = khi - klo
If xin(k) > x Then
khi = k
Else
klo = k
End If
k = khi - klo
Loop While k > 1
h = xin(khi) - xin(klo)
a = (xin(khi) - x) / h
b = (x - xin(klo)) / h
y = a * yin(klo) + b * yin(khi) + ((a ^ 3 - a) * yt(klo) + (b ^ 3 - b) * yt(khi)) * (h ^ 2) _/ 6
CUBIC = y
out:
End Function