How to plot the Poincaré Section? (Duffing Oscillator) - fortran

I've written a program that successfully shows a simple limit cycle for the Duffing equation. However, I now need to plot the Poincaré section for this case.
I need to do this by taking snapshots of the Phase-Space diagram at regular time intervals, such that t*omega = 2*pi*n. As I have omega set to 1 for this case, this is just when t = 2*pi*n. I've attempted this, but am not getting the Poincaré section I expect.
Here's my code:
program rungekutta
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer :: i, n
real(kind=dp) z, y, t, A, C, D, B, omega, h
open(unit=100, file="rungekutta.dat",status='replace')
n = 0
!constants
omega = 1.0_dp
A = 0.25_dp
B = 1.0_dp
C = 0.1_dp
D = 1.0_dp
y = 0.0_dp
z = 0.0_dp
t = 0.0_dp
do i=1,1000
call rk2(z, y, t, n)
n = n + 1.0_dp
write(100,*) y, z
end do
contains
subroutine rk2(z, y, t, n) !subroutine to implement runge-kutta algorithm
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer, intent(inout) :: n
real(kind=dp) :: k1y, k1z, k2y, k2z, y, z, t, pi
pi = 4.0*ATAN(1.0)
h = 0.1_dp
t = n*2*pi
k1y = dydt(y,z,t)*h
k1z = dzdt(y,z,t)*h
k2z = dzdt(y + (0.5_dp*k1y), z + (0.5_dp*k1z), t + (0.5_dp*h))*h
k2y = dydt(y, z +(0.5_dp*k1z), t)*h
y = y + k2y
z = z + k2z
end subroutine
!2nd order ODE split into 2 for coupled Runge-Kutta, useful to define 2
functions
function dzdt(y,z,t)
real(kind=dp) :: y, z, t, dzdt
dzdt = -A*y**3.0_dp + B*y - C*z + D*sin(omega*t)
end function
function dydt(y,z,t)
real(kind=dp) :: z, dydt, y, t
dydt = z
end function
end program
I have also attached an image of what my Poincaré section looks like:
.
This is y on the x axis vs dydt.
And an image of what I'd expect:

In your rk2 routine you perform one step of step length 0.1. Thus the plot is the full trajectory of the solution at that resolution. However the intend seems to be to integrate over a full period length. This would require a loop in that routine.
In other words, what you want is the plot of (y(n*T), z(n*T)) where T is one of the periods of the system, per your code T=2*p. What you actually compute is (y(n*h), z(n*h)) where h=0.1 is the step size of a single step of RK2.
Also the arguments of k2y need to be corrected as per the comment of user5713492
With a corrected integrator you should get something like the following picture:
where the red squares are the points at t=n*2*pi. The indicated step size by the dots on the solution curve is the same h=0.1, the integration is over t=0..300.
def RK2(f,u,times,subdiv = 1):
uout = np.zeros((len(times),)+u.shape)
uout[0] = u;
for k in range(len(times)-1):
t = times[k]
h = (times[k+1]-times[k])/subdiv
for j in range(subdiv):
k1 = f(u,t)*h
k2 = f(u+0.5*k1, t+0.5*h)*h
u, t = u+k2, t+h
uout[k+1]=u
return uout
def plotphase(A,B,C,D):
def derivs(u,t): y,z = u; return np.array([ z, -A*y**3 + B*y - C*z + D*np.sin(t) ])
N=60
u0 = np.array([0.0, 0.0])
t = np.arange(0,300,2*np.pi/N);
u = RK2(derivs, u0, t, subdiv = 10)
plt.plot(u[:-2*N,0],u[:-2*N,1],'.--y', u[-2*N:,0],u[-2*N:,1], '.-b', lw=0.5, ms=2);
plt.plot(u[::N,0],u[::N,1],'rs', ms=4); plt.grid(); plt.show()
plotphase(0.25, 1.0, 0.1, 1.0)

Related

Incorrect Order of Error of Verlet Algorithm in Fortran

I am trying to simulate harmonic oscillator by using Verlet Method(Original Verlet) in Fortran.
My research tells that the order of error should be 2 but my calculation showed the order of 1.
I couldn't find my mistake in my source code. What should I do?
Edit:
The algorithm I am using is below:
x(t+Δt) = 2x(t) - x(t-Δt) + Δt² F(t)/m
v(t) = {x(t+Δt) -x(t-Δt)}/2Δt
Where x(t) represents the position, v(t) represents velocity and F(t) represents Force. I recognize this is the Original Verlet described here
According to this site, the order of error should be at least O(Δt²) but the error of the order of my program plotted in gnuplot (below) does not have a order of O(Δt²).
program newton_verlet
implicit none
real*16, parameter :: DT = 3.0
real*16, parameter :: T0 = 0.0
real*16, parameter :: TEND = 2.0
integer, parameter :: NT = int(TEND/DT + 0.5)
real*16, parameter :: M = 1.0
real*16, parameter :: X0 = 1.0
real*16, parameter :: V0 = 0.0
real*16 x,v,t,xold,xnew,vnew,ek,ep,et,f,h
integer it,n
do n=0,20
h = DT/2**n
x = X0
v = V0
ek = 0.5*M*v*v
ep = x*x/2
et = ek + ep
xold = x - v*h
do it = 1,2**n
! f = -x
f = -x
xnew = 2.0*x - xold + f*h*h/M
v = (xnew-xold)/(2.0*h)
ek = 0.5*M*v*v
ep = 0.5*xnew*xnew
et = ek + ep
xold = x
x = xnew
end do
write(*,*) h,abs(x-cos(DT))+abs(v+sin(DT))
end do
end program
Above program calculates the error of calculation for the time step h.
According to the Wiki page for Verlet integrators, it seems that we need to use a more accurate way of setting the initial value of xold (i.e., include terms up to the force) to get the global error of order 2. Indeed, if we modify xold as
program newton_verlet
implicit none
real*16, parameter :: DT = 3.0
real*16, parameter :: M = 1.0
real*16, parameter :: X0 = 1.0
real*16, parameter :: V0 = 0.0
real*16 x,v,xold,xnew,f,h
integer it,n
do n = 0, 20
h = DT / 2**n
x = X0
v = V0
f = -x
! xold = x - v * h !! original
xold = x - v * h + f * h**2 / (2 * M) !! modified
do it = 1, 2**n
f = -x
xnew = 2 * x - xold + f * h * h / M
xold = x
x = xnew
end do
write(*,*) log10( h ), log10( abs(x - cos(DT)) )
end do
end program
the global error becomes of order 2 (please see the log-log plot below).

How can I reduce floating-point error in a cubic equation solver?

