Related
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
Every time I compile this program I get these errors...
(This error occurs every time I try to call the subroutine.)
103 | call ColumnInsert(M(n,n), b, n, col, MatOut(n,n))
| 1
Error: Explicit interface required for ‘columninsert’ at (1): assumed-shape argument
(This error also occurs every time I run the function)
107 | detA = Determinant (MatOut(:,:), n)
| 1
Error: Type mismatch in argument ‘m’ at (1); passed INTEGER(4) to REAL(8)
Here is the main program:
program CramersRule
! System of equations. 2x2, 3x3
implicit none
! Declare varialble
integer :: n, row, col, i
real*8, allocatable :: Matrix1(:,:), b(:), x(:)
real*8 :: detA, detM, determinant
logical :: Success
! Open the input and output files.
open(42,file='Data2.txt')
open(43,file='Data2Out.txt')
! Solve each system in the input files.
do
! Read in size of first system.
read(42,*) n
if (n .eq. 0) exit ! Quit if zero.
! Allocate memory for system, right hand side, and solution vector.
allocate(Matrix1(n,n), b(n), x(n))
! Read in the system. Ask if you do not understand how this works!
do row = 1, n
read(42,*) (Matrix1(row, col), col = 1, n), b(row)
print*, Matrix1
enddo
! Use cramers rule to get solution.
call Cramer(Matrix1, b, n, x, Success)
if (Success) then
! Write solution to file
do row = 1, n
write(43,*) x(row)
enddo
write(43,*)
else ! This happens when there is no unique solution.
write(43,*) 'No Solution'
write(43,*)
endif
! clean up memory and go back up to top for next system.
deallocate(Matrix1, b, x)
enddo
! close files
close(42)
close(43)
end program CramersRule
subroutine Cramer(M, b, n, x, Success)
! This subroutine does Cramer's Rule
implicit none
! Declare and initialize your variables first.
real*8, allocatable :: M(:,:), b(:), x(:)
integer :: n, row, col, i
integer :: MatOut(n,n)
real*8 :: detA, detM, x1, x2, x3, Determinant, solution1, solution2, solution3
logical :: Success
! Find the determinant of M first. print it to screen.
detM = Determinant(M, n)
print*, "The determinant of this matrix is = ", detM
! If it is zero, set the Success logical variable and quit.
if (detM .eq. 0) then
Success = .false.
return
end if
! Allocate memory for a working matrix for column substituion. Then, for each
! column, i, substitute column i with vector b and get that determinant.
! Compute the ith solution.
if (n .eq. 2)then
col = 1
call ColumnInsert(M(n,n), b, n, col, MatOut(n,n))
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x1 = detA/detM
solution1 = x1
col = col + 1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x2 = detA/detM
solution2 = x2
success = .true.
return
else
col = 1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x1 = detA/detM
solution1 = x1
col = col + 1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x2 = detA/detM
solution2 = x2
col = col +1
call ColumnInsert(M, b, n, col, MatOut)
print*, MatOut(:,:)
detA = Determinant (MatOut(:,:), n)
x3 = detA/detM
solution3 = x3
success = .true.
return
end if
! deallocate memory for the working matrix.
deallocate(M, b, x)
end subroutine Cramer
subroutine ColumnInsert(M, b, n, col, MatOut)
! This subroutine takes vector b and inserts in into matrix M at column col.
implicit none
integer :: n
integer, intent(out) :: col, MatOut(:,:)
real :: a, b1, c, d, e, f, g, h, j, k, l, m1
double precision :: M(n,n), b(1,n)
if (n .eq. 2)then
a = M(1,1)
b1 = M(1,2)
c = M(2,1)
d = M(2,2)
e = b(1,1)
f = b(1,2)
!the next if statement substitutes based on which column the main program asks for
if (col .eq. 1)then
M(1,1) = e
M(1,2) = f
M(2,1) = c
M(2,2) = d
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
else
M(1,1) = a
M(1,2) = b1
M(2,1) = e
M(2,2) = f
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
endif
!this is for 3x3 matricies
else
a = M(1,1)
b1 = M(1,2)
c = M(1,3)
d = M(2,1)
e = M(2,2)
f = M(2,3)
g = M(3,1)
h = M(3,2)
j = M(3,3)
k = b(1,1)
l = b(1,2)
m1 = b(1,3)
if (col .eq. 1) then
M(1,1) = k
M(1,2) = l
M(1,3) = m1
M(2,1) = d
M(2,2) = e
M(2,3) = f
M(3,1) = g
M(3,2) = h
M(3,3) = j
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
else if (col .eq. 2)then
M(1,1) = a
M(1,2) = b1
M(1,3) = c
M(2,1) = k
M(2,2) = l
M(2,3) = m1
M(3,1) = g
M(3,2) = h
M(3,3) = j
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
else
M(1,1) = a
M(1,2) = b1
M(1,3) = c
M(2,1) = d
M(2,2) = e
M(2,3) = f
M(3,1) = k
M(3,2) = l
M(3,3) = m1
MatOut(:,:) = M(:,:)
print*, MatOut(:,:)
return
endif
endif
end subroutine ColumnInsert
function Determinant(M, n) result(Det)
!pulled straight from lab 2 in week 4
integer :: n
real*8 :: M(n,n), Det, a, b, c, d, e, f, g, h, j
if (n .eq. 2) then
a = M(1,1)
b = M(1,2)
c = M(2,1)
d = M(2,2)
Det = (a*d)-(b*c)
else
a = M(1,1)
b = M(1,2)
c = M(1,3)
d = M(2,1)
e = M(2,2)
f = M(2,3)
g = M(3,1)
h = M(3,2)
j = M(3,3)
Det = (a*e*j)+(b*f*g)+(c*d*h)-(c*e*g)-(b*d*j)-(a*f*h)
endif
end function Determinant
I know this might seem like a dumb question to be asking, but I cannot for the life of me find where I need to change something. Any help or guidance is greatly appreciated. Thanks!
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
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.
I made a post about this issue a few weeks ago and edited it but I'm not sure if it's still active. So since it is still bothering me I'm making a new one but in a better form, I hope.
For an assignment I am supposed to interpolate function values and derivative values in newton form. I can do it on paper but I'm completely lost when it comes to turning it into a fortran code. I have looked at different source codes but they either opened a file or asked for input, I was given 5 sets of values and have to use those. I was able to write a small program that will do the interpolation without the derivatives. Then I tried to add the derivatives to it.
In the code below "yp" is for the derivatives
program main
implicit none
double precision , allocatable , dimension (:,:) :: nt
double precision , allocatable , dimension (:) :: xnodes, yval, yp
double precision :: x, evalnewton
integer :: i,n,k
n = 7
allocate ( xnodes (0:n), yval (0:n), yp (0:n), nt (0:n, 0:n) )
xnodes = (/ 1.32d0, 2.47d0, 5.81d0, 6.83d0, 7.0d0 /)
yval = (/ 5.63d0, 6.11d0, 8.12d0, 4.33d0, 6.15d0 /)
yp = (/ 1.29d0, 2.21d0, 1.48d0, -3.61d0, 3.11d0 /)
call computent (n, xnodes, yval, yp, nt)
do i = 0,n
x = xnodes(i)
print*, xnodes(i), yval(i), yp(i), evalnewton (n, xnodes, nt, x)
end do
open (unit = 4, file = 'z', status = 'replace')
do i = 0,100
x = dble(i) * 1.0d-1
write (4,*) x, evalnewton (n, xnodes, nt, x)
end do
close (4)
deallocate (xnodes, yval, yp)
stop
end
subroutine computent (n, xnodes, yval, yp, nt)
implicit none
integer :: i, j, n, k, top, bot
double precision :: nt (0:n, 0:n)
double precision xnodes (0:n), yval (0:n), yp(0:n)
double precision :: x, evalnewton
nt = 0.0d0
do i = 0,n
nt (i,0) = yval (i)
end do
do k = 1,n
top = k
bot = 0
do i = k,n
nt (i,k) = (nt (i,k-1) - nt (i-1,k-1))/(xnodes(top) - xnodes(bot))
top = top + 1
bot = bot + 1
end do
print*, 'Column number', k
do j = 0,n
print*, nt (j,k)
end do
end do
return
end
double precision function evalnewton (n, xnodes, nt, x)
implicit none
integer :: i, j, n, k, top, bot
double precision :: nt(0:n, 0:n)
double precision xnodes (0:n), yval(0:n), yp(0:n)
double precision :: x
evalnewton = nt(n,n)
do i = n, 1, -1
evalnewton = evalnewton * (x - xnodes (i-1)) + nt (i-1, i-1)
end do
return
end
To be honest I just added "yp" everywhere, where I had "yval" and hoped for a mystery solver to do its magic. I have not figured out yet what to add so the program will include the derivatives in the calculations. It would be nice if someone could explain me the next steps to take.
EDIT:
I added minor changes to computent which I thought would solve the issue:
do i = 0,n
nt (i*2,0) = yval (i)
nt (i*2+1,0) = yval (i)
end do
do k = 1,n
top = k
bot = 0
do i = k,n
nt (i,k) = (nt (i,k-1) - nt (i-1,k-1))/(xnodes(top) - xnodes(bot))
if (nt(i,k) == 0) then
nt(i,k) = yp(i/2)
end if
top = top + 2
bot = bot + 2
end do
print*, 'Column number', k
do j = 0,n
print*, nt (j,k)
end do
now as first number I get 2.420...e^-322, and that number is messing up the rest of the calculations. Any ideas how to get rid of it?
I'm pretty I figured it out with a small issue. I have it as answer just in case someone else needs it.
program main
implicit none
double precision , allocatable , dimension (:,:) :: yt
double precision , allocatable , dimension (:) :: xnodes, yval, yp, xt
double precision :: x, evalnewton
integer :: i,n,k
n = 9
allocate ( xnodes (0:n), yval (0:n), yp (0:n), yt (0:n, 0:n), xt (0:n) )
xnodes = (/ 1.32d0, 2.47d0, 5.81d0, 6.83d0, 7.0d0 /)
yval = (/ 5.63d0, 6.11d0, 8.12d0, 4.33d0, 6.15d0 /)
yp = (/ 1.29d0, 2.21d0, 1.48d0, -3.61d0, 3.11d0 /)
call computent (n, xnodes, yval, yp, yt, xt)
do i = 0,n
x = xnodes(i)
print*, xnodes(i), yval(i), yp(i), evalnewton (n, xnodes, yt, x)
end do
open (unit = 4, file = 'z', status = 'replace')
do i = 0,100
x = dble(i) * 1.0d-1
write (4,*) x, evalnewton (n, xnodes, yt, x)
end do
close (4)
deallocate (xnodes, yval, yp, yt, xt)
stop
end
subroutine computent (n, xnodes, yval, yp, yt, xt)
implicit none
integer :: i, j, n, k, top, bot
double precision :: yt (0:n, 0:n)
double precision xnodes (0:n), yval (0:n), yp(0:n), xt (0:n)
double precision :: x, evalnewton
xt = 0.0d0
yt = 0.0d0
do i = 0,n
xt(i*2) = xnodes (i)
xt(i*2+1) = xnodes (i)
yt(i*2,0) = yval (i)
yt(i*2+1,0) = yval (i)
end do
do k = 1,n
do i = k,n
yt(i,k) = (yt(i,k-1) - yt(i-1,k-1))/(xt(i) - xt(i-1))
if (xt(i) - xt(i-1) == 0) then
yt(i,k) = yp(i/2)
end if
end do
print*, 'Column number', k
do j = 0,n
print*, yt (j,k)
end do
end do
return
end
double precision function evalnewton (n, xnodes, yt, x)
implicit none
integer :: i, j, n, k, top, bot
double precision :: yt(0:n, 0:n)
double precision xnodes (0:n), yval(0:n), yp(0:n)
double precision :: x
evalnewton = yt(n,n)
do i = n, 1, -1
evalnewton = evalnewton * (x - xnodes (i-1)) + yt (i-1, i-1)
end do
return
end
the small issue is that I get an error message when I run the program and the file is not created
Error Message:
a.out: malloc.c:2372: sysmalloc: Assertion `(old_top == (((mbinptr) (((char *) &((av)->bins[((1) - 1) * 2])) - __builtin_offsetof (struct malloc_chunk, fd)))) && old_size == 0) || ((unsigned long) (old_size) >= (unsigned long)((((__builtin_offsetof (struct malloc_chunk, fd_nextsize))+((2 *(sizeof(size_t))) - 1)) & ~((2 *(sizeof(size_t))) - 1))) && ((old_top)->size & 0x1) && ((unsigned long) old_end & pagemask) == 0)' failed.
Program received signal SIGABRT: Process abort signal.
Backtrace for this error: