Don't Get Me Started - VB6: Waking a Sleeping Giant:
https://msdn.microsoft.com/en-us/magazine/mt632280
Don't Get Me Started - VB6: Waking a Sleeping Giant:
https://msdn.microsoft.com/en-us/magazine/mt632280
↧
VB6: Waking a Sleeping Giant
Don't Get Me Started - VB6: Waking a Sleeping Giant:
https://msdn.microsoft.com/en-us/magazine/mt632280
↧
Explanation File for Euler-Romberg Method
Explanation File for Euler-Romberg Method
=========================================
We want to solve the Cauchy's problem:
| y' = f(x,y)
|
| with y(x0) = y0
using the Euler-Romberg method.
For that, we calculate approximate values for y1, y2,...yn,
the exact solution is y(x1), y(x2),...y(xn), using an iterative
algorithm based on:
* repeatedly apply the Euler method in the same
interval with an integration step halved after
each iteration.
* linearly extrapolate to obtain a better
approximation.
This procedure allows getting the same precision all along the
computation.
Let be (xn, yn) and a starting step h0, the approximation yn+1
is obtained by building up a table in the same way than in the
integration Romberg method.
0
We start with estimating an initial value of yn+1, noted y0 by
Euler method, using step h0:
0
y0 = yn + h0 f(xn,yn)
then the new step is h0/2 and we do the same computations for
all the points of the sub-interval:
0
h0 y0
1 0
L=1 h0/2 y0 y1
2 2 1 0
L=2 h0/2 y0 y1 y2
----------------------------------
k k k-1 1 0
L=k h0/2 y0 y ... y y
1 k-1 k
0
The first element y0 of the column 0 is an approximation of
y(x ) with the step h0=x - x . The other elements are the
n+1 n-1 n
successive approximations of y(x ) given by the Euler's formula
n+1
for h0/2, h0/4... i.e.:
L=1 h1=h0/2
x0=xn y0=yn f0=f(x0,y0)
x1=xn+h1 y1=y0+h1f0 f1=f(x1,y1)
1
x2=xn+2h1 y2=y1+h1f1 -> Y0 = Y2
-------
k
The elements Y of the column m (m=1,2...) are obtained by using
m
the linear extrapolation formula:
k k+1
k Ym-1[h-h ] - Ym-1[h-h ]
k+m k
Y (h) = -------------------------
m h - h
k k+m
and when h -> 0:
k k+m k+1 k
k Y [0-h0/2 ] - Y [0-h0/2 ]
m-1 m-1
Y = -------------------------------
m k k+m
h0/2 - h0/2
Dividing by h0/2, we obtain:
m k+1 k
k 2 Ym-1 - Ym-1
Y = -------------
m m
2 - 1
k
Observing how the table elements Ym are calculated, we can see
that it is not necessary to keep in memory a table with two dimen-
k-1 k-2 0 k
sions, we first calculate Y1, then Y2 ... until Yk. The table Ym
is then replaced by the one-dimension table, Tk:
k
iteration # step Ym Tk
---------------------------------------------------
0
0 h Y0 T1
1 0
1 h/2 Y0 Y1 T2 T1
2 1 0
2 h/4 Y0 Y1 Y2 T3 T2 T1
---- ---- --------- ---------
k k 0
k h/2 Y0 ... Yk Tk ... T1
---------------------------------------------------
To fully understand the mechanism, we recommend the reader to
0 1 0 2
manually calculate a few elements: Y1, Y1 and Y2, Y1, etc.
Or else:
m
2 T - T
K=1 k
T = ------------- (k = L...1)
k m
2 - 1
To sum up, we have in the program EULROMB the following steps:
1. Define the function f(x,y), the starting values, X(1), Y(1),
the starting step H, the maximum error ER, the max. number
of subdivisions LA and the number of calculations NC.
NC = (X - X ) / H
n+1 1
2. Approximate Yn+1 by Euler's method:
0 0
Y0 = Yn + h f(xn,yn) and T1 = Y0
3. Calculate the Tk elements of the extrapolation table; we
initialize the iteration with L=1.
a) XC = X ; YC = Y
n n
approximate Y by Euler's method successively dividing
n+1
the step by 2 ; T is the value of Y given by
L+1 n+1
Euler.
b) Initialize the column count m=1; k=L is the T index.
k
c) calculate Ym or rather T using:
k
m
2 T - T
k+1 k
T = -------------
k m
2 - 1
d) if k<1 goto subroutine f.
e) test convergence: if |Tk - Tk+1| < ER, the iteration is
finished, otherwise increment m, decrement k, go to step c)
f) if L<Lmax, increment L then goto step a) else display a
message "No convergence!"
g) if n < N, increment n, go to 2. else end program.
Note: the program EULROMB is made such as the solution Yk is
stored for all the points (this is not always necessary).
[From BIBLI 04].
SOURCE WEBSITE: http://jean-pierre.moreau.pagesperso-orange.fr/eqdiff.html
↧
↧
Euler-Romberg Method
'********************************************************************
'* Solve Y' = F(X,Y) with Initial Condition Y(X0)=Y0 using the *
'* Euler-Romberg Method *
'* ---------------------------------------------------------------- *
'* SAMPLE RUN: *
'* (Solve Y' = X*X*Y with Y(0)=1 for X0=0 up to Xn=1.1, exact *
'* solution is Y = Exp(X^3/3) ). *
'* *
'* X Y Y Error Number of *
'* estimated exact subdivisions *
'* ---------------------------------------------------------- *
'* 0.1 1.000333 1.000333 0.00000000 4 *
'* 0.2 1.002670 1.002670 0.00000001 4 *
'* 0.3 1.009041 1.009041 0.00000006 4 *
'* 0.4 1.021562 1.021562 0.00000014 4 *
'* 0.5 1.042547 1.042547 0.00000027 4 *
'* 0.6 1.074654 1.074655 0.00000086 4 *
'* 0.7 1.121125 1.121126 0.00000107 4 *
'* 0.8 1.186094 1.186095 0.00000126 4 *
'* 0.9 1.275067 1.275069 0.00000133 4 *
'* 1.0 1.395611 1.395612 0.00000114 4 *
'* 1.1 1.558410 1.558412 0.00000047 4 *
'* ---------------------------------------------------------- *
'* *
'* Ref.: "Methodes de calcul numerique By Claude Nowakowski, Tome 2 *
'* PSI Editions, France, 1981" [BIBLI 04]. *
'* *
'********************************************************************
'Program EulerRomberg
DefInt I-N
DefDbl A-H, O-Z
Option Base0
NMAX =100
H =0.1'initial integration step
ER =0.000001'desired precision
LA =10'maximum number of subdivisions
NC =10'number of calculations NC = (Xn+1 - X1)/H
Dim X(NMAX), Y(NMAX), T(20)
'Initial conditions
X(0)=0#: Y(0)=1#
'write header
Cls
Print" X Y Y Error Number of "
Print" estimated exact subdivisions "
Print"---------------------------------------------------------"
'main integration loop
For N =0To NC
XC = X(N): YC = Y(N)
XX = XC: YY = YC:GoSub1000
T(1)= Y(N)+ H * F
L =1: LM =2: ET =1#
While L < LA And ET >= ER
XC = X(N): YC = Y(N)
For J =1To LM
XC = XC + H / LM
XX = XC: YY = YC:GoSub1000
YC = YC + H / LM * F
Next J
T(L +1)= YC: M =1: K = L: MM =2: ET =1#
If K >1Then
While ET >= ER And K >1
T(K)=(MM * T(K +1)- T(K))/(MM -1)
ET =Abs(T(K)- T(K -1))
M = M +1: K = K -1: MM = MM *2
Wend
EndIf
If K =1Then
L = L +1: LM = LM *2
EndIf
Wend
X(N +1)= X(N)+ H: Y(N +1)= T(K)
XX = X(N +1):GoSub2000: YEX = FX
EF =Abs(YEX - Y(N +1))
Print USING;"###.#"; X(N +1);
Print USING;"#####.######"; Y(N +1);
Print USING;"#####.######"; YEX;
Print USING;"#####.########"; EF;
Print""; L
Next N
Print"---------------------------------------------------------"
End'of main program
'Y' = F(X,Y)
1000'Function F(XX,YY)
F = XX * XX * YY
Return
'Exact solution FX(XX)
2000'Function FX(XX)
FX =Exp(XX ^3/3)
Return
'end of file eulromb.bas
↧
Adams-Bashforth Method
'********************************************************************
'* Solve Y' = F(X,Y) with Initial Condition Y(X0)=Y0 using the *
'* Adams-Bashforth Method *
'* ---------------------------------------------------------------- *
'* REFERENCE: "Méthode de calcul numérique- Tome 2 - Programmes en *
'* Basic et en Pascal By Claude Nowakowski, Edition du *
'* P.S.I., 1984" [4]. *
'* ---------------------------------------------------------------- *
'* SAMPLE RUN: *
'* (Solve Y' = -Y + X/((1+X)*(1+X)) with Y(0)=1 for X0=0 up to *
'* X1=1.0, exact solution is Y = 1 / (1+X). *
'* *
'* X Y Y exact Error *
'* ----------------------------------------------- *
'* 0.000000 1.000000 1.000000 0 *
'* 0.000000 1.000000 1.000000 0.000000 *
'* 0.050000 0.952381 0.952381 0.000000 *
'* 0.100000 0.909091 0.909091 0.000000 *
'* 0.150000 0.869525 0.869565 0.000040 *
'* 0.200000 0.833265 0.833333 0.000068 *
'* 0.250000 0.799910 0.800000 0.000090 *
'* 0.300000 0.769125 0.769231 0.000106 *
'* 0.350000 0.740623 0.740741 0.000117 *
'* 0.400000 0.714160 0.714286 0.000125 *
'* 0.450000 0.689525 0.689655 0.000131 *
'* 0.500000 0.666533 0.666667 0.000134 *
'* 0.550000 0.645026 0.645161 0.000135 *
'* 0.600000 0.624865 0.625000 0.000135 *
'* 0.650000 0.605926 0.606061 0.000134 *
'* 0.700000 0.588103 0.588235 0.000133 *
'* 0.750000 0.571298 0.571429 0.000131 *
'* 0.800000 0.555428 0.555556 0.000128 *
'* 0.850000 0.540416 0.540541 0.000125 *
'* 0.900000 0.526194 0.526316 0.000121 *
'* 0.950000 0.512703 0.512821 0.000118 *
'* 1.000000 0.499886 0.500000 0.000114 *
'* ----------------------------------------------- *
'* *
'* Basic Release By J-P Moreau, Paris. *
'* (www.jpmoreau.fr) *
'********************************************************************
DefDbl A-H, O-Z
DefInt I-N
Option Base0
H =0.05'integration step
Dim B(4), X(4), Y(4)
'Initial conditions
X(0)=0#'starting X
X1 =1#'ending X
Y(0)=1#'initial Y
'write header
Cls
Print" X Y Y exact Error "
Print" ------------------------------------------------"
'write initial line
F$ ="#####.######"
Print USING; F$; X(0);
Print USING; F$; Y(0);
Print USING; F$; Y(0);
Print" 0"
'use Runge-Kutta to start
For K =0To1
GoSub1000'call RK4
XX = X(K +1):GoSub600: ER =Abs(FX - Y(K +1))
Print USING; F$; X(K +1);
Print USING; F$; Y(K +1);
Print USING; F$; FX;
Print USING; F$; ER
Next K
'main integration loop
While X(2)< X1
For I =1To3
XX = X(3- I): YY = Y(3- I):GoSub500
B(I)= F
Next I
X(3)= X(2)+ H
Y(3)= Y(2)+ H *(23#* B(1)-16#* B(2)+5#* B(3))/12#
XX = X(3):GoSub600: ER =Abs(Y(3)- FX)
Print USING; F$; X(3);
Print USING; F$; Y(3);
Print USING; F$; FX;
Print USING; F$; ER
For K =0To2
X(K)= X(K +1): Y(K)= Y(K +1)
Next K
Wend
Print" ------------------------------------------------"
End
'User defined function Y'=F(XX,YY)
500 F =-YY + XX /((1#+ XX)*(1#+ XX))
Return
'Exact solution Y=FX(XX)
600 FX =1#/(1#+ XX)
Return
'Runge-Kutta method to calculate first points only
1000 XX = X(K): YY = Y(K):GoSub500: C1 = F
XX = X(K)+ H /2#: YY = Y(K)+ H /2#* C1:GoSub500: C2 = F
XX = X(K)+ H /2#: YY = Y(K)+ H /2#* C2:GoSub500: C3 = F
XX = X(K)+ H: YY = Y(K)+ H * C3:GoSub500: C4 = F
X(K +1)= X(K)+ H
Y(K +1)= Y(K)+ H *(C1 +2* C2 +2* C3 + C4)/6#
Return
'end of file adambash.bas
EXPLANATION FILE OF PROGRAM ADAMBASH
====================================
Ordinary Differential Equations Y' = F(x,y)
-------------------------------------------
Linked Steps Method
-------------------
We have seen that Euler, Runge-Kutta... methods can be put under the general
form:
y = y + h phi(x , y , h)
n+1 n n n
and each point y of the solution is only determined from previous point, y
n+1 n
Calculations are made for y1, y2,...,yn-1, yn, yn+1... These methods are cal-
led "with separate steps": each step is independant from the previous one. To
obtain a given accuracy, each step has to be divided into intermediate steps.
Let us take an example:
For the Runge-Kutta method of order 4, we use the formulas:
k1 = h f(xn, yn)
k2 = h f(xn+h/2, yn+k1/2)
k3 = h f(xn+h/2, yn+k2/2)
k4 = h f(xn+h, yn+k3)
y = y + (1/6)(k1+2k2+2k3+k4)
n+1 n
Another method consists in using the previous calculations to improve speed;
the y point is evaluated from y , y and y points.
n+1 n n-1 n-2
The general formula is:
y = a y + a y + ... + a y
n+1 0 n 1 n-1 k n-k
+ h (b f + b f + b f + ... + b f
-1 n+1 0 n 1 n-1 k n-k
This can be written as:
k k
y = Sum a y + h Sum b f
n+1 j=0 j n-j j=-1 j n-j
These methods are called "with linked steps" and f(x,y) evaluations are only
made at points x0, x1, x2,..., xn.
If b = 0, the process is explicit; y is directly obtained by applying the
-1 n+1
formula.
If b <> 0, the process is implicit: we must solve an equation of the form
-1
y = phi(y ) to obtain y .
n+1 n+1 n+1
For the three first points, y1, y2, y3, we have no previous points to calcu-
late them: these methods cannot start by themselves like "with separate steps"
methods.
The truncation error Tn is estimated by using the Taylor formula for y(x )
n+j
(jh)² (jh)^p (p)
y(x ) = y(x ) + jhy'(x ) + ----- y"(x ) + ... + ------ y (x )
n+j n n 2! n p! n
+ h^p eps(h)
and also for f(x , y(x )):
n+j n+j
f(x , y(x )) = y'(x +jh)
n+j n+j n p-1
h (jh) (p)
= y'(x ) + j y"(x ) + ... + -------- y (x ) + h^p eps(h)
n n (p-1)! n
Example: let us estimate the truncation error for the implicit formula:
y = y + (h/2) (f + f )
n+1 n n+1 n
T = y(x ) - y
n+1 n+1 n+1
3
y(x ) = y(x ) + hy'(x ) + (h^2/2) y"(x ) + (h^3/3) y"'(x ) + h eps(h)
n+1 n n n n
2 3
(h/2) f = (h/2) y'(x + h) = (h/2) y'(x ) + (h /2) y"(x ) + (h /4)
n+1 n n n
3
y"'(x ) + h eps(h)
n
(h/2) f = (h/2) y'(x )
n n
Hence y(x ) - y = y(x ) - y + (h/2) (f + f ) =
n+1 n+1 n+1 n n+1 n
3 3
= (h /12) y"'(x ) + h eps(h)
n
Here the method is of order two.
The methods with separate steps can be integrated by the formula
xn+2h
y(x ) - y(x ) = Sum f(t,y(t)) dt
n+1 n-M xn
and by applying the Simpson's formula
b b - a a + h
Sum (f(t) dt = ----- {f(x) + 4f(-----) + f(b)}
a 6 2
Hence y - y = (h/3)[f + 4f + f ]
n+2 n n n+1 n+2
Here we have an implicit process.
In a more general way, knowing y , y , y , we can calculate f , f ,
n n-1 n-2 n n-1
f and approximate y' = f(x,y) by an interpolation polynomial at points
n-2
x , x , x :
n n-1 n-2 x
n+1
y = y + Sum P(x) dx
n+1 n-M x
n-M
where y is an approximation of y(x ) and y is an approximation of
n-M n-M n+1
y(x ).
n+1
In the case of an implicit method, y(x ) can be approximated by the formula:
n+1
x
p n+1
y = y + Sum P(x) dx
n+1 n-M x
n-M
p p
This allows evaluating f = f(x , y ) and we can resume the interpolation
n+1 n+1 n+1
step with a new polynomial P*(x). y is calculated by the correction formula
n+1
x
c n+1
y = y + Sum P*(x) dx
n+1 n-M x
n-M
As the points are equally spaced and indices are decreasing, xn, xn-1, xn-2...
we can use the Newton formula with back diferences:
Div (f ) = f - f
n n n-1
2
Div (f ) = f - 2f +f
n n n-1 n-2
--------------------------
k |k| |k| k
Div (f ) = f - | | f | | f +...+ (-1) f
n n |1| n-1 |2| n-2 n-k
Hence x 2
p n+1 Div(fn) Div (fn)
y = y + Sum [f + ------- (x-x ) + -------- (x-x )(x-x ) + ...
n+1 n-M x n h n 2h^2 n n-1
n-M
k
Div (fn)
+ -------- (x-x )(x-x )...(x-x )] dx
k! h^k n n-1 n-k+1
Let us put u = (x-x )/h, then du = dx/dh and
n 2
p 1 Div (fn)
y = y + Sum [f + Div(f )u + -------- u(u+1) + ...
n+1 n-M -M n n 2
k
Div (fn)
+ -------- u(u+1)(u+2)...(u+k-1) h du
k!
After integration:
p _ _ _ 2 _ k
y = y + h [P f + P Div(f ) + P Div (f ) + ... + P Div (f )]
n+1 n-M 0 n 1 n 2 n k n
_ 1 1
where P = -- Sum u(u+1)(u+2)...(u+j-1) du
j j! -M
j |j| |j| j
and Div (f ) = f - | | f | | f +...+ (-1) f
n n |1| n-1 |2| n-2 n-j
|j| j!
with | | = --------- (Newton's coefficients)
|m| m! (j-m)!
Fianally p
y = y
n+1 n-M + h [P f + P f + ... + P f ]
0 n 1 n-1 k n-k
Example: M=3, k=2
x 2
p n+1 Div(fn) Div (fn)
y = y + Sum [f + ------- (x-x ) + -------- (x-x )(x-x )] dx
n+1 n-3 x n n n 2h² n n-1
n-3
Let us put u = (x-xn)/h, then
2
p 1 Div (fn)
y = y + Sum [f + Div(f ) u + -------- u (u+1)] h du
n+1 n-3 -3 n n 2
After integration:
p 2
y = y + h [4f - 4 Div(f ) + (8/3)Div (f )
n+1 n-3 n n n
This leads to the Milne's formula (explicit process):
p
y = y + (4h/3) [2f - f + 2f ]
n+1 n-3 n n-1 n-2
We do in a similar way for the implicit process. For example, with M=1 and
k=2, the Milne's corrector formula is:
c
y = y + (h/3) [f + 4f + f ]
n+1 n-1 n+1 n n-1
This corresponds to the numerical integration of
x
n+1
Sum f(x) dx by the Simpson's method.
x
n-1
For the Adams-Moulton's implicit formulas, we have:
p h
k=1 y = y + - [3f - f ]
n+1 n 2 n n-1
c h
y = y + - [f + f ]
n+1 n 2 n+1 n
p h
k=2 y = y + -- [23f - 16f + 5f ]
n+1 n 12 n n-1 n-2
c h
y = y + -- [5f + 8f - f ]
n+1 n 12 n+1 n n-1
p h
k=3 y = y + -- [55f - 59f + 17f - 9f ]
n+1 n 24 n n-1 n-2 n-3
c h
y = y + -- [9f + 19f - 5f +f ]
n+1 n 24 n+1 n n-1 n-2
p h
k=4 y = y + --- [1901f - 2984f + 2616f - 1274f + 251f ]
n+1 n 720 n n-1 n-2 n-3 n-4
c h
y = y + --- [251f + 646f - 264f +106f - 19f ]
n+1 n 720 n+1 n n-1 n-2 n-3
In these formulas, the main part of what is left aside in the integration
corresponds to the truncation error.
3
c h "'
Example: for y = y + (h/2) (f + f ) - -- y (ksi)
n+1 n n+1 n 12
with x <= ksi <= x
n n+1
Another way to obtain an explicit or implicit process is using a recursive
formula:
y = a y + a y + ... + a y
n+1 0 n 1 n-1 k n-k
+ h [b f + b f + ... + b y ]
-1 n+1 0 n k n-k
For y, the polynomial of greatest degree is:
y(x) = 1, y'(x) = 0
y(x) = x, y'(x) = 1
y(x) = x², y'(x) = 2x
---------------------
m m-1
y(x) = x , y'(x) = mx
So
1 = a0 + a1 + ... + ak
x = (x-h)a + (x-2h)a + ... + ha + b +b + b + ... +b
0 1 k-1 -1 0 1 k
x² = (x-h)²a + (x-2h)²a + ... + ha
0 1 k-1
+ 2 [xb +(x-h)b + ... + hb
-1 0 k-1
--------------------------------------------------
l l l
x = (x-h) a + (x-2h) a + ... + ha
0 1 k-1
l-1 l-1
+ l [x b +(x-h) b + ... + hb
-1 0 k-1
Example: Nystroem's explicit formula:
3
y = y + h Sum b f
n+1 n-1 j=0 j n-j
3 2
y = x , y' = 3x
3 3
==> y = x , y = (x-2h)
n+1 n-1
2 2 2
f = y' = 3(x-h) , f = 3(x-2h) , f = 3(x-3h)
n n n-1 n-2
3 2 2 2 2
==> x = (x-2h) + 3h [b (x-h) + b (x-2h) + b (x-3h)
0 1 2
By developing and identifying:
b0 + b1 + b2 = 2
b0 + 2b1 +3b2 = 2
b0 + 4b1 + 9b2 = 8/3
We find: b0 = 7, b1 = -2, b2 = 1.
So we have the Adams's formulas:
Explicit, order 2: y = y + h/2 (3f - f )
n+1 n n n-1
order 3: y = y + h/12 (23f - 16f + 5f )
n+1 n n n-1 n-2
Implicit, order 2: y = y + h/2 (f + f )
n+1 n n+1 n
and Nystroem's formulas:
Explicit, order 2: y = y + 2h f
n+1 n-1 n
order 3: y = y + h/3 (7f - 2f + f )
n+1 n+1 n n-1 n-2
Implicit, order 3: y = y + h/12 (f + 4f -f )
n+1 n-1 n+1 n n-1
From [BIBLI 04].
------------------------------------------------
End of file adambash.txt
↧
Adams-Moulton Prediction-Correction Method
'********************************************************************
'* Solve Y' = F(X,Y) with initial conditions using the Adams- *
'* Moulton Prediction-Correction Method *
'* ---------------------------------------------------------------- *
'* SAMPLE RUN *
'* (Integrate Y' = -Y + X/(1+X)^2 from X=0 to X=1 with initial *
'* condition Y(0) = 1 ) *
'* *
'* X Y Y True |Y-Y True| *
'* --------------------------------------------- *
'* 0.000000 1.000000 1.000000 0.000000 *
'* 0.050000 0.952381 0.952381 0.000000 *
'* 0.100000 0.909091 0.909091 0.000000 *
'* 0.150000 0.869569 0.869565 0.000004 1 *
'* 0.200000 0.833340 0.833333 0.000006 1 *
'* 0.250000 0.800008 0.800000 0.000009 1 *
'* 0.300000 0.769241 0.769231 0.000010 1 *
'* 0.350000 0.740752 0.740741 0.000011 1 *
'* 0.400000 0.714298 0.714286 0.000012 1 *
'* 0.450000 0.689668 0.689655 0.000012 1 *
'* 0.500000 0.666679 0.666667 0.000013 1 *
'* 0.550000 0.645174 0.645161 0.000013 1 *
'* 0.600000 0.625013 0.625000 0.000013 1 *
'* 0.650000 0.606073 0.606061 0.000013 1 *
'* 0.700000 0.588248 0.588235 0.000013 1 *
'* 0.750000 0.571441 0.571429 0.000013 1 *
'* 0.800000 0.555568 0.555556 0.000012 1 *
'* 0.850000 0.540553 0.540541 0.000012 1 *
'* 0.900000 0.526327 0.526316 0.000012 1 *
'* 0.950000 0.512832 0.512821 0.000011 1 *
'* 1.000000 0.500011 0.500000 0.000011 1 *
'* ---------------------------------------------------------------- *
'* REFERENCE: "Méthode de calcul numérique- Tome 2 - Programmes en *
'* Basic et en Pascal By Claude Nowakowski, Edition du *
'* P.S.I., 1984". *
'* *
'* Quick Basic Release By J-P Moreau, Paris. *
'* (www.jpmoreau.fr) *
'********************************************************************
'See explanation file adambash.txt
'---------------------------------
DefInt I-N
DefDbl A-H, O-Z
Option Base0'index begins from zero
Dim X(3), Y(3)
H =0.05'integration step
X(0)=0#: Y(0)=1#'Initial conditions
EC =0.000001'Precision
F$ =" ##.###### ##.###### ##.###### ##.###### ##"
Cls
Print" X Y Y True |Y-Y True| "
Print" ---------------------------------------------"
Print USING; F$; X(0); Y(0); Y(0); X(0)
'Start with Runge-Kutta
For K =0To1
XX = X(K): YY = Y(K):GoSub1000: C1 = C
XX = X(K)+ H /2#: YY = Y(K)+ H /2#* C1:GoSub1000: C2 = C
YY = Y(K)+ H /2#* C2:GoSub1000: C3 = C
X(K +1)= X(K)+ H
XX = X(K +1): YY = Y(K)+ H * C3:GoSub1000: C4 = C
Y(K +1)= Y(K)+ H *(C1 +2* C2 +2* C3 + C4)/6#
XX = X(K +1):GoSub2000: ER =Abs(F - Y(K +1))
Print USING; F$; X(K +1); Y(K +1); F; ER
Next K
100 K =2
XX = X(K): YY = Y(K):GoSub1000: C1 = C
XX = X(K -1): YY = Y(K -1):GoSub1000: C2 = C
XX = X(K -2): YY = Y(K -2):GoSub1000: C3 = C
X(K +1)= X(K)+ H
YP = Y(K)+ H /12#*(23* C1 -16* C2 +5* C3)
L =0
200 XX = X(K +1): YY = YP:GoSub1000: C1 = C
XX = X(K): YY = Y(K):GoSub1000: C2 = C
XX = X(K -1): YY = Y(K -1):GoSub1000: C3 = C
YC = Y(K)+ H /12#*(5* C1 +8* C2 - C3)
'PRINT YC
IfAbs(YP - YC)> EC Then
YP = YC: L = L +1:GoTo200
EndIf
Y(K +1)= YC: XX = X(K +1):GoSub2000: ER =Abs(F - Y(K +1))
Print USING; F$; X(K +1); Y(K +1); F; ER; L
For K =0To2
X(K)= X(K +1): Y(K)= Y(K +1)
Next K
If X(2)<1#Then
GoTo100
EndIf
End
1000 C =-YY + XX /((1#+ XX)^2)
Return
2000 F =1#/(1#+ XX)
Return
↧
↧
Runge-Kutta method of order 4
'********************************************************************
'* Differential equations with p variables of order 1 *
'* by Runge-Kutta method of order 4 *
'* ---------------------------------------------------------------- *
'* Reference: "Analyse en Turbo Pascal versions 5.5 et 6.0 by Marc *
'* DUCAMP et Alain REVERCHON - Eyrolles, Paris 1991" *
'* *
'* Basic version 1.1 By J-P Moreau, Paris *
'* (www.jpmoreau.fr) *
'* ---------------------------------------------------------------- *
'* SAMPLE RUN: *
'* *
'* Example #1: integrate system of equations from x=0 to x=3: *
'* y1' = y2 + y3 - 3*y1 *
'* y2' = y1 + y3 - 3*y2 *
'* y3' = y1 + y2 - 3*y3 *
'* with initial conditions: y1(0)=1, y2(0)=2 and y3(0)=-1 *
'* *
'* *
'* DIFFERENTIAL EQUATION WITH P VARIABLE OF ORDER 1 *
'* of type yi' = f(y1,y2,...,yn), i=1..n *
'* *
'* number of variables: 3 *
'* begin value x : 0 *
'* end value x : 3 *
'* y1 value at x0 : 1 *
'* y2 value at x0 : 2 *
'* y3 value at x0 : -1 *
'* number of points : 7 *
'* finesse : 30 *
'* *
'* X Y1 Y2 Y3 *
'* -------------------------------------------------------- *
'* 0.000000 1.000000 2.000000 -1.000000 *
'* 0.500000 0.449466 0.584801 0.178795 *
'* 1.000000 0.251358 0.269674 0.214727 *
'* 1.500000 0.149580 0.152058 0.144622 *
'* 2.000000 0.090335 0.090671 0.089664 *
'* 2.500000 0.054738 0.054784 0.054648 *
'* 3.000000 0.033193 0.033200 0.033181 *
'* -------------------------------------------------------- *
'* *
'* Example #2: integrate system of equations from x=0 to PI*Sqrt(2) *
'* y1' = y2 *
'* y2' = -4*y1 - 3*y3 *
'* y3' = y4 *
'* y4' = -8*y1 - 2*y3 *
'* with initial conditions: y1(0)=3, y2(0)=0, y3(0)=4, y4(0)=0 *
'* *
'* *
'* DIFFERENTIAL EQUATION WITH P VARIABLE OF ORDER 1 *
'* of type yi' = f(y1,y2,...,yn), i=1..n *
'* *
'* number of variables: 4 *
'* begin value x : 0 *
'* end value x : 4.442883 *
'* y1 value at x0 : 3 *
'* y2 value at x0 : 0 *
'* y3 value at x0 : 4 *
'* y4 value at x0 : 0 *
'* number of points : 9 *
'* finesse : 30 *
'* *
'* X Y1 Y2 Y3 Y4 *
'* -------------------------------------------------------- *
'* 0.000000 3.000000 0.000000 4.000000 0.000000 *
'* 0.555360 0.000000 -8.485281 0.000000 -11.313708 *
'* 1.110721 -3.000000 -0.000001 -4.000000 -0.000002 *
'* 1.666081 -0.000001 8.485281 -0.000001 11.313708 *
'* 2.221442 3.000000 0.000003 4.000000 0.000003 *
'* 2.776802 0.000001 -8.485281 0.000002 -11.313708 *
'* 3.332162 -3.000000 -0.000004 -4.000000 -0.000005 *
'* 3.887523 -0.000002 8.485281 -0.000002 11.313708 *
'* 4.442883 3.000000 0.000005 4.000000 0.000007 *
'* -------------------------------------------------------- *
'* *
'* Release 1.1: Added example #2 (Sept. 2008). *
'********************************************************************
DefInt I-N
DefDbl A-H, O-Z
'ifi,ip : INTEGER
Dim y(10), yi(10), t1(50), t2(50), t3(50), t4(50)
Cls
Print" DIFFERENTIAL EQUATIONS WITH P VARIABLES OF ORDER 1"
Print" of type yi' = f(y1,y2,...,yn), i=1..n"
PRINT" number of variables : ";:INPUT ip
PRINT" begin value x : ";:INPUT xi
PRINT" end value x : ";:INPUT xf
For i =0To ip -1
PRINT" y"; i +1;" value at x0 : ";:INPUT yi(i)
Next i
PRINT" number of points : ";:INPUT m
PRINT" finesse : ";:INPUT ifi
'call subroutine eqdifp
GoSub2000
End
'Example #1: y1'=y2+y3-3y1, y2'=y1+y3-3y2, y3'=y1+y2-3y3
'1000 'FUNCTION fp
' IF k = 0 THEN
' fp = y(1) + y(2) - 3# * y(0)
' ELSEIF k = 1 THEN
' fp = y(0) + y(2) - 3# * y(1)
' ELSEIF k = 2 THEN
' fp = y(0) + y(1) - 3# * y(2)
' ELSE
' fp = 0#
' END IF
'RETURN
'Example #2: y1'=y2, y2'=-4y1-3y3, y'3=y4, y'4=-8y1-2y3
1000'FUNCTION fp
If k =0Then
fp = y(1)
ElseIf k =1Then
fp =-4#* y(0)-3#* y(2)
ElseIf k =2Then
fp = y(3)
ElseIf k =3Then
fp =-8#* y(0)-2#* y(2)
Else
fp =0#
EndIf
Return
'****************************************************************************
'* SOLVING DIFFERENTIAL SYSTEMS WITH P VARIABLES OF ORDER 1 *
'* of type yi' = f(y1,y2,...,yn), i=1..n *
'* ------------------------------------------------------------------------ *
'* INPUTS: *
'* m number of points to calculate *
'* xi, xf begin, end values of variable x *
'* yi table of begin values of functions at xi *
'* ip number of independant variables *
'* ifi finesse (number of intermediary points) *
'* *
'* OUTPUTS: *
'* t1,t2 real vectors storing the results for first two functions, *
'* y1 and y2. *
'* ------------------------------------------------------------------------ *
'* EXAMPLE: y1'=y2+y3-3y1, y2'=y1+y3-3y2, y3'=y1+y2-3y3 *
'* Exact solution : y1 = 1/3 (exp(-4x) + 2 exp(-x)) *
'* y2 = 1/3 (4exp(-4x) + 2 exp(-x)) *
'* y3 = 1/3 (-5exp(-4x)+ 2 exp(-x)) *
'****************************************************************************
2000'subroutine Eqdifp
Dim ta(10), tb(10), tc(10), td(10), z(10)
h =(xf - xi)/ ifi /(m -1)
ip = ip -1
t1(1)= yi(0)
t2(1)= yi(1)
t3(1)= yi(2)
t4(1)= yi(3)
For k =0To ip
y(k)= yi(k): z(k)= yi(k)
Next k
For i =1To m
ni =(i -1)* ifi -1
For j =1To ifi
X = xi + h *(ni + j)
For k =0To ip
y(k)= z(k)
Next k
For k =0To ip
GoSub1000
ta(k)= h * fp
Next k
For k =0To ip
y(k)= z(k)+ ta(k)/2#
Next k
X = X + h /2#
For k =0To ip
GoSub1000
tb(k)= h * fp
Next k
For k =0To ip
y(k)= z(k)+ tb(k)/2#
Next k
For k =0To ip
GoSub1000
tc(k)= h * fp
Next k
For k =0To ip
y(k)= z(k)+ tc(k)
Next k
X = X + h /2#
For k =0To ip
GoSub1000
td(k)= h * fp
Next k
For k =0To ip
z(k)= z(k)+(ta(k)+2#* tb(k)+2#* tc(k)+ td(k))/6#
Next k
Next j
t1(i +1)= z(0)
t2(i +1)= z(1)
t3(i +1)= z(2)
t4(i +1)= z(3)
Next i
'Display(t1,t2,t3,t4,m,p,xi,xf)
GoSub3000
Return
3000'subroutine Display
h =(xf - xi)/(m -1)
X = xi - h
Print" X";
For i =1To ip +1
Print" Y"; i;
Next i
Print"--------------------------------------------------------"
For i =1To m
X = X + h
If ip =1Then
Print USING;" ##.###### ##.###### ##.######"; X; t1(i); t2(i)
ElseIf ip =2Then
Print USING;" ##.###### ##.###### ##.###### ##.######"; X; t1(i); t2(i); t3(i)
ElseIf ip >2Then
Print USING;" ##.###### ##.###### ##.###### ##.###### ###.######"; X; t1(i); t2(i); t3(i); t4(i)
EndIf
Next i
Print"--------------------------------------------------------"
Return
'End of file teqdifp.bas
↧
The Runge-Kutta Method
'********************************************************************
'* Differential equations of order 1 *
'* by Runge-Kutta method of order 4 *
'* *
'* Basic version by J-P Moreau, Paris *
'* (www.jpmoreau.fr) *
'* ---------------------------------------------------------------- *
'* Reference: "Analyse en Turbo Pascal versions 5.5 et 6.0 By Marc *
'* DUCAMP et Alain REVERCHON - Eyrolles, Paris 1991" *
'* [BIBLI 03]. *
'* ---------------------------------------------------------------- *
'* SAMPLE RUN: *
'* *
'* Example: integrate y'=4x*(y+sqrt(y))/1+x^2 from x=0 to x=1 *
'* *
'* DIFFERENTIAL EQUATION WITH 1 VARIABLE OF ORDER 1 *
'* of type y' = f(x,y) *
'* *
'* begin value x : ? 0 *
'* end value x : ? 1 *
'* y value at x0 : ? 1 *
'* number of points: ? 11 *
'* finesse : ? 10 *
'* *
'* X Y *
'* ------------------------- *
'* 0.000000 1.000000 *
'* 0.100000 1.040400 *
'* 0.200000 1.166400 *
'* 0.300000 1.392400 *
'* 0.400000 1.742400 *
'* 0.500000 2.250000 *
'* 0.600000 2.958400 *
'* 0.700000 3.920400 *
'* 0.800000 5.198400 *
'* 0.900000 6.864400 *
'* 1.000000 9.000000 *
'* *
'********************************************************************
DefInt I-N
DefDbl A-H, O-Z
'ifi:INTEGER
Cls
Print" DIFFERENTIAL EQUATION WITH 1 VARIABLE OF ORDER 1"
Print" of type y' = f(x,y)"
print" begin value x : ";:input xi
print" end value x : ";:input xf
print" y value at x0 : ";:input yi
print" number of points: ";:input m
print" finesse : ";:input ifi
Dim t(m +1)
'equadiff1(fp,t,xi,xf,yi,m,ifi)
GoSub2000
End
1000'Example: y'=4x(y+rac(y))/(1+x²)
fp =4#* xx *(yy +Sqr(yy))/(1#+ xx * xx)
Return
'***************************************************************************
'* SOLVING DIFFERENTIAL EQUATIONS WITH 1 VARIABLE OF ORDER 1 *
'* of type y' = f(x,y) *
'* ----------------------------------------------------------------------- *
'* INPUTS: *
'* fp Given equation to integrate (see test program) *
'* xi, xf Begin, end values of variable x *
'* yi Begin Value of y at x=xi *
'* m Number of points to calculate *
'* fi finesse (number of intermediate points) *
'* *
'* OUTPUTS: *
'* t : real vector storing m results for function y *
'***************************************************************************
2000'Subroutine Equadiff1
If ifi <1ThenReturn
h =(xf - xi)/ ifi /(m -1)
Y = yi
t(1)= yi
For i =1To m
ni =(i -1)* ifi -1
For j =1To ifi
X = xi + h *(ni + j)
xx = X: yy = Y
GoSub1000'calculate current fp(x,y)
a = h * fp
xx = X + h /2#: yy = Y + a /2#
GoSub1000'calculate fp(x+h/2,y+a/2)
B = h * fp
yy = Y + B /2#
GoSub1000'calculate fp(x+h/2,y+b/2)
c = h * fp
X = X + h
xx = X: yy = Y + c
GoSub1000'calculate fp(x,y+c)
d = h * fp
Y = Y +(a + B + B + c + c + d)/6
Next j
t(i +1)= Y
Next i
'Affiche(t,m,xi,xf)
GoSub3000
Return
3000'Subroutine Affiche
h =(xf - xi)/(m -1)
X = xi - h
Cls
Print" X Y "
Print"----------------------"
For i =1To m
X = X + h
Print using;" ##.###### ##.######"; X; t(i)
Next i
Return
'End of file teqdif1.bas
EXPLANATION FILE OF PROGRAM TEQUDIF1
====================================
The Runge-Kutta Method
----------------------
We present here the Runge-Kutta method of order 4 to integrate an ODE
of order 1: Y' = F(X, Y)
The development of Y around x coincidates with its Taylor development
n
of order 4:
y = y + h y' + (h^2/2) y" + (h^3/6) y"' + (h^4/24) y""
n+1 n n n n n
Other orders may also be used for the Runge-Kutta method, for instance
the Euler's method is a Runge-Kutta of order one.
Order 4 is often used because it is a good compromise between speed and
accuracy.
From a current point (x , y ), the next point is determined by:
n n
K = h f(x , y )
0 n n
k = h f(x + h/2, y + K /2)
1 n n 0
k = h f(x + h/2, y + K /2)
2 n n 1
k = h f(x + h, y + K )
3 n n 2
and y = y + (1/6)(K + 2 K + K )
n+1 n 0 1 3
It can be proved that the error at each step is about h^5.
The only drawback is the time of calculation: at each step, four function
evaluations are necessary.
From [BIBLI 03].
-------------------------------------------------------------
End of file rkutta.txt.
↧
A Chart Class for VB6
Another project from Olaf ! The man no longer needs introduction !
Download from me
Download from source
![]()
![]()
![]()
By
Olaf
Source: VBForums
Download from me
Download from source
Although the contained cChart-Class is able to render any x,y-ValuePairs - often one has to handle and store "timestamp-based Data", as e.g. from a "Stock-Exchange-Ticker" (when the y-Values are Prices) - or from a "Data-Logger" of a measurement-device (where y-Data comes in as more "physically related units". Though in both cases we have some kind of time-values in the x-Members of the x,y-Pairs - and the amount of data can get quite large "over time". So, a DB-based storage is not only useful to "archive and persist" such x,y-Pairs (on Disk) - it is also useful, to make use of "time-range-queries". These are usually queries which start from the most recent TimeStamp-Value in the DB-Table, then covering a certain range "to the left of this RightMost-x,y-Pair". E.g. "Show me a Chart for all the Values in the last hour" (or the last day, or the last week, etc.). Now one might say: "Yeah - a DB and SQL-queries would be nicer to use - but for my small project . I don't want to introduce a DB-Engine, just for more comfortable Charting..."
Well, and this is the scenario where an InMemory-DB makes sense - offering all of the benefits of a full DB-Engine, at basically no cost - later on (in case persisting of the Data on Disk becomes a topic) - the App would be upgradable to a filebased-DB just by changing the DB-Creation-Line. What's nice with DB-Engines in general, is that they offer a robust and convenient way, to perform "grouping aggregations" - which is useful for Charting, in case one wants to visualize trends, averages, Min- and Max-Values etc. With SQL one can handle such tasks quite nicely and efficient in one single statement, as e.g. this one here, which I used in the Demo, to do Grouping on the x.y-Pairs with regards to Average, Min- and Max-Values - and the time-range (starting from a MaxDate, then reaching parts - or multiples - of HoursBack into the DataStorage. Important for InMemory-Usage of DB-Engines is, that they can be filled with Data fast (being roughly at "Dictionary-Level") - and with SQLite that is a given, as the following ScreenShot shows ... second-based values of two full days (2*86400) were transferred into the DB in about 370msec, included in this case also the time, to create an index on the TimeStamp-column. The above ScreenShot shows also, how the Min- Max-and Avg-Values are rendered finally - due to the index we build at the time of data-import, we can then perform fast querying and rendering in typically 10-30msec per complete Chart. Below is another Picture, which shows the timing, needed for both (querying and rendering), and at this occasion also how the same Data will be rendered with cChart, when certain Options are changed (no BSpline, no Min-Values, no Max-Values - note the automatic scaling of the Y-Axis, which now covers a different value-range):
So, yeah - and as is normal for RichClient-based code, the whole thing is quite compact - cChart.cls, as well as the second Code-Module (fMain.frm) contain both less than 100 lines of code... have fun adapting it to your needs.
By
Olaf
Source: VBForums
↧
Implicit Gear method of order 4
DECLARE SUB SWAP1 (a#, b#)
DECLARE FUNCTION det#(n%, xmat#())
DECLARE FUNCTION XNormMax#(vektor#(), n%)
DECLARE SUB settxt (bspn ASINTEGER, n%, dgltxt$())
DECLARE SUB gear4 (x#, xend#, bspn ASINTEGER, n%, y#(), epsabs#, epsrel#, h#,
fmax ASINTEGER, aufrufe ASINTEGER, fehler ASINTEGER)
DECLARE FUNCTION DistMax#(vector1#(), vector2#(), n%)
DECLARE SUB ruku23 (x#, y#(), bspn ASINTEGER, n%, h#, y2#(), y3#())
DECLARE SUB dgl (bspn ASINTEGER, n%, x#, y#(), f#())
DECLARE SUB engl45 (x#, y#(), bspn ASINTEGER, n%, h#, y4#(), y5#())
DECLARE SUB prdo45 (x#, y#(), bspn ASINTEGER, n%, h#, y4#(), y5#(),
steif1 ASINTEGER, steifanz ASINTEGER, steif2 ASINTEGER)
DECLARE SUB awp (x#, xend#, bspn ASINTEGER, n%, y#(), epsabs#, epsrel#, h#,
methode%, fmax ASINTEGER, aufrufe ASINTEGER, fehler ASINTEGER)
DECLARE FUNCTION XMax#(a#, b#)
DECLARE FUNCTION XMin#(a#, b#)
DECLARE SUB ISWAP (ia%, ib%)
DECLARE SUB gauss (mode%, n%, xmat#(), xlumat#(), iperm%(), b#(), x#(),
signd ASINTEGER, code ASINTEGER)
DECLARE SUB gaudec (n%, xmat#(), xlumat#(), iperm%(), signd ASINTEGER, rc ASINTEGER)
DECLARE SUB gausol (n%, xlumat#(), iperm%(), b#(), x#(), rc ASINTEGER)
'************************************************************************
'* Solve a first order Stiff System of Differential Equations using *
'* the implicit Gear method of order 4. *
'* -------------------------------------------------------------------- *
'* Mode of operation: *
'* ================== *
'* This program can solve two of the 11 examples of file t_dgls using *
'* the implicit Gear method of order 4 (see file gear.pas). *
'* To test other systems of DEs, please proceed as explained in file *
'* t_dgls.pas. *
'* *
'* Inputs: *
'* ======= *
'* bspnummer Number of DE system from t_dgls.pas *
'* epsabs desired absolute error bound *
'* epsrel desired relative error bound *
'* x0 left edge of integration *
'* y0[0] \ known approximation for the solution at x0 *
'* .. . > *
'* y0[n-1] / *
'* h initial step size *
'* xend right endpoint of integration *
'* fmax maximal number of calls of the right hand side *
'* *
'* The size n of the DE system is passed on from t_dgls.bas. *
'* -------------------------------------------------------------------- *
'* SAMPLE RUN *
'* *
'* Example #1: *
'* (Solve set of differential equations (n=2): *
'* f[0] = y[0] * y[1] + COS(x) - HALF * SIN(TWO * x); *
'* f[1] = y[0] * y[0] + y[1] * y[1] - (ONE + SIN(x)); *
'* Find values of f(0), f(1) at x=1.5). *
'* *
'* Input example number (0 to 11): 0 *
'* abs. epsilon: 1e-6 *
'* rel. epsilon: 1e-8 *
'* x0: 0 *
'* y0[0]: 0.5 *
'* y0[1]: 0.5 *
'* initial step size h: 0.0001 *
'* right edge xend: 1.5 *
'* maximal number of calls of right hand side: 6000 *
'* *
'* Input data: *
'* ----------- *
'* Example # 0 *
'* Number of DEs = 2 *
'* x0 = 0 *
'* xend = 1.5 *
'* epsabs = 0.000001 *
'* epsrel = 0.00000001 *
'* fmax = 6000 *
'* h = 0.0001 *
'* y0(0) = 0.5 *
'* y0(1) = 0.5 *
'* *
'* Output data: *
'* ------------ *
'* error code from gear4: 0 *
'* final local step size: 6.06783655109067E-02 *
'* number of calls of right hand side: 360 *
'* Integration stopped at x = 1.5 *
'* *
'* approximate solution y1(x) = 1.23598612893281 *
'* approximate solution y2(x) = -0.104949617987246 *
'* *
'* Example #2: *
'* (Solve set of differential equations (n=5): *
'* f[0] = y[1]; *
'* f[1] = y[2]; *
'* f[2] = y[3]; *
'* f[3] = y[4]; *
'* f[4] = ((REAL)45.0 * y[2] * y[3] * y[4] - *
'* (REAL)40.0 * y[3] * y[3] * y[3]) / (NINE * y[2] * y[2]); *
'* Find values of f(0), ..., f(4) at x=1.5). *
'* *
'* Input example number (0 to 11): 3 *
'* abs. epsilon: 1e-10 *
'* rel. epsilon: 1e-10 *
'* x0: 0 *
'* y0[0]: 1 *
'* y0[1]: 1 *
'* y0[2]: 1 *
'* y0[3]: 1 *
'* y0[4]: 1 *
'* initial step size h: 0.001 *
'* right edge xend: 1.5 *
'* maximal number of calls of right hand side: 6000 *
'* *
'* Input data: *
'* ----------- *
'* Example # 3 *
'* Number of DEs = 5 *
'* x0 = 0 *
'* xend = 1.5 *
'* epsabs = 0.0000000001 *
'* epsrel = 0.0000000001 *
'* fmax = 6000 *
'* h = 0.001 *
'* y0[0] = 1 *
'* y0[1] = 1 *
'* y0[2] = 1 *
'* y0[3] = 1 *
'* y0[4] = 1 *
'* *
'* Output data: *
'* ------------ *
'* error code from gear4: 0 *
'* final local step size: 4.86347661993806E-03 *
'* number of calls of right hand side: 3423 *
'* Integration stopped at x = 1.5 *
'* *
'* approximate solution y1(x) = 4.36396102990278 *
'* approximate solution y2(x) = 4.00000000763431 *
'* approximate solution y3(x) = 2.82842715661993 *
'* approximate solution y4(x) = 4.86163232512205E-08 *
'* approximate solution y5(x) = -3.7712362229557 *
'* *
'* -------------------------------------------------------------------- *
'* REF.: "Numerical Algorithms with C, By Gisela Engeln-Muellges *
'* and Frank Uhlig, Springer-Verlag, 1996" [BIBLI 11]. *
'* *
'* Quick Basic Release By J-P Moreau, Paris. *
'* (www.jpmoreau.fr) *
'************************************************************************
DefDbl A-H, O-Z
DefInt I-N
Option Base0
' epsabs, absolute error bound
' epsrel, relative error bound
' x0 left edge of integration interval
' y0 (0:n-1)-vector initial values
' yex(0:n-1)-vector exact solution (when given)
' h initial, final step size
' xend right edge of integration interval
Dim fmax AsInteger' maximal number of calls of right side in gear4
Dim aufrufe AsInteger' actual number of function calls
Dim bspnummer AsInteger' # example
' n ' number of DEs in system (see t_dlgs.bas)
Dim fehler AsInteger' error code from subroutine gear4
Dim dgltxt$(5)' text of equations
' -------------------- read input --------------------
Cls
INPUT" Example number (0 to 11): ", bspnummer
If bspnummer <>0 And bspnummer <>3Then
Print" Example not registered."
End'stop program
EndIf
' input absolute and relative errors
INPUT" epsabs = ", epsabs
INPUT" epsrel = ", epsrel
' input x starting value
INPUT" x0 = ", x0
Call settxt(bspnummer, n, dgltxt$())'read text of equations
'and parameter n
' allocate memory for vectors y0, yex
Dim y0(n)
Dim yex(n)
' input initial values y0(i)
' y0(0) = 0.5: y0(1) = 0.5 (Ex. 0)
For i =0To n -1
PRINT" y0("; i;") = ";:INPUT"", y0(i)
Next i
' input initial step size
INPUT" h = ", h
' input ending x value
INPUT" xend = ", xend
' input maximum number of calls to right hand side
INPUT" fmax = ", fmax
' ----------------- print input data ----------------------
Cls
Print" =============================================="
Print" Solve a first order ordinary system of DEs "
Print" using the implicit method of Gear of 4th order"
Print" =============================================="
Print" System of DEs:"
Print" ------------- "
For i =0To n -1
Print""; dgltxt$(i)
Next i
Print" Example # "; bspnummer
Print" Number of DEs = "; n
Print" x0 = "; x0
Print" xend = "; xend
Print" epsabs = "; epsabs
Print" epsrel = "; epsrel
Print" fmax = "; fmax
Print" h = "; h
For i =0To n -1
Print" y0("; i;") = "; y0(i)
Next i
' ------------------- Solve system of DEs ------------------------------
gear4 x0, xend, bspnummer, n, y0(), epsabs, epsrel, h, fmax, aufrufe, fehler
If fehler <>0Then'something went wrong
Print" Gear4: error nø ";10+ fehler
End'stop program
EndIf
' ---------------------- print results ---------------------
Print" Output data:"
Print" -----------"
Print" error code from gear4: "; fehler
Print" final local step size: "; h
Print" number of calls of right hand side: "; aufrufe
Print" Integration stopped at x = "; x0
For i =0To n -1
Print" approximate solution y"; i +1;"(x) = "; y0(i)
Next i
End'of main program
'************************************************************************
'* *
'* Solve an ordinary system of first order differential equations using *
'* -------------------------------------------------------------------- *
'* automatic step size control *
'* ---------------------------- *
'* *
'* Programming language: ANSI C *
'* Author: Klaus Niederdrenk (FORTRAN) *
'* Adaptation: Juergen Dietel, Computer Center, RWTH Aachen *
'* Source: existing C, Pascal, QuickBASIC and FORTRAN *
'* codes *
'* Date: 6.2.1992, 10.2.1995 *
'* *
'* Quick Basic Release By J-P Moreau, Paris. *
'* -------------------------------------------------------------------- *
'* REF.: "Numerical Algorithms with C, by Gisela Engeln-Muellges *
'* and Frank Uhlig, Springer-Verlag, 1996". *
'************************************************************************
' 1st order DESs with automatic step size control ...........................
Sub awp(x, xend, bspn AsInteger, n, y(), epsabs, epsrel, h, methode, fmax AsInteger, aufrufe AsInteger, fehler AsInteger)
' double x, initial/final x value ..............
' xend desired end point ..................
' integer bspn, # example
' n number of DEs ......................
' double y(0:n-1), initial/final y value ..............
' epsabs, absolute error bound ...............
' epsrel, relative error bound ...............
' h initial/final step size ............
' integer methode, desired method (3, 6, 7) ...........
' fmax, maximal # of calls of dgl() .......
' aufrufe, actual # of calls of dgl() ........
' fehler error code .........................
'************************************************************************
'* Compute the solution y of a system of first order ordinary *
'* differential equations y' = f(x,y) at xend from the given *
'* initial data (x0, y0). *
'* We use automatic step size control internally so that the error of *
'* y (absolutely or relatively) lies within the given error bounds *
'* epsabs and epsrel. *
'* *
'* Input parameters: *
'* ================= *
'* x initial value for x *
'* y initial values for y(0:n-1) *
'* bspn # example *
'* n number of differential equations *
'* dgl function that evaluates the right hand side of the system *
'* y' = f(x,y) (see t_dgls) (Removed from list of parameters) *
'* xend end of integration; xend > x0 *
'* h initial step size *
'* epsabs absolute error bound; >= 0; if = 0 we only check the *
'* relative error. *
'* epsrel relative error bound; >= 0; if = 0 we check only the *
'* absolute eror. *
'* fmax max number of evaluations of right hand side in dgl() *
'* methode chooses the method *
'* = 3: Runge-Kutta method of 2nd/3rd order *
'* = 6: England formula of 4th/5th order *
'* = 7: Formula of Prince-Dormand of 4th/5th order *
'* *
'* Output parameters: *
'* ================== *
'* x final x-value for iteration. If fehler = 0 we usually have *
'* x = xend. *
'* y final y-values for the solution at x *
'* h final step size used; leave for subsequent calls *
'* aufrufe actual number of calls of dgl() *
'* *
'* Return value (fehler): *
'* ===================== *
'* = 0: all ok *
'* = 1: both error bounds chosen too small for the given mach. constant *
'* = 2: xend <= x0 *
'* = 3: h <= 0 *
'* = 4: n <= 0 *
'* = 5: more right hand side calls than allowed: aufrufe > fmax, *
'* x and h contain the current values when stop occured. *
'* = 6: improper input for embedding formula *
'* = 7: lack of available memory (not used here) *
'* = 8: Computations completed, but the Prince Dormand formula stiff- *
'* ness test indicates possible stiffness. *
'* = 9: Computations completed, but both Prince Dormand formula stiff- *
'* ness tests indicate possible stiffness. Use method for stiff *
'* systems instead ' *
'* =10: aufrufe > fmax, see error code 5; AND the Prince Dormand formula*
'* indicates stiffness; retry using a stiff DE solver ' *
'* *
'************************************************************************
Dim MachEps AsDouble
Dim MACH2 AsDouble
Dim MACH1 AsDouble'machine constant dependent variable which
'avoids using too little steps near xend.
Dim xendh AsDouble'|xend| - MACH2, carrying same sign as xend
Dim ymax AsDouble'Maximum norm of newest approximation of max
'order.
Dim hhilf AsDouble'aux storage for the latest value of h
'produced by step size control. It is saved
'here in order to avoid to return a `h' that
'resulted from an arbitrary reduction at the
'end of the interval.
Dim diff AsDouble'distance of the two approximations from the
'embedding formula.
Dim s AsDouble'indicates acceptance level for results from
'embeding formula.
'approximate solution of low order
Dim ybad(n)
'ditto of high order
Dim ygood(n)
Dim amEnde AsInteger'flag that shows if the end of the interval
'can be reached with the actual step size.
Dim fertig AsInteger'flag indicating end of iterations.
Dim steif1 AsInteger'Flag, that is set in prdo45() if its
'stiffness test (dominant eigenvalue)
'indicates so. Otherwise no changes.
Dim steifanz AsInteger'counter for number of successive successes
'of stiffness test of Shampine and Hiebert in
'prdo45().
Dim steif2 AsInteger'Flag, set in prdo45(), when the stiffness
'test of Shampine and Hiebert wa successful
'three times in a row; otherwise no changes.
'initialize some variables
fehler =0
MachEps =1.2E-16
MACH2 =100* MachEps
MACH1 = MachEps ^0.75
amEnde =0
fertig =0
steif1 =0
steif2 =0
steifanz =0
aufrufe =1
ymax = XNormMax(y(), n)
If xend >=0#Then
xendh = xend *(1#- MACH2)
Else
xendh = xend *(1#+ MACH2)
EndIf
' ----------------------- check inputs ----------------------
If epsabs <= MACH2 * ymax And epsrel <= MACH2 Then
fehler =1
ExitSub
EndIf
If xendh < x Then
fehler =2
ExitSub
EndIf
If h < MACH2 *Abs(x)Then
fehler =3
ExitSub
EndIf
If n <=0Then
fehler =4
ExitSub
EndIf
If methode <>3 And methode <>6 And methode <>7Then
fehler =6
ExitSub
EndIf
' **********************************************************************
' * *
' * I t e r a t i o n s *
' * *
' **********************************************************************
If x + h > xendh Then
'almost at end point ?
hhilf = h 'A shortened step might be
h = xend - x 'enough.
amEnde =1
EndIf
While fertig =0'solve DE system by integrating from
'x0 to xend by suitable steps.
'choose method
If methode =3Then
Call ruku23(x, y(), bspn, n, h, ybad(), ygood())
ElseIf methode =6Then
Call engl45(x, y(), bspn, n, h, ybad(), ygood())
ElseIf methode =7Then
Call prdo45(x, y(), bspn, n, h, ybad(), ygood(), steif1, steifanz, steif2)
EndIf
aufrufe = aufrufe + methode
diff = DistMax(ybad(), ygood(), n)
If(diff < MACH2)Then'compute s
s =2#
Else
ymax = XNormMax(ygood(), n)
s =Sqr(h *(epsabs + epsrel * ymax)/ diff)
If methode <>3Then s =Sqr(s)
EndIf
If s >1#Then'integration acceptable ?
For i =0To n -1'accept highest order solution
y(i)= ygood(i)'move x
Next i
x = x + h
If amEnde <>0Then'at end of interval ?
fertig =1'stop iteration
If methode =7Then
If steif1 >0 Or steif2 >0Then fehler =8
If steif1 >0 And steif2 >0Then fehler =9
EndIf
ElseIf aufrufe > fmax Then'too many calls of dgl() ?
hhilf = h 'save actual step size
fehler =5'report error and stop
fertig =1
If methode =7 And (steif1 >0 Or steif2 >0)Then fehler =10
Else'Integration was successful
'not at the interval end ?
h = h * XMin(2#,0.98* s)'increase step size for next
'step properly, at most by
'factor two. Value `0.98*s' is
'used in order to avoid that
'the theoretical value s is
'exceeded by accidental
'rounding errors.
If x + h > xendh Then'nearly reached xend ?
hhilf = h '=> One further step with
h = xend - x 'reduced step size might be
amEnde =1'enough.
If h < MACH1 *Abs(xend)Then'very close to xend ?
fertig =1'finish iteration.
EndIf
EndIf
EndIf
Else'step unsuccessful ?
'before repeating this step
h = h * XMax(0.5,0.98* s)'reduce step size properly, at
'most by factor 1/2 (for factor
amEnde =0'0.98: see above).
EndIf
Wend
h = hhilf 'return the latest step size computed by step
'size control and error code to the caller.
EndSub
Function det(n, xmat())
' Determinant .......................................................
' integer n Dimension of the matrix .........
' double xmat(0:n-1,0:n-1) matrix ..........................
'*====================================================================*
'* *
'* det computes the determinant of an n x n real matrix xmat *
'* *
'*====================================================================*
'* *
'* Input parameter: *
'* ================ *
'* n integer; (n > 0) *
'* Dimension of xmat *
'* xmat matrix(0:n-1,0:n-1) *
'* stored in a vector(n*n). *
'* *
'* Return value: *
'* ============= *
'* REAL Determinant of mat. *
'* If the return value = 0, then the matrix is singular *
'* or the storage is insufficient *
'* *
'*====================================================================*
'* *
'* subroutine used: *
'* ================ *
'* *
'* gaudec (): LU decomposition of mat *
'* *
'*====================================================================*
Dim rc AsInteger, signd AsInteger
Dim iperm(n), xlu(n * n)
Dim MachEps AsDouble
Dim MAXROOT AsDouble
If n <1Then'n not valid
det =0#
ExitFunction
EndIf
MachEps =1.2E-16
MAXROOT =1E+16
Call gaudec(n, xmat(), xlu(), iperm(), signd, rc)'decompose
If rc <>0 Or signd =0Then
det =0#
ExitFunction
EndIf
tmpdet =1#* signd
For i =0To n -1
IfAbs(tmpdet)< MachEps Then
det =0#
ExitFunction
ElseIfAbs(tmpdet)> MAXROOT Or Abs(xlu(n * i + i))> MAXROOT Then
det = MAXROOT
ExitFunction
Else
tmpdet = tmpdet * xlu(n * i + i)'compute det
EndIf
Next i
det = tmpdet
EndFunction
'************************************************************************
'* *
'* Test examples for methods to solve first order ordinary systems of *
'* differential equations. *
'* *
'* We supply the right hand sides, their alpha-numeric description and *
'* the exact analytic solution, if known. *
'* *
'* When running the main test program, the user can select among the *
'* examples below. *
'* *
'* Quick Basic Release By J-P Moreau, Paris. *
'* -------------------------------------------------------------------- *
'* REF.: "Numerical Algorithms with C, by Gisela Engeln-Muellges *
'* and Frank Uhlig, Springer-Verlag, 1996". *
'************************************************************************
' Note: here, only examples #0 and #3 are implemented in Quick Basic
'
Sub dgl(bspn AsInteger, n, x, y(), f())
If bspn =0Then
f(0)= y(0)* y(1)+Cos(x)-0.5*Sin(2#* x)
f(1)= y(0)^2+ y(1)^2-(1#+Sin(x))
ElseIf bspn =3Then
f(0)= y(1)
f(1)= y(2)
f(2)= y(3)
f(3)= y(4)
f(4)=(45#* y(2)* y(3)* y(4)-40#* y(3)^3)/(9#* y(2)^2)
EndIf
EndSub
'Maximum norm of a difference vector ........
Function DistMax(vector1(), vector2(), n)
'************************************************************************
'* Compute the maximum norm of the difference of two [0..n-1] vectors *
'* *
'* global Name1 used: *
'* ================ *
'* None *
'************************************************************************
' double abstand reference value for computation of distance
' double hilf distance of two vector elements
abstand =0#
For i = n -1To0 Step -1
hilf =Abs(vector1(i)- vector2(i))
If hilf > abstand Then abstand = hilf
Next i
DistMax = abstand
EndFunction
' England's Einbettungs formulas of 4th and 5th degree ................
Sub engl45(x, y(), bspn AsInteger, n, h, y4(), y5())
' double x starting point of integration ........
' double y(0:n-1) initial value at x ...................
' integer bspn, # example
' n number of differential equations .....
' double h step size ............................
' double y4(0:n-1), 4th order approximation for y at x + h
' y5(0:n-1) 5th order approximation for y at x + h
' auxiliary vectors
Dim yhilf(n)
Dim k1(n)AsDouble
Dim k2(n)AsDouble
Dim k3(n)AsDouble
Dim k4(n)AsDouble
Dim k5(n)AsDouble
Dim k6(n)AsDouble
'************************************************************************
'* Compute 4th and 5th order approximates y4, y5 at x + h starting with *
'* a solution y at x by using the England embedding formulas on the *
'* first order system of n differential equations y' = f(x,y) , as *
'* supplied by dgl(). *
'* *
'* Input parameters: *
'* ================= *
'* x initial x-value *
'* y y-values at x, type pVEC *
'* n number of differential equations *
'* dgl function that evaluates the right hand side of the system *
'* y' = f(x,y) *
'* h step size *
'* *
'* yhilf, k1..K6: auxiliary vectors *
'* *
'* Output parameters: *
'* ================== *
'* y4 4th order approximation for y at x + h (pVEC) *
'* y5 5th order approximation for y at x + h (pVEC) *
'* *
'************************************************************************
Call dgl(bspn, n, x, y(), k1())
For i =0To n -1
yhilf(i)= y(i)+0.5* h * k1(i)
Next i
Call dgl(bspn, n, x +0.5* h, yhilf(), k2())
For i =0To n -1
yhilf(i)= y(i)+(0.25* h *(k1(i)+ k2(i)))
Next i
Call dgl(bspn, n, x +0.5* h, yhilf(), k3())
For i =0To n -1
yhilf(i)= y(i)+ h *(-k2(i)+2#* k3(i))
Next i
Call dgl(bspn, n, x + h, yhilf(), k4())
For i =0To n -1
yhilf(i)= y(i)+ h /27#*(7#* k1(i)+10#* k2(i)+ k4(i))
Next i
Call dgl(bspn, n, x +(2#/3#)* h, yhilf(), k5())
For i =0To n -1
yhilf(i)= y(i)+ h /625#*(28#* k1(i)-125#* k2(i)+546#* k3(i)+54#* k4(i)-378#* k5(i))
Next i
Call dgl(bspn, n, x + h /5#, yhilf(), k6())
For i =0To n -1
y4(i)= y(i)+ h /6#*(k1(i)+4#* k3(i)+ k4(i))
y5(i)= y(i)+ h /336#*(14#* k1(i)+35#* k4(i)+162#* k5(i)+125#* k6(i))
Next i
EndSub
' Gauss decomposition ................................................
Sub gaudec(n, xmat(), xlumat(), iperm(), signd AsInteger, rc AsInteger)
' integer n size of matrix ..................
' double xmat(0:n-1,0:n-1), Input matrix ....................
' xlumat(0:n-1,0:n-1) matrix decomposition ............
' integer iperm(0:n-1), row interchanges ................
' signd, sign of perm ....................
' rc error code ......................
'Note: in matrices xmat,xlumat, iperm, element [i,j] is replaced by
' vector element [n*i+j].
'*====================================================================*
'* *
'* gaudec decomposes a nonsingular n x n matrix into a product of a *
'* unit lower and an upper triangular matrix. Both triangular factors*
'* are stored in lumat (minus the unit diagonal, of course). *
'* *
'* ------------------------------------------------------------------ *
'* *
'* Input parameter: *
'* ================ *
'* n integer; (n > 0) *
'* Dimension of mat and lumat, *
'* size of b , x and perm. *
'* xmat pointer to original system matrix in vector form. *
'* *
'* Output parameters: *
'* ================== *
'* xlumat pointer to LU factorization *
'* iperm pointer to row permutation vector for xlumat *
'* signd sign of perm. The determinant of xmat can be computed*
'* as the product of the diagonal entries of xlumat *
'* times signd. *
'* *
'* Return value (rc): *
'* ================= *
'* = 0 all ok *
'* = 1 n < 1 or invalid input *
'* = 2 lack of memory *
'* = 3 Matrix is singular *
'* = 4 Matrix numerically singular *
'* *
'*====================================================================*
Dim MachEps AsDouble
Dim d(n)AsDouble'scaling vector for pivoting
MachEps =1.2E-16
If n <1Then
rc =1'Invalid parameters
ExitSub
EndIf
'copy xmat to xlumat
For i =0To n -1
For j =0To n -1
xlumat(n * i + j)= xmat(n * i + j)
Next j
Next i
For i =0To n -1
iperm(i)= i 'Initialize iperm
zmax =0#
For j =0To n -1'find row maxima
tmp =Abs(xlumat(n * i + j))
If tmp > zmax Then zmax = tmp
Next j
If zmax =0#Then'xmat is singular
rc =3
ExitSub
EndIf
d(i)=1#/ zmax
Next i
signd =1'initialize sign of iperm
For i =0To n -1
piv =Abs(xlumat(n * i + i))* d(i)
j0 = i 'Search for pivot element
For j = i +1To n -1
tmp =Abs(xlumat(n * j + i))* d(j)
If piv < tmp Then
piv = tmp 'Mark pivot element and
j0 = j 'its location
EndIf
Next j
If piv < MachEps Then'If piv is small, xmat is
signd =0'nearly singular
rc =4
ExitSub
EndIf
If j0 <> i Then
signd =-signd 'update signd
Call ISWAP(iperm(j0), iperm(i))'SWAP1 pivot entries
Call SWAP1(d(j0), d(i))'SWAP1 scaling vector
For j =0To n -1
'SWAP1 j0-th and i-th rows of xlumat
Call SWAP1(xlumat(n * j0 + j), xlumat(n * i + j))
Next j
EndIf
For j = i +1To n -1'Gauss elimination
If xlumat(n * j + i)<>0#Then
xlumat(n * j + i)= xlumat(n * j + i)/ xlumat(n * i + i)
tmp = xlumat(n * j + i)
For m = i +1To n -1
xlumat(n * j + m)= xlumat(n * j + m)- tmp * xlumat(n * i + m)
Next m
EndIf
Next j
Next i
rc =0'all ok
EndSub
' Gauss solution .....................................................
Sub gausol(n, xlumat(), iperm(), b(), x(), rc AsInteger)
' integer n size of matrix ..................
' real*8 xlumat(0:n-1,0:n-1) decomposed matrix (LU) ..........
' integer perm(0:n-1) row permutation vector ..........
' real*8 b(0:n-1), Right hand side .................
' x(0:n-1) solution ........................
' integer rc error code ......................
'====================================================================*
' *
' gausol finds the solution x of the linear system lumat * x = b *
' for the product matrix lumat, that describes an LU decomposition, *
' as produced by gaudec. *
' *
'====================================================================*
' *
' Input parameters: *
' ================ *
' n integer (n > 0) *
' Dimension of xlumat. *
' xlumat Matrix(0:n-1,0:n-1) stored in a vector(n*n). *
' LU factorization, as produced from gaudec. *
' iperm integer vector(0:n-1) *
' row permutation vector for xlumat *
' b vector(0:n-1) *
' Right hand side of the system. *
' *
' Output parameter: *
' ================ *
' x vector(0:n-1) *
' Solution vector *
' *
' Return value (rc): *
' ================= *
' = 0 all ok *
' = 1 n < 1 or other invalid input parameter *
' = 3 improper LU decomposition ( zero diagonal entry) *
' *
'====================================================================*
Dim MachEps AsDouble
MachEps =1.2E-16
If n <1Then
rc =1'Invalid input parameter
ExitSub
EndIf
MachEps =1.2E-16
For k =0To n -1'update b
x(k)= b(iperm(k))
For j =0To k -1
x(k)= x(k)- xlumat(n * k + j)* x(j)
Next j
Next k
For k = n -1To0 Step -1'back substitute
Sum =0#
For j = k +1To n -1
Sum = Sum + xlumat(n * k + j)* x(j)
Next j
IfAbs(xlumat(n * k + k))< MachEps Then
rc =3
ExitSub
EndIf
x(k)=(x(k)- Sum)/ xlumat(n * k + k)
Next k
rc =0'all ok
EndSub
' Gauss algorithm for solving linear equations .......................
Sub gauss(mode, n, xmat(), xlumat(), iperm(), b(), x(), signd AsInteger, code AsInteger)
' integer mode Modus: 0, 1, 2, 3 ...............
' integer n Dimension of matrix .............
' double xmat(0:n-1,0:n-1), Input matrix ....................
' xlumat(0:n-1,0:n-1) LU decomposition ................
' integer iperm(0:n-1,0:n-1) row remutation vector ...........
' double b(0:n-1), right hand side .................
' x(0:n-1) solution of the system ..........
' integer signd, sign of the permutation .........
' code return error code ...............
'Note: in matrices xmat,xlumat, iperm, element [i,j] is replaced by
' vector element [n*i+j].
'*====================================================================*
'* *
'* The procedure gauss solves a linear system : mat * x = b. *
'* Here mat is the nonsingular system matrix, b the right hand side *
'* of the system and x the solution vector. *
'* *
'* gauss uses the Gauss algorithm and computes a triangular factori- *
'* zation of mat and scaled column pivot search. (Crout method with *
'* row SWAP1s). *
'* *
'* ------------------------------------------------------------------ *
'* *
'* Application: *
'* ============ *
'* Solve general linear system with a nonsingular coefficient *
'* matrix. *
'* *
'*====================================================================*
'* *
'* Control parameter: *
'* ================== *
'* mode integer; *
'* calling modus for gauss: *
'* = 0 Find factorization and solve linear system *
'* = 1 Find factorization only. *
'* = 2 Solve linear system only; the factorization is *
'* already available in lumat. This saves work when *
'* solving a linear system repeatedly for several right *
'* hand sides and the same system matrix such as when *
'* inverting the matrix. *
'* = 3 as under 2, additionally we improve the solution *
'* via iterative refinement (not available here). *
'* *
'* Input parameters: *
'* ================ *
'* n integer; (n > 0) *
'* Dimension of mat and lumat, *
'* size of the vector b, the right hand side, the *
'* solution x and the permutation vector perm. *
'* xmat matrix of the linear system. It is stored in vector *
'* form. *
'* xlumat (for mode = 2, 3) *
'* LU factors of mat *
'* xlumat can be stored in the space of xmat. *
'* iperm (for mode = 2, 3) *
'* Permutation vector, of the row interchangfes in *
'* xlumat. *
'* b Right hand side of the system. *
'* signd (for mode = 2, 3) *
'* sign of the permutation in perm; the determinant of *
'* mat can be computed as the product of the diagonal *
'* entries of lumat times signd. *
'* *
'* Output parameters: *
'* ================== *
'* xlumat (for mode = 0, 1) *
'* LU factorization of xmat. *
'* iperm (for mode = 0, 1) *
'* row ermutation vector *
'* x (for mode = 0, 2, 3) *
'* solution vector(0:n-1). *
'* signd (for mode = 0, 1) *
'* sign of perm. *
'* *
'* Return value (code): *
'* =================== *
'* =-1 Max. number (MAXITER) of iterative refinements *
'* reached (MAXITER) while mode = 3 *
'* = 0 all ok *
'* = 1 n < 1 or other invalid input *
'* = 2 lack of memory *
'* = 3 Matrix singular *
'* = 4 Matrix numerically singular *
'* = 5 incorrect call *
'* *
'*====================================================================*
'* *
'* subroutines used: *
'* ================ *
'* *
'* gaudec: determines LU decomposition *
'* gausol: solves the linear system *
'* *
'*====================================================================*
Dim rc AsInteger
If(n <1)Then
code =1
Return
EndIf
'Select mode
If mode =0Then'Find factorization and solve system ...................
Call gaudec(n, xmat(), xlumat(), iperm(), signd, rc)
If rc =0Then
Call gausol(n, xlumat(), iperm(), b(), x(), rc)
code = rc
Else
code = rc
ExitSub
EndIf
ElseIf mode =1Then'Find factorization only ...........................
Call gaudec(n, xmat(), xlumat(), iperm(), signd, rc)
code = rc
ExitSub
ElseIf mode =2Then'Solve only ........................................
Call gausol(n, xlumat(), iperm(), b(), x(), rc)
code = rc
ExitSub
ElseIf mode =3Then'Solve and then use iterative refinement ...........
Print" fgauss: gausoli not implemented."
code =5
ExitSub
EndIf
code =5'Wrong call
EndSub
'************************************************************************
'* *
'* Solve a first order system of DEs using the implicit Gear method *
'* of order 4. *
'* *
'* Programming language: ANSI C *
'* Author: Klaus Niederdrenk, 1.22.1996 (FORTRAN 77) *
'* Adaptation: Juergen Dietel, Computing Center, RWTH Aachen *
'* Source: FORTRAN 77 source code *
'* Date: 2.26.1996 *
'* *
'* Quick Basic Release By J-P Moreau, Paris. *
'* -------------------------------------------------------------------- *
'* REF.: "Numerical Algorithms with C, by Gisela Engeln-Muellges *
'* and Frank Uhlig, Springer-Verlag, 1996". *
'************************************************************************
'Gear method of 4th order for DESs of 1st order
Sub gear4(x, xend, bspn AsInteger, n, y(), epsabs, epsrel, h, fmax AsInteger, aufrufe AsInteger, fehler AsInteger)
' double x, starting or end point ................
' xend desired end point (> x) ..............
' integer bspn, # of example .........................
' n number of DEs ........................
' double y(0:n-1), initial value or solution ............
' epsabs, absolute error bound .................
' epsrel, relative error bound .................
' h starting or final step size ..........
' integer fmax, maximal number of calls of dgl() .....
' aufrufe, actual number of calls of dgl() ......
' fehler error code ...........................
'************************************************************************
'* Compute the value of the solution at xend, starting with the IVP. *
'* We use the implicit method of Gear of 4th order with step size *
'* control which is especially suited for stiff DEs. *
'* The local step size control insures that the two error bounds are met*
'* The number of function calls of the right hand side is limited by *
'* fmax. This function can be used inside a loop to find solutions at *
'* a specified point to arbitrary accuracy. *
'* *
'* Input parameters: *
'* ================= *
'* x initial value x0 *
'* xend final value for the integration (xend > x0) *
'* bspn # example *
'* n number of DEs *
'* dgl Function to compute the right hand side f(x0,y0) for the *
'* system of DEs (removed from parameters). *
'* y [0..n-1] solution vector y0 of the system of DEs at x0 *
'* epsabs absolute error bound (>= 0); if zero, we only check for the *
'* relative error. *
'* epsrel relative error bound (>= 0); if zero, we only check for the *
'* absolute error. *
'* h given step size for first step *
'* fmax maximal number of calls of the right hand side of the system*
'* *
'* Output parameters: *
'* ================= *
'* x final x-value of the integration; normally equal to xend *
'* h final step size; keep for further calls *
'* y [0..n-1]-vector, the solution of the system of DEs at x *
'* aufrufe counter of calls of dgl() *
'* *
'* erroe code (fehler): *
'* ==================== *
'* = 0: all ok *
'* = 1: Both error bounds too small *
'* = 2: xend <= x0 *
'* = 3: Step size h <= 0 *
'* = 4: n <= 0 *
'* = 5: # calls > fmax; we have not reached the desired xend; *
'* repeat function call with actual values of x, y, h. *
'* = 6: Jacobi matrix is singular; x, y, h are the last values *
'* that could be computed with accuracy *
'* = 7: ran out of memory (not used here) *
'* = 8: error when calling gauss() for the second time; *
'* should not occur. *
'* *
'************************************************************************
' double eps1, 'MachEps^0.75; used instead of MachEps
''to check whether we have reached xend in
''order to avoid minuscule step sizes
' eps2, '100 * MachEps; for comparison with zero
' hs 'optimal step size for Jacobi matrix
''approximation
Dim hilf(n)'(0..n-1)-vector
Dim zj(5* n)'(0:4,0:n-1)-matrix stored in a vector(5*n)
Dim zjp1(5* n)'(0:4,0:n-1)-matrix stored in a vector(5*n)
Dim f(n), ykp1(n)'(0..n-1)-vectors
Dim fs(n * n), fsg(n * n)'(0..n-1,0..n-1)-matrices stored in vectors(n*n)
Dim con(n)'(0..n-1)-vector
Dim iperm(n)'(0..n-1) permutation vector for Gauss elimination
' sg, sign of xend
' xe |xend| - eps2, carrying the sign of xend
Dim amEnde AsInteger'Flag, indicating that we shall reach
'xend with the current step
' ymax, Maximum norm of the current
'approximate value of y
' dummy, aux storage for h
' auxiliary variables (double);
' xka, xke , hka, hk1, diff, eps, q, halt, quot1, quot2, quot3, quot4
Dim done AsInteger'Boolean (0 or 1)
' nochmal 'Boolean (0 or 1)
Dim aufrufeawp AsInteger
Dim signdet AsInteger'sign of determinant in Gauss
Dim dum(n), dum1(n)'dummy vectors for gauss
Dim MachEps AsDouble'machine smallest real number
'auxiliary vectors
'Dim yhilf(n), k1(n), k2(n), k3(n), k4(n), k5(n), k6(n)
' ------------------------- Initialize ------------------------------
dummy =0#: done =0
MachEps =1.2E-16'for IBM PC
eps1 = MachEps ^0.75
eps2 =100#* MachEps
hs =10#*Sqr(MachEps)
ONE =1#
If(xend >=0#)Then
sg =1#
Else
sg =-1#
EndIf
xe =(1#- sg * eps2)* xend
fehler =0
aufrufe =1
amEnde =0
' --------- check input parameters -------------------
ymax = XNormMax(y(), n)
If epsabs <= eps2 * ymax And epsrel <= eps2 Then
fehler =1
ElseIf xe < x Then
fehler =2
ElseIf h < eps2 *Abs(x)Then
fehler =3
ElseIf n <=0Then
fehler =4
EndIf
If fehler >0ThenExitSub
' ------------ first integration step ---------------
If x + h > xe Then
h = xend - x
dummy = h
amEnde =1
EndIf
For i =0To n -1
hilf(i)= y(i)
Next i
xka = x
xke = xka
hka =0.25* h
hk1 = hka
For k =1To4
xke = xke + hka
awp xka, xke, bspn, n, hilf(), epsabs, epsrel, hk1,6, fmax - aufrufe, aufrufeawp, fehler
aufrufe = aufrufe + aufrufeawp
If fehler <>0ThenExitSub
For i =0To n -1
zjp1(n * k + i)= hilf(i)
Next i
Next k
dgl bspn, n, x, y(), f()
aufrufe = aufrufe +1
' ---------- Compute first Gear-Nordsieck approximation -------------------
For i =0To n -1
zj(i)= y(i)
zj(i + n)= h * f(i)
zj(i +2* n)= ONE /24*(35* y(i)-104* zjp1(i + n)+114* zjp1(i +2* n)-56* zjp1(i +3* n)+11* zjp1(i +4* n))
zj(i +3* n)= ONE /12*(-5* y(i)+18* zjp1(i + n)-24* zjp1(i +2* n)+14* zjp1(i +3* n)-3* zjp1(i +4* n))
zj(i +4* n)= ONE /24*(y(i)-4* zjp1(i + n)+6* zjp1(i +2* n)-4* zjp1(i +3* n)+ zjp1(i +4* n))
Next i
' ------------------------ adjust step size --------------------------
While done =0
' --- use Newton method for an implicit approximation ---
For i =0To n -1
ykp1(i)= zj(i)+ zj(i + n)+ zj(i +2* n)+ zj(i +3* n)+ zj(i +4* n)
Next i
dgl bspn, n, x + h, ykp1(), f()
For k =0To n -1
'copy vector ykp1 in hilf
For i =0To n -1
hilf(i)= ykp1(i)
Next i
hilf(k)= hilf(k)- hs
dgl bspn, n, x + h, hilf(), dum()
For i =0To n -1
fs(k * n + i)= dum(i)
Next i
For i =0To n -1
fs(k * n + i)=-h *0.48*(f(i)- fs(k * n + i))/ hs
Next i
fs(k * n + k)= fs(k * n + k)+ ONE
Next k
'update number of calls to dgl
aufrufe = aufrufe + n +1
For i =0To n -1
con(i)= ykp1(i)-0.48*(zj(i + n)+2* zj(i +2* n)+3* zj(i +3* n)+4* zj(i +4* n))
For k =0To n -1
fsg(k * n + i)= fs(i * n + k)
Next k
Next i
gauss 1, n, fsg(), fsg(), iperm(), dum(), dum1(), signdet, fehler
If fehler >0Then'error in gauss ?
fehler =6
ExitSub
EndIf
For iter =1To3
For i =0To n -1
hilf(i)=-ykp1(i)
For k =0To n -1
hilf(i)= hilf(i)+ fs(k * n + i)* ykp1(k)
Next k
hilf(i)= h *0.48* f(i)+ hilf(i)+ con(i)
Next i
gauss 2, n, fsg(), fsg(), iperm(), hilf(), ykp1(), signdet, fehler
If fehler >0Then
fehler =8
ExitSub
EndIf
dgl bspn, n, x + h, ykp1(), f()
Next iter
'update number of calls to dgl
aufrufe = aufrufe +3
' ---- Compute corresponding Gear-Nordsieck approximation ----
For i =0To n -1
hilf(i)= h * f(i)- zj(i + n)-2* zj(i +2* n)-3* zj(i +3* n)-4* zj(i +4* n)
Next i
For i =0To n -1
zjp1(i)= ykp1(i)
zjp1(i + n)= h * f(i)
zjp1(i +2* n)= zj(i +2* n)+3#* zj(i +3* n)+6#* zj(i +4* n)+0.7* hilf(i)
zjp1(i +3* n)= zj(i +3* n)+4#* zj(i +4* n)+0.2* hilf(i)
zjp1(i +4* n)= zj(i +4* n)+0.02* hilf(i)
Next i
' --- decide whether to accept last step ---
' copy vector zjp1(4) in hilf and zj(4) in con
For i =0To n -1
hilf(i)= zjp1(i +4* n)
con(i)= zj(i +4* n)
Next i
diff = DistMax(hilf(), con(), n)
ymax = XNormMax(ykp1(), n)
eps =(epsabs + epsrel * ymax)/6#
q =Sqr(Sqr(eps / diff))/1.2
If(diff < eps)Then
' --- accept last step; prepare for next one ---
x = x + h
'copy vector ykp1 in y
For i =0To n -1
y(i)= ykp1(i)
Next i
' stop integration, if interval end xend has been reached
' or if there has been too many function dgl calls.
nochmal =0
While nochmal =0
If amEnde <>0Then
h = dummy
ExitSub
ElseIf aufrufe > fmax Then
fehler =5
ExitSub
EndIf
' --- adjust step size for next step ---
halt = h
h = XMin(q,2#)* h
If x + h >= xe Then
dummy = h
h = xend - x
amEnde =1
' --- close enough to xend => stop integration ---
If h < eps1 *Abs(xend)Then nochmal =1
EndIf
If nochmal =0ThenGoTo10
Wend
' ------ compute Gear-Nordsieck approximation -----
' ------ for the next step -----
10 quot1 = h / halt
quot2 = quot1 ^2
quot3 = quot2 * quot1
quot4 = quot3 * quot1
For i =0To n -1
zj(i)= zjp1(i)
zj(i + n)= quot1 * zjp1(i + n)
zj(i +2* n)= quot2 * zjp1(i +2* n)
zj(i +3* n)= quot3 * zjp1(i +3* n)
zj(i +4* n)= quot4 * zjp1(i +4* n)
Next i
Else
' ------ repeat last step with smaller step size; -----
' -------- adjust Gear-Nordsieck approximation ---------
halt = h
h = XMax(0.5, q)* h
quot1 = h / halt
quot2 = quot1 ^2
quot3 = quot2 * quot1
quot4 = quot3 * quot1
For i =0To n -1
zj(i + n)= quot1 * zj(i + n)
zj(i +2* n)= quot2 * zj(i +2* n)
zj(i +3* n)= quot3 * zj(i +3* n)
zj(i +4* n)= quot4 * zj(i +4* n)
Next i
amEnde =0
EndIf
Wend'while done=0
EndSub'gear4
Sub ISWAP(ia, ib)
Dim tnp AsInteger
tmp = ib: ib = ia: ia = tmp
EndSub
' Gauss for multiple right hand sides ................................
Sub mgauss(n, k, xmat(), rmat(), code AsInteger)
' integer n, Dimension of system .............
' k number of right hand sides ......
' real*8 mat(0:n-1,0:n-1), original matrix .................
' rmat(0:n-1,0:n-1) Right hand sides/solutions ......
' integer code Error code ......................
'*====================================================================*
'* *
'* mgauss finds the solution matrix x for the linear system *
'* mat * x = rmat with an n x n coefficient matrix mat and a *
'* n x k matrix rmat of right hand sides. Here mat must be *
'* nonsingular. *
'* *
'* ------------------------------------------------------------------ *
'* *
'* Input parameters: *
'* ================ *
'* n integer; (n > 0) *
'* Dimension of xmat. *
'* k integer k; (k > 0) *
'* number of right hand sides *
'* xmat matrix(0:n-1,0:n-1) stored in a vector(n*n) *
'* n x n original system matrix *
'* rmat matrix(0:n-1,0:n-1) stored in a vector(n*n) *
'* Right hand sides *
'* *
'* Output parameter: *
'* ================ *
'* rmat solution matrix for the system. *
'* The input right hand sides are lost. *
'* *
'* Return value (code): *
'* =================== *
'* = 0 all ok *
'* = 1 n < 1 or k < 1 or invalid input parameter *
'* = 2 lack of memory (not used here) *
'* = 3 mat is numerically singular. *
'* *
'* ------------------------------------------------------------------ *
'* *
'* subroutine used: *
'* ================ *
'* *
'* gaudec: LU decomposition of mat. *
'* *
'*====================================================================*
Dim signd AsInteger, rc AsInteger
Dim iperm(n)
Dim xlu(n * n), x(n)
Dim MachEps AsDouble
If n <1 Or k <1Then'Invalid parameter
code =1
ExitSub
EndIf
MachEps =1.2E-16
Call gaudec(n, xmat(), xlu(), iperm(), signd, rc)'compute factorization
'in matrix lu
If rc <>0 Or signd =0Then'if not possible
code =3'exit with code=3
ExitSub
EndIf
For m =0To k -1'Loop over the right hand sides
For i =0To n -1'Updating the b's
x(i)= rmat(n * iperm(i)+ m)
For j =0To i -1
x(i)= x(i)- xlu(n * i + j)* x(j)
Next j
Next i
For i = n -1To0 Step -1'back substitution
Sum =0#
For j = i +1To n -1
Sum = Sum + xlu(n * i + j)* x(j)
Next j
IfAbs(xlu(n * i + i))< MachEps Then'invalid LU decomposition
code =2
ExitSub
EndIf
x(i)=(x(i)- Sum)/ xlu(n * i + i)
Next i
For j =0To n -1'Save result
rmat(n * j + m)= x(j)
Next j
Next m
code =0
EndSub
' embedding formulas of Prince-Dormand of 4./5. order .........................
Sub prdo45(x, y(), bspn AsInteger, n, h, y4(), y5(), steif1 AsInteger, steifanz AsInteger, steif2 AsInteger)
' double x, starting point of integration .....
' y(0:n-1) initial value at x ................
' integer bspn, # example .........................
' n number of DEs .....................
' double h, step size .........................
' y4(0:n-1), solution of 4th order at x+h ......
' y5(0:n-1) solution of 5th order at x+h ......
' auxiliary flags
' integer steif1, steifanz,steif2
' auxiliary vectors
Dim yhilf(n)
Dim k1(n)AsDouble, k2(n)AsDouble
Dim k3(n)AsDouble, k4(n)AsDouble
Dim k5(n)AsDouble, k6(n)AsDouble
Dim k7(n)AsDouble
Dim g6(n)AsDouble, g7(n)AsDouble
'************************************************************************
'* Compute 4th and 5th order approximates y4, y5 at x + h starting with *
'* a solution y at x by using the Prince-Dormand embedding formulas on *
'* the first order system of n differential equations y' = f(x,y) , as *
'* supplied by dgl(). *
'* Simultaneously we perform two tests for stiffness whose results are *
'* stored in steif1 and steif2. *
'* *
'* Input parameters: *
'* ================= *
'* x initial x-value *
'* y y-values at x (pVEC) *
'* n number of differential equations *
'* dgl function that evaluates the right hand side of the system *
'* y' = f(x,y) *
'* h step size *
'* *
'* yhilf, k1..k7,g6,g7: auxiliary vectors. *
'* *
'* Output parameters: *
'* ================== *
'* y4 4th order approximation for y at x + h *
'* y5 5th order approximation for y at x + h *
'* *
'***********************************************************************}
Dim steifa AsInteger'Flag which is set if the second test for stiffness
'Shampine und Hiebert) is positive; otherwise the
'flag is erased.
Call dgl(bspn, n, x, y(), k1())
For i =0To n -1
yhilf(i)= y(i)+0.2* h * k1(i)
Next i
Call dgl(bspn, n, x +0.2* h, yhilf(), k2())
For i =0To n -1
yhilf(i)= y(i)+0.075* h *(k1(i)+3#* k2(i))
Next i
Call dgl(bspn, n, x +0.3* h, yhilf(), k3())
For i =0To n -1
yhilf(i)= y(i)+ h /45#*(44#* k1(i)-168#* k2(i)+160#* k3(i))
Next i
Call dgl(bspn, n, x +0.8* h, yhilf(), k4())
For i =0To n -1
yhilf(i)= y(i)+ h /6561#*(19372#* k1(i)-76080#* k2(i)+64448#* k3(i)-1908#* k4(i))
Next i
Call dgl(bspn, n, x +(8#/9#)* h, yhilf(), k5())
For i =0To n -1
g6(i)= y(i)+ h /167904#*(477901#* k1(i)-1806240#* k2(i)+1495424#* k3(i)+46746#* k4(i)-45927#* k5(i))
Next i
Call dgl(bspn, n, x + h, g6(), k6())
For i =0To n -1
g7(i)= y(i)+ h /142464#*(12985#* k1(i)+64000#* k3(i)+92750#* k4(i)-45927#* k5(i)+18656#* k6(i))
Next i
Call dgl(bspn, n, x + h, g7(), k7())
For i =0To n -1
y5(i)= g7(i)
y4(i)= y(i)+ h /21369600#*(1921409#* k1(i)+969088#* k3(i)+13122270#* k4(i)-5802111#* k5(i)+1902912#* k6(i)+534240#* k7(i))
Next i
' Test for stiffness via dominant eigenvalue
If DistMax(k7(), k6(), n)>3.3* DistMax(g7(), g6(), n)Then steif1 =1
' one step in steffness test of Shampine & Hiebert
For i =0To n -1
g6(i)= h *(2.2* k2(i)+0.13* k4(i)+0.144* k5(i))
g7(i)= h *(2.134* k1(i)+0.24* k3(i)+0.1* k6(i))
Next i
If DistMax(g6(), g7(), n)< DistMax(y4(), y5(), n)Then
steifa =1
Else
steifa =0
EndIf
If(steifa >0)Then
steifanz = steifanz +1
If steifanz >=3Then steif2 =1
Else
steifanz =0
EndIf
EndSub
'print a REAL square matrix with Name1 (debug only)
Sub PrintMat(Name1 AsString, n, xmat())
' Name1 Matrix caption
' n Size of matrix
' double xmat(0:n-1,0:n-1) stored in a vector(n*n)
' matrix to be printed
Print""; Name1
For i =0To n -1
For j =0To n -1
Print""; xmat(n * i + j);
Next j
Next i
EndSub
'debug only
Sub PrintVec(Name1 AsString, n, V())
Print Name1
For i =0To n -1
Print""; V(i);
Next i
EndSub
' Runge-Kutta embedding formulas of 2nd, 3rd degree ....................
Sub ruku23(x, y(), bspn AsInteger, n, h, y2(), y3())
'************************************************************************
'* Compute 2nd and 3rd order approximates y2, y3 at x + h starting with *
'* a solution y at x by using Runge-Kutta embedding formulas on the *
'* first order system of n differential equations y' = f(x,y) , as *
'* supplied by dgl(). *
'* *
'* Input parameters: *
'* ================= *
'* x x-value of left end point *
'* y y-values at x *
'* bspn # example *
'* n number of differential equations *
'* dgl function that evaluates the right hand side of the system *
'* y' = f(x,y) *
'* h step size *
'* *
'* yhilf,k1,k2,k3: auxiliary vectors defined in module awp. *
'* *
'* Output parameters: *
'* ================== *
'* y2 2nd order approximation for y at x + h *
'* y3 3rd order approximation for y at x + h *
'* *
'************************************************************************
Dim yhilf(n)
Dim k1(n)AsDouble
Dim k2(n)AsDouble
Dim k3(n)AsDouble
Call dgl(bspn, n, x, y(), k1())
For i =0To n -1
yhilf(i)= y(i)+ h * k1(i)
Next i
Call dgl(bspn, n, x + h, yhilf(), k2())
For i =0To n -1
yhilf(i)= y(i)+0.25* h *(k1(i)+ k2(i))
Next i
Call dgl(bspn, n, x +0.5* h, yhilf(), k3())
For i =0To n -1
y2(i)= y(i)+0.5* h *(k1(i)+ k2(i))
y3(i)= y(i)+ h /6#*(k1(i)+ k2(i)+4#* k3(i))
Next i
EndSub
'***************************************************************
'* This subroutine defines n, number of DEs and dgltxt(), the *
'* text decription of current example. *
'***************************************************************
'NOTE: here, only examples #0, #3 are implemented.
Sub settxt(bspn AsInteger, n, dgltxt$())
If bspn =0Then
n =2
dgltxt$(0)=" y1' = y1 * y2 + cos(x) - 0.5 * sin(2.0*x)"
dgltxt$(1)=" y2' = y1 * y1 + y2 * y2 - (1 + sin(x))"
ElseIf bspn =3Then
n =5
dgltxt$(0)=" y1' = y2"
dgltxt$(1)=" y2' = y3"
dgltxt$(2)=" y3' = y4"
dgltxt$(3)=" y4' = y5"
dgltxt$(4)=" y5' = (45 * y3 * y4 * y5 - 40 * y4 * y4 * y4) / (9 * y3 * y3)"
EndIf
EndSub
Sub SWAP1(a, b)
tmp = b: b = a: a = tmp
EndSub
Function XMax(a, b)
If a >= b Then
XMax = a
Else
XMax = b
EndIf
EndFunction
Function XMin(a, b)
If a <= b Then
XMin = a
Else
XMin = b
EndIf
EndFunction
' Find the maximum norm of a REAL vector ............................
Function XNormMax(vektor(), n)
' double vektor(0:n-1) vector .................
' integer n length of vector .......
' ************************************************************************
' * Return the maximum norm of a [0..n-1] vector v *
' * *
' ************************************************************************
Dim norm AsDouble' local max.
' double betrag ' magnitude of a component
norm =0#
For i =0To n -1
betrag =Abs(vektor(i))
If betrag > norm Then norm = betrag
Next i
XNormMax = norm
EndFunction
' -------------------------- END mgear1.bas -------------------------
↧
↧
Stormer's method
'*************************************************************
'* Differential equation y"=f(x,y,y') by Stormer's method *
'* --------------------------------------------------------- *
'* SAMPLE RUN: *
'* Integrate y" = 8yy / (1 + 2x) from x=0 to x=1, *
'* with initial conditions: x(0)=0, y(0)=1 and y'(0)=-2 *
'* and compare with exact solution: y = 1 / (1 + 2x) *
'* *
'* Output file (stormer.lst): *
'* *
'* --------------------------------------------------------- *
'* Differential equation y"=f(x,y,y') by Stormer's method *
'* --------------------------------------------------------- *
'* X Y Y exact Error *
'* 0.000 1.000000 1.000000 0.0000000000 *
'* 0.010 0.980392 0.980392 0.0000000001 *
'* 0.020 0.961538 0.961538 0.0000000295 *
'* 0.030 0.943396 0.943396 0.0000000457 *
'* 0.040 0.925926 0.925926 0.0000000974 *
'* 0.050 0.909091 0.909091 0.0000001285 *
'* ... ... ... ... *
'* 0.950 0.344866 0.344828 0.0000381695 *
'* 0.960 0.342505 0.342466 0.0000388874 *
'* 0.970 0.340176 0.340136 0.0000396196 *
'* 0.980 0.337878 0.337838 0.0000403406 *
'* 0.990 0.335612 0.335570 0.0000410721 *
'* 1.000 0.333375 0.333333 0.0000418231 *
'* *
'* End of file. *
'* Basic Version By J-P Moreau *
'* (www.jpmoreau.fr) *
'*************************************************************
defint i-n
defdbl a-h,o-z
dim c(4),x(4),y(4),z(4)
h=0.01#
a1=1.08333333333333#
a2=-2#*(a1-1#)
a3=a1-1#
f$=" ##.#### ##.###### ##.###### ##.##########"
open"stormer.lst"for output as#2
cls
print#2,"-----------------------------------------------------------------"
print#2," Differential equation y""=f(x,y,y') by Stormer's method"
print#2,"-----------------------------------------------------------------"
'initial conditions
x(1)=0#: y(1)=1#: z(1)=-2#
xx=x(1):gosub1200: yex=Fx : er=0#
print#2," X Y Y exact Error"
print#2, using f$; x(1); y(1); yex; er
for k=1to2
'call Runge-Kutta for first 2 steps
gosub2000
xx=x(k+1):gosub1200: yex=Fx : er=abs(yex-y(k+1))
print#2, using f$; x(k+1); y(k+1); yex; er
next k
'main Stormer loop
10'continue
for k=2to4
xx=x(5-k): yy=y(5-k):gosub1100
c(k)=G
next k
y(4)=2#*y(3)-y(2)+h*h*(a1*c(2)+a2*c(3)+a3*c(4))
x(4)=x(3)+h : xx=x(4):gosub1200: yex=Fx : er=abs(yex-y(4))
print#2, using f$; x(4); y(4); yex; er
for k=1to3
x(k)=x(k+1): y(k)=y(k+1)
next k
if x(3)<1#thengoto10'end x value = 1
print#2,
print#2," End of file."
Close#2
print" Results in file stormer.lst"
END
1000'real*8 function F(x,y,z)
F=zz
return
1100'real*8 function G(x,y,z)
G=8#*yy*yy/(1#+2#*xx)
return
1200'exact solution real*8 function Fx(x)
Fx=1#/(1#+2#*xx)
return
2000'SUBROUTINE RK4D2(x,y,z,h,x1,y1,z1)
xx=x(k): yy=y(k): zz=z(k)
gosub1000: c1=F
gosub1100: d1=G
xx=x(k)+h/2#: yy=y(k)+h/2#*c1 : zz=z(k)+h/2#*d1
gosub1000: c2=F
gosub1100: d2=G
zz=z(k)+h/2#*d2 :gosub1000: c3=F
yy=y(k)+h/2#*c2 :gosub1100: d3=G
xx=x(k)+h
zz=z(k)+h*d3 :gosub1000: c4=F
yy=y(k)+h*c3 :gosub1100: d4=G
x(k+1)=x(k)+h
y(k+1)=y(k)+h*(c1+2#*c2+2#*c3+c4)/6#
z(k+1)=z(k)+h*(d1+2#*d2+2#*d3+d4)/6#
return
'End of file stormer.bas
EXPLANATION FILE OF PROGRAM STORMER
===================================
Solve Y"=f(x,y,y') with initial conditions by Stormer's method
--------------------------------------------------------------
The differential equation of order 2 can be replaced by a system of two
equations of order 1:
Given y"=f(x,y,y') with y(a) and y'(a), by calling u = y', the problem becomes
| u'=f(x,y,u)
| y'=u
| with y(a), u(a) given
We start from a particular form of the Taylor's formula, where the remainder
is under the form of an integral:
x+h
y(x+h) = y(x) + h y'(x) + Sum (x+h-t) y"(t) dt
x
In the same way
x-h
y(x-h) = y(x) - h y'(x) + Sum (x-h-t) y"(t) dt
x
By summing
x+h x-h
y(x+h) - 2y(x) + y(x-h) = Sum ... + Sum ...
x x
For the second integral, we change the variable: u = 2x - t
So x-h x+h
Sum (x-h-t) y"(t) dt = - Sum (x+h-u) y"(u) du
x x
x+h
du=-dt ==> = Sum (x+h-t) y"(2x-t) dt
x
Finally
x+h
y(x+h) - 2y(x) + y(x-h) = Sum (x+h-t)[y"(t)+y"(2x-t)] dt
x
We now use the interpolation polynomial recalling that y"(x)=f(x,y,y'):
x
n+1
y - y + y = Sum (x - t)[P(t)+P(2x - 1)] dt
n+1 n n-1 x n+1 n
n
x
2 n+1 0 1 2
= h Sum (x - t) [O0 Div (fn) + O1 Div (fn) +O2 Div (fn)] dt
x n+1
n
m 1 |(-s) (m)|
with O = (-1) Sum (1-s) |( ) + ( )| ds
m 0 |(m ) (s)|
(see file Adambash.txt).
This leads to Stormer's formulas:
Explicit: y - 2 y + y = (h²/12)[13f - 2 f + f ]
n+1 n n-1 n n-1 n-2
Implicit: y - 2 y + y = (h²/12)[f + 10 f + f ]
n+1 n n-1 n+1 n n-1
From [BIBLI 04]
---------------------------------------
End of file Stormer.txt
↧
Runge-Kutta-Fehlberg method
'***********************************************************************
'* Integrate a System of Ordinary Differential Equations By the *
'* Runge-Kutta-Fehlberg method (double precision) *
'* ------------------------------------------------------------------- *
'* REFERENCE: H A Watts and L F Shampine, *
'* Sandia Laboratories, *
'* Albuquerque, New Mexico. *
'* ------------------------------------------------------------------- *
'* SAMPLE RUN: *
'* *
'* PROGRAM TRKF45 *
'* Demonstrate the RKF45 ODE integrator. *
'* *
'* TEST01 *
'* Solve a scalar equation: *
'* *
'* Y' = 0.25 * Y * ( 1 - Y / 20 ) *
'* *
'* T Y Y_Exact Error *
'* *
'* 0.00000 1.00000 1.00000 0.0000000 *
'* 4.00000 2.50321 2.50322 -0.0000087 *
'* 8.00000 5.60007 5.60009 -0.0000193 *
'* 12.00000 10.27774 10.27773 -0.0000069 *
'* 16.00000 14.83682 14.83683 -0.0000038 *
'* 20.00000 17.73017 17.73017 -0.0000084 *
'* *
'* TEST02 *
'* Solve a vector equation: *
'* *
'* Y'(1) = Y(2) *
'* Y'(2) = - Y(1) *
'* *
'* T Y1 Y2 *
'* *
'* 0.00000 1.00000 0.00000 *
'* 0.52360 0.86603 -0.50000 *
'* 1.04720 0.50000 -0.86603 *
'* 1.57080 0.00000 -1.00000 *
'* 2.09440 -0.50000 -0.86603 *
'* 2.61799 -0.86603 -0.50000 *
'* 3.14159 -1.00000 -0.00000 *
'* 3.66519 -0.86603 0.50000 *
'* 4.18879 -0.50000 0.86603 *
'* 4.71239 -0.00000 1.00001 *
'* 5.23599 0.50000 0.86604 *
'* 5.75959 0.86604 0.50001 *
'* 6.28319 1.00002 0.00000 *
'* *
'* TEST03 *
'* Solve a vector equation: *
'* *
'* Y'(1) = Y(2) *
'* Y'(2) = Y(3) *
'* Y'(3) = Y(4) *
'* Y'(4) = Y(5) *
'* Y'(5) = (45 * Y(3) * Y(4) * Y(5) - 40 * Y(4)^3) / (9 * Y(3)^2) *
'* *
'* T Y1 Y2 Y3 Y4 Y5 *
'* *
'* 0.00000 1.00000 1.00000 1.00000 1.00000 1.00000 *
'* 0.13636 1.14610 1.14609 1.14587 1.14068 1.05604 *
'* 0.27273 1.31354 1.31340 1.31128 1.28532 1.05248 *
'* 0.40909 1.50538 1.50460 1.49612 1.42333 0.95209 *
'* 0.54545 1.72508 1.72223 1.69844 1.53859 0.71111 *
'* 0.68182 1.97638 1.96840 1.91370 1.60897 0.28809 *
'* 0.81818 2.26328 2.24438 2.13400 1.60781 -0.33918 *
'* 0.95455 2.58984 2.55011 2.34770 1.50801 -1.15027 *
'* 1.09091 2.96003 2.88369 2.53985 1.28946 -2.06094 *
'* 1.22727 3.37739 3.24105 2.69376 0.94820 -2.92046 *
'* 1.36364 3.84475 3.61589 2.79372 0.50379 -3.54302 *
'* 1.50000 4.36396 4.00000 2.82843 -0.00000 -3.77124 *
'* ------------------------------------------------------------------- *
'* *
'* Basic Release 1.1 By J-P Moreau, Paris. *
'* (www.jpmoreau.fr) *
'* *
'* Release 1.1: added test #3. *
'***********************************************************************
' LIST OF SUBROUTINES:
' 400: User defined calculation of derivatives (examples #1 and #2)
' 500: Calculate exact solution (example #1)
' 600: Define example #1
' 700: Define example #2
' 800: Define example #3
' 1000: Fehlberg subroutine (one step)
' 1200: Emulation of Fortran routine Sign (with integers)
' 1210: Emulation of Fortran routine Sign (with real numbers)
' 1300: Emulation of Fortran routine Max (with real numbers)
' 1310: Emulation of Fortran routine Min (with real numbers)
' 2000: Runge-Kutta-Fehlberg method (double precision)
'------------------------------------------------------------
DefDbl A-H, O-Z
DefInt I-N
NEQ =5'Maximum number of equations
PI =4#*Atn(1#)'Constant PI
EPSILON =2.22E-16'Small number
Dim y(NEQ), yp(NEQ)
'auxiliary variables used by 400
Dim yy(NEQ), yyp(NEQ)
'work space used by successive calls to 1000 and 2000
Dim f1(NEQ), f2(NEQ), f3(NEQ), f4(NEQ), f5(NEQ)
Cls
Print" PROGRAM TRKF45"
Print" Demonstrate the RKF45 ODE integrator."
GoSub600'call test01
INPUT"Any key to continue... ", R$
GoSub700'call test02
INPUT"Any key to continue... ", R$
GoSub800'call test03
INPUT"Any key to continue... ", R$
End'of main program
'User defined system of diff. equations
400'Subroutine f(tt, yy, yyp)
'--------------------------------------------------------------------
'
' F evaluates the derivative for the ODE (TESTS #1 and #2).
'
'-------------------------------------------------------------------}
If num =1Then
yyp(1)=0.25* yy(1)*(1#- yy(1)/20#)
ElseIf num =2Then
yyp(1)= yy(2): yyp(2)=-yy(1)
Else
yyp(1)= yy(2)
yyp(2)= yy(3)
yyp(3)= yy(4)
yyp(4)= yy(5)
yyp(5)=(45#* yy(3)* yy(4)* yy(5)-40#* yy(4)^3)/(9#* yy(3)^2)
EndIf
Return
500'function yexact(tt)
'--------------------------------------------------------------------
'
' YEXACT evaluates the exact solution of the ODE (For TEST #1).
'
'--------------------------------------------------------------------
yexact =20#/(1#+19#*Exp(-0.25* tt))
Return
600'Subroutine test01
'--------------------------------------------------------------------
'
' TEST01 solves a scalar ODE in double precision.
'
'--------------------------------------------------------------------
num =1'example #1
neqn =1'one equation
F$ ="####.#####"
G$ ="####.#######"
Print" TEST01"
Print" Solve a scalar equation:"
Print" Y' = 0.25 * Y * ( 1 - Y / 20 )"
abserr =0.000001
relerr =0.000001
iflag =1
tstart =0#
tstop =20#
nstep =5
tout =0#
y(1)=1#
Print" T Y Y_Exact Error"
tt = tout:GoSub500'calculate yexact(tout)
Print"";:Print USING; F$; tout;
Print"";:Print USING; F$; y(1);
Print"";:Print USING; F$; yexact;
Print"";:Print USING; G$; y(1)- yexact
For istep =1To nstep
t =((nstep - istep +1)* tstart +(istep -1)* tstop)/ nstep
tout =((nstep - istep)* tstart +(istep)* tstop)/ nstep
GoSub2000'call rkfs (neqn,y,t,tout,relerr,abserr,iflag,yp,h,f1..f5,savr,save,
'nfe,kop,init,jflag,kflag)
tt = tout:GoSub500'calculate yexact(tout)
Print"";:Print USING; F$; tout;
Print"";:Print USING; F$; y(1);
Print"";:Print USING; F$; yexact;
Print"";:Print USING; G$; y(1)- yexact
Next istep
Return
700'Subroutine test02
'--------------------------------------------------------------------
'
' TEST02 solves a vector ODE.
'
'--------------------------------------------------------------------
num =2'Example #2
neqn =2'2 equations
Print" TEST02"
Print" Solve a vector equation:"
Print" Y'(1) = Y(2)"
Print" Y'(2) = - Y(1)"
abserr =0.000001
relerr =0.000001
iflag =1
tstart =0#
tstop =2#* PI
nstep =12
tout =0#
y(1)=1#
y(2)=0#
Print" T Y1 Y2"
Print"";:Print USING; F$; tout;
Print"";:Print USING; F$; y(1);
Print"";:Print USING; F$; y(2)
For istep =1To nstep
t =((nstep - istep +1)* tstart +(istep -1)* tstop)/ nstep
tout =((nstep - istep)* tstart +(istep * tstop)/ nstep)
GoSub2000'call rkfs (neqn,y,t,tout,relerr,abserr,iflag,yp,h,f1..f5,savr,save,
'nfe,kop,init,jflag,kflag)
Print"";:Print USING; F$; tout;
Print"";:Print USING; F$; y(1);
Print"";:Print USING; F$; y(2)
Next istep
Return
800'Subroutine test03
'--------------------------------------------------------------------
'
' TEST02 solves a vector ODE.
'
'--------------------------------------------------------------------
num =3'Example #3
neqn =5'5 equations
Print" TEST03"
Print" Solve a vector equation:"
Print" Y'(1) = Y(2)"
Print" Y'(2) = Y(3)"
Print" Y'(3) = Y(4)"
Print" Y'(4) = Y(5)"
Print" Y'(5) = (45 * Y(3) * Y(4) * Y(5) - 40 * Y(4)^3) / (9 * Y(3)^2)"
abserr =0.000001
relerr =0.000001
iflag =1
tstart =0#
tstop =1.5
nstep =11
tout =0#
y(1)=1#
y(2)=1#
y(3)=1#
y(4)=1#
y(5)=1#
Print" T Y1 Y2 Y3 Y4 Y5"
Print"";:Print USING; F$; tout;
Print"";:Print USING; F$; y(1);
Print"";:Print USING; F$; y(2);
Print"";:Print USING; F$; y(3);
Print"";:Print USING; F$; y(4);
Print"";:Print USING; F$; y(5)
For istep =1To nstep
t =((nstep - istep +1)* tstart +(istep -1)* tstop)/ nstep
tout =((nstep - istep)* tstart +(istep * tstop)/ nstep)
GoSub2000'call rkfs (neqn,y,t,tout,relerr,abserr,iflag,yp,h,f1..f5,savr,save,
'nfe,kop,init,jflag,kflag)
Print"";:Print USING; F$; tout;
Print"";:Print USING; F$; y(1);
Print"";:Print USING; F$; y(2);
Print"";:Print USING; F$; y(3);
Print"";:Print USING; F$; y(4);
Print"";:Print USING; F$; y(5)
Next istep
Return
'************************************************************************
'* Collection of Basic subroutines to Integrate a System of Ordinary *
'* Differential Equations By the Runge-Kutta-Fehlberg method (in double *
'* precision). *
'************************************************************************
1000'Subroutine fehl(neqn, y, t, h, yp, f1, f2, f3, f4, f5, s)
'************************************************************************
'
' FEHL takes one Fehlberg fourth-fifth order step (double precision).
'
' Discussion:
'
' FEHL integrates a system of NEQN first order ordinary differential
' equations of the form
' dY(i)/dT = F(T,Y(1),---,Y(NEQN))
' where the initial values Y and the initial derivatives
' YP are specified at the starting point T.
'
' FEHL advances the solution over the fixed step H and returns
' the fifth order (sixth order accurate locally) solution
' approximation at T+H in array S.
'
' The formulas have been grouped to control loss of significance.
' FEHL should be called with an H not smaller than 13 units of
' roundoff in T so that the various independent arguments can be
' distinguished.
'
' Author:
'
' H A Watts and L F Shampine,
' Sandia Laboratories,
' Albuquerque, New Mexico.
'
' RKF45 is primarily designed to solve non-stiff and mildly stiff
' differential equations when derivative evaluations are inexpensive.
'
' Parameters:
'
' Input, external F, a subroutine of the form
' Procedure f(t:double; y:VEC; var yp:VEC);
' to evaluate the derivatives.
' YP(I) = dY(I) / dT;
'
' Input, integer NEQN, the number of equations to be integrated.
'
' Input, double Y(NEQN), the current value of the dependent variable.
'
' Input, double T, the current value of the independent variable.
'
' Input, double H, the step size to take.
'
' Input, double YP(NEQN), the current value of the derivative of the
' dependent variable.
'
' Output, double F1(NEQN), double F2(NEQN), double F3(NEQN), double F4(NEQN),
' double F5(NEQN) are arrays of dimension NEQN which are needed for
' internal storage.
'
' Output, double S(NEQN), the computed estimate of the solution at T+H.
'******************************************************************************}
ch = h /4#
For i =1To neqn
f5(i)= y(i)+ ch * yp(i)
Next i
tt = t + ch:
For i =1To neqn
yy(i)= f5(i)
Next i
GoSub400'call f(t+ch, f5, f1)
For i =1To neqn
f1(i)= yyp(i)
Next i
ch =3#* h /32#
For i =1To neqn
f5(i)= y(i)+ ch *(yp(i)+3#* f1(i))
Next i
tt = t +3#* h /8#
For i =1To neqn
yy(i)= f5(i)
Next i
GoSub400'call f(t+3#*h/8#, f5, f2)
For i =1To neqn
f2(i)= yyp(i)
Next i
ch = h /2197#
For i =1To neqn
f5(i)= y(i)+ ch *(1932#* yp(i)+(7296#* f2(i)-7200#* f1(i)))
Next i
tt = t +12#* h /13#
For i =1To neqn
yy(i)= f5(i)
Next i
GoSub400'call f(t+12#*h/13#, f5, f3)
For i =1To neqn
f3(i)= yyp(i)
Next i
ch = h /4104#
For i =1To neqn
f5(i)= y(i)+ ch *((8341#* yp(i)-845#* f3(i))+(29440#* f2(i)-32832#* f1(i)))
Next i
tt = t + h
For i =1To neqn
yy(i)= f5(i)
Next i
GoSub400:'call f(t+h, f5, f4)
For i =1To neqn
f4(i)= yyp(i)
Next i
ch = h /20520#
For i =1To neqn
tmp =(41040#* f1(i)-28352#* f2(i))
f1(i)= y(i)+ ch *((-6080#* yp(i)+(9295#* f3(i)-5643#* f4(i)))+ tmp)
Next i
tt = t + h /2#
For i =1To neqn
yy(i)= f1(i)
Next i
GoSub400'call f(t+h/2#, f1, f5)
For i =1To neqn
f5(i)= yyp(i)
Next i
' Ready to compute the approximate solution at T+H.
ch = h /7618050#
For i =1To neqn
tmp =(3953664#* f2(i)+277020#* f5(i))
f1(i)= y(i)+ ch *((902880#* yp(i)+(3855735#* f3(i)-1371249#* f4(i)))+ tmp)
Next i
Return
'Emulation of Fortran Intrisic Functions
1200'Function ISign(ia,ib)
If ib <0Then
ISign =-Abs(ia)
Else
ISign =Abs(ia)
EndIf
Return
1210'Function Sign(a,b)
If B <0Then
Sign =-Abs(a)
Else
Sign =Abs(a)
EndIf
Return
1300'Function XMax(a,b)
If a >= B Then
XMax = a
Else
XMax = B
EndIf
Return
1310'Function XMin(a,b)
If a <= B Then
XMIN = a
Else
XMIN = B
EndIf
Return
2000'Subroutine rkfs(neqn, y, t, tout, relerr, abserr, iflag, yp, h, f1, f2, f3, f4,f5,
' savr, save, nfe, kop, init, jflag, kflag)
'***************************************************************************************
'
' RKFS implements the Runge-Kutta-Fehlberg method (double precision).
'
' Discussion:
'
' RKFS integrates a system of first order ordinary differential
' equations as described in the comments for RKF45.
'
' The arrays yp, f1, f2, f3, f4, and f5 (of dimension neqn) and
' the variables h, savre, savae, nfe, kop, init, jflag and kflag are used
' internally by the code and appear in the call list to eliminate
' local retention of variables between calls. Accordingly, they
' should not be altered. Items of possible interest are
'
' YP - the derivative of the solution vector at T;
' H - an appropriate stepsize to be used for the next step;
' NFE - the number of derivative function evaluations.
'
' The expense is controlled by restricting the number
' of function evaluations to be approximately MAXNFE.
' As set, this corresponds to about 500 steps.
'
' REMIN is the minimum acceptable value of RELERR. Attempts
' to obtain higher accuracy with this subroutine are usually
' very expensive and often unsuccessful.
'***************************************************************************************
'Labels: 25,40,45,50,60,65,80,100,200,260
remin =0.000000000001
maxnfe =3000
' ihfaild, ioutput: boolean (0 or 1)
' Check the input parameters
eps = EPSILON
If neqn <1Then
iflag =8
Return
EndIf
If relerr <0#Then
iflag =8
Return
EndIf
If abserr <0#Then
iflag =8
Return
EndIf
mflag =Abs(iflag)
IfAbs(iflag)<1 Or Abs(iflag)>8Then
iflag =8
Return
EndIf
' Is this the first call?
If mflag =1ThenGoTo50
' Check continuation possibilities
If t = tout And kflag <>3Then
iflag =8
Return
EndIf
If mflag <>2ThenGoTo25
' iflag = +2 or -2
If kflag =3ThenGoTo45
If init =0ThenGoTo45
If kflag =4ThenGoTo40
If kflag =5 And abserr =0#ThenEnd
If kflag =6 And relerr <= savr And abserr <= save ThenEnd
GoTo50
' iflag = 3,4,5,6,7 or 8
25If iflag =3ThenGoTo45
If iflag =4ThenGoTo40
If iflag =5 And abserr >0#ThenGoTo45
' Integration cannot be continued since user did not respond to
' the instructions pertaining to iflag=5,6,7 or 8.
End
' Reset function evaluation counter
40 nfe =0
If mflag =2ThenGoTo50
' Reset flag value from previous call
45 iflag = jflag
If kflag =3Then mflag =Abs(iflag)
' Save input iflag and set continuation flag for subsequent input checking
50 jflag = iflag
kflag =0
' Save relerr and abserr for checking input on subsequent calls
savr = relerr
save = abserr
' Restrict relative error tolerance to be at least as large as
' 2*eps+remin to avoid limiting precision difficulties arising
' from impossible accuracy requests.
rer =2#* EPSILON + remin
' The relative error tolerance is too small
If relerr < rer Then
relerr = rer
iflag =3
kflag =3
Return
EndIf
dt = tout - t
If mflag =1ThenGoTo60
If init =0ThenGoTo65
GoTo80
' Initialization:
' set initialization completion indicator, init
' set indicator for too many output points, kop
' evaluate initial derivatives
' set counter for function evaluations, nfe
' evaluate initial derivatives
' set counter for function evaluations, nfe
' estimate starting stepsize.
60 init =0
kop =0
a = t
For i =1To neqn
yy(i)= y(i)
Next i
GoSub400'call f(a, y, yp)
For i =1To neqn
yp(i)= yyp(i)
Next i
nfe =1
If t = tout Then
iflag =2
Return
EndIf
65 init =1
h =Abs(dt)
toln =0#
For k =1To neqn
tol = relerr *Abs(y(k))+ abserr
If tol >0#Then
toln = tol
ypk =Abs(yp(k))
If ypk * h ^5> tol Then
h =(tol / ypk)^0.2
EndIf
EndIf
Next k
If toln <=0#Then h =0#
'h = XMax(h, 26# * eps * XMax(abs(t), abs(dt)))
IfAbs(t)>Abs(dt)Then
tmp =Abs(t)
Else
tmp =Abs(dt)
EndIf
If h <26#* eps * tmp Then
h =26#* eps * tmp
EndIf
ia =2: ib = iflag:GoSub1200
jflag = ISign
' Set stepsize for integration in the direction from T to TOUT
80 a = h: B = dt:GoSub1210
h = Sign
' Test to see if RKF45 is being severely impacted by too many output points.
IfAbs(h)>=2#*Abs(dt)Then kop = kop +1
' Unnecessary frequency of output
If kop =100Then
kop =0
iflag =7
Return
EndIf
' If too close to output point, extrapolate and return
IfAbs(dt)<=26#* eps *Abs(t)Then
For i =1To neqn
y(i)= y(i)+ dt * yp(i)
Next i
a = tout
For i =1To neqn
yy(i)= y(i)
Next i
GoSub400'call f(a, y, yp)
For i =1To neqn
yp(i)= yyp(i)
Next i
nfe = nfe +1
t = tout
iflag =2
Return
EndIf
' Initialize output point indicator
ioutput =0
' To avoid premature underflow in the error tolerance function,
' scale the error tolerances.
scale =2#/ relerr
ae = scale * abserr
' Step by step integration
100: ihfaild =0
' Set smallest allowable stepsize
hmin =26#* eps *Abs(t)
' Adjust stepsize if necessary to hit the output point.
' Look ahead two steps to avoid drastic changes in the stepsize and
' thus lessen the impact of output points on the code.
dt = tout - t
IfAbs(dt)>=2#*Abs(h)ThenGoTo200
' The next successful step will complete the integration to the output point.
IfAbs(dt)<=Abs(h)Then
ioutput =1
h = dt
GoTo200
EndIf
h =0.5* dt 'reduce step
' Core integrator for taking a single step
'
' The tolerances have been scaled to avoid premature underflow in
' computing the error tolerance function ET.
' To avoid problems with zero crossings, relative error is measured
' using the average of the magnitudes of the solution at the
' beginning and end of a step.
' The error estimate formula has been grouped to control loss of
' significance.
'
' To distinguish the various arguments, H is not permitted
' to become smaller than 26 units of roundoff in T.
' Practical limits on the change in the stepsize are enforced to
' smooth the stepsize selection process and to avoid excessive
' chattering on problems having discontinuities.
' To prevent unnecessary failures, the code uses 9/10 the stepsize
' it estimates will succeed.
'
' After a step failure, the stepsize is not allowed to increase for
' the next attempted step. This makes the code more efficient on
' problems having discontinuities and more effective in general
' since local extrapolation is being used and extra caution seems
' warranted.
'
' Test number of derivative function evaluations.
' If okay, try to advance the integration from T to T+H.
' Too many function calls.
200If nfe > maxnfe Then
iflag =4
kflag =4
Return
EndIf
' Advance an approximate solution over one step of length H.
GoSub1000'call fehl(neqn, y, t, h, yp, f1, f2, f3, f4, f5, f1)
nfe = nfe +5
' Compute and test allowable tolerances versus local error estimates
' and remove scaling of tolerances. Note that relative error is
' measured with respect to the average of the magnitudes of the
' solution at the beginning and end of the step.
eeoet =0#
For k =1To neqn
et =Abs(y(k))+Abs(f1(k))+ ae
If et <=0#Then
iflag =5
Return
EndIf
tmp =(22528#* f2(k)-27360#* f5(k))
ee =Abs((-2090#* yp(k)+(21970#* f3(k)-15048#* f4(k)))+ tmp)
'eeoet = XMax(eeoet, ee/et)
a = eecet: B = ee / et:GoSub1300: eecet = XMax
Next k
esttol =ABS(h)* eeoet * scale /752400#
If esttol <=1#ThenGoTo260
' Unsuccessful step. Reduce the stepsize, try again.
' The decrease is limited to a factor of 1/10.
ihfaild =1
ioutput =0
If esttol <59049#Then
s =0.9/(esttol ^0.2)
Else
s =0.1
EndIf
h = s * h
IfAbs(h)< hmin Then
iflag =6
kflag =6
Return
Else
GoTo200
EndIf
' Successful step. Store solution at T+H and evaluate derivatives there.
260 t = t + h
For i =1To neqn
y(i)= f1(i)
Next i
a = t
For i =1To neqn
yy(i)= y(i)
Next i
GoSub400'call f(a, y, yp)
For i =1To neqn
yp(i)= yyp(i)
Next i
nfe = nfe +1
' Choose next stepsize. The increase is limited to a factor of 5.
' If step failure has just occurred, next stepsize is not allowed to increase.
If esttol >0.0001889568Then
s =0.9/ esttol ^0.2
Else
s =5#
EndIf
If ihfaild <>0Then
's = XMin(s, 1#)
a = s: B =1#:GoSub1310: s = XMIN
EndIf
'h = Sign(XMax(s * abs(h), hmin), h)
a = s *Abs(h): B = hmin:GoSub1300
a = XMax: B = h:GoSub1210: h = Sign
' End of core integrator
' Should we take another step?
If ioutput <>0Then
t = tout
iflag =2
EndIf
If iflag >0ThenGoTo100
' Integration successfully completed
' ne-step mode
iflag =-2
Return
'end of file trkf45.bas
↧
Visual Basic 6.0 by default on Windows
Windows has many tools by default like Paint or Notepad. What is missing in the tool arsenal is a programming language. Visual Basic 6.0 seems to be extraordinarily well suited since is particularly powerful, fast and with millions of programmers.
In the community, it was concluded that Microsoft may not have powerful specialists on the programming languages side like they had in the 90's and that would be one of the reasons why they can not make a new Visual Basic 6.X version.
Another reason in the community gossip would be that they no longer have the source code of the Visual Basic 6.0 programming language probably due to data corruption.
The list of suspicions is long as Microsoft tried to break the support for VB6 in 2008, but they could not do that because of the masses of programmers who have resisted.
Another false information would be that VB6 programmers do not want to go to other languages, but as far as I know personally, VB6 programmers know a very wide range of languages, especially C++, Java, PHP and ASM.
The support for VB6 is now guaranteed by Microsoft until 2027. So it will survive longer than most of the programming packages released right now.
Such an idea would be very constructive for Windows 10 and future variants.
![]()
In the community, it was concluded that Microsoft may not have powerful specialists on the programming languages side like they had in the 90's and that would be one of the reasons why they can not make a new Visual Basic 6.X version.
Another reason in the community gossip would be that they no longer have the source code of the Visual Basic 6.0 programming language probably due to data corruption.
The list of suspicions is long as Microsoft tried to break the support for VB6 in 2008, but they could not do that because of the masses of programmers who have resisted.
Another false information would be that VB6 programmers do not want to go to other languages, but as far as I know personally, VB6 programmers know a very wide range of languages, especially C++, Java, PHP and ASM.
The support for VB6 is now guaranteed by Microsoft until 2027. So it will survive longer than most of the programming packages released right now.
Such an idea would be very constructive for Windows 10 and future variants.
↧
Microsoft say "It is not feasible to open source VB6 tools chain and ecosystem." Why ?
Microsoft say of the VB6 programming language "In summary, VB6 was awesome. We agree. We don’t expect or demand anyone to throw away their code or rewrite from any of our technologies unless it makes business sense for them to do so. We have to innovate to enable our customers to innovate. It is not a viable option to create a next version of VB6. We stand by our decision to make VB.NET and the .NET Framework. We think they are awesome too. It is not feasible to open source VB6 tools chain and ecosystem." - Paul Yuknewicz, Group Program Manager, June 3, 2014.It does not make business sense to have to rewrite VB6 applications. And yet without an updated or open source VB6 you are forcing VB6 developers to move to a different language.
Why is it "not a viable option to create a next version of VB6" ?
Why is it "not feasible to open source VB6 tools chain and ecosystem" ?
You have updated the VBA programming language from VBA6 to VBA7.x. Exactly why can't you do this for VB6 ?
You have open sourced much of .Net. Exactly why can't you open source VB6 ?
by
↧
↧
Visual Basic 6.0 is an attractor for the young intelligent minds
Up to my last count in 2014, there have been around 200 pages dedicated to VB6 on FaceBook. I am subscribed to one of the very active pages, namely https://www.facebook.com/MicrosoftVB/. I asked the administrators this page if they had something related to the VB6 programmers age data. They did more than send me data, they gave me access to their statistics. The current number of programmers subscribed to the page in 2017 is 13 thousand. Not just that young minds prefer VB6, but new blood comes to the VB6 community and not to the other communities. While in general the trend of using a language is artificially maintained by different companies and groups, the Visual Basic 6.0 language has a natural trend, it's like an attractor for the intelligent minds. Of 13,000 programmers this is the age distribution on the https://www.facebook.com/MicrosoftVB/:
Here's an example with a video that was posted over a single day
↧
Microsoft languages !
↧
Visual Basic 6.0 has a total of 22 million dedicated videos on Youtube
Visual Basic 6.0 has a total of 22 million videos on Youtube. This shows how active a community can be. For instance, 764,000 results are shown for "VB6". About 14,600,000 results are shown for "Visual Basic 6.0" and about 6,260,000 results are shown for "Visual Basic" ("Visual Basic" is the general term for Visual Basic 6.0, Visual Basic 5.0). Not to mention that many of the uploaded video files are related to VB6 but "VB6" as a keyword is not mentioned in the title or description. For instance, one of the known programmers (MiorSoft (reexre)) that makes advanced (better than anything that Google has) open source Neural Networks in Visual Basic 6.0, does not mention the programming language. (Ex1, Ex2, Ex3, Ex4).
Good job VB6 community, continue to post !
↧
VB6 graph control
This project is from Woka, one of the VB6 community fighters. I do not know anything about Woka but I see it made a gorgeous chart with relatively wide applicability. Thank you Woka !
Download from me and me v2
Download from source
I have written a small compact graph usercontrol control.
Features:
Squigillians of points
Draw Line Graph
Draw Bar Graph
All Custom Colors
Draw Points
Draw Axis
Fixed Items
Save ALL grid and point properties to a file
Load a graph from a saved file
I think that's it.
With the graph it's possible to do the following:
Draw a moving graph, like you see in task manager
Draw a histogram, bar and line graphs
Draw mathematical equations, like Sin Wave or x^2
Draw a moving music graphic equaliser thingy like in media player
Create a progress bar
It's something I knocked up in the last 24hrs. I can't find any bugs, but I am sure one of the little bastards is still lurking around
Any comments or suggestions would be great.
Cheers.
Woka
![]()
![]()
![]()
![]()
![]()
Download from me and me v2
Download from source
I have written a small compact graph usercontrol control.
Features:
Squigillians of points
Draw Line Graph
Draw Bar Graph
All Custom Colors
Draw Points
Draw Axis
Fixed Items
Save ALL grid and point properties to a file
Load a graph from a saved file
I think that's it.
With the graph it's possible to do the following:
Draw a moving graph, like you see in task manager
Draw a histogram, bar and line graphs
Draw mathematical equations, like Sin Wave or x^2
Draw a moving music graphic equaliser thingy like in media player
Create a progress bar
It's something I knocked up in the last 24hrs. I can't find any bugs, but I am sure one of the little bastards is still lurking around
Any comments or suggestions would be great.
Cheers.
Woka
↧
↧
Prediction-correction method
'***********************************************************
'* SOLVING DIFFERENTIAL EQUATIONS OF ORDER 1 *
'* (Prediction-correction method) *
'* ------------------------------------------------------- *
'* Reference: *
'* "Analyse en Turbo Pascal versions 5.5 et 6.0 By Marc *
'* DUCAMP et Alain REVERCHON - Eyrolles, Paris 1991" *
'* [BIBLI 03]. *
'* *
'* Basic version by J-P Moreau, Paris *
'* (www.jpmoreau.fr) *
'* ------------------------------------------------------- *
'* SAMPLE RUN: *
'* (Integrate y'=(4xy+4x*sqrt(y))/(1+xý) from x=0 to x=10 *
'* with initial condition y(0)=1) *
'* *
'* Input x begin: 0 *
'* Input x end : 10 *
'* Input y begin: 1 *
'* Input number of points: 10 *
'* Input finesse: 10 *
'* *
'* X Y *
'* ----------------------------- *
'* 1.000000 8.999984 *
'* 2.000000 80.999881 *
'* 3.000000 360.999496 *
'* 4.000000 1088.998512 *
'* 5.000000 2600.996484 *
'* 6.000000 5328.992838 *
'* 7.000000 9800.986875 *
'* 8.000000 16640.977767 *
'* 9.000000 26568.964559 *
'* 10.000000 40400.946171 *
'* ----------------------------- *
'* * *
'***********************************************************
DefInt I-N
DefDbl A-H, O-Z
MAXDATA =100
Dim tx(MAXDATA), ty(MAXDATA)
'integer ifi, n
Cls
input" Input x begin: ", xi
input" Input x end : ", xf
input" Input y begin: ", yi
input" Input number of points: ", n
input" Input finesse: ", ifi
GoSub3000'call equadiff_pc(tx,ty,xi,xf,yi,n,ifi)
' print results
f$ ="#####.###### #####.######"
Print" X Y "
Print" -----------------------------"
For i =1To n
Print using; f$; tx(i); ty(i)
Next i
Print" -----------------------------"
End'of main program
1000'Function y'=(4xy+4x*sqrt(y))/(1+xý)
If yy >0Then
f =(4* xx * yy +4* xx *Sqr(yy))/(1+ xx * xx)
Else
f =0
EndIf
Return
2000'classical Runge-Kutta method of order 4
xx = X: yy = y:GoSub1000: a = h * f
xx = X + h /2: yy = y + a /2:GoSub1000: B = h * f
yy = y + B /2:GoSub1000: c = h * f
X = X + h: xx = X: yy = y + c:GoSub1000: d = h * f
y = y +(a + B + B + c + c + d)/6
Return
'**********************************************************
'* Prediction-correction method *
'* ------------------------------------------------------ *
'* INPUTS: *
'* xi begin x value *
'* xf end x value *
'* yi begin y value (at x=xi) *
'* n number of points to calculate *
'* ifi finesse (number of intermediate *
'* points (for example 10) *
'* OUTPUTS: *
'* tx table of x values (m values) *
'* ty table of y values (m values) *
'* *
'* DESCRIPTION: *
'* The algorithm has the following steps: *
'* 1. calculate y2, y3, y4 using a classical Runge- *
'* Kutta method of order 4. *
'* 2. from point (x4, y4), first estimate y(n+1) by *
'* formula: *
'* y(n+1)=y(n) + h/24(55y'(n)-59y'(n-1)+37y'(n-2) *
'* -9y'(n-3) *
'* then continue with formula: *
'* y(n+1)=y(n) + h/24(9y'(n+1)+19y'(n)-5y'(n-1) *
'* +y'(n-2), *
'* noting that y'(n+1)=f(x(n+1),y(n+1)) with the *
'* estimated value of y(n+1), until convergence is *
'* obtained. *
'**********************************************************
3000'Subroutine equadiff_pc(tx, ty, xi, xf, yi, n, ifi)
Dim p(3)
z = yi
m = n
If(m > MAXDATA) Or (ifi <1)ThenReturn
h =(xf - xi)/ ifi / m
xx = xi: yy = yi:GoSub1000: p(3)= f
tx(0)= xi: ty(0)= yi
k =0
For i =1To m
ni =(i -1)* ifi -1
For j =1To ifi
X = xi + h *(ni + j)
k = k +1
If(k <4)Then
'call runge_kutta(h,x,z)
y = z:GoSub2000: z = y
xx = X: yy = z:GoSub1000: p(3- k)= f
Else
X = X + h
w = z +(h /24)*(55* p(0)-59* p(1)+37* p(2)-9* p(3))
'continue
10 y = w
xx = X: yy = y:GoSub1000
w = z +(h /24)*(9* f +19* p(0)-5* p(1)+ p(2))
IfAbs(y - w)>0.0000000001ThenGoTo10
z = w: p(3)= p(2): p(2)= p(1)
p(1)= p(0): xx = X: yy = z:GoSub1000: p(0)= f
EndIf
Next j 'j loop
tx(i)= X: ty(i)= z
Next i 'i loop
Return
' end of file teqdifpc.bas
↧
NUMERICAL SOLUTION OF A STIFF SYSTEM OF FIRST ORDER ORDINARY DIFFERENTIAL EQUATIONS Y':=F(X,Y) BY ROSENBROCK METHOD.
'****************************************************************
'* NUMERICAL SOLUTION OF A STIFF SYSTEM OF FIRST 0RDER ORDINARY *
'* DIFFERENTIAL EQUATIONS Y':=F(X,Y) BY ROSENBROCK METHOD. *
'* ------------------------------------------------------------ *
'* SAMPLE RUN: *
'* Example #1: *
'* (Solve set of differential equations (N=2): *
'* F(1) = Y(1) * Y(2) + COS(X) - HALF * SIN(TWO * X) *
'* F(2) = Y(1) * Y(1) + Y(2) * Y(2) - (ONE + SIN(X)) *
'* Find values of F(1), F(2) at X=1.5). *
'* *
'* SOLUTION AT X= 1.50000000000000E+0000 *
'* Y(1) = 1.236006095804576 *
'* Y(2) = -.1049268945803322 *
'* *
'* LAST STEP SIZE = 3.089293500117273D-04 *
'* ERROR CODE = 1 *
'* *
'* Example #2: *
'* (Solve set of differential equations (N=5): *
'* F(1) = Y(2) *
'* F(2) = Y(3) *
'* F(3) = Y(4) *
'* F(4) = Y(5) *
'* F(5) = (45.0 * Y(3) * Y(4) * Y(5) - *
'* 40.0 * Y(4) * Y(4) * Y(4)) / (9.0 * Y(3) * Y(3)) *
'* Find values of F(1), F(2), ..., F(5) at X=1.5). *
'* *
'* SOLUTION AT X= 1.50000000000000E+0000 *
'* Y(1) = 4.363967162542581 *
'* Y(2) = 4.000019057753676 *
'* Y(3) = 2.82847148934375 *
'* Y(4) = 5.641335228805289D-05 *
'* Y(5) = -3.77130489085171 *
'* *
'* LAST STEP SIZE = 7.626269049659622D-05 *
'* ERROR CODE = 1 *
'* ------------------------------------------------------------ *
'* Ref.: From Numath Library By Tuan Dang Trong in Fortran 77 *
'* [BIBLI 18]. *
'* *
'* Basic Release 1.0 By J-P Moreau, Paris *
'* (www.jpmoreau.fr) *
'****************************************************************
' LIST OF USED SUBROUTINES (HERE INCLUDED):
' ========================================
' 500 FCN DEFINE SYSTEM OF DIFFERENTIAL EQUATIONS (TWO EXAMPLES)
' 600 IMAX MAXIMUM OF TWO INTEGERS
' 610 IMIN MINIMUM OF TWO INTEGERS
' 620 XMAX MAXIMUM OF TWO REAL NUMBERS
' 630 XMIN MINIMUM OF TWO REAL NUMBERS
' 650 SIGN EMULATION OF FUNCTION SIGN OF FORTRAN
' 1000 ROS4 NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC)
' SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS
' MY'=F(X,Y)
' 2000 RO4COR CORE INTEGRATOR FOR ROS4
' 3000 SHAMP DEFINE CONSTANTS A21... TO D4 (METHOD 1)
' 3001 GRK4A DEFINE CONSTANTS A21... TO D4 (METHOD 3)
' 3002 GRK4T DEFINE CONSTANTS A21... TO D4 (METHOD 2 USED HERE)
' 3003 VELDD DEFINE CONSTANTS A21... TO D4 (METHOD 4)
' 3004 VELDS DEFINE CONSTANTS A21... TO D4 (METHOD 5)
' 3005 LSTAB DEFINE CONSTANTS A21... TO D4 (METHOD 6)
' 4000 DECB MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED
' MATRIX WITH LOWER BANDWIDTH MLDE AND UPPER BANDWIDTH MUE
' 4500 DECA GENERAL MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION
' 5000 SOLB SOLUTION OF A BANDED LINEAR SYSTEM, E*X = B
' (E IS A TRIANGULARIZED MATRIX OBTAINED FROM DECB).
' 5500 SOL SOLUTION OF A GENERAL LINEAR SYSTEM, E*X = B
' (E IS A TRIANGULARIZED MATRIX OBTAINED FROM DECA).
' --------------------------------------------------------------------------
'NOTE: THE BANDED MATRIX BRANCH HAS NOT BEEN TESTED HERE, HOWEVER
' IS FULLY IMPLEMENTED.
DefDbl A-H, O-Z
DefInt I-N
'constants
NMX =30'Maximum size of temporary vectors TMP1 to TMP11 and ITMP
HALF =0.5
ONE =1#
TEN =10#
TWO =2#
XNINE =9#
ZERO =0#
Dim B(NMX), F(NMX), Y(NMX), YY(NMX)
Dim FJAC(5,5), E(5,5), FMAS(5,5)
'variables for statistics (optional use)
'XNFCN,XNSTEP,XNJAC,XNACCPT,NREJCT,XNDEC,XNSOL
'(Long integers are simulated by real numbers).
'begin main program
'Initialize parameters (see 1000 ROS4)
N =2'DIMENSION OF THE SYSTEM (N=5 for example #2)
IFCN =1'FCN(N,X,Y,F) MAY DEPEND ON X
X = ZERO 'INITIAL X-VALUE
XEND =1.5'FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
H =0.001'INITIAL STEP SIZE GUESS (0.01 FOR example #2)
RTOL =0.00000001'RELATIVE XERROR TOLERANCE (HERE SCALAR)
ATOL =0.0000000001'ABSOLUTE XERROR TOLERANCE (HERE SCALAR)
ITOL =0'BOTH RTOL AND ATOL ARE SCALARS
IJAC =0'JACOBIAN IS COMPUTED INTERNALLY BY FINITE
'DIFFERENCES, Subroutine "JAC" IS NEVER CALLED
MLJAC = N 'JACOBIAN IS A FULL MATRIX. THE LINEAR ALGEBRA
'IS DONE BY FULL-MATRIX GAUSS-ELIMINATION
IDFX =0'DF/DX IS COMPUTED INTERNALLY BY FINITE
'DIFFERENCES, Subroutine "DFX" IS NEVER CALLED
IMAS =0'M IS SUPPOSED TO BE THE IDENTITY
'MATRIX, Subroutine "MAS" IS NEVER CALLED
MLMAS = N 'MLMAS=N: THE FULL MATRIX CASE. THE LINEAR ALGEBRA
'IS DONE BY FULL-MATRIX GAUSS-ELIMINATION
IOUT =0'Subroutine SOLOUT IS NEVER CALLED
LE1 = N 'IF MLJAC=N (FULL JACOBIAN)
LJAC = N 'IF MLJAC=N (FULL JACOBIAN)
LMAS =0'IF IMAS=0
LIWORK = N +2'DECLARED LENGTH OF ARRAY "IWORK"
LWORK = N *(LJAC + LMAS + LE1 +8)+5'DECLARED LENGTH OF ARRAY "WORK"
Dim WORK(LWORK)
Dim IWORK(LIWORK)
'Temporary vectors
Dim TMP1(NMX), TMP2(NMX), TMP3(NMX), TMP4(NMX), TMP5(NMX), TMP6(NMX)
Dim TMP7(NMX), TMP8(NMX), TMP9(NMX), TMP10(NMX), TMP11(NMX)
Dim ITMP(NMX)
For I =1To LWORK
WORK(I)= ZERO 'This triggers default values (see 1000 ROS4)
Next I
For I =1To LIWORK
IWORK(I)=0
Next I
Y(1)= HALF 'INITIAL VALUES FOR Y
Y(2)= HALF 'In example #2, Y(1) = Y(2) = ... = Y(5) = ONE
Cls
Print" Computing..."
'call Rosenbrock SUBROUTINE with appropriate parameters
GoSub1000'call ROS4(N,IFCN,X,Y,XEND,H,
'RTOL,ATOL,ITOL,
'IJAC,MLJAC,MUJAC,IDFX,
'IMAS,MLMAS,MUMAS,
'IOUT,WORK,LWORK,IWORK,LIWORK,IDID)
'print results
Cls
Print" SOLUTION AT X="; X
For I =1To N
Print" Y("; I;") = "; Y(I)
Next I
Print" LAST STEP SIZE ="; H
Print" ERROR CODE = "; IDID
INPUT"", RR$
End'of main program
'define example #1
500'FCN(N,XX,YY,F)
F(1)= YY(1)* YY(2)+Cos(XX)- HALF *Sin(TWO * XX)
F(2)= YY(1)* YY(1)+ YY(2)* YY(2)-(ONE +Sin(XX))
Return
'define example #2
'500 'FCN(N,XX,YY,F)
' F(1) = YY(2);
' F(2) = YY(3);
' F(3) = YY(4);
' F(4) = YY(5);
' F(5) = (45.0 * YY(3) * YY(4) * YY(5) -
' 40.0 * YY(4) * YY(4) * YY(4)) / (NINE * YY(3) * YY(3))
'return
600'IMAX(ia,ib)
If ia > ib Then
IMAX = ia
Else
IMAX = ib
EndIf
Return
610'IMIN(ia,ib)
If ia < ib Then
IMIN = ia
Else
IMIN = ib
EndIf
Return
620'XMAX(xa,xb)
If xa > xb Then
XMAX = xa
Else
XMAX = xb
EndIf
Return
630'XMIN(xa,xb)
If xa < xb Then
XMIN = xa
Else
XMIN = xb
EndIf
Return
650'SIGN(xa,xb)
If xb <0Then
SIGN =-Abs(xa)
Else
SIGN =Abs(xa)
EndIf
Return
'**********************************************************************
1000'ROS4 (N,IFCN,X,Y,XEND,H,RTOL,ATOL,ITOL,IJAC,MLJAC,MUJAC,IDFX,
' IMAS,MLMAS,MUMAS,IOUT,WORK,LWORK,IWORK,LIWORK,IDID)
' ---------------------------------------------------------------------
' NUMERICAL SOLUTION OF A STIFF (OR DIFFERENTIAL ALGEBRAIC)
' SYSTEM OF FIRST 0RDER ORDINARY DIFFERENTIAL EQUATIONS MY'=F(X,Y).
' THIS IS AN EMBEDDED ROSENBROCK METHOD OF ORDER (3)4
' (WITH STEP SIZE CONTROL).
' C.F. SECTION IV.7
'
' AUTHORS: E. HAIRER AND G. WANNER
' UNIVERSITE DE GENEVE, DEPT. DE MATHEMATIQUES
' CH-1211 GENEVE 24, SWITZERLAND
' E-MAIL: HAIRER@CGEUGE51.BITNET, WANNER@CGEUGE51.BITNET
'
' THIS CODE IS PART OF THE BOOK:
' E. HAIRER AND G. WANNER, SOLVING ORDINARY DIFFERENTIAL
' EQUATIONS II. STIFF AND DIFFERENTIAL-ALGEBRAIC PROBLEMS.
' SPRINGER SERIES IN COMPUTATIONAL MATHEMATICS,
' SPRINGER-VERLAG (1990)
'
' VERSION OF OCTOBER 12, 1990
'
' INPUT PARAMETERS
' ----------------
' N DIMENSION OF THE SYSTEM
'
' FCN NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE
' VALUE OF F(X,Y):
' Subroutine FCN(N,X,Y,F)
' dim Y(N), F(N)
' F(1)=... ETC.
'
' IFCN GIVES INFORMATION ON FCN:
' IFCN=0: F(X,Y) INDEPENDENT OF X (AUTONOMOUS)
' IFCN=1: F(X,Y) MAY DEPEND ON X (NON-AUTONOMOUS)
'
' X INITIAL X-VALUE
'
' Y(N) INITIAL VALUES FOR Y
'
' XEND FINAL X-VALUE (XEND-X MAY BE POSITIVE OR NEGATIVE)
'
' H INITIAL STEP SIZE GUESS;
' FOR STIFF EQUATIONS WITH INITIAL TRANSIENT,
' H=1.D0/(NORM OF F'), USUALLY 1.D-2 OR 1.D-3, IS GOOD.
' THIS CHOICE IS NOT VERY IMPORTANT, THE CODE QUICKLY
' ADAPTS ITS STEP SIZE. STUDY THE CHOSEN VALUES FOR A FEW
' STEPS IN SUBROUTINE "SOLOUT", WHEN YOU ARE NOT SURE.
' (IF H=0.D0, THE CODE PUTS H=1.D-6).
'
' RTOL,ATOL RELATIVE AND ABSOLUTE XERROR TOLERANCES. THEY
' CAN BE BOTH SCALARS OR ELSE BOTH VECTORS OF LENGTH N.
'
' ITOL SWITCH FOR RTOL AND ATOL:
' ITOL=0: BOTH RTOL AND ATOL ARE SCALARS.
' THE CODE KEEPS, ROUGHLY, THE LOCAL XERROR OF
' Y(I) BELOW RTOL*ABS(Y(I))+ATOL
' ITOL=1: BOTH RTOL AND ATOL ARE VECTORS.
' THE CODE KEEPS THE LOCAL XERROR OF Y(I) BELOW
' RTOL(I)*ABS(Y(I))+ATOL(I).
'
' JAC NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
' THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO Y
' (THIS ROUTINE IS ONLY CALLED IF IJAC=1).
' FOR IJAC=1, THIS SUBROUTINE MUST HAVE THE FORM:
' SUBROUTINE JAC(N,X,Y,DFY,LDFY)
' DIM Y(N),DFY(LDFY,N)
' DFY(1,1)= ...
' LDFY, THE COLUMN-LENGTH OF THE ARRAY, IS
' FURNISHED BY THE CALLING PROGRAM.
' IF MLJAC = N, THE JACOBIAN IS SUPPOSED TO
' BE FULL AND THE PARTIAL DERIVATIVES ARE
' STORED IN DFY AS
' DFY(I,J) = PARTIAL F(I) / PARTIAL Y(J)
' ELSE, THE JACOBIAN IS TAKEN AS BANDED AND
' THE PARTIAL DERIVATIVES ARE STORED
' DIAGONAL-WISE AS
' DFY(I-J+MUJAC+1,J) = PARTIAL F(I) / PARTIAL Y(J).
'
' IJAC SWITCH FOR THE COMPUTATION OF THE JACOBIAN:
' IJAC=0: JACOBIAN IS COMPUTED INTERNALLY BY FINITE
' DIFFERENCES, SUBROUTINE "JAC" IS NEVER CALLED.
' IJAC=1: JACOBIAN IS SUPPLIED BY SUBROUTINE JAC.
'
' MLJAC SWITCH FOR THE BANDED STRUCTURE OF THE JACOBIAN:
' MLJAC=N: JACOBIAN IS A FULL MATRIX. THE LINEAR
' ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
' 0<=MLJAC<N: MLJAC IS THE LOWER BANDWITH OF JACOBIAN
' MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
' THE MAIN DIAGONAL).
'
' MUJAC UPPER BANDWITH OF JACOBIAN MATRIX (>= NUMBER OF NON-
' ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
' NEED NOT BE DEFINED IF MLJAC=N.
'
' DFX NAME (EXTERNAL) OF THE SUBROUTINE WHICH COMPUTES
' THE PARTIAL DERIVATIVES OF F(X,Y) WITH RESPECT TO X
' (THIS ROUTINE IS ONLY CALLED IF IDFX=1 AND IFCN=1).
' OTHERWISE, THIS SUBROUTINE MUST HAVE THE FORM
' SUBROUTINE DFX(N,X,Y,FX)
' DIM Y(N),FX(N)
' FX(1)= ...
'
' IDFX SWITCH FOR THE COMPUTATION OF THE DF/DX:
' IDFX=0: DF/DX IS COMPUTED INTERNALLY BY FINITE
' DIFFERENCES, SUBROUTINE "DFX" IS NEVER CALLED.
' IDFX=1: DF/DX IS SUPPLIED BY SUBROUTINE DFX.
'
' ---- MAS,IMAS,MLMAS, AND MUMAS HAVE ANALOG MEANINGS -----
' ---- FOR THE "MASS MATRIX" (THE MATRIX "M" OF SECTION IV.8): -
'
' MAS NAME (EXTERNAL) OF SUBROUTINE COMPUTING THE MASS-
' MATRIX M.
' IF IMAS=0, THIS MATRIX IS ASSUMED TO BE THE IDENTITY
' MATRIX AND NEEDS NOT TO BE DEFINED;
' IF IMAS=1, THE SUBROUTINE MAS IS OF THE FORM
' SUBROUTINE MAS(N,AM,LMAS)
' DIM AM(LMAS,N)
' AM(1,1)= ....
' IF (MLMAS.EQ.N) THE MASS-MATRIX IS STORED
' AS FULL MATRIX LIKE
' AM(I,J) = M(I,J)
' ELSE, THE MATRIX IS TAKEN AS BANDED AND STORED
' DIAGONAL-WISE AS
' AM(I-J+MUMAS+1,J) = M(I,J).
'
' IMAS GIVES INFORMATION ON THE MASS-MATRIX:
' IMAS=0: M IS SUPPOSED TO BE THE IDENTITY
' MATRIX, MAS IS NEVER CALLED.
' IMAS=1: MASS-MATRIX IS SUPPLIED.
'
' MLMAS SWITCH FOR THE BANDED STRUCTURE OF THE MASS-MATRIX:
' MLMAS=N: THE FULL MATRIX CASE. THE LINEAR
' ALGEBRA IS DONE BY FULL-MATRIX GAUSS-ELIMINATION.
' 0<=MLMAS<N: MLMAS IS THE LOWER BANDWITH OF THE
' MATRIX (>= NUMBER OF NON-ZERO DIAGONALS BELOW
' THE MAIN DIAGONAL).
' MLMAS IS SUPPOSED TO BE <= MLJAC.
'
' MUMAS UPPER BANDWITH OF MASS-MATRIX (>= NUMBER OF NON-
' ZERO DIAGONALS ABOVE THE MAIN DIAGONAL).
' NEED NOT BE DEFINED IF MLMAS=N.
' MUMAS IS SUPPOSED TO BE <= MUJAC.
'
' SOLOUT NAME (EXTERNAL) OF SUBROUTINE PROVIDING THE
' NUMERICAL SOLUTION DURING INTEGRATION.
' IF IOUT=0, NO INTERPOLATION SUBROUTINE IS NECESSARY.
' IF IOUT=1, IT IS CALLED AFTER EVERY SUCCESSFUL STEP.
' IT MUST HAVE THE FORM
' SUBROUTINE SOLOUT (NR,XOLD,X,Y,N,IRTRN)
' DIM Y(N)
' ....
' SOLOUT FURNISHES THE SOLUTION "Y" AT THE NR-TH
' GRID-POINT "X" (THEREBY THE INITIAL VALUE IS
' THE FIRST GRID-POINT).
'"IRTRN" SERVES TO INTXERRUPT THE INTEGRATION. IF IRTRN
' IS SET <0, ROS4 RETURNS TO THE CALLING PROGRAM.
'
' IOUT GIVES INFORMATION ON THE SUBROUTINE SOLOUT:
' IOUT=0: SUBROUTINE IS NEVER CALLED
' IOUT=1: SUBROUTINE IS USED FOR OUTPUT
'
' WORK ARRAY OF WORKING SPACE OF LENGTH "LWORK".
' SERVES AS WORKING SPACE FOR ALL VECTORS AND MATRICES.
'"LWORK" MUST BE AT LEAST
' N*(LJAC+LMAS+LE1+8)+5
' WHERE
' LJAC=N IF MLJAC=N (FULL JACOBIAN)
' LJAC=MLJAC+MUJAC+1 IF MLJAC<N (BANDED JAC.)
' AND
' LMAS=0 IF IMAS=0
' LMAS=N IF IMAS=1 AND MLMAS=N (FULL)
' LMAS=MLMAS+MUMAS+1 IF MLMAS<N (BANDED MASS-M.)
' AND
' LE1=N IF MLJAC=N (FULL JACOBIAN)
' LE1=2*MLJAC+MUJAC+1 IF MLJAC<N (BANDED JAC.).
'
' IN THE USUAL CASE WHERE THE JACOBIAN IS FULL AND THE
' MASS-MATRIX IS THE INDENTITY (IMAS=0), THE MINIMUM
' STORAGE REQUIREMENT IS
' LWORK = 2*N*N+8*N+5.
'
' LWORK DECLARED LENGHT OF ARRAY "WORK".
'
' IWORK INTEGER WORKING SPACE OF LENGTH "LIWORK".
'"LIWORK" MUST BE AT LEAST N+2.
'
' LIWORK DECLARED LENGHT OF ARRAY "IWORK".
'
' ----------------------------------------------------------------------
'
' SOPHISTICATED SETTING OF PARAMETERS
' -----------------------------------
' SEVERAL PARAMETERS OF THE CODE ARE TUNED TO MAKE IT WORK
' WELL. THEY MAY BE DEFINED BY SETTING WORK(1),..,WORK(5)
' AS WELL AS IWORK(1),IWORK(2) DIFFERENT FROM ZERO.
' FOR ZERO INPUT, THE CODE CHOOSES DEFAULT VALUES:
'
' IWORK(1) THIS IS THE MAXIMAL NUMBER OF ALLOWED STEPS.
' THE DEFAULT VALUE (FOR IWORK(1)=0) IS 100000.
'
' IWORK(2) SWITCH FOR THE CHOICE OF THE COEFFICIENTS
' IF IWORK(2).EQ.1 METHOD OF SHAMPINE
' IF IWORK(2).EQ.2 METHOD GRK4T OF KAPS-RENTROP
' IF IWORK(2).EQ.3 METHOD GRK4A OF KAPS-RENTROP
' IF IWORK(2).EQ.4 METHOD OF VAN VELDHUIZEN (GAMMA=1/2)
' IF IWORK(2).EQ.5 METHOD OF VAN VELDHUIZEN ("D-STABLE")
' IF IWORK(2).EQ.6 AN L-STABLE METHOD
' THE DEFAULT VALUE (FOR IWORK(2)=0) IS IWORK(2)=2.
'
' WORK(1) UROUND, THE ROUNDING UNIT, DEFAULT 1D-16.
'
' WORK(2) MAXIMAL STEP SIZE, DEFAULT XEND-X.
'
' WORK(3), WORK(4) PARAMETERS FOR STEP SIZE SELECTION
' THE NEW STEP SIZE IS CHOSEN SUBJECT TO THE RESTRICTION
' WORK(3) <= HNEW/HOLD <= WORK(4)
' DEFAULT VALUES: WORK(3)=0.2D0, WORK(4)=6.D0
'
' WORK(5) AVOID THE HUMP: AFTER TWO CONSECUTIVE STEP REJECTIONS
' THE STEP SIZE IS MULTIPLIED BY WORK(5)
' DEFAULT VALUES: WORK(5)=0.1#
'
'-----------------------------------------------------------------------
'
' OUTPUT PARAMETERS
' -----------------
' X X-VALUE WHERE THE SOLUTION IS COMPUTED
' (AFTER SUCCESSFUL RETURN X=XEND)
'
' Y(N) SOLUTION AT X
'
' H PREDICTED STEP SIZE OF THE LAST ACCEPTED STEP
'
' IDID REPORTS ON SUCCESSFULNESS UPON RETURN:
' IDID=1 COMPUTATION SUCCESSFUL,
' IDID=-1 COMPUTATION UNSUCCESSFUL.
'
' ---------------------------------------------------------
' *** *** *** *** *** *** *** *** *** *** *** *** ***
' DECLARATIONS
' *** *** *** *** *** *** *** *** *** *** *** *** ***
' IAUTNMS,IMPLCT,JBAND,IARRET: Boolean (here integers).
' --------------------------------------------------------------------
' --- THESE COMMON VARIABLES CAN BE USED FOR STATISTICS:
' --- XNFCN NUMBER OF FUNCTION EVALUATIONS (THOSE FOR NUMERICAL
' EVALUATION OF THE JACOBIAN ARE NOT COUNTED)
' --- XNJAC NUMBER OF JACOBIAN EVALUATIONS (EITHER ANALYTICALLY
' OR NUMERICALLY)
' --- XNSTEP NUMBER OF COMPUTED STEPS
' --- XNACCPT NUMBER OF ACCEPTED STEPS
' --- NREJCT NUMBER OF REJECTED STEPS (AFTER AT LEAST ONE STEP
' HAS BEEN ACCEPTED)
' --- XNDEC NUMBER OF LU-DECOMPOSITIONS (N-DIMENSIONAL MATRIX)
' --- XNSOL NUMBER OF FORWARD-BACKWARD SUBSTITUTIONS
' --------------------------------------------------------------------
' LDE,LDJAC,LDMAS,LDMAS2,METH: Integer
' XNMAX: LongInt (here double)
' FAC1,FAC2,FACREJ,HMAX,UROUND: Double
' IEYNEW,IEDY1,IEDY,IEAK1,IEAK2,IEAK3,IEAK4,
' IEFX,IEJAC,IEMAS, IEE, ISTORE: Integer;
' IEIP: Integer
' *** *** *** *** *** *** ***
' SETTING THE PARAMETERS
' *** *** *** *** *** *** ***
XNFCN = ZERO
XNJAC = ZERO
XNSTEP = ZERO
XNACCPT = ZERO
NREJCT =0
XNDEC = ZERO
XNSOL = ZERO
IARRET =0
' ------- XNMAX , THE MAXIMAL NUMBER OF STEPS -----
If IWORK(1)=0Then
XNMAX =100000#
Else
XNMAX =1#* IWORK(1)
If XNMAX <= ZERO Then
Print" WRONG INPUT, IWORK(1)= "; IWORK(1)
IARRET =1
EndIf
EndIf
' -------- METH COEFFICIENTS OF THE METHOD ------
If IWORK(2)=0Then
METH =2
Else
METH = IWORK(2)
If METH <=0 Or METH >=7Then
Print" CURIOUS INPUT, IWORK(2)="; IWORK(2)
IARRET =1
EndIf
EndIf
' -------- UROUND, SMALLEST NUMBER SATISFYING ONE + UROUND > ONE ---
If WORK(1)= ZERO Then
UROUND =1E-16
Else
UROUND = WORK(1)
If UROUND <=0.00000000000001 Or UROUND >= ONE Then
Print" COEFFICIENTS HAVE 16 DIGITS, UROUND="; WORK(1)
IARRET =1
EndIf
EndIf
' -------- MAXIMAL STEP SIZE -----------
If WORK(2)= ZERO Then
HMAX = XEND - X
Else
HMAX = WORK(2)
EndIf
' ------- FAC1,FAC2 PARAMETERS FOR STEP SIZE SELECTION ------
If WORK(3)= ZERO Then
FAC1 =5#
Else
FAC1 = ONE / WORK(3)
EndIf
If WORK(4)= ZERO Then
FAC2 = ONE /6#
Else
FAC2 = ONE / WORK(4)
EndIf
' ------- FACREJ FOR THE HUMP -------
If WORK(5)= ZERO Then
FACREJ =0.1
Else
FACREJ = WORK(5)
EndIf
' --------- CHECK IF TOLERANCES ARE O.K. ---------
If ITOL =0Then
If ATOL <= ZERO Or RTOL <= TEN * UROUND Then
Print" TOLERANCES ARE TOO SMALL."
IARRET =1
EndIf
Else
'Multiple tolerances not implemented here
'For I=1 to N
'IF ATOL(I) <= ZERO OR RTOL(I) <= TEN*UROUND THEN
' print " TOLERANCE(";I;") IS TOO SMALL."
' IARRET=1
'end if
EndIf
' *** *** *** *** *** *** *** *** *** *** *** *** ***
' COMPUTATION OF ARRAY ENTRIES
' *** *** *** *** *** *** *** *** *** *** *** *** ***
' ---- AUTONOMOUS, IMPLICIT, BANDED OR NOT ?
If IFCN =0Then
IAUTNMS =1
Else
IAUTNMS =0
EndIf
If IMAS <>0Then
IMPLCT =1
Else
IMPLCT =0
EndIf
If MLJAC <> N Then
JBAND =1
Else
JBAND =0
EndIf
IARRET =0
' -------- COMPUTATION OF THE ROW-DIMENSIONS OF THE 2-ARRAYS ------
' -- JACOBIAN --
If JBAND <>0Then
LDJAC = MLJAC + MUJAC +1
Else
LDJAC = N
EndIf
' -- MATRIX E FOR LINEAR ALGEBRA --
If JBAND <>0Then
LDE =2* MLJAC + MUJAC +1
Else
LDE = N
EndIf
' -- MASS MATRIX --
If IMPLCT <>0Then
If MLMAS <> N Then
LDMAS = MLMAS + MUMAS +1
Else
LDMAS = N
EndIf
' ------ BANDWITH OF "MAS" NOT LARGER THAN BANDWITH OF "JAC" -------
If MLMAS > MLJAC Or MUMAS > MUJAC Then
Print" BANDWITH OF MAS MUST NOT BE LARGER THAN BANDWITH OF JAC."
IARRET =1
EndIf
Else
LDMAS =0
EndIf
ia =1: ib = LDMAS:GoSub600
LDMAS2 = IMAX
' ------- PREPARE THE ENTRY-POINTS FOR THE ARRAYS IN WORK ------
IEYNEW =6
IEDY1 = IEYNEW + N
IEDY = IEDY1 + N
IEAK1 = IEDY + N
IEAK2 = IEAK1 + N
IEAK3 = IEAK2 + N
IEAK4 = IEAK3 + N
IEFX = IEAK4 + N
IEJAC = IEFX + N
IEMAS = IEJAC + N * LDJAC
IEE = IEMAS + N * LDMAS
' ------ TOTAL STORAGE REQUIREMENT -----------
ISTORE = IEE + N * LDE -1
If ISTORE > LWORK Then
Print" INSUFFICIENT STORAGE FOR WORK, MINIMUM LWORK="; ISTORE
IARRET =1
EndIf
' ------- ENTRY POINTS FOR INTEGER WORKSPACE ------
IEIP =3
' --------- TOTAL REQUIREMENT ---------------
ISTORE = IEIP + N -1
If ISTORE > LIWORK Then
Print" INSUFF. STORAGE FOR IWORK, MINIMUM LIWORK="; ISTORE
IARRET =1
EndIf
' ------ WHEN A FAIL HAS OCCURED, WE RETURN WITH IDID=-1 ------
If IARRET <>0Then
IDID =-1
Return
EndIf
' ------------- prepare arguments of RO4COR --------------------------
' Here, appropriate parts of WORK (IWORK) are put in temporary vectors
' TMP1 to TMP11 (ITMP) to simulate Fortran arguments of RO4COR.
For I =1To N
If I + IEYNEW -1<= N Then
TMP1(I)= WORK(I + IEYNEW -1)
Else
TMP1(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEDY1 -1<= N Then
TMP2(I)= WORK(I + IEDY1 -1)
Else
TMP2(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEDY -1<= N Then
TMP3(I)= WORK(I + IEDY -1)
Else
TMP3(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEAK1 -1<= N Then
TMP4(I)= WORK(I + IEAK1 -1)
Else
TMP4(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEAK2 -1<= N Then
TMP5(I)= WORK(I + IEAK2 -1)
Else
TMP5(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEAK3 -1<= N Then
TMP6(I)= WORK(I + IEAK3 -1)
Else
TMP6(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEAK4 -1<= N Then
TMP7(I)= WORK(I + IEAK4 -1)
Else
TMP7(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEFX -1<= N Then
TMP8(I)= WORK(I + IEFX -1)
Else
TMP8(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEJAC -1<= N Then
TMP9(I)= WORK(I + IEJAC -1)
Else
TMP9(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEE -1<= N Then
TMP10(I)= WORK(I + IEE -1)
Else
TMP10(I)= ZERO
EndIf
Next I
For I =1To No
If I + IEMAS -1<= N Then
TMP11(I)= WORK(I + IEMAS -1)
Else
TMP11(I)= ZERO
EndIf
Next I
For I =1To N
If I + IEIP -1<= N Then
ITMP(I)= IWORK(I + IEIP -1)
Else
ITMP(I)=0
EndIf
Next I
' -------- CALL TO CORE INTEGRATOR ------------
GoSub2000'call RO4COR(N,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL,IJAC,
'MLJAC,MUJAC,IDFX,MLMAS,MUMAS,IOUT,IDID,
'XNMAX,UROUND,METH,FAC1,FAC2,FACREJ,IAUTNMS,
'IMPLCT,JBAND,LDJAC,LDE,LDMAS2,TMP1,TMP2,
'TMP3,TMP4,TMP5,TMP6,TMP7,TMP8,TMP9,TMP10,
'TMP11, ITMP)
Return'from 1000 ROS4
' --------- ... AND HERE IS THE CORE INTEGRATOR ----------
2000'Subroutine RO4COR(N,X,Y,XEND,HMAX,H,RTOL,ATOL,ITOL,IJAC,
'MLJAC,MUJAC,IDFX,MLMAS,MUMAS,IOUT,IDID,
'XNMAX,UROUND,METH,FAC1,FAC2,FACREJ,IAUTNMS,
'IMPLCT,JBAND,LDJAC,LDE,LDMAS2,TMP1,TMP2,
'TMP3,TMP4,TMP5,TMP6,TMP7,TMP8, TMP9,TMP10,
'TMP11,ITMP)
' ----------------------------------------------------------
' CORE INTEGRATOR FOR ROS4
' PARAMETERS SAME AS IN ROS4 WITH WORKSPACE ADDED
' ----------------------------------------------------------
' DECLARATIONS
' ----------------------------------------------------------
'Labels 2001,2002, 2012, 2014, 2079, 2080
' I,J,K,L,MBB,MBDIAG,MBJAC,MDIAG,MDIFF,MLDE,MUE: Integer
' IREJECT,IRJECT2: Boolean (here integers)
' A21,A31,A32,C21,C31,C32,C41,C42,C43: Double
' B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4: Double
' DELT,HMAXN,HOPT,POSNEG,XDELT,XXOLD,YSAFE: Double
' IRTRN,LBEG,LDEND,MD,MUJACJ,MUJACP,NSING:Integer;
' FAC,HC21,HC31,HC32,HC41,HC42,HC43,SUM: Double
' I1,I2,IB,INFO,J1,J2,MADD: Integer;
' XERR, HD1,HD2,HD3,HD4, HNEW,S,SK: Double
' ------- restore Fortran parameters FJAC, E, FMAS ----------
For J =1To N
For I =1To N
FJAC(I, J)= TMP9(I + J -1)
E(I, J)= TMP10(I + J -1)
FMAS(I, J)= TMP11(I + J -1)
Next I
Next J
' ------- COMPUTE MASS MATRIX FOR IMPLICIT CASE ----------
' IF IMPLCT <> 0 CALL MAS(N,FMAS,LDMAS2)
' (Not provided here).
' ---- PREPARE BANDWIDTHS -----
If JBAND <>0Then
MLDE = MLJAC
MUE = MUJAC
MBJAC = MLJAC + MUJAC +1
MBB = MLMAS + MUMAS +1
MDIAG = MLDE + MUE +1
MBDIAG = MUMAS +1
MDIFF = MLDE + MUE - MUMAS
EndIf
' *** *** *** *** *** *** ***
' INITIALISATIONS
' *** *** *** *** *** *** *** }
'POSNEG=SIGN(ONE,XEND-X)
xa = ONE: xb = XEND - X:GoSub650: POSNEG = SIGN
If METH =1ThenGoSub3000'call SHAMP(A21,A31,A32,C21,C31,C32,C41,C42,C43,
'B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
If METH =2ThenGoSub3002'call GRK4T(A21,A31,A32,C21,C31,C32,C41,C42,C43,
'B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
If METH =3ThenGoSub3001'call GRK4A(A21,A31,A32,C21,C31,C32,C41,C42,C43,
'B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
If METH =4ThenGoSub3003'call VELDS(A21,A31,A32,C21,C31,C32,C41,C42,C43,
'B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
If METH =5ThenGoSub3004'call VELDD(A21,A31,A32,C21,C31,C32,C41,C42,C43,
'B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
If METH =6ThenGoSub3005'call LSTAB(A21,A31,A32,C21,C31,C32,C41,C42,C43,
'B1,B2,B3,B4,E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
' --- INITIAL PREPARATIONS ---
'HMAXN=XMIN(ABS(HMAX),ABS(XEND-X))
xa =Abs(HMAX): xb =Abs(XEND - X):GoSub630
HMAXN = XMIN
'H=XMIN(XMAX(1D-10,ABS(H)),HMAXN)
xa =0.0000000001: xb =Abs(H):GoSub620
xa = XMAX: xb = HMAXN:GoSub630: H = XMIN
'H=SIGN(H,POSNEG)
xa = H: xb = POSNEG:GoSub650: H = SIGN
IREJECT =0
NSING =0
IRTRN =1
XXOLD = X
' IF IOUT <> 0 THEN
' call SOLOUT(XNACCPT+1,XXOLD,X,Y,N,IRTRN)
' (not provided here).
' END IF
If IRTRN <0ThenGoTo2079
' --- BASIC INTEGRATION STEP ---
2001If XNSTEP > XNMAX Or X +0.1* H = X Or Abs(H)<= UROUND ThenGoTo2079
If(X - XEND)* POSNEG + UROUND > ZERO Then
H = HOPT
IDID =1
Return'Normal return
EndIf
HOPT = H
If(X + H - XEND)* POSNEG > ZERO Then H = XEND - X
'call FCN(N,X,Y,TMP2)
XX = X
For I =1To N
YY(I)= Y(I)
Next I
GoSub500
For I =1To N
TMP2(I)= F(I)
Next I
XNFCN = XNFCN +1#
' *** *** *** *** *** *** ***
' COMPUTATION OF THE JACOBIAN
' *** *** *** *** *** *** ***
XNJAC = XNJAC + ONE
If IJAC =0Then
' --- COMPUTE JACOBIAN MATRIX NUMERICALLY ---
If JBAND <>0Then
' --- JACOBIAN IS BANDED ---
MUJACP = MUJAC +1
'MD=IMIN(MBJAC,N)
ia = MBJAC: ib = N:GoSub610: MD = IMIN
For K =1To MD
J = K
2012 TMP5(J)= Y(J)
'TMP6(J)=SQR(UROUND*XMAX(1D-5,ABS(Y(J))))
xa =0.00001: xb = Y(J):GoSub620
TMP6(J)=Sqr(UROUND * XMAX)
Y(J)= Y(J)+ TMP6(J)
J = J + MD
If J <= N ThenGoTo2012
'call FCN(N,X,Y,TMP4)
GoSub500
For I =1To N
TMP4(I)= F(I)
Next I
J = K
'LBEG=IMAX(1,J-MUJAC)
ia =1: ib = MUJAC:GoSub600: LBEG = IMAX
2014'LDEND=IMIN(N,J+MLJAC)
ia = N: ib = J + MLJAC:GoSub610: LDEND = IMIN
Y(J)= TMP5(J)
MUJACJ = MUJACP - J
For L = LBEG To LDEND
FJAC(L + MUJACJ, J)=(TMP4(L)- TMP2(L))/ TMP6(J)
Next L
J = J + MD
LBEG = LDEND +1
If J <= N ThenGoTo2014
Next K
Else
' --- JACOBIAN IS FULL ---
For I =1To N
YSAFE = Y(I)
'DELT=SQR(UROUND*XMAX(1D-5,ABS(YSAFE)))
xa =0.00001: xb =Abs(YSAFE):GoSub620
DELT =Sqr(UROUND * XMAX)
Y(I)= YSAFE + DELT
'call FCN(N,X,Y,TMP4)
XX = X
For II =1To N
YY(II)= Y(II)
Next II
GoSub500
For II =1To N
TMP4(II)= F(II)
Next II
For J =1To N
FJAC(J, I)=(TMP4(J)- TMP2(J))/ DELT
Next J
Y(I)= YSAFE
Next I
MLJAC = N
EndIf
Else
' --- COMPUTE JACOBIAN MATRIX ANALYTICALLY ---
' JAC(N,X,Y,FJAC,LDJAC)
' (Not provided here).
EndIf
If IAUTNMS =0Then
If IDTMP8 =0Then
' --- COMPUTE NUMERICALLY THE DERIVATIVE WITH RESPECT TO X ---
'DELT=SQR(UROUND*XMAX(1D-5,ABS(X)))
xa =0.00001: xb =Abs(X):GoSub620
DELT =Sqr(UROUND * XMAX)
XDELT = X + DELT
'call FCN(N,XDELT,Y,TMP4)
XX = XDELT:GoSub500
For I =1To N
TMP4(I)= F(I)
Next I
For J =1To N
TMP8(J)=(TMP4(J)- TMP2(J))/ DELT
Next J
' ELSE
' --- COMPUTE ANALYTICALLY THE DERIVATIVE WITH RESPECT TO X ---
' CALL DTMP8(N,X,Y,TMP8)
' (Not provided here).
EndIf
EndIf
' *** *** *** *** *** *** ***
' COMPUTE THE STAGES
' *** *** *** *** *** *** ***
2002 XNDEC = XNDEC + ONE
HC21 = C21 / H
HC31 = C31 / H
HC32 = C32 / H
HC41 = C41 / H
HC42 = C42 / H
HC43 = C43 / H
FAC = ONE /(H * GAMMA)
If IMPLCT <>0Then
If JBAND <>0Then
' --- THE MATRIX E (B IS A JBAND MATRIX, JACOBIAN A JBAND MATRIX) ---
For J =1To N
'I1=IMAX(1,MUJAC+2-J)
ia =1: ib = MUJAC +2- J:GoSub600: I1 = IMAX
'I2=IMIN(MBJAC,N+MUJAC+1-J)
ia = MBJAC: ib = N + MUJAC +1- J:GoSub610: I2 = IMIN
For I = I1 To I2
E(I + MLDE, J)=-FJAC(I, J)
Next I
Next J
For J =1To N
'I1=IMAX(1,MUMAS+2-J)
ia =1: ib = MUMAS +2- J:GoSub600: I1 = IMAX
'I2=IMIN(MBB,N+MUMAS+1-J)
ia = MBB: ib = N + MUMAS +1- J:GoSub610: I2 = IMIN
For I = I1 To I2
ib = I + MDIFF
E(ib, J)= E(ib, J)+ FAC * FMAS(I, J)
Next I
Next J
GoSub4000'call DECB(N,E,MLDE,MUE,ITMP,INFO)
If INFO <>0ThenGoTo2080
If IAUTNMS <>0Then
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
' --- 2) THE MATRIX B AND THE JACOBIAN OF F ARE BANDED
' --- 3) THE DIFFERENTIAL EQUATION IS AUTONOMOUS.
For I =1To N
TMP4(I)= TMP2(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X,TMP1,TMP3)
XX = X
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC21 * TMP4(I)
Next I
For I =1To N
Sum = ZERO
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MBDIAG, J)* TMP1(J)
Next J
TMP5(I)= Sum + TMP3(I)
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X,TMP1,TMP3)
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
Sum = ZERO
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MBDIAG, J)* TMP1(J)
Next J
TMP6(I)= Sum + TMP3(I)
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP1(I)= HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
Sum = ZERO
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MBDIAG, J)* TMP1(J)
Next J
TMP7(I)= Sum + TMP3(I)
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
Else
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
' --- 2) THE MATRIX B AND THE JACOBIAN OF F ARE BANDED
' --- 3) THE DIFFERENTIAL EQUATION IS NON-AUTONOMOUS.
HD1 = H * D1
HD2 = H * D2
HD3 = H * D3
HD4 = H * D4
For I =1To N
TMP4(I)= TMP2(I)+ HD1 * TMP8(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X+C2*H,TMP1,TMP3)
XX = X + C2 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC21 * TMP4(I)
Next I
For I =1To N
Sum = ZERO
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MBDIAG, J)* TMP1(J)
Next J
TMP5(I)= Sum + TMP3(I)+ HD2 * TMP8(I)
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X+C3*H,TMP1,TMP3)
XX = X + C3 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
Sum = ZERO
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MBDIAG, J)* TMP1(J)
Next J
TMP6(I)= Sum + TMP3(I)+ HD3 * TMP8(I)
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP1(I)= HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
Sum = ZERO
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MBDIAG, J)* TMP1(J)
Next J
TMP7(I)= Sum + TMP3(I)+ HD4 * TMP8(I)
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
EndIf
Else
If MLMAS <> N Then
' --- THE MATRIX E (B IS A BANDED MATRIX, JACOBIAN A FULL MATRIX) ---
MADD = MUMAS +1
For J =1To N
For I =1To N
E(I, J)=-FJAC(I, J)
Next I
Next J
For J =1To N
'I1=IMAX(1,J-MUMAS)
ia =1: ib = J - MUMAS:GoSub600: I1 = IMAX
'I2=IMIN(N,J+MLMAS)
ia = N: ib = J + MLMAS:GoSub610: I2 = IMIN
For I = I1 To I2
E(I, J)= E(I, J)+ FAC * FMAS(I - J + MADD, J)
Next I
Next J
GoSub4500'call DECA(N,LDE,E,ITMP,INFO)
If INFO <>0ThenGoTo2080
If IAUTNMS <>0Then
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
' --- 2) THE MATRIX B IS BANDED BUT THE JACOBIAN OF F IS NOT
' --- 3) THE DIFFERENTIAL EQUATION IS AUTONOMOUS.
For I =1To N
TMP4(I)= TMP2(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5500'call SOL(N,E,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X,TMP1,TMP3)
XX = X
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC21 * TMP4(I)
Next I
For I =1To N
Sum = TMP3(I)
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MADD, J)* TMP1(J)
Next J
TMP5(I)= Sum
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X,TMP1,TMP3)
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
Sum = TMP3(I)
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MADD, J)* TMP1(J)
Next J
TMP6(I)= Sum
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5500'call SOL(N,E,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP1(I)= HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
Sum = TMP3(I)
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MADD, J)* TMP1(J)
Next J
TMP7(I)= Sum
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5500'call SOL(N,E,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
Else
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
' --- 2) THE MATRIX B IS BANDED BUT THE JACOBIAN OF F IS NOT
' --- 3) THE DIFFERENTIAL EQUATION IS NON-AUTONOMOUS.
HD1 = H * D1
HD2 = H * D2
HD3 = H * D3
HD4 = H * D4
For I =1To N
TMP4(I)= TMP2(I)+ HD1 * TMP8(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5500'call SOL(N,E,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X+C2*H,TMP1,TMP3)
XX = X + C2 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC21 * TMP4(I)
Next I
For I =1To N
Sum = TMP3(I)+ HD2 * TMP8(I)
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MADD, J)* TMP1(J)
Next J
TMP5(I)= Sum
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X+C3*H,TMP1,TMP3)
XX = X + C3 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
Sum = TMP3(I)+ HD3 * TMP8(I)
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MADD, J)* TMP1(J)
Next J
TMP6(I)= Sum
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
Sum = TMP3(I)+ HD4 * TMP8(I)
'J1=IMAX(1,I-MLMAS)
ia =1: ib = I - MLMAS:GoSub600: J1 = IMAX
'J2=IMIN(N,I+MUMAS)
ia = N: ib = I + MUMAS:GoSub610: J2 = IMIN
For J = J1 To J2
Sum = Sum + FMAS(I - J + MADD, J)* TMP1(J)
Next J
TMP7(I)= Sum
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5500'call SOL(N,E,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
EndIf
Else
' --- THE MATRIX E (B IS A FULL MATRIX, JACOBIAN A FULL OR BANDED MATRIX) ---
If MLJAC = N Then
For J =1To N
For I =1To N
E(I, J)= FMAS(I, J)* FAC - FJAC(I, J)
Next I
Next J
Else
MADD = MUJAC +1
For J =1To N
For I =1To N
E(I, J)= FMAS(I, J)* FAC
Next I
Next J
For J =1To N
'I1=IMAX(1,J-MUJAC)
ia =1: ib = J - MUJAC:GoSub600: I1 = IMAX
'I2=IMIN(N,J+MLJAC)
ia = N: ib = J + MLJAC:GoSub610: I2 = IMIN
For I = I1 To I2
E(I, J)= E(I, J)- FJAC(I - J + MADD, J)
Next I
Next J
EndIf
GoSub4500'call DECA(N,E,ITMP,INFO)
If INFO <>0ThenGoTo2080
If IAUTNMS <>0Then
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
' --- 2) THE MATRIX B IS NOT BANDED
' --- 3) THE DIFFERENTIAL EQUATION IS AUTONOMOUS.
For I =1To N
TMP4(I)= TMP2(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5500'call SOL(N,E,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X,TMP1,TMP3)
XX = X
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC21 * TMP4(I)
Next I
For I =1To N
Sum = TMP3(I)
For J =1To N
Sum = Sum + FMAS(I, J)* TMP1(J)
Next J
TMP5(I)= Sum
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X,TMP1,TMP3)
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
Sum = TMP3(I)
For J =1To N
Sum = Sum + FMAS(I, J)* TMP1(J)
Next J
TMP6(I)= Sum
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5500'call SOL(N,E,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP1(I)= HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
Sum = TMP3(I)
For J =1To N
Sum = Sum + FMAS(I, J)* TMP1(J)
Next J
TMP7(I)= Sum
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5500'call SOL(N,E,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
Else
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
' --- 2) THE MATRIX B IS NOT BANDED
' --- 3) THE DIFFERENTIAL EQUATION IS NON-AUTONOMOUS.
HD1 = H * D1
HD2 = H * D2
HD3 = H * D3
HD4 = H * D4
For I =1To N
TMP4(I)= TMP2(I)+ HD1 * TMP8(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5500'call SOL(N,E,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X+C2*H,TMP1,TMP3)
XX = X + C2 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC21 * TMP4(I)
Next I
For I =1To N
Sum = TMP3(I)+ HD2 * TMP8(I)
For J =1To N
Sum = Sum + FMAS(I, J)* TMP1(J)
Next J
TMP5(I)= Sum
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X+C3*H,TMP1,TMP3)
XX = X + C3 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP1(I)= HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
Sum = TMP3(I)+ HD3 * TMP8(I)
For J =1To N
Sum = Sum + FMAS(I, J)* TMP1(J)
Next J
TMP6(I)= Sum
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5500'call SOL(N,E,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP1(I)= HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
Sum = TMP3(I)+ HD4 * TMP8(I)
For J =1To N
Sum = Sum + FMAS(I, J)* TMP1(J)
Next J
TMP7(I)= Sum
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5500'call SOL(N,E,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
EndIf
EndIf
EndIf
Else
If JBAND <>0Then
' --- THE MATRIX E (B=IDENTITY, JACOBIAN A BANDED MATRIX) ---
For J =1To N
'I1=IMAX(1,MUJAC+2-J)
ia =1: ib = MUJAC +2- J:GoSub600: I1 = IMAX
'I2=IMIN(MBJAC,N+MUJAC+1-J)
ia = MBJAC: ib = N + MUJAC +1- J:GoSub610: I2 = IMIN
For I = I1 To I2
E(I + MLDE, J)=-FJAC(I, J)
Next I
E(MDIAG, J)= E(MDIAG, J)+ FAC
Next J
GoSub4000'call DECB(N,E,MLDE,MUE,ITMP,INFO)
If INFO <>0ThenGoTo2080
If IAUTNMS <>0Then
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
' --- 2) THE JACOBIAN OF THE PROBLEM IS A BANDED MATRIX
' --- 3) THE DIFFERENTIAL EQUATION IS AUTONOMOUS.
For I =1To N
TMP4(I)= TMP2(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X,TMP1,TMP3)
XX = X
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP5(I)= TMP3(I)+ HC21 * TMP4(I)
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X,TMP1,TMP3)
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP6(I)= TMP3(I)+ HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP7(I)= TMP3(I)+ HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
Else
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
' --- 2) THE JACOBIAN OF THE PROBLEM IS A BANDED MATRIX
' --- 3) THE DIFFERENTIAL EQUATION IS NON-AUTONOMOUS.
HD1 = H * D1
HD2 = H * D2
HD3 = H * D3
HD4 = H * D4
For I =1To N
TMP4(I)= TMP2(I)+ HD1 * TMP8(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X+C2*H,TMP1,TMP3)
XX = X + C2 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP5(I)= TMP3(I)+ HD2 * TMP8(I)+ HC21 * TMP4(I)
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X+C3*H,TMP1,TMP3)
XX = X + C3 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP6(I)= TMP3(I)+ HD3 * TMP8(I)+ HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP7(I)= TMP3(I)+ HD4 * TMP8(I)+ HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5000'call SOLB(N,E,MLDE,MUE,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
EndIf
Else
' --- THE MATRIX E (B=IDENTITY, JACOBIAN A FULL MATRIX) ---
For J =1To N
For I =1To N
E(I, J)=-FJAC(I, J)
Next I
E(J, J)= E(J, J)+ FAC
Next J
GoSub4500'call DECA(N,LDE,E,ITMP,INFO)
If INFO <>0ThenGoTo2080
If IAUTNMS <>0Then
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
' --- 2) THE JACOBIAN OF THE PROBLEM IS A FULL MATRIX
' --- 3) THE DIFFERENTIAL EQUATION IS AUTONOMOUS.
For I =1To N
TMP4(I)= TMP2(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5500'call SOL(N,E,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X,TMP1,TMP3)
XX = X
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP5(I)= TMP3(I)+ HC21 * TMP4(I)
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X,TMP1,TMP3)
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP6(I)= TMP3(I)+ HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5500'call SOL(N,E,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP7(I)= TMP3(I)+ HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5500'call SOL(N,E,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
Else
' --- THIS PART COMPUTES THE STAGES IN THE CASE WHERE
' --- 1) THE DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
' --- 2) THE JACOBIAN OF THE PROBLEM IS A FULL MATRIX
' --- 3) THE DIFFERENTIAL EQUATION IS NON-AUTONOMOUS.
HD1 = H * D1
HD2 = H * D2
HD3 = H * D3
HD4 = H * D4
For I =1To N
TMP4(I)= TMP2(I)+ HD1 * TMP8(I)
Next I
For I =1To N
B(I)= TMP4(I)
Next I
GoSub5500'call SOL(N,E,TMP4,ITMP)
For I =1To N
TMP4(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A21 * TMP4(I)
Next I
'call FCN(N,X+C2*H,TMP1,TMP3)
XX = X + C2 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP5(I)= TMP3(I)+ HD2 * TMP8(I)+ HC21 * TMP4(I)
Next I
For I =1To N
B(I)= TMP5(I)
Next I
GoSub5500'call SOL(N,E,TMP5,ITMP)
For I =1To N
TMP5(I)= B(I)
Next I
For I =1To N
TMP1(I)= Y(I)+ A31 * TMP4(I)+ A32 * TMP5(I)
Next I
'call FCN(N,X+C3*H,TMP1,TMP3)
XX = X + C3 * H
For I =1To N
YY(I)= TMP1(I)
Next I
GoSub500
For I =1To N
TMP3(I)= F(I)
Next I
For I =1To N
TMP6(I)= TMP3(I)+ HD3 * TMP8(I)+ HC31 * TMP4(I)+ HC32 * TMP5(I)
Next I
For I =1To N
B(I)= TMP6(I)
Next I
GoSub5500'call SOL(N,E,TMP6,ITMP)
For I =1To N
TMP6(I)= B(I)
Next I
For I =1To N
TMP7(I)= TMP3(I)+ HD4 * TMP8(I)+ HC41 * TMP4(I)+ HC42 * TMP5(I)+ HC43 * TMP6(I)
Next I
For I =1To N
B(I)= TMP7(I)
Next I
GoSub5500'call SOL(N,E,TMP7,ITMP)
For I =1To N
TMP7(I)= B(I)
Next I
EndIf
EndIf
EndIf
XNSOL = XNSOL +4#
XNFCN = XNFCN +2#
' *** *** *** *** *** *** ***
' ERROR ESTIMATION
' *** *** *** *** *** *** ***
XNSTEP = XNSTEP + ONE
' ------------ NEW SOLUTION ---------------
For I =1To N
TMP1(I)= Y(I)+ B1 * TMP4(I)+ B2 * TMP5(I)+ B3 * TMP6(I)+ B4 * TMP7(I)
Next I
' ------------ COMPUTE ERROR ESTIMATION ----------------
XERR = ZERO
For I =1To N
S = E1 * TMP4(I)+ E2 * TMP5(I)+ E3 * TMP6(I)+ E4 * TMP7(I)
If ITOL =0Then
'SK = ATOL + RTOL * XMAX(ABS(Y(I)), ABS(TMP1(I)))
xa =Abs(Y(I)): xb =Abs(TMP1(I)):GoSub620
SK = ATOL + RTOL * XMAX
Else
' Multiple tolerances not implemented here.
' SK = ATOL(I) + RTOL(I) * XMAX(ABS(Y(I)), ABS(TMP1(I)))
EndIf
XERR = XERR +Sqr(Abs(S / SK))
Next I
XERR =Sqr(XERR / N)
' --- COMPUTATION OF HNEW
' --- WE REQUIRE 0.2<=HNEW/H<=6.0
'FAC=XMAX(FAC2,XMIN(FAC1,XERR^(0.25#/0.9#)))
xa = FAC1: xb = XERR ^(0.25/0.9):GoSub630
xa = FAC2: xb = XMIN:GoSub620: FAC = XMAX
HNEW = H / FAC
' *** *** *** *** *** *** ***
' IS THE XERROR SMALL ENOUGH ?
' *** *** *** *** *** *** ***
If XERR <= ONE Then
' --- STEP IS ACCEPTED ---
XNACCPT = XNACCPT + ONE
For I =1To N
Y(I)= TMP1(I)
Next I
XXOLD = X
X = X + H
If IOUT <>0Then
'SOLOUT(XNACCPT+1,XXOLD,X,Y,N,IRTRN)
EndIf
If IRTRN <0ThenGoTo2079
IfAbs(HNEW)> HMAXN Then HNEW = POSNEG * HMAXN
If IREJECT <>0Then
'HNEW=POSNEG*XMIN(ABS(HNEW),ABS(H))
xa =Abs(HNEW): xb =Abs(H):GoSub630
HNEW = POSNEG * XMIN
EndIf
IREJECT =0
IRJECT2 =0
H = HNEW
GoTo2001
Else
' --- STEP IS IREJECTED ---
If IRJECT2 <>0Then HNEW = H * FACREJ
If IREJECT <>0Then IRJECT2 =1
IREJECT =1
H = HNEW
If XNACCPT >= ONE Then NREJCT = NREJCT +1
GoTo2002
EndIf
' --- EXIT SECTION ---
2080Print" MATRIX E IS SINGULAR, INFO = "; INFO
NSING = NSING +1
If NSING >=5ThenGoTo2079
H = H * HALF
GoTo2002
2079Print
Print" EXIT OF ROS4 AT X="; X;" H="; H
IDID =-1
Return'from RO4COR
3000'SHAMP(A21,A31,A32,C21,C31,C32,C41,C42,C43,B1,B2,B3,B4,
'E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
A21 =2#
A31 =48#/25#
A32 =6#/25#
C21 =-8#
C31 =372#/25#
C32 =12#/5#
C41 =-112#/125#
C42 =-54#/125#
C43 =-2#/5#
B1 =19#/9#
B2 =1#/2#
B3 =25#/108#
B4 =125#/108#
E1 =17#/54#
E2 =7#/36#
E3 =0#
E4 =125#/108#
GAMMA = HALF
C2 =1#
C3 =0.6
D1 =0.5
D2 =-1.5
D3 =2.42
D4 =0.116
Return
3001'GRK4A(A21,A31,A32,C21,C31,C32,C41,C42,C43,B1,B2,B3,B4,
'E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
A21 =1.10886075949367
A31 =2.37708526198336
A32 =0.185011498889969
C21 =-4.92018840239764
C31 =1.05558868604858
C32 =3.35181726766894
C41 =3.84686900704931
C42 =3.42710924126818
C43 =-2.16240884875326
B1 =1.84568324040584
B2 =0.13697968943605
B3 =0.712909778329156
B4 =0.632911392405063
E1 =4.83187017720177E-02
E2 =-0.647110865104951
E3 =0.218687666050024
E4 =-0.632911392405063
GAMMA =0.395
C2 =0.438
C3 =0.87
D1 =0.395
D2 =-0.372672395484092
D3 =6.62919654457149E-02
D4 =0.434094696256863
Return
3002'GRK4T(A21,A31,A32,C21,C31,C32,C41,C42,C43,B1,B2,B3,B4,
'E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
A21 =2#
A31 =4.52470820737312
A32 =4.16352878859765
C21 =-5.07167533877632
C31 =6.02015272865079
C32 =0.159750684672712
C41 =-1.85634361868611
C42 =-8.50538085817983
C43 =-2.08407513602319
B1 =3.95750374664078
B2 =4.62489238836331
B3 =0.617477263875011
B4 =1.28261294526904
E1 =2.302155402933
E2 =3.07363448539262
E3 =-0.873280801804503
E4 =-1.28261294526904
GAMMA =0.231
C2 =0.462
C3 =0.880208333333333
D1 =0.231
D2 =-0.039629667752443
D3 =0.550778939578913
D4 =-5.53509845705276E-02
Return
3003'VELDS(A21,A31,A32,C21,C31,C32,C41,C42,C43,B1,B2,B3,B4,
'E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
' --- METHOD GIVEN BY VAN VELDHUIZEN ---
A21 =2#
A31 =1.75
A32 =0.25
C21 =-8#
C31 =-8#
C32 =-1#
C41 =0.5
C42 =-0.5
C43 =2#
B1 =1.33333333333333
B2 =0.666666666666667
B3 =-1.33333333333333
B4 =1.33333333333333
E1 =-0.333333333333333
E2 =-0.333333333333333
E3 =-0#
E4 =-1.33333333333333
GAMMA =0.5
C2 =1#
C3 =0.5
D1 =0.5
D2 =-1.5
D3 =-0.75
D4 =0.25
Return
3004'VELDD(A21,A31,A32,C21,C31,C32,C41,C42,C43,B1,B2,B3,B4,
'E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
' --- METHOD GIVEN BY VAN VELDHUIZEN ---
A21 =2#
A31 =4.81223436269544
A32 =4.57814695674784
C21 =-5.33333333333333
C31 =6.10052967884825
C32 =1.80473679737843
C41 =-2.54051545663475
C42 =-9.44374632891521
C43 =-1.98847175321599
B1 =4.28933925465454
B2 =5.03609848285141
B3 =0.608573642067392
B4 =1.35595894120115
E1 =2.17567278753176
E2 =2.95091122257574
E3 =-0.785974454488743
E4 =-1.35595894120115
GAMMA =0.225708114822568
C2 =0.451416229645136
C3 =0.875592894601846
D1 =0.225708114822568
D2 =-4.59940350268058E-02
D3 =0.517759050494408
D4 =-3.80562393805443E-02
Return
3005'LSTAB(A21,A31,A32,C21,C31,C32,C41,C42,C43,B1,B2,B3,B4,
'E1,E2,E3,E4,GAMMA,C2,C3,D1,D2,D3,D4)
' --- AN L-STABLDE METHOD ---
A21 =2#
A31 =1.86794363780392
A32 =0.234444971139916
C21 =-7.13761503641231
C31 =2.58070808795146
C32 =0.651595007644798
C41 =-2.13714899438253
C42 =-0.321466969123763
C43 =-0.694974250178178
B1 =2.25557007341874
B2 =0.287049326218679
B3 =0.435317943184018
B4 =1.09350225240916
E1 =-0.281543193214115
E2 =-7.27619912493892E-02
E3 =-0.108219620149531
E4 =-1.09350225240916
GAMMA =0.57282
C2 =1.14564
C3 =0.65521686381559
D1 =0.57282
D2 =-1.76919389131923
D3 =0.759263343792048
D4 =-0.104902108710045
Return
4000'Subroutine DECB(N, E, MLDE, MUE, ITMP, INFO)
' Labels 4007, 4020, 4030, 4045, 4060, 4070, 4080
'-----------------------------------------------------------------------
' MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION OF A BANDED
' MATRIX WITH LOWER BANDWIDTH MLDE AND UPPER BANDWIDTH MUE
' INPUTS:
' N ORDER OF THE ORIGINAL MATRIX A.
' E CONTAINS THE MATRIX IN BAND STORAGE. THE COLUMNS
' OF THE MATRIX ARE STORED IN THE COLUMNS OF E AND
' THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
' MLDE+1 THROUGH 2*MLDE+MUE+1 OF E.
' MLDE LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
' MUE UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
' OUTPUTS:
' E AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
' THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
' ITMP INDEX VECTOR OF PIVOT INDICES.
' ITMP(N) (-1)^(NUMBER OF INTERCHANGES) OR O.
' INFO = 0 IF MATRIX A IS NONSINGULAR, OR = K IF FOUND TO BE
' SINGULAR AT STAGE K.
' NOTE: USE SOLB TO OBTAIN SOLUTION OF LINEAR SYSTEM.
' DETERM(E) = ITMP(N)*E(MD,1)*E(MD,2)*...*E(MD,N) WITH MD=MLDE+MUE+1.
' IF ITMP(N)=O, E IS SINGULAR, SOLB WILL DIVIDE BY ZERO.
'
' REFERENCE..
' THIS IS A MODIFICATION OF
' C. B. MOLDER, ALGORITHM 423, LINEAR EQUATION SOLVER,
' C.A.C.M. 15 (1972), P. 274.
'-----------------------------------------------------------------------
INFO =0
ITMP(N)=1
MD = MLDE + MUE +1
MD1 = MD +1
JU =0
If MLDE =0ThenGoTo4070
If N =1ThenGoTo4070
If N < MUE +2ThenGoTo4007
For J = MUE +2To N
For I =1To MLDE
E(I, J)= ZERO
Next I
Next J
4007 NM1 = N -1
For K =1To NM1
KP1 = K +1
M = MD
'MDL = IMIN(MLDE,N-K) + MD
ia = MLDE: ib = N - K:GoSub610
MDL = IMIN + MD
For I = MD1 To MDL
IfAbs(E(I, K))>Abs(E(M, K))Then M = I
Next I
ITMP(K)= M + K - MD
t = E(M, K)
If M = MD ThenGoTo4020
ITMP(N)=-ITMP(N)
E(M, K)= E(MD, K)
E(MD, K)= t
4020If t = ZERO ThenGoTo4080
t = ONE / t
For I = MD1 To MDL
E(I, K)=-E(I, K)* t
Next I
'JU = IMIN(IMAX(JU,MUE+ITMP(K)),N)
ia = JU: ib = MUE + ITMP(K):GoSub600
ia = IMAX: ib = N:GoSub610: JU = IMIN
MM = MD
If JU < KP1 ThenGoTo4060
For J = KP1 To JU
M = M -1
MM = MM -1
t = E(M, J)
If M = MM ThenGoTo4030
E(M, J)= E(MM, J)
E(MM, J)= t
4030If t = ZERO ThenGoTo4045
JK = J - K
For I = MD1 To MDL
IJK = I - JK
E(IJK, J)= E(IJK, J)+ E(I, K)* t
Next I
4045Next J
4060Next K
4070 K = N
If E(MD, N)= ZERO ThenGoTo4080
Return
4080 INFO = K
ITMP(N)=0
Return'DECB
4500'Subroutine DECA(N, E, ITMP, INFO)
' REAL DOUBLE PRECISION VERSION OF DEC
' Labels: 4520, 4550, 4570, 4580
'-----------------------------------------------------------------------
' GENERAL MATRIX TRIANGULARIZATION BY GAUSSIAN ELIMINATION.
' INPUT..
' N = ORDER OF MATRIX.
' E = MATRIX TO BE TRIANGULARIZED.
' OUTPUT..
' E(I,J), I <= J = UPPER TRIANGULAR FACTOR, U.
' E(I,J), I > J = MULTIPLIERS = LOWER TRIANGULAR FACTOR, I - L.
' ITMP(K), K < N = INDEX OF K-TH PIVOT ROW.
' ITMP(N) = (-1)^(NUMBER OF INTERCHANGES) OR O.
' INFO = 0 IF MATRIX E IS NONSINGULAR, OR K IF FOUND TO BE
' SINGULAR AT STAGE K.
' NOTE: USE SOL TO OBTAIN SOLUTION OF LINEAR SYSTEM.
' DETERM(E) = ITMP(N)*E(1,1)*E(2,2)*...*E(N,N).
' IF ITMP(N)=O, A IS SINGULAR, SOL WILL DIVIDE BY ZERO.
'
' REFERENCE..
' C. B. MOLDER, ALGORITHM 423, LINEAR EQUATION SOLVER,
' C.A.C.M. 15 (1972), P. 274.
'------------------------------------------------------------------------
INFO =0
ITMP(N)=1
If N =1ThenGoTo4570
NM1 = N -1
For K =1To NM1
KP1 = K +1
M = K
For I = KP1 To N
IfAbs(E(I, K))>Abs(E(M, K))Then M = I
Next I
ITMP(K)= M
t = E(M, K)
If M = K ThenGoTo4520
ITMP(N)=-ITMP(N)
E(M, K)= E(K, K)
E(K, K)= t
4520If t = ZERO ThenGoTo4580
t = ONE / t
For I = KP1 To N
E(I, K)=-E(I, K)* t
Next I
For J = KP1 To N
t = E(M, J)
E(M, J)= E(K, J)
E(K, J)= t
If t = ZERO ThenGoTo4550
For I = KP1 To N
E(I, J)= E(I, J)+ E(I, K)* t
Next I
4550Next J
Next K
4570 K = N
If E(N, N)= ZERO ThenGoTo4580
Return
4580 INFO = K
ITMP(N)=0
Return
5000'Subroutine SOLB(N, E, MLDE, MUE, B, ITMP)
' Labels 5025, 5050
'-----------------------------------------------------------------------
' SOLUTION OF A BANDED LINEAR SYSTEM, E*X = B.
' INPUTS:
' N ORDER OF MATRIX A.
' E TRIANGULARIZED MATRIX OBTAINED FROM DECB.
' MLDE LOWER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
' MUE UPPER BANDWIDTH OF A (DIAGONAL IS NOT COUNTED).
' B RIGHT HAND SIDE VECTOR.
' ITMP PIVOT VECTOR OBTAINED FROM DECB.
' DO NOT USE IF DECB HAS SET INFO <> 0.
' OUTPUT:
' B SOLUTION VECTOR.
'-----------------------------------------------------------------------
MD = MLDE + MUE +1
MD1 = MD +1
MDM = MD -1
NM1 = N -1
If MLDE =0ThenGoTo5025
If N =1ThenGoTo5050
For K =1To NM1
M = ITMP(K)
t = B(M)
B(M)= B(K)
B(K)= t
'MDL = IMIN(MLDE,N-K) + MD
ia = MLDE: ib = N - K:GoSub610
MDL = IMIN + MD
For I = MD1 To MDL
IMD = I + K - MD
B(IMD)= B(IMD)+ E(I, K)* t
Next I
Next K
5025For KB =1To NM1
K = N +1- KB
B(K)= B(K)/ E(MD, K)
t =-B(K)
KMD = MD - K
'LM = IMAX(1,KMD+1)
ia =1: ib = KMD +1:GoSub600
LM = IMAX
For I = LM To MDM
IMD = I - KMD
B(IMD)= B(IMD)+ E(I, K)* t
Next I
Next KB
5050 B(1)= B(1)/ E(MD,1)
Return
5500'Subroutine SOL (N, E, B, ITMP)
' Label: 5550
'-----------------------------------------------------------------------
' SOLUTION OF A GENERAL LINEAR SYSTEM, E*X = B.
' INPUTS:
' N = ORDER OF MATRIX.
' E = TRIANGULARIZED MATRIX OBTAINED FROM DECA.
' B = RIGHT HAND SIDE VECTOR.
' ITMP = PIVOT VECTOR OBTAINED FROM DEC.
' DO NOT USE IF DEC HAS SET INFO <> 0.
' OUTPUT:
' B = SOLUTION VECTOR.
'-----------------------------------------------------------------------
If N =1ThenGoTo5550
NM1 = N -1
For K =1To NM1
KP1 = K +1
M = ITMP(K)
t = B(M)
B(M)= B(K)
B(K)= t
For I = KP1 To N
B(I)= B(I)+ E(I, K)* t
Next I
Next K
For KB =1To NM1
KM1 = N - KB
K = KM1 +1
B(K)= B(K)/ E(K, K)
t =-B(K)
For I =1To KM1
B(I)= B(I)+ E(I, K)* t
Next I
Next KB
5550 B(1)= B(1)/ E(1,1)
Return
'end of file tros4.bas
↧
Advanced 200 fps 3D engine in Visual Basic 6.0 !
Here we have a particularly advanced 3D engine that uses Directx 8.1. It can be adapted for the current DirectX version. The package consists of the map editor and the 3D engine. The map editor can compose the elevations of the landscape for the virtual world. With current technology, this 3D engine moves at an astonishing 200 fps. I say astonishing 200 fps, because the virtual world created is particularly complex with 3D dynamic objects (the grass undulates), rain, fog, shadows, particles, etc. You have to see this, it's impressive ! Unfortunately, I do not know who is the author of this project.
Download from ME
Map Editor:
![]()
The LandScape 3D game:
![]()
The autor words:
Howto: Create/Edit Height Maps
[hm] File Format:
4 Bytes (Single): Width
4 Bytes (Single): Height
4 Bytes (Single): Height Points (Range: From -1 to +1)
...Points...Points...
And, by the way, there is a cool height map editor inside this ZIP :)
It is not optimized, but works (i hope) without bugs...
P.S.: No comments for the HM editor code :(
LowFPS!!!
I have 35 fps with the following hardware...
Vid: Radeon 8500 (64 Mb)
Cpu: 1.3 Ghz (1.6)
Ram: 512 Mb
------->
Disable Grass, Rain & Lightning Rendering In Program Code, it will run faster :)
------->
Download from ME
Map Editor:
The LandScape 3D game:
The autor words:
Howto: Create/Edit Height Maps
[hm] File Format:
4 Bytes (Single): Width
4 Bytes (Single): Height
4 Bytes (Single): Height Points (Range: From -1 to +1)
...Points...Points...
And, by the way, there is a cool height map editor inside this ZIP :)
It is not optimized, but works (i hope) without bugs...
P.S.: No comments for the HM editor code :(
LowFPS!!!
I have 35 fps with the following hardware...
Vid: Radeon 8500 (64 Mb)
Cpu: 1.3 Ghz (1.6)
Ram: 512 Mb
------->
Disable Grass, Rain & Lightning Rendering In Program Code, it will run faster :)
------->
↧