Spline interpolation in Fortran - fortran

I'm running a spline interpolation on two small arrays in Fortran, it works but I get numbers that are either a bit off or really off.
Can anybody tell me if I made any mistakes in the logic or the formulas?
SUBROUTINE spline(x, y, n, y1, yn, y2)
! =====================================================
! Input x and y=f(x), n (dimension of x,y), (Ordered)
! y1 and yn are the first derivatives of f in the 1st point and the n-th
! Output: array y2(n) containing second derivatives of f(x_i)
! =====================================================
IMPLICIT NONE
INTEGER:: n, i, j
INTEGER, PARAMETER:: n_max = 500
REAL*8, INTENT(in):: x(n), y(n), y1, yn
REAL*8, INTENT(out):: y2(n)
REAL*8:: p, qn, sig, un, u(n)
IF (y1 > .99e30) THEN ! natural spline conditions
y2(1) = 0
u(1) = 0
ELSE
y2(1) = -0.5
u(1) = (3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-y1)
END IF
DO i = 2, n-1 ! tridiag. decomposition
sig = (x(i)-(i-1))/(x(i+1)-x(i-1))
p = sig*y2(i-1)+2.
y2(i) = (sig-1.)/p
u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
END DO
IF (yn > .99e30) THEN ! natural spline conditions
qn = 0
un = 0
ELSE
qn = 0.5
un=(3./(x(n)-x(n-1)))*(yn-(y(n)-y(n-1))/(x(n)-x(n-1)))
END IF
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
DO j = n-1, 1, -1 ! backwards substitution tri-diagonale
y2(j) = y2(j)*y2(j+1)+u(j)
END DO
RETURN
END SUBROUTINE spline
SUBROUTINE splint(x_in, y_in, spline_res, n, x_0, y_final)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x_0 is the corresponding value we are looking for
! i.e. (time_at_max in hubble), y_final is the output result
! =====================================================
IMPLICIT NONE
INTEGER:: n, k, k_low, k_high
REAL*8, INTENT(in):: x_in(n), y_in(n), spline_res(n), x_0
REAL*8, INTENT(out):: y_final
REAL*8:: a, b, h
k_low = 1
k_high = n
99 IF (k_high - k_low > 1) THEN
k = (k_high + k_low) / 2
IF (x_in(k) > x_0) THEN
k_high = k
ELSE
k_low = k
END IF
GOTO 99
ENDIF
h = x_in(k_high) - x_in(k_low)
IF (h == 0) STOP "Bad x_in input"
a = (x_in(k_high)-x_0)/h
b = (x_0 - x_in(k_low))/h
y_final = a*y_in(k_low)+b*y_in(k_high)+((a**3-a)*spline_res(k_low)+(b**3-b)*spline_res(k_high))*(h**2)/6
RETURN
END SUBROUTINE splint
SUBROUTINE spline_interp(x, y, n, x0, y_out)
! =====================================================
! Simply merging spline and splint in one subroutine
! input x and y and get y_out at x0
! =====================================================
IMPLICIT NONE
INTEGER::n
REAL*8, INTENT(in):: x(n), y(n), x0
REAL*8, INTENT(out):: y_out
REAL*8:: y1, yn, res(n)
! natural conditions attempt, change if not working well
y1 = 0.5
yn = 0.5
CALL spline(x, y, n, y1, yn, res)
CALL splint(x, y, res, n, x0, y_out)
END SUBROUTINE spline_interp
I'm then trying to interpolate the time of maximum brightness of a supernova, having the time of observation and the magnitudes at each moment:
Time (JD):
53682.03732
53683.04882
53684.08633
53687.03535
53689.11806
53690.06398
53694.10385
53695.10682
53698.06705
53699.09681
53702.10265
53706.12631
53716.10135
53721.06836
53726.0874
53730.07961
53738.03101
53746.03825
53755.03675
Mag in b band: 17.117
17.015
16.935
16.838
16.863
16.903
17.167
17.25
17.562
17.664
18.045
18.583
19.37
19.713
19.945
20.141
20.328
20.357
20.547
As you can see from the light curve, the supernova was at peak brightness at 53687.03535, but the interpolation is giving me 53639.43568130193.
Even worse, I also need to interpolate the brightness 15 days after the peak, which looks like should be around 18.5 mag; but instead I'm getting this random number: -5142981.630692291
What's wrong with my spline?
Thank for your help and sorry for the long post guys
<3

The data provided is not indicative of the chart shown
So I am going to answer based on synthetic fake data that I made up for this example.
with the code
Program
The program uses the code from the NR book, and the question above, and put it into a module called mod_splines for usability purposes. This way it can be easily extended.
program FortranConsoleSpline
use mod_splines
implicit none
! Variables
real(wp), allocatable :: xi(:), yi(:), h, x, y, yp
type(spline) :: sp
integer :: i, n
! compile with /fpconstant
xi = [0.0,0.25,0.5,0.75,1.0,1.25,1.5,1.75,2.0]
yi = [18.0,18.4921875,18.9375,19.2890625,19.5,19.5234375,19.3125,18.8203125,18.0]
print *, 'Cubic Spline Interpolation Demo'
n = 11
h = (xi(size(xi))-xi(1))/(n-1)
sp = spline(xi, yi)
print *, ""
print '(1x,a6,1x,a18,1x,a18,1x,a18)', "Index", "x", "y", "yp"
do i=0,n-1
x = xi(1) + i*h
y = sp%value(x)
yp = sp%slope(x)
print '(1x,i6,1x,g18.11,1x,g18.6,1x,g18.6)', i, x, y, yp
end do
print *, ""
x = sp%extrema()
i = sp%indexof(x)
y = sp%value(x)
yp = sp%slope(x)
print *, "Local Extrema"
print '(1x,a6,1x,a18,1x,a18,1x,a18)', "Index", "x", "y", "yp"
print '(1x,i6,1x,g18.11,1x,g18.6,1x,g18.6)', i, x, y, yp
end program FortranConsoleSpline
Output
The code has been extended by using a bisection method to find the local min/max of the cubic spline. I could have used a direct evaluation by solving the quadratic equation, but this is fast enough.
The result below finds the maximum point at x=1.1857554913
Cubic Spline Interpolation Demo
Index x y yp
0 0.0000000000 18.0000 2.06799
1 0.20000000000 18.4009 1.87745
2 0.40000000000 18.7637 1.73300
3 0.60000000000 19.0861 1.47687
4 0.80000000000 19.3398 0.943939
5 1.0000000000 19.5000 0.209478
6 1.2000000000 19.5304 -0.461936E-01
7 1.4000000000 19.4106 -0.938651
8 1.6000000000 19.1328 -1.85224
9 1.8000000000 18.6726 -3.07239
10 2.0000000000 18.0000 -3.50827
Local Extrema
Index x y yp
5 1.1857554913 19.5308 0.738816E-07
As you can see the slope at the maximum point is about 1e-7.
mod_splines
Here is the module I created for this demo. The spline coefficients are calculated using the spline(x,y) interface (for natural spline) or spline(x,y,dy_1,dy_n) for known end slopes.
The spline coefficients are stored together with the input (x,y) nodes in a user-defined type called spline.
Evaluation of the spline, and its derivatives are done with value(x), slope(x) and slope2(x) type bound methods.
Additional auxiliary methods are indexof(x) to find the integer index where x(i) <= x < x(i+1), and extrema() which as mentioned above uses a bisection to find the x value where the slope is nearest zero.
module mod_splines
use, intrinsic :: iso_fortran_env
implicit none
integer, parameter :: wp = real64
real(wp), parameter :: big = 1e30_wp, tiny=1/big
type :: spline
real(wp), allocatable :: x(:), y(:), y2(:)
contains
procedure :: indexof => sp_index_of_x
procedure :: value => sp_interpolate_value
procedure :: slope => sp_interpolate_slope
procedure :: slope2 => sp_interpolate_slope2
procedure :: extrema => sp_find_local_extrema
end type
interface spline
module procedure :: sp_calculate_from_data
end interface
contains
pure function sp_calculate_from_data(x,y,y1_slope,yn_slope) result(sp)
! =====================================================
! Input x and y=f(x), n (dimension of x,y), (Ordered)
! y1 and yn are the first derivatives of f in the 1st point and the n-th
! Output: array y2(n) containing second derivatives of f(x_i)
! =====================================================
type(spline) :: sp
real(wp), intent(in) :: x(:), y(:)
real(wp) :: y2(size(y))
real(wp), optional, intent(in) :: y1_slope, yn_slope
real(wp):: p, qn, sig, un, u(size(y))
INTEGER:: n, i, j
n = size(y)
IF (present(y1_slope)) THEN ! natural spline conditions
y2(1) = -0.5
u(1) = (3./(x(2)-x(1)))*((y(2)-y(1))/(x(2)-x(1))-y1_slope)
ELSE
y2(1) = 0
u(1) = 0
END IF
DO i = 2, n-1 ! tridiag. decomposition
sig = (x(i)-(i-1))/(x(i+1)-x(i-1))
p = sig*y2(i-1)+2.
y2(i) = (sig-1.)/p
u(i)=(6.*((y(i+1)-y(i))/(x(i+1)-x(i))-(y(i)-y(i-1))/(x(i)-x(i-1)))/(x(i+1)-x(i-1))-sig*u(i-1))/p
END DO
IF (present(yn_slope)) THEN ! natural spline conditions
qn = 0.5
un=(3./(x(n)-x(n-1)))*(yn_slope-(y(n)-y(n-1))/(x(n)-x(n-1)))
ELSE
qn = 0
un = 0
END IF
y2(n)=(un-qn*u(n-1))/(qn*y2(n-1)+1.)
DO j = n-1, 1, -1 ! backwards substitution tri-diagonale
y2(j) = y2(j)*y2(j+1)+u(j)
END DO
sp%x = x
sp%y = y
sp%y2 = y2
RETURN
end function sp_calculate_from_data
elemental function sp_index_of_x(sp,x) result(k_low)
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
integer:: n, k, k_low, k_high
n = size(sp%y)
k_low = 1
k_high = n
if(x<sp%x(k_low)) then
return
elseif (x>sp%x(k_high)) then
k_low = k_high-1
return
end if
do while(k_high - k_low > 1)
k = (k_high + k_low) / 2
IF (sp%x(k) > x) THEN
k_high = k
ELSE
k_low = k
END IF
end do
end function
elemental function sp_interpolate_value(sp,x) result(y)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x is the corresponding value we are looking for
! i.e. (time_at_max in hubble), y is the output result
! =====================================================
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
real(wp) :: y
integer:: n, k
real(wp):: a, b, c, d, h, t
n = size(sp%y)
k= sp%indexof(x)
h = sp%x(k+1) - sp%x(k)
IF (h == 0) error STOP "Bad x input"
t = (x-sp%x(k))/h
a = 1-t
b = t
if( x>=sp%x(k) .and. x<=sp%x(k+1)) then
! Cubic inside the interval
c = (a**3-a)*(h**2)/6
d = (b**3-b)*(h**2)/6
else
! Linear outside the interval
c = 0.0_wp
d = 0.0_wp
end if
y = a*sp%y(k)+b*sp%y(k+1)+c*sp%y2(k)+d*sp%y2(k+1)
RETURN
end function sp_interpolate_value
elemental function sp_interpolate_slope(sp,x) result(yp)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x is the corresponding value we are looking for
! i.e. (time_at_max in hubble), yp is the output result slope
! =====================================================
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
real(wp) :: yp
integer:: n, k
real(wp):: a, b, c, d, h, t
n = size(sp%y)
k= sp%indexof(x)
h = sp%x(k+1) - sp%x(k)
IF (h == 0) error STOP "Bad x input"
t = (x-sp%x(k))/h
a = -1/h
b = 1/h
if( x>=sp%x(k) .and. x<=sp%x(k+1)) then
! Cubic inside the interval
c = (1-3*(1-t)**2)*(h/6)
d = (3*t**2-1)*(h/6)
else
! Linear outside the interval
c = 0.0_wp
d = 0.0_wp
end if
yp = a*sp%y(k)+b*sp%y(k+1)+c*sp%y2(k)+d*sp%y2(k+1)
RETURN
end function sp_interpolate_slope
elemental function sp_interpolate_slope2(sp,x) result(yp2)
! =====================================================
! Subroutine that does the actual interpolation
! Input arrays of x_in and y_in=f(x), spline_res is the result of
! the 'spline' subroutine, x is the corresponding value we are looking for
! i.e. (time_at_max in hubble), yp is the output result 2nd slope
! =====================================================
class(spline), intent(in) :: sp
real(wp), intent(in) :: x
real(wp) :: yp2
integer:: n, k
real(wp):: a, b, c, d, h, t
n = size(sp%y)
k= sp%indexof(x)
h = sp%x(k+1) - sp%x(k)
IF (h == 0) error STOP "Bad x input"
t = (x-sp%x(k))/h
a = 0.0_wp
b = 0.0_wp
if( x>=sp%x(k) .and. x<=sp%x(k+1)) then
! Cubic inside the interval
c = 1-t
d = t
else
! Linear outside the interval
c = 0.0_wp
d = 0.0_wp
end if
yp2 = a*sp%y(k)+b*sp%y(k+1)+c*sp%y2(k)+d*sp%y2(k+1)
RETURN
end function sp_interpolate_slope2
pure function sp_find_local_extrema(sp, x_low, x_high) result(x)
class(spline), intent(in) :: sp
real(wp) :: x
real(wp), intent(in), optional :: x_low, x_high
integer :: n, k1, k2
real(wp) :: x1, x2, yp1, yp2, h, tol, yp
n = size(sp%y)
if(present(x_low)) then
x1 = x_low
else
x1 = sp%x(1)
end if
if(present(x_high)) then
x2 = x_high
else
x2 = sp%x(n)
end if
h = x2 - x1
tol = h/(2**23)
yp1 = sp_interpolate_slope(sp, x1)
yp2 = sp_interpolate_slope(sp, x2)
if( yp1*yp2 > 0 ) then
! no solution
if( yp1>0 ) then
x = big
else
x = tiny
end if
end if
do while (x2-x1>tol)
x = (x1+x2)/2
yp = sp_interpolate_slope(sp, x)
if( yp1*yp > 0) then
x1 = x
yp1 = yp
else
x2 = x
yp2 = yp
end if
end do
end function
end module mod_splines
GitHub repo for the code above: FortranConsoleSpline

Related

Fortran Subroutines/Functions: Returned Value Changes If Subroutines/Functions Is Called More Often?

I am currently implementing integrals in Fortran as subroutines. The subroutines on their own return the correct values. If i now call the e.g. same subroutine twice after each other, with the same input values, their returned value differs significantly?
The main program only calls the function like this:
program main
use types
use constants
use integrals
use basis
real(dp), dimension(2,3) :: molecule_coords
real(dp), dimension(2) :: z
type(primitive_gaussian), allocatable :: molecule(:,:)
molecule_coords(1,:) = (/0.,0.,0./)
molecule_coords(2,:) = (/0.,0.,1.6/)
molecule = def_molecule(molecule_coords)
z = (/1.0, 1.0/)
call overlap(molecule) ! Correct Value returned
call overlap(molecule) ! Wrong Value returned
end program main
My function for the overlap looks like this:
module integrals
use types
use constants
use basis
use stdlib_specialfunctions_gamma!, only: lig => lower_incomplete_gamma
contains
subroutine overlap(molecule)
implicit none
type(primitive_gaussian), intent(in) :: molecule(:,:)
integer :: nbasis, i, j, k, l
real(dp) :: norm, p, q, coeff, Kab
real(dp), dimension(3) :: Q_xyz
real(dp), dimension(INT(size(molecule,1)),INT(size(molecule,1))) :: S
nbasis = size(molecule,1)
do i = 1, nbasis
do j = 1, nbasis
! Iterate over l and m primitives in basis
do k = 1, size(molecule(i,:))
do l = 1, size(molecule(j,:))
norm = molecule(i, k)%norm() * molecule(j, l)%norm()
! Eq. 63
Q_xyz = (molecule(i, k)%coords - molecule(j, l)%coords)
! Eq. 64, 65
p = (molecule(i, k)%alpha + molecule(j, l)%alpha)
q = (molecule(i, k)%alpha * molecule(j, l)%alpha) / p
! Eq. 66
Kab = exp(-q * dot_product(Q_xyz,Q_xyz))
coeff = molecule(i, k)%coeff * molecule(j, l)%coeff
S(i,j) = S(i,j) + norm * coeff * Kab * (pi / p) ** (1.5)
end do
end do
end do
end do
print *, S
end subroutine overlap
end module integrals
I am a bit lost, why this would be the case, but I am also rather new to Fortran.
Any help is appreciated! Thanks!

I need to determine the velocity change that allows for an orbital rendezvous between two orbiting spacecraft