I'm using the following algorithm to solve a cubic polynomial equation (x^3 + ax^2 + bx + c = 0):
function find_roots(a, b, c, lower_bound, upper_bound)
implicit none
real*8, intent(in) :: a, b, c, lower_bound, upper_bound
real*8 :: find_roots
real*8 :: Q, R, theta, x, Au, Bu
integer :: i, iter
Q = (a**2 - 3.D0*b)/9.D0
R = (2.D0*a**3 - 9.D0*a*b + 27.D0*c)/54.D0
!If roots are all real, get root in range
if (R**2.lt.Q**3) then
iter = 0
theta = acos(R/sqrt(Q**3))
!print *, "theta = ", theta
do i=-1,1
iter = iter+1
x = -2.D0*sqrt(Q)*cos((theta + dble(i)*PI*2.D0)/3.D0)-a/3.D0
!print *, "iter = ", iter, "root = ", x
if ((x.ge.lower_bound).and.(x.le.upper_bound)) then
find_roots = x
return
end if
end do
!Otherwise, two imaginary roots and one real root, return real root
else
Au = -sign(1.D0, R)*(abs(R)+sqrt(R**2-Q**3))**(1.D0/3.D0)
if (Au.eq.0.D0) then
Bu = 0.D0
else
Bu = Q/Au
end if
find_roots = (Au+Bu)-a/3.D0
return
end if
end function find_roots
Now it turns out that it can be shown analytically that a cubic equation with the following inputs:
Q0 = 1.D0
alpha = 1.D-2
dt = 0.00001D0
Y = 1000000.D0
find_roots(-(2.D0*Q0+Y), &
-(alpha-Q0**2-2.D0*Y*Q0+dt/2.D0*alpha), &
(dt/2.D0*alpha*Q0+Y*alpha-Y*Q0**2), &
Q0-sqrt(alpha), &
Q0+sqrt(alpha)))
MUST have a root between Q0+sqrt(alpha) and Q0-sqrt(alpha). This is a mathematical certainty. However, the function as called above will return 0, not the correct root, due to floating-point error, since the required result is very close to Q0+sqrt(alpha). I've confirmed this by creating a new function which uses quadruple precision. Unfortunately, I can't just always use quadruple precision since this function will be called billions of times and is a performance bottleneck.
So my question is, are there any general ways I could re-write this code to reduce these precision errors, while also maintaining the performance? I tried using the algorithm suggested by wikipedia, but the problem actually got worse.
https://www.cliffsnotes.com/study-guides/algebra/algebra-ii/factoring-polynomials/sum-or-difference-of-cubes
This should reduce rounding error.
Likewise, you should be able to find a much better grouping of terms, where you don't make the compiler guess what you want,
https://en.wikipedia.org/wiki/Horner%27s_method
alpha-Q0**2-2.D0*Y*Q0+dt/2.D0*alpha /= (alpha+alpha*.5*dt)-Q0*(Q0+2*Y)
You might argue that any good optimizer should know what to do with .5dt vs. dt/2. ifort considers that a part of -no-prec-div even though it can't change roundoff.
It's up to you whether you choose single precision constants for readability after checking to make sure that the promotion rules cause them to promote exactly to double. It seems particularly bad style to depend on f77 D0 suffix to choose the same data type as the never-standard real*8; no doubt it does if your compiler doesn't complain.
There is something wrong with the accuracy of your calculations, either the calculation of a,b,c or the find_roots function estimates.
I used the a,b,c that are calculated and found that your lower_bound and upper_bound were better estimates of the roots.
I then modified the bounds to be +/- sqrt(alpha)*1.1 so that the range test would work for 64-bit.
I also simplified constants that promote exactly to double.
Finally I compared your estimate of the root to the fn (0.9d0) and fn (1.1d0), which shows the find_roots function does not work for the a,b,c provided.
You should check your references for the error or it may just be the approach fails when acos (+/- 1.0 ) is used.
The program I used to test this with lots of prints is:
real*8 function find_roots (a, b, c, lower_bound, upper_bound)
implicit none
real*8, intent(in) :: a, b, c, lower_bound, upper_bound
real*8 :: Q, R, theta, x, Au, Bu, thi
integer :: i, iter
real*8 :: two_pi ! = 8 * atan (1.0d0)
Q = (a**2 - 3.*b)/9.
R = (2.*a**3 - 9.*a*b + 27.*c)/54.
two_pi = 8 * atan (1.0d0)
!If roots are all real, get root in range
if (R**2 < Q**3) then
iter = 0
x = R/sqrt(Q**3)
theta = acos(x)
print *, "theta = ", theta, x
do i=-1,1
iter = iter+1
!! x = -2.D0*sqrt(Q)* cos((theta + dble(i)*PI*2.D0)/3.D0) - a/3.D0
thi = (theta + i*two_pi)/3.
x = -2.*sqrt(Q) * cos (thi) - a/3.
!print *, "iter = ", iter, "root = ", x
if ( (x >= lower_bound) .and. (x <= upper_bound) ) then
find_roots = x
print *, "find_roots = ", x
! return
end if
end do
!Otherwise, two imaginary roots and one real root, return real root
else
Au = -sign(1.D0, R)*(abs(R)+sqrt(R**2-Q**3))**(1.D0/3.D0)
if (Au.eq.0.D0) then
Bu = 0.D0
else
Bu = Q/Au
end if
find_roots = (Au+Bu)-a/3.D0
return
end if
end function find_roots
real*8 function get_cubic (x, a, b, c)
implicit none
real*8, intent(in) :: x, a, b, c
get_cubic = ( ( x + a) * x + b ) * x + c
end function get_cubic
! Now it turns out that it can be shown analytically that a cubic equation with the following inputs:
real*8 Q0, alpha, dt, Y, a, b, c, lower_bound, upper_bound, val, fn
real*8, external :: find_roots, get_cubic
!
Q0 = 1.D0
alpha = 1.0D-2
dt = 0.00001D0
Y = 1000000.0D0
!
a = -(2.*Q0 + Y)
b = -(alpha - Q0**2 - 2.*Y*Q0 + dt/2.*alpha)
c = (dt/2.*alpha*Q0 + Y*alpha - Y*Q0**2)
write (*,*) a,b,c
!
lower_bound = Q0-sqrt(alpha)*1.1
upper_bound = Q0+sqrt(alpha)*1.1
write (*,*) lower_bound, upper_bound
!
val = find_roots (a, b, c, lower_bound, upper_bound)
!
fn = get_cubic ( val, a,b,c )
write (*,*) val, fn
!
! Test the better root values
val = 0.9d0
fn = get_cubic ( val, a,b,c )
write (*,*) val, fn
!
val = 1.1d0
fn = get_cubic ( val, a,b,c )
write (*,*) val, fn
end