I need to perform an exercise with Fortran90 that has as its objective what is written in the title. I have a starting system formed by second degree equations with certain boundary conditions. I transformed the system to have equivalent first degree equations in order to integrate it, and then it was dimensionalized obtaining : dx/dt= vx; d(vx)/dt=-1; dy/dt= vy; d(vy)/dt=-1 with the following boundary conditions x(0)=1; y(0)=0; y(t)=0; x(t)=-1 with t=1.
Now I solve with the method of shooting and RK4 with the initial conditions so chosen: x(0)=1; y(0)=0; vx(0)=0; vy(0)=v1+Δv. Being a nonlinear system I have to iterate until convergence, the rendezvous is considered successfully completed at time t when the two vehicles are within 3 m, i.e. the set tolerance, to be dimensionalized. I report my code below:
SUBROUTINE dydx(neq, x, y, f)
INTEGER, INTENT(IN) :: neq
REAL*8, INTENT(IN) :: x
REAL*8, DIMENSION(neq), INTENT(IN) :: y !y=(y1,y2)=(1,v)
REAL*8, DIMENSION(neq),INTENT(OUT) :: f
!y 1 componente y, 2 componente v
f(1) = y(2) !dx/dt=v
f(2) = -y(1) !dv/dt=-1
END SUBROUTINE dydx
SUBROUTINE RK4(neq, h, x, yold, ynew)
INTEGER, INTENT(IN) :: neq
REAL*8, INTENT(IN) :: h, x
REAL*8, DIMENSION(neq), INTENT(IN) :: yold
REAL*8, DIMENSION(neq), INTENT(OUT) :: ynew
REAL*8, DIMENSION(neq) :: k1, k2, k3, k4
INTEGER :: i
CALL dydx(neq, x, yold, k1)
DO i=1, neq
ynew(i) = yold(i) + 0.5d0*h*k1(i)
END DO
CALL dydx(neq, x + 0.5d0*h, ynew, k2)
DO i=1, neq
ynew(i) = yold(i) + 0.5d0*h*k2(i)
END DO
CALL dydx(neq, x + 0.5d0*h, ynew, k3)
DO i=1, neq
ynew(i) = yold(i) + h*k3(i)
END DO
CALL dydx(neq, x + h, ynew, k4)
DO i=1, neq
ynew(i) = yold(i) + h*(k1(i) + 2.0d0*k2(i) + 2.0d0*k3(i) + k4(i)) / 6.0d0
END DO
END SUBROUTINE RK4
SUBROUTINE save_results(fname, neq, npoints, x, y)!!!!!risultati da salvare
CHARACTER (len=*), INTENT(IN) :: fname
INTEGER, INTENT(IN) :: npoints, neq
REAL*8, DIMENSION(0:npoints), INTENT(IN) :: x
REAL*8, DIMENSION(neq, 0:npoints), INTENT(IN) :: y
INTEGER :: i,j
OPEN(40, FILE=fname)
DO i=0, npoints
WRITE(40,'(5(1pe20.12))') x(i), (y(j,i), j=1, neq) !!!!!!
END DO
CLOSE(40)
END SUBROUTINE save_results
PROGRAM secondo
IMPLICIT NONE
INTEGER, PARAMETER :: npoints = 1000
INTEGER, PARAMETER :: neq = 4
INTEGER :: i, toll
REAL*8, DIMENSION(0:npoints) :: x
REAL*8, DIMENSION(neq,0:npoints) :: y
REAL*8 :: h, xmin, xmax
REAL*8 :: w1, w2, w3, y1, y2, yn, xn
!shooting
!condizioni al contorno
xmin = 0.0d0 !t0=0
xmax = 1.0d0 !t_rv=1
xn=-1.0d0
yn= 0.0d0
h = (xmax - xmin) / npoints
DO i=0, npoints
x(i) = xmin + i*h
END DO
!condizioni iniziali
y(1,0) = 1.0d0 !x(0)
y(2,0) = 0.0d0 !y(0)
y(3,0) = 0.0d0 !vx
y(4,0) = 0.5d0!vy
w1 = y(4,0)
DO i=1, npoints
CALL RK4(neq, h, x(i), y(:,i-1), y(:,i))
END DO
y1 = y(1,npoints)
CALL save_results('risultati_prima_iter.txt', neq, npoints, x, y)
y(1,0) = 1.0d0 !x(0)
y(2,0) = 0.0d0 !y(0)
y(3,0) = 0.0d0 !vx
y(4,0) = 2.0d0 !vy
w2 = y(4,0)
DO i=1, npoints
CALL RK4(neq, h, x(i), y(:,i-1), y(:,i))
END DO
y2 = y(1,npoints)
CALL save_results('risultati_seconda_iter.txt', neq, npoints, x, y)
w3 = w2 + (w2 -w1) / (y2 -y1) * (yn - y2)
!!!!!convergenza
toll=1.d-12
DO i=1, npoints
DO WHILE (ABS(yn-y2)<=toll)
CALL RK4(neq, h, x(i), y(:,i-1), y(:,i))
w2=w3
END DO
CALL save_results('risultati_terza_iter.txt', neq, npoints, x, y)
END DO
END PROGRAM secondo
At this point, if the code is correct, I should have found the value of Δv searched (in m/s) but I can not understand which column of the file "results_third_iter.txt" gives me the calculated result.
In fact the next step is to make two graphs with gnuplot: the first with the trajectory of vehicle 1 in time, the second with the distance from the earth's surface of vehicle 1, as a function of time (distances in km, time in minutes) but even here I can not get sensible results.
Which data column in the file should I use to plot the graph? Also I think there is some error in the code because if I plot the three files at the same time without specifying the data columns to use, I get three identical parabolas which should not be so, where am I wrong?
Thanks to anyone who can help me

Storing a Variable with a Multi-Dimensional Index in Fortran