Why is this Runge-Kutta 2nd order program printing out incorrect values?

I've recently posted a question about this code in relation to the concept behind it, but I've sorted that now. However, the code is printing out incorrect values and I can't spot why. Here's the code:
program rungekutta
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer :: i
real(kind=dp) z, y, t
do i=1,100
call rk2(dydt, dzdt, z, y, t)
print *, z, y
end do
contains
subroutine rk2(z, y, t)
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
real(kind=dp) :: k1y, k1z, k2y, k2z, n, h=0.1, y=1, z=0, t
k1y = dydt(y,z,t)*h
k1z = dzdt(y,z,t)*h
k2z = dzdt(y + (0.5*k1y), z + (0.5*k1z), t + (0.5*h))*h
k2y = dydt(y, z +(0.5*k1z), t)*h
y = y + k2y
z = z + k2z
end subroutine
function dzdt(y,z,t)
real(kind=dp) :: y, z, t, dzdt, omega=1, A=0, B, C=0, D=0
B = omega**2
dzdt = A*y**3 + B*y - C*z + D*sin(omega*t)
end function
function dydt(z)
real(kind=dp) :: z, dydt
dydt = z
end function
end program
Here is a print screen of the terminal : https://prnt.sc/hchmv7
Any help would be appreciated, thanks!
It looks like you call rk2 with 5 arguments but declare it only with 3

Eigenvector discontinuities in hermitian matrix diagonalization

I need to diagonalize a 2x2 Hermitian matrix that depends on a parameter x, which varies continuously. For diagonalization I use EISPACK. When I plot the real and imaginary components of eigenvectors as a function of x, I notice that they have discontinuities. The eigenvalues calculation is OK. When I plot the eigenvectors in Maxima, the solutions appear continuous. I need the continuous eigenvectors since in next step I will need to calculate their derivatives.
Below the f77 code I use as test (compiling with gfortran on mingw).
program Eigenvalue
implicit none
integer n, m
parameter (n=2)
integer ierr, matz, i, j
double precision x, dx, xf, amp, xin
double precision w(n)
double precision Ar(n,n), Ai(n,n)
double precision xr(n,n), xi(n,n)
double precision fm1(2,n) ! f77
double precision fv1(n) ! f77
double precision fv2(n) ! f77
double complex psi1a, psi1b, psi2a, psi2b
m = 51
xf = 10.d0
xin = 0.0d0
amp = 2.d0
dx = (xf - xin)/(m-1)
do i = 1, m
x = dx*(i-m) + xf
Ar(1,1) = dsin(x)**2
Ar(1,2) = amp*dcos(x)
Ar(2,1) = amp*dcos(x)
Ar(2,2) = dcos(x)**2
Ai(1,1) = 0.0d0
Ai(1,2) = amp*dsin(x)
Ai(2,1) = -amp*dsin(x)
Ai(2,2) = 0.0d0
matz = 1
call ch ( n, n, ar, ai, w, matz, xr, xi, fv1, fv2, fm1, ierr ) !f77
write(20,*) x, w(1), w(2)
write(21,*) x, xr(1,1), xi(1,1)
write(22,*) x, xr(2,1), xi(2,1)
write(23,*) x, xr(1,2), xi(1,2)
write(24,*) x, xr(2,2), xi(2,2)
! autovetor 1
psi1a = cmplx(xr(1,1),xi(1,1))
psi1b = cmplx(xr(1,2),xi(1,2))
! autovetor 2
psi2a = cmplx(xr(2,1),xi(2,1))
psi2b = cmplx(xr(2,2),xi(2,2))
end do
end
While not really an answer, what follows is the code I used with LAPACK.
I used the latest versions of LAPACK and BLAS, with the following compiler options:
gfortran -Og -std=f2008 -Wall -Wextra {location_of_lapack}/liblapack.a {location_of_blas}/blas_LINUX.a main.f90 -o main
I'm compiling on Mac OS X with gfortran 6.3.0 from homebrew.
As Ian mentioned above, things like dcos are replaced with cos and I have used the KIND= formulation to ensure the same precision.
Ian also mentioned above about the arbitrary phase.
This problem is answered here; I have translated this solution into my code below.
The "magic" happens after the call to ZHEEV.
With this fix, I see no discontinuities.
program Eigenvalue
!> This can be used with the f2008 call
use, intrinsic :: iso_fortran_env
implicit none
!> dp contains the kind value for double precision.
!> Use below if compiling to f2008
integer, parameter :: dp = REAL64
!> Use below if compiling with f95 up and comment out iso_fortran_env
!>integer, parameter :: dp = SELECTED_REAL_KIND(15, 300)
!> Set wp to the desired precision.
integer, parameter :: wp = dp
integer, parameter :: n = 2
integer :: i, j, k, m
real(kind=wp) x, dx, xf, amp, xin
real(kind=wp), dimension(n) :: w
real(kind=wp), dimension(n, n) :: Ar, Ai
complex(kind=wp), dimension(n, n) :: A
complex(kind=wp), dimension(max(1,2*n-1)) :: WORK
integer, parameter :: lwork = max(1,2*n-1)
real(kind=wp), dimension(max(1, 3*n-2)) :: RWORK
integer :: info
complex(kind=wp) :: psi1a, psi1b, psi2a, psi2b
real(kind=wp) :: mag
m = 51
xf = 10.0_wp
xin = 0.0_wp
amp = 2.0_wp
if (m .eq. 1) then
dx = 0.0_wp
else
dx = (xf - xin)/(m-1)
end if
do i = 1, m
x = dx*(i-m) + xf
Ar(1,1) = sin(x)**2
Ar(1,2) = amp*cos(x)
Ar(2,1) = amp*cos(x)
Ar(2,2) = cos(x)**2
Ai(1,1) = 0.0_wp
Ai(1,2) = amp*sin(x)
Ai(2,1) = -amp*sin(x)
Ai(2,2) = 0.0_wp
do j = 1, n
do k = 1, n
A(j, k) = cmplx(Ar(j, k), Ai(j, k), kind=wp)
end do
end do
call ZHEEV('V', 'U', N, A, N, W, WORK, LWORK, RWORK, INFO)
do j = 1, n
A(:, j) = A(:, j) / A(1, j)
mag = sqrt(real(A(1, j)*conjg(A(1, j)))+ real(A(2, j)*conjg(A(2, j))))
A(:, j) = A(:, j)/mag
end do
psi1a = A(1, 1)
psi1b = A(1, 2)
psi2a = A(2, 1)
psi2b = A(2, 2)
end do
end program Eigenvalue