Question
Consider the following code:
program example
implicit none
integer, parameter :: n_coeffs = 1000
integer, parameter :: n_indices = 5
integer :: i
real(8), dimension(n_coeffs) :: coeff
integer, dimension(n_coeffs,n_indices) :: index
do i = 1, n_coeffs
coeff(i) = real(i*3,8)
index(i,:) = [2,4,8,16,32]*i
end do
end
For any 5 dimensional index I need to obtain the associated coefficient, without knowing or calculating i. For instance, given [2,4,8,16,32] I need to obtain 3.0 without computing i.
Is there a reasonable solution, perhaps using sparse matrices, that would work for n_indices in the order of 100 (though n_coeffs still in the order of 1000)?
A Bad Solution
One solution would be to define a 5 dimensional array as in
real(8), dimension(2000,4000,8000,16000,32000) :: coeff2
do i = 1, ncoeffs
coeff2(index(i,1),index(i,2),index(i,3),index(i,4),index(i,5)) = coeff(i)
end do
then, to get the coefficient associated with [2,4,8,16,32], call
coeff2(2,4,8,16,32)
However, besides being very wasteful of memory, this solution would not allow n_indices to be set to a number higher than 7 given the limit of 7 dimensions to an array.
OBS: This question is a spin-off of this one. I have tried to ask the question more precisely having failed in the first attempt, an effort that greatly benefited from the answer of #Rodrigo_Rodrigues.
Actual Code
In case it helps here is the code for the actual problem I am trying to solve. It is an adaptive sparse grid method for approximating a function. The main goal is to make the interpolation at the and as fast as possible:
MODULE MOD_PARAMETERS
IMPLICIT NONE
SAVE
INTEGER, PARAMETER :: d = 2 ! number of dimensions
INTEGER, PARAMETER :: L_0 = 4 ! after this adaptive grid kicks in, for L <= L_0 usual sparse grid
INTEGER, PARAMETER :: L_max = 9 ! maximum level
INTEGER, PARAMETER :: bound = 0 ! 0 -> for f = 0 at boundary
! 1 -> adding grid points at boundary
! 2 -> extrapolating close to boundary
INTEGER, PARAMETER :: max_error = 1
INTEGER, PARAMETER :: L2_error = 1
INTEGER, PARAMETER :: testing_sample = 1000000
REAL(8), PARAMETER :: eps = 0.01D0 ! epsilon for adaptive grid
END MODULE MOD_PARAMETERS
PROGRAM MAIN
USE MOD_PARAMETERS
IMPLICIT NONE
INTEGER, DIMENSION(d,d) :: ident
REAL(8), DIMENSION(d) :: xd
INTEGER, DIMENSION(2*d) :: temp
INTEGER, DIMENSION(:,:), ALLOCATABLE :: grid_index, temp_grid_index, grid_index_new, J_index
REAL(8), DIMENSION(:), ALLOCATABLE :: coeff, temp_coeff, J_coeff
REAL(8) :: temp_min, temp_max, V, T, B, F, x1
INTEGER :: k, k_1, k_2, h, i, j, L, n, dd, L1, L2, dsize, count, first, repeated, add, ind
INTEGER :: time1, time2, clock_rate, clock_max
REAL(8), DIMENSION(L_max,L_max,2**(L_max),2**(L_max)) :: coeff_grid
INTEGER, DIMENSION(d) :: level, LL, ii
REAL(8), DIMENSION(testing_sample,d) :: x_rand
REAL(8), DIMENSION(testing_sample) :: interp1, interp2
! ============================================================================
! EXECUTABLE
! ============================================================================
ident = 0
DO i = 1,d
ident(i,i) = 1
ENDDO
! Initial grid point
dsize = 1
ALLOCATE(grid_index(dsize,2*d),grid_index_new(dsize,2*d))
grid_index(1,:) = 1
grid_index_new = grid_index
ALLOCATE(coeff(dsize))
xd = (/ 0.5D0, 0.5D0 /)
CALL FF(xd,coeff(1))
CALL FF(xd,coeff_grid(1,1,1,1))
L = 1
n = SIZE(grid_index_new,1)
ALLOCATE(J_index(n*2*d,2*d))
ALLOCATE(J_coeff(n*2*d))
CALL SYSTEM_CLOCK (time1,clock_rate,clock_max)
DO WHILE (L .LT. L_max)
L = L+1
n = SIZE(grid_index_new,1)
count = 0
first = 1
DEALLOCATE(J_index,J_coeff)
ALLOCATE(J_index(n*2*d,2*d))
ALLOCATE(J_coeff(n*2*d))
J_index = 0
J_coeff = 0.0D0
DO k = 1,n
DO i = 1,d
DO j = 1,2
IF ((bound .EQ. 0) .OR. (bound .EQ. 2)) THEN
temp = grid_index_new(k,:)+(/ident(i,:),ident(i,:)*(grid_index_new(k,d+i)-(-1)**j)/)
ELSEIF (bound .EQ. 1) THEN
IF (grid_index_new(k,i) .EQ. 1) THEN
temp = grid_index_new(k,:)+(/ident(i,:),ident(i,:)*(-(-1)**j)/)
ELSE
temp = grid_index_new(k,:)+(/ident(i,:),ident(i,:)*(grid_index_new(k,d+i)-(-1)**j)/)
ENDIF
ENDIF
CALL XX(d,temp(1:d),temp(d+1:2*d),xd)
temp_min = MINVAL(xd)
temp_max = MAXVAL(xd)
IF ((temp_min .GE. 0.0D0) .AND. (temp_max .LE. 1.0D0)) THEN
IF (first .EQ. 1) THEN
first = 0
count = count+1
J_index(count,:) = temp
V = 0.0D0
DO k_1 = 1,SIZE(grid_index,1)
T = 1.0D0
DO k_2 = 1,d
CALL XX(1,temp(k_2),temp(d+k_2),x1)
CALL BASE(x1,grid_index(k_1,k_2),grid_index(k_1,k_2+d),B)
T = T*B
ENDDO
V = V+coeff(k_1)*T
ENDDO
CALL FF(xd,F)
J_coeff(count) = F-V
ELSE
repeated = 0
DO h = 1,count
IF (SUM(ABS(J_index(h,:)-temp)) .EQ. 0) THEN
repeated = 1
ENDIF
ENDDO
IF (repeated .EQ. 0) THEN
count = count+1
J_index(count,:) = temp
V = 0.0D0
DO k_1 = 1,SIZE(grid_index,1)
T = 1.0D0
DO k_2 = 1,d
CALL XX(1,temp(k_2),temp(d+k_2),x1)
CALL BASE(x1,grid_index(k_1,k_2),grid_index(k_1,k_2+d),B)
T = T*B
ENDDO
V = V+coeff(k_1)*T
ENDDO
CALL FF(xd,F)
J_coeff(count) = F-V
ENDIF
ENDIF
ENDIF
ENDDO
ENDDO
ENDDO
ALLOCATE(temp_grid_index(dsize,2*d))
ALLOCATE(temp_coeff(dsize))
temp_grid_index = grid_index
temp_coeff = coeff
DEALLOCATE(grid_index,coeff)
ALLOCATE(grid_index(dsize+count,2*d))
ALLOCATE(coeff(dsize+count))
grid_index(1:dsize,:) = temp_grid_index
coeff(1:dsize) = temp_coeff
DEALLOCATE(temp_grid_index,temp_coeff)
grid_index(dsize+1:dsize+count,:) = J_index(1:count,:)
coeff(dsize+1:dsize+count) = J_coeff(1:count)
dsize = dsize + count
DO i = 1,count
coeff_grid(J_index(i,1),J_index(i,2),J_index(i,3),J_index(i,4)) = J_coeff(i)
ENDDO
IF (L .LE. L_0) THEN
DEALLOCATE(grid_index_new)
ALLOCATE(grid_index_new(count,2*d))
grid_index_new = J_index(1:count,:)
ELSE
add = 0
DO h = 1,count
IF (ABS(J_coeff(h)) .GT. eps) THEN
add = add + 1
J_index(add,:) = J_index(h,:)
ENDIF
ENDDO
DEALLOCATE(grid_index_new)
ALLOCATE(grid_index_new(add,2*d))
grid_index_new = J_index(1:add,:)
ENDIF
ENDDO
CALL SYSTEM_CLOCK (time2,clock_rate,clock_max)
PRINT *, 'Elapsed real time1 = ', DBLE(time2-time1)/DBLE(clock_rate)
PRINT *, 'Grid Points = ', SIZE(grid_index,1)
! ============================================================================
! Compute interpolated values:
! ============================================================================
CALL RANDOM_NUMBER(x_rand)
CALL SYSTEM_CLOCK (time1,clock_rate,clock_max)
DO i = 1,testing_sample
V = 0.0D0
DO L1=1,L_max
DO L2=1,L_max
IF (L1+L2 .LE. L_max+1) THEN
level = (/L1,L2/)
T = 1.0D0
DO dd = 1,d
T = T*(1.0D0-ABS(x_rand(i,dd)/2.0D0**(-DBLE(level(dd)))-DBLE(2*FLOOR(x_rand(i,dd)*2.0D0**DBLE(level(dd)-1))+1)))
ENDDO
V = V + coeff_grid(L1,L2,2*FLOOR(x_rand(i,1)*2.0D0**DBLE(L1-1))+1,2*FLOOR(x_rand(i,2)*2.0D0**DBLE(L2-1))+1)*T
ENDIF
ENDDO
ENDDO
interp2(i) = V
ENDDO
CALL SYSTEM_CLOCK (time2,clock_rate,clock_max)
PRINT *, 'Elapsed real time2 = ', DBLE(time2-time1)/DBLE(clock_rate)
END PROGRAM
For any 5 dimensional index I need to obtain the associated
coefficient, without knowing or calculating i. For instance, given
[2,4,8,16,32] I need to obtain 3.0 without computing i.
function findloc_vector(matrix, vector) result(out)
integer, intent(in) :: matrix(:, :)
integer, intent(in) :: vector(size(matrix, dim=2))
integer :: out, i
do i = 1, size(matrix, dim=1)
if (all(matrix(i, :) == vector)) then
out = i
return
end if
end do
stop "No match for this vector"
end
And that's how you use it:
print*, coeff(findloc_vector(index, [2,4,8,16,32])) ! outputs 3.0
I must confess I was reluctant to post this code because, even though this answers your question, I honestly think this is not what you really want/need, but you dind't provide enough information for me to know what you really do want/need.
Edit (After actual code from OP):
If I decrypted your code correctly (and considering what you said in your previous question), you are declaring:
REAL(8), DIMENSION(L_max,L_max,2**(L_max),2**(L_max)) :: coeff_grid
(where L_max = 9, so size(coeff_grid) = 21233664 =~160MB) and then populating it with:
DO i = 1,count
coeff_grid(J_index(i,1),J_index(i,2),J_index(i,3),J_index(i,4)) = J_coeff(i)
ENDDO
(where count is of the order of 1000, i.e. 0.005% of its elements), so this way you can fetch the values by its 4 indices with the array notation.
Please, don't do that. You don't need a sparse matrix in this case either. The new approach you proposed is much better: storing the indices in each row of an smaller array, and fetching on the array of coefficients by the corresponding location of those indices in its own array. This is way faster (avoiding the large allocation) and much more memory-efficient.
PS: Is it mandatory for you to stick to Fortran 90? Its a very old version of the standard and chances are that the compiler you're using implements a more recent version. You could improve the quality of your code a lot with the intrinsic move_alloc (for less array copies), the kind constants from the intrinsic module iso_fortran_env (for portability), the [], >, <, <=,... notation (for readability)...