Shooting method in fortran (neutron star oscillation)

I have been writing a script in fortran 90 for solving the radial oscillation problem of a neutron star with the use of shooting method. But for unknown reason, my program never works out. Without the shooting method component, the program runs smoothly as it successfully constructed the star. But once the shooting comes in, everything dies.
PROGRAM ROSCILLATION2
USE eos_parameters
IMPLICIT NONE
INTEGER ::i, j, k, l
INTEGER, PARAMETER :: N_ode = 5
REAL, DIMENSION(N_ode) :: y
REAL(8) :: rho0_cgs, rho0, P0, r0, phi0, pi
REAL(8) :: r, rend, mass, P, phi, delta, xi, eta
REAL(8) :: step, omega, omegastep, tiny, rho_print, Radius, B, a2, s0, lamda, E0, E
EXTERNAL :: fcn
!!!! User input
rho0_cgs = 2.D+15 !central density in cgs unit
step = 1.D-4 ! step size dr
omegastep = 1.D-2 ! step size d(omega)
tiny = 1.D-8 ! small number P(R)/P(0) to define star surface
!!!!!!!!!
open(unit=15, file="data.dat", status="new")
pi = ACOS(-1.D0)
a2 =((((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6))**(0.5D0))*a2_MeV !convert to code unit (km^-1)
B = ((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6)*B_MeV !convert to code unit (km^-2)
s0 = (1.D0/3.D0) - (1/(6*pi**2))*a2*((1/(16*pi**2)*a2**2 + (pi**-2)*a4*(rho0 - B))**-0.5) !square of the spped of sound at r=0
lamda = -0.5D0*log(1-2*y(1)/r)
E0 = (r0**-2)*s0*exp(lamda + 3*phi0)
rho0 = rho0_cgs*6.67D-18 / 9.D0 !convert rho0 to code unit (km^-2)
!! Calculate central pressure P0
P0 = (1.D0/3.D0)*rho0 - (4.D0/3.D0)*B - (1.D0/(a4*(12.D0)*(pi**2)))*a2**2 - &
&(a2/((3.D0)*a4))*(((1.D0/(16.D0*pi**4))*a2**2+(1.D0/(pi**2))*a4*(rho0-B))**0.5D0)
!! initial value for metric function phi
phi0 = 0.1D0 ! arbitrary (needed to be adjusted later)
r0 = 1.D-30 ! integration starting point
!! Set initial conditions
!!!!!!!!!!!!!!!!!
!!Start integration loop
!!!!!!!!!!!!!!!!!
r = r0
y(1) = 0.D0
y(2) = P0
y(3) = phi0
y(4) = 1/(3*E0)
y(5) = 1
omega = 2*pi*1000/(2.997D5) !omega of 1kHz in code unit
DO l = 1, 1000
omega = omega + omegastep !shooting method part
DO i = 1, 1000000000
rend = r0 + REAL(i)*step
call oderk(r,rend,y,N_ode,fcn)
r = rend
mass = y(1)
P = y(2)
phi = y(3)
xi = y(4)
eta = y(5)
IF (P < tiny*P0) THEN
WRITE(*,*) "Central density (10^14 cgs) = ", rho0_cgs/1.D14
WRITE(*,*) " Mass (solar mass) = ", mass/1.477D0
WRITE(*,*) " Radius (km) = ", r
WRITE(*,*) " Compactness M/R ", mass/r
WRITE(15,*) (omega*2.997D5/(2*pi)), y(5)
GOTO 21
ENDIF
ENDDO
ENDDO
21 CONTINUE
END PROGRAM roscillation2
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE fcn(r,y,yprime)
USE eos_parameters
IMPLICIT NONE
REAL(8), DIMENSION(5) :: y, yprime
REAL(8) :: r, m, P, phi, rho, pi, B, a2, xi, eta, W, Q, E, s, lamda, omega
INTEGER :: j
pi = ACOS(-1.D0)
a2 =((((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6))**(0.5D0))*a2_MeV !convert to code unit (km^-1)
B = ((1.6022D-13)**4)*(6.674D-11)*((2.997D8)**-7)*((1.0546D-34)**-3)*(1.D6)*B_MeV !convert to code unit (km^-2)
m = y(1)
P = y(2)
phi = y(3)
xi = y(4)
eta = y(5)
rho = 3.D0*P + 4.D0*B +((3.D0)/(4.D0*a4*(pi**2)))*a2**2+(a2/a4)*&
&(((9.D0/((16.D0)*(pi**4)))*a2**2+((3.D0/(pi**2))*a4*(P+B)))**0.5D0)
s = (1.D0/3.D0) - (1/(6*pi**2))*a2*((1/(16*pi**2)*a2**2 + (pi**-2)*a4*(rho - B))**-0.5) !square of speed of sound
W = (r**-2)*(rho + P)*exp(3*lamda + phi)
E = (r**-2)*s*exp(lamda + 3*phi)
Q = (r**-2)*exp(lamda + 3*phi)*(rho + P)*((yprime(3)**2) + 4*(r**-1)*yprime(3)- 8*pi*P*exp(2*lamda))
yprime(1) = 4.D0*pi*rho*r**2
yprime(2) = - (rho + P)*(m + 4.D0*pi*P*r**3)/(r*(r-2.D0*m))
yprime(3) = (m + 4.D0*pi*P*r**3)/(r*(r-2.D0*m))
yprime(4) = y(5)/(3*E)
yprime(5) = -(W*omega**2 + Q)*y(4)
END SUBROUTINE fcn
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!
!! Runge-Kutta method (from Numerical Recipes)
!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine oderk(ri,re,y,n,derivs)
INTEGER, PARAMETER :: NMAX=16
REAL(8) :: ri, re, step
REAL(8), DIMENSION(NMAX) :: y, dydx, yout
EXTERNAL :: derivs,rk4
call derivs(ri,y,dydx)
step=re-ri
CALL rk4(y,dydx,n,ri,step,yout,derivs)
do i=1,n
y(i)=yout(i)
enddo
return
end subroutine oderk
SUBROUTINE RK4(Y,DYDX,N,X,H,YOUT,DERIVS)
INTEGER, PARAMETER :: NMAX=16
REAL(8) :: H,HH,XH,X,H6
REAL(8), DIMENSION(N) :: Y, DYDX, YOUT
REAL(8), DIMENSION(NMAX) :: YT, DYT, DYM
EXTERNAL :: derivs
HH=H*0.5D0
H6=H/6D0
XH=X+HH
DO I=1,N
YT(I)=Y(I)+HH*DYDX(I)
ENDDO
CALL DERIVS(XH,YT,DYT)
DO I=1,N
YT(I)=Y(I)+HH*DYT(I)
ENDDO
CALL DERIVS(XH,YT,DYM)
DO I=1,N
YT(I)=Y(I)+H*DYM(I)
DYM(I)=DYT(I)+DYM(I)
ENDDO
CALL DERIVS(X+H,YT,DYT)
DO I=1,N
YOUT(I)=Y(I)+H6*(DYDX(I)+DYT(I)+2*DYM(I))
ENDDO
END SUBROUTINE RK4
Any reply would be great i am just really depressed for the long debugging.
Your program is blowing up because of this line:
yprime(5) = -(W*omega**2 + Q)*y(4)
in subroutine fcn. In this subroutine, omega is completely independent of the one declared in your main program. This one is uninitialized and used in an expression, which will either contain random values or zero, if your compiler is nice enough (or told) to initialize variables.
If you want the variable omega from your main program to be the same variable you use in fcn then you need to pass that variable to fcn somehow. Due to the way you've architected this program, passing it would require modifying all of your procedures to pass omega so that it can be provided to all of your calls to DERIVS (which is the dummy argument you are associating with fcn).
An alternative would be to put omega into a module and use that module where you need access to omega, e.g. declare it in eos_parameters instead of declaring it in the scoping units of fcn and your main program.