Check bounds changes variables

I'm porting a program that I use in a chemistry classroom from Matlab (very forgiving) to Fortran (err, not so much). The problem I see is that if I include print statements in 1 subroutine, my code returns significantly different values than if I don't (the ones with the print statement included are correct).
After reading stack overflow, I removed the print statement, recompiled with gfortran and fcheck='bounds', and my program returned the correct results, and no errors during compile.
The subroutines stored in a module Basis_Subs, and called from the main program, which I've posted below. The problem appears in the 4 dimensional matrix Gabcd(nb,nb,nb,nb) which is constructed using the subroutine Build_Electron_Repulsion from the Basis_Subs module. That subroutine calculates the matrix elements of Gabcd, and uses 1 internal helper functions, Rntuv, and 1 internal subroutine Gprod_1D, both of which are also stored in the Basis_Subs module.
These functions/routines are used in another section of the program, and that portion of the program doesn't show any errors or funny array behavior. That leads me to think the problem must either be in Build_Electron_Repulsion, how I'm calling Build_Electron_Repulsion or how I'm calling the the helper functions from inside Build_Electron_Repulsion.
I've posted the main program, and the subroutines for Build_Electron_Repulsion, gprod_1D, and the function Rntuv. What I'm really wondering is if you have any tips on tracking down where the error might be.
I'm using a pico style editor and gfortran.
Main Program, Z.f08
program HF
use typedefs
use Basis_Subs
use SCF_Mod
implicit none
real(dp) :: output, start, finish
integer (kind=4) :: IFLAG , i, N, nb,j,k,l,natom
integer, allocatable, dimension(:) :: Z
real(dp), allocatable, dimension(:,:) :: AL, S,T, VAB, H0
real(dp), allocatable, dimension(:,:,:,:) :: Gabcd
real(dp), dimension(maxl) :: Ex=0
real(dp) :: Energy, Nuc
type(primitive) :: g1, Build_Primitive
type(Basis) :: b1
type(Basis), dimension(100) :: bases
character(LEN=20) :: fname
print *, 'Input the filename'
read (*,*), fname
open(unit=12, file=fname)
read(12,*) natom
allocate(Z(natom))
allocate(AL(natom,3))
read(12,*) Z
do i=1, natom
read(12,*) AL(i,1), AL(i,2), AL(i,3)
end do
print *, 'Atomic Coorinates = ', AL
print *, 'Z in the main routine = ', Z
call cpu_time(start)
%Calculate the energies that don't depend on electrons
call Nuclear_Repulsion(natom, Z, AL, Nuc)
N=Sum(Z)
%Build the atom specific basis set
call Build_Bases(Z, AL, nb, bases)
%Using nb, from Build_Basis, allocate matrices
allocate(S(nb,nb))
allocate(T(nb,nb))
allocate(VAB(nb,nb))
allocate(Gabcd(nb,nb,nb,nb))
call Build_Overlap(bases, nb, S)
call Build_Kinetic(bases, nb, T)
call Build_Nuclear_Attraction(Z, AL, bases, nb, VAB)
H0 = T+VAB
call Build_Electron_Repulsion(bases, nb, Gabcd)
call cpu_time(finish)
print *, 'Total time for Matrix Elements= ', finish - start
call SCF(N, nb, H0, S, Gabcd, Nuc, Energy)
end program HF
Build_Electron_Repulsion is located inside the module Basis_Subs:
subroutine Build_Electron_Repulsion(bases, nbases, Gabcd)
!!Calculate the 4 centered electron repulsion integrals. Loop over array of !!basis sets 1:nb 4 times. Each element of basis set is a defined type that !!includes and array of gaussian functions and contraction coefficients !!basis(a)%g(1:nga) and basis(a)%c(1:nga). For each gaussian in each basis set,
!!Calculate int(int(basis(a1)*basis(b1)*basis(c2)*basis(d2)*1/r12 dr1)dr2).
!!Uses helper function Rntuv listed below
implicit none
type(basis), dimension(100), intent(in) :: bases
integer, intent(in) :: nbases
real(dp), dimension(nbases, nbases,nbases,nbases), intent(out) :: Gabcd
integer :: a, b,c,d, nga, ngb, ngc, ngd, index, lx, ly, lz, llx, lly,llz
integer :: llxmax, llymax, llzmax, lxmax, lymax, lzmax, xmax, ymax, zmax
integer :: x, y, z
real(dp) :: p, q, midpoint, PX, PY, PZ, output
real(dp) :: pp, qq, midpoint2, PPX, PPY, PPZ, tmp
real(dp) :: alpha_a, alpha_b, alpha_c, alpha_d, alpha
real(dp) :: ax, ay, az, bx, by, bz, cx,cy,cz, dx,dy,dz
real(dp), dimension(maxl) ::EabX, EabY, EabZ, EcdX, EcdY, EcdZ
real(dp), dimension(2*maxl, 2*maxl, 2*maxl) :: R
R=0
Gabcd=0.0D0
print *, 'Calculating 4 centered integrals'
do a=1, nbases
do b=1, nbases
do c=1, nbases
do d=1, nbases
do nga = 1, bases(a)%n
do ngb = 1, bases(b)%n
alpha_a=bases(a)%g(nga)%alpha
alpha_b=bases(b)%g(ngb)%alpha
p=alpha_a + alpha_b
ax=bases(a)%g(nga)%x
ay=bases(a)%g(nga)%y
az=bases(a)%g(nga)%z
bx=bases(b)%g(ngb)%x
by=bases(b)%g(ngb)%y
bz=bases(b)%g(ngb)%z
PX=(alpha_a*ax + alpha_b*bx)/p
PY=(alpha_a*ay + alpha_b*by)/p
PZ=(alpha_a*az + alpha_b*bz)/p
call gprod_1D(ax, alpha_a, bases(a)%g(nga)%lx, bx, alpha_b, bases(b)%g(ngb)%lx, EabX)
call gprod_1D(ay, alpha_a, bases(a)%g(nga)%ly, by, alpha_b, bases(b)%g(ngb)%ly, EabY)
call gprod_1D(az, alpha_a, bases(a)%g(nga)%lz, bz, alpha_b, bases(b)%g(ngb)%lz, EabZ)
lxmax=bases(a)%g(nga)%lx + bases(b)%g(ngb)%lx
lymax=bases(a)%g(nga)%ly + bases(b)%g(ngb)%ly
lzmax=bases(a)%g(nga)%lz + bases(b)%g(ngb)%lz
do ngc= 1, bases(c)%n
do ngd = 1, bases(d)%n
alpha_c=bases(c)%g(ngc)%alpha
alpha_d=bases(d)%g(ngd)%alpha
pp=alpha_c + alpha_d
cx=bases(c)%g(ngc)%x
cy=bases(c)%g(ngc)%y
cz=bases(c)%g(ngc)%z
dx=bases(d)%g(ngd)%x
dx=bases(d)%g(ngd)%y
dz=bases(d)%g(ngd)%z
PPX=(alpha_c*cx + alpha_d*dx)/pp
PPY=(alpha_c*cy + alpha_d*dy)/pp
PPZ=(alpha_c*cz + alpha_d*dz)/pp
llxmax=bases(c)%g(ngc)%lx + bases(d)%g(ngd)%lx
llymax=bases(c)%g(ngc)%ly + bases(d)%g(ngd)%ly
llzmax=bases(c)%g(ngc)%lz + bases(d)%g(ngd)%lz
call gprod_1D(cx, alpha_c, bases(c)%g(ngc)%lx, dx, alpha_d, bases(d)%g(ngd)%lx, EcdX)
call gprod_1D(cy, alpha_c, bases(c)%g(ngc)%ly, dy, alpha_d, bases(d)%g(ngd)%ly, EcdY)
call gprod_1D(cz, alpha_c, bases(c)%g(ngc)%lz, dz, alpha_d, bases(d)%g(ngd)%lz, EcdZ)
alpha=p*pp/(p+pp)
tmp=0
xmax= lxmax + llxmax
ymax = lymax + llymax
zmax = lzmax + llzmax
do x = 0, xmax
do y =0, ymax
do z=0, zmax
R(x+1,y+1,z+1)=Rntuv(0,x,y,z,alpha, PX, PY, PZ, PPX, PPY, PPZ)
end do
end do
end do
!if (a ==1 .and. b==1 .and. c ==1 .and. d==1) then
! print *,' R = ', R(1,1,1)
!print *, xmax, ymax, zmax
!print *,a,b,c,d,nga,ngb,ngc,ngd, 'R = ', R(1,1,1)
!end if
! if (PZ ==PPZ) then
! ! print *, R(1,1,1)
! output = Rntuv(0,0,0,0,alpha, PX, PY, PZ, PPX, PPY, PPZ)
! print *, output
! print *, a,b,c,d , PY, PPY
!
! end if
do lx = 0, lxmax
do ly = 0, lymax
do lz = 0, lzmax
do llx= 0, llxmax
do lly= 0, llymax
do llz= 0, llzmax
tmp = tmp + EabX(lx+1)*EabY(ly+1)*EabZ(lz+1)*(-1.0D0)**(llx + lly + llz) * &
EcdX(llx+1)*EcdY(lly+1)*EcdZ(llz+1)*R(lx+ llx+1, ly+lly+1, lz+llz+1)
end do
end do
end do
end do
end do
end do
Gabcd(a,b,c,d) = Gabcd(a,b,c,d) + 2.0D0*pi**2.5D0/(p*pp*sqrt(p + pp))*tmp*bases(a)%g(nga)%N &
* bases(b)%g(ngb)%N * bases(c)%g(ngc)%N * bases(d)%g(ngd)%N * bases(a)%c(nga) &
* bases(b)%c(ngb) * bases(c)%c(ngc) * bases(d)%c(ngd)
end do
end do
end do
end do
end do
end do
end do
end do
end subroutine Build_Electron_Repulsion
real(dp) function Rntuv(n, tmax, umax, vmax, p, Px, Py, Pz, Ax, Ay, Az) result(out)
!Rntuv(n, t,u,v,p,P,A)Determine the helper integral Rntuv for the coulomb
!integral of order n, the t,u,v th Hermite polynomial with exponent p
!centered at [Px Py Pz] and charge centered at location [Ax Ay Az];
implicit none
integer, intent(in) :: n, tmax, umax, vmax
real(dp), intent(in) :: Px, Py, Pz, Ax, Ay, Az, p
real(dp) :: PA2, output
real(dp), dimension(n+tmax+umax+vmax+2, tmax+1, umax+1, vmax+1) :: R
integer :: nmax, t, u, v
integer :: i, IFLAG
R=0
nmax = n+ tmax + umax + vmax + 2
PA2 = (Px-Ax)**2.0D0 + (Py-Ay)**2.0D0 + (Pz-Az)**2.0D0
do i = 0, nmax-1
output=Boys(i, p*PA2)
R(i+1,1,1,1)= (-2*p)**(1.0D0*i)*Boys(i, p*PA2)
end do
do t=1, tmax
if (t==1) then
do i=1,nmax-1
R(i,2,1,1)=(Px - Ax)*R(i+1,1,1,1)
end do
else
do i=1,nmax-1
R(i,t+1,1,1)=(t-1)*R(i+1,t-1,1,1)+ (Px-Ax)*R(i+1,t,1,1)
end do
end if
end do
do u = 1,umax
if (u==1) then
do i = 1,nmax-1
R(i,tmax+1,2,1)=(Py-Ay)*R(i+1,tmax+1,1,1)
end do
else
do i = 1,nmax-1
R(i,tmax+1,u+1,1)=(u-1)*R(i+1,tmax+1,u-1,1) + (Py-Ay)*R(i+1,tmax+1,u,1)
end do
end if
end do
do v=1,vmax
if (v==1) then
do i = 1, nmax-1
R(i,tmax+1,umax+1,2)=(Pz-Az)*R(i+1,tmax+1,umax+1,1)
end do
else
do i = 1, nmax-1
R(i,tmax+1,umax+1,v+1)=(v-1)*R(i+1,tmax+1,umax+1,v-1) + (Pz-Az)*R(i+1,tmax+1,umax+1,v)
end do
end if
end do
out = R(n+1,tmax+1,umax+1,vmax+1)
end function Rntuv
subroutine gprod_1D(x1, alpha1, lx1, x2, alpha2, lx2, Ex)
real(dp), intent(in) :: x1, alpha1, x2, alpha2
integer, intent(in) :: lx1, lx2
integer :: tmax, i, j ,t, qint
real(dp) :: p, q, midpoint, weighted_middle, KAB
real(dp), dimension(maxl), intent(inout) :: Ex
real(dp), dimension(maxl, maxl, 2*maxl) ::coefficients
coefficients=0.0D0
tmax=lx1 + lx2
Ex=0
p=alpha1 + alpha2
q=alpha1*alpha2/p
midpoint = x1 - x2
weighted_middle=(alpha1*x1 + alpha2*x2)/p
KAB= e**(-q*midpoint**2.0D0)
coefficients(1,1,1) = KAB
i=0
j=0
do while (i < lx1)
do t= 0, i+j+1
if (t==0) then
coefficients(i+2,j+1,t+1)=(weighted_middle - x1)*coefficients(i+1,j+1,t+1) + (t+1)*coefficients(i+1,j+1,t+2)
else
coefficients(i+2,j+1,t+1)=1/(2*p)*coefficients(i+1,j+1,t) + (weighted_middle-x1)*coefficients(i+1,j+1,t+1) + &
(t+1)*coefficients(i+1,j+1,t+2)
end if
end do
i=i+1
end do
do while (j < lx2)
do t=0, i+j+1
if (t==0) then
coefficients(i+1,j+2,t+1) = (weighted_middle - x2)*coefficients(i+1,j+1,t+1) + (dble(t)+1.0d0)*coefficients(i+1,j+1,t+2)
else
coefficients(i+1,j+2,t+1)=1/(2*p)*coefficients(i+1,j+1,t) + (weighted_middle - x2)*coefficients(i+1,j+1,t+1) + &
(t+1)*coefficients(i+1,j+1,t+2)
end if
end do
j=j+1
end do
do qint=1, i+j+1
Ex(qint) = coefficients(i+1,j+1,qint)
end do
end subroutine gprod_1D

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.