This question already has answers here:
Line truncated, Syntax error in argument list
(2 answers)
Closed 5 years ago.
I have tried to write a code in fortran to calculate the coordination number. But a got these errors
coord.f:43.72:
read(13,*) ri(i), g(2,2,i), g(1,2,i), g(1,2,i), g(1,
1
Error: Expected array subscript at (1)
coord.f:78.38:
call integrate(npts-1,ri,gt,ans)
1
Warning: Rank mismatch in argument 'ans' at (1) (scalar and rank-2)
coord.f:79.8:
t1(ia,ib)=ans
1
Error: Incompatible ranks 0 and 2 in assignment at (1)
coord.f:52.32:
call coordination(ri,g,ro,num)
1
Warning: Invalid procedure argument at (1)
This is the code below which I have tried for it. Can anyone please
help me to solve these errors?
ccccc Solution for Coordination number:
c 2 :macro-ion
c 1 :counter-ion
include "prmts" ! parameter for npts, l, pi, bl!
character init*10
integer icont(l,l)
double precision grid, dm22, dr, dt, num
double precision g(l,l,npts),
& ro(l,l),z(l),r(l),ri(npts),dm(l,l),
& h(l,l,npts),ans(l,l), t1(l,l),gt(npts)
open(unit=13,file='grm.out.txt',status='old')
open(unit=14,file='cor.out',status='unknown')
read(13,*)(z(i),i=1,l) ! algebric charge !
read(13,*)(r(i),i=1,l) ! radious of ions !
read(13,*)ro(2,2) ! no.density of 2 !
do i = 1, l
r(i) = r(i)
enddo
dm22 = dm22
dr = r(2)/grid
ro(2,2) = ro(2,2)
ro(1,1) = -z(2)*ro(2,2)/z(1)
! From condition of electro neutrality !
open(unit=13,file='grm.out.txt',status='old')
do i=1, npts-1
read(13,*) ri(i), g(2,2,i), g(1,2,i), g(1,2,i), g(1,1,i)
enddo
close(13)
CCCCC CALCULATE COORDINATION NUMBER
call coordination(ri,g,ro,num)
write(14,*)"# Cornum = ", num(ia,ib)
write(14,*)"#----------------------------------------------"
write(14,*)"# num22 num21 num12 num11 "
write(14,*)"#----------------------------------------------"
999 format( 4f18.6)
stop
end ! end of main !
subroutine coordination(ri,g,ro,num)
include 'prmts' ! for l, npts, pi and bl !
double precision ri(npts), g(l,l,npts), ro(l,l)
& , num(l,l), ans(l,l), t1(l,l),gt(npts)
integer i, ia, ib
CCCCC COORDINATION NUMBER
CCCCC Cornum : Coordination number.
do ia=1,l
do ib=1,l
do i=1,npts-1
gt(i)=g(ia,ib,i)*ri(i)**2
enddo
call integrate(npts-1,ri,gt,ans)
t1(ia,ib)=ans
enddo
enddo
CCCCC COORDINATION NUMBER
do ia=1,l
do ib=1,l
num(ia,ib)= 4.0d0*pi*ro(ib,ib)*t1(ia,ib)
enddo
enddo
write(*,*) 'Cornum = ', num(ia,ib)
end
subroutine integrate(n,x,y,ans)
integer nin, nout
parameter (nin=5,nout=6)
double precision ans, error
integer ifail, n
double precision x(n), y(n)
ifail = 1
call pintegr(x,y,n,ans,error,ifail)
if (ifail.eq.0) then
write (nout,99999) 'integral = ', ans,
+ ' estimated error = ', error
else if (ifail.eq.1) then
write (nout,*) 'less than 4 points supplied'
else if (ifail.eq.2) then
write (nout,*)
+ 'points not in increasing or decreasing order'
else if (ifail.eq.3) then
write (nout,*) 'points not all distinct'
end if
return
99999 format (1x,a,e12.4,a,e12.4)
end
subroutine pintegr(x,y,n,ans,er,ifail)
double precision ans, er
integer n
double precision x(n), y(n)
double precision c, d1, d2, d3, h1, h2, h3, h4, r1, r2, r3,
* r4, s
integer i, nn
ans = 0.0d0
er = 0.0d0
if (n.ge.4) go to 20
ifail = 1
return
h2 = x(2) - x(1) 20
do 80 i = 3, n
h3 = x(i) - x(i-1)
if (h2*h3) 40, 40, 80
write(*,*)'points not specified correctly' 40
ifail = 3
return
continue 80
d3 = (y(2)-y(1))/h2
h3 = x(3) - x(2)
d1 = (y(3)-y(2))/h3
h1 = h2 + h3
d2 = (d1-d3)/h1
h4 = x(4) - x(3)
r1 = (y(4)-y(3))/h4
r2 = (r1-d1)/(h4+h3)
h1 = h1 + h4
r3 = (r2-d2)/h1
ans = h2*(y(1)+h2*(d3/2.0d0-h2*(d2/6.0d0-(h2+2.0d0*h3)*r3/12.0d0))
* )
s = -(h2**3)*(h2*(3.0d0*h2+5.0d0*h4)+10.0d0*h3*h1)/60.0d0
r4 = 0.0d0
nn = n - 1
do 120 i = 3, nn
ans = ans + h3*((y(i)+y(i-1))/2.0d0-h3*h3*(d2+r2+(h2-h4)*r3)
* /12.0d0)
c = h3**3*(2.0d0*h3*h3+5.0d0*(h3*(h4+h2)+2.0d0*h4*h2))/120.0d0
er = er + (c+s)*r4
if (i.ne.3) s = c
if (i.eq.3) s = s + 2.0d0*c
if (i-n+1) 100, 140, 100
h1 = h2 100
h2 = h3
h3 = h4
d1 = r1
d2 = r2
d3 = r3
h4 = x(i+2) - x(i+1)
r1 = (y(i+2)-y(i+1))/h4
r4 = h4 + h3
r2 = (r1-d1)/r4
r4 = r4 + h2
r3 = (r2-d2)/r4
r4 = r4 + h1
r4 = (r3-d3)/r4
continue 120
continue 140
ans = ans + h4*(y(n)-h4*(r1/2.0d0+h4*(r2/6.0d0+(2.0d0*h3+h4)
* *r3/12.0d0)))
er = er - h4**3*r4*(h4*(3.0d0*h4+5.0d0*h2)+10.0d0*h3*(h2+h3+h4))
* /60.0d0 + s*r4
ans = ans + er
ifail = 0
return
end
END of Program
The key is to notice that the first error is at column 72 and that the line is incomplete in the error message.
The line is to long for Fortran 77 which allows only 72 characters. Divide the lines into to or use some compiler option to allow longer lines (breaks portability).
There are other errors too, like
t1(ia,ib)=ans
t1(ia,ib) is a scalar (one array element) and ans is an array. That is not possible, you must be consistent.
The procedure integrate defines its dummy argument ans as a scalar real due to implicit typing, but you pass an array ans to it. That is also not possible.
I suggest you to use implicit none in all programs although it is technically not Fortran 77. It will help you to avoid many errors.
Finally, num was declared as as double precision but used as
num(ia,ib)
for this reason the compiler thinks it is an external function and warns you about the invalid procedure argument. You must be consistent and declare it as an array or use it as a scalar.
Probably, there are many more errors in the code, it is quite messy and very hard to read.
Related
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
The program is as follows.
The issue occurs when I try to run the code for >~80 years, at which point the code apparently 'runs' instantly, generating an empty text file. The code runs fine for smaller timescales.
PROGRAM NBody
IMPLICIT NONE
DOUBLE PRECISION:: m(1:10), deltaR(1:3)
DOUBLE PRECISION:: G, r
DOUBLE PRECISION, DIMENSION(10,3):: pos, v, a0, a1 !x, y, z
INTEGER:: n,i,j,k,stepsize, year, zero, length
CHARACTER(len=13):: fname !xxxyrxxpl.txt
zero = 0
m(1) = 1988500e24 !sun
m(2) = 0.33e24 !mercury
m(3) = 4.87e24 !venus
m(4) = 5.97e24 !earth
m(5) = 0.642e24 !mars
m(6) = 1898e24 !jupiter
m(7) = 568e24 !saturn
m(8) = 86.8e24 !uranus
m(9) = 102e24 !!neptune
m(10) = 0.0146e24 !pluto
!Initial POS
pos = zero
pos(2,1) = 57.9e9
pos(3,1) = 108e9
pos(4,1) = 149e9
pos(5,1) = 227e9
pos(6,1) = 778e9
pos(7,1) = 1352.6e9
pos(8,1) = 2741.3e9
pos(9,1) = 4444.5e9
pos(10,1) = 4436.8e9
!FORTRAN works column,row: (particle,x/y/z)
!Momentum is initially non-zero due to planet and velocity starting points. Figure out a solution.
!Initial velocity
v = zero
v(2,2) = 47.4e3
v(3,2) = 35e3
v(4,2) = 29.8e3
v(5,2) = 24.1e3
v(6,2) = 13.1e3
v(7,2) = 9.7e3
v(8,2) = 6.8e3
v(9,2) = 5.4e3
v(10,2) = 4.7e3
g = 6.67e-11
stepsize = 1800 !3600 = 1 hour
year = 3.154e+7
!Calculate initial values
a0 = 0
a1 = 0
do i = 1,10
do j = 1,10
if(i==j) cycle
deltaR(:) = (pos(i,:)-pos(j,:))
r = -sqrt((pos(i,1)-pos(j,1))**2+(pos(i,2)-pos(j,2))**2+(pos(i,3)-pos(j,3))**2)
a0(i,:) = a0(i,:) + g*M(j)*deltaR*r**(-3)
END DO
END DO
write(6,*) "Specify length in years"
read (*,*) length
write(6,*) "Specify file name (xxxYRzzPL.txt)"
read(*,*) fname
!Just above is where I call for a length in the terminal, values of 40 will work, much higher do not. I don't know the exact cut-off.
open (unit = 2, file = fname)
!Do loop over time, planet and partners to step positions
do k=0, length*year,stepsize
write(2,*) pos
pos = pos + v*stepsize + 0.5*a0*stepsize**2
do i = 1,10
do j = 1,10
if(i==j) cycle
deltaR(:) = (pos(i,:)-pos(j,:))
r = -sqrt((pos(i,1)-pos(j,1))**2+(pos(i,2)-pos(j,2))**2+(pos(i,3)-pos(j,3))**2)
a1(i,:) = a1(i,:) + G*M(j)*deltaR/r**3
END DO
END DO
v = v + 0.5*(a0+a1)*stepsize
a0=a1
a1=0
END DO
close (2)
END PROGRAM
I suspected it could be an issue with variable storage but I can't see any problems there.
Using an iterator like this can be dubious. Even an 8 byte integer will overflow if you go long enough. Considering how this code is set up, I would do something like this:
do iYear = 1, length
do k = 0, year, stepsize
....
enddo
enddo
Inner do loop loops over one year. Outer do loop loops over the years. Could go Gigayears like this with just 4 byte integers if you want to wait that long.
I would likely rename your variables too to make more sense. This would look better:
do iYear = 1, nYears
do k = 0, YearLength, stepsize
....
enddo
enddo
Expanding on #francescalus, you may need to specify your integers as 8-bytes rather than the default 4:
integer, parameter :: c_int8 = selected_int_kind (10)
integer(kind = c_int8) :: n,i,j,k,stepsize, year, zero, length
EDIT I added a parameter to determine the correct value for a 64-bit integer intrinsically.
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 have this part of the following Fortran code, where at allocate(temp), valgrind says about definitely memory loss. Is there any mistake in the way I am doing on allocating this data?
subroutine insert_linked_list_grids(l,ncell,nclust,corner,headlev)
implicit none
integer :: ig, jg, kg, k, l, m1, m2, m3, nx, ny, nz, ncell, &
nclust, bsaux, bnaux, bwaux, beaux, bbaux, btaux
double precision :: dx, dy, dz, dxaux, dyaux, dzaux
double precision, dimension(24,maxcl) :: corner
type(level_components1), pointer :: temp, curr
type(level_components1), dimension(ltop), target :: headlev
dx = headlev(l)%hx
dy = headlev(l)%hy
dz = headlev(l)%hz
dxaux = headlev(l-1)%hx
dyaux = headlev(l-1)%hy
dzaux = headlev(l-1)%hz
!nullify(headlev(l)%next)
curr => headlev(l)
headlev(l)%npatches = 0
!calculating ix, iy, iz, mx, my, mz
write(*,*) 'total number of cluster =', nclust
do k=1,nclust
headlev(l)%npatches = headlev(l)%npatches +1
ig = nint(r*(corner(1,k) - 0.5d0*dxaux - a1)/dxaux ) + 1
jg = nint(r*(corner(2,k) - 0.5d0*dyaux - a2)/dyaux ) + 1
kg = nint(r*(corner(3,k) - 0.5d0*dzaux - a3)/dzaux ) + 1
!write(*,*) "cluster = ", k,"ig = ", ig,"jg = ", jg,&
! "kg = ",kg
nx = nint(r*(corner(10,k)-corner(1,k) + dxaux)/dxaux)
ny = nint(r*(corner(5,k)-corner(2,k) + dyaux)/dyaux)
nz = nint(r*(corner(15,k)-corner(3,k) + dzaux)/dzaux)
!write(*,*) "cluster = ", k,"nx = ", nx,"ny = ", ny,&
! "nz = ",nz
call bc_linked_list(ig,jg,kg,nx,ny,nz,dx,dy,dz,bwaux,beaux,&
bsaux,bnaux,bbaux,btaux,headlev)
allocate(temp)
temp%grid%ix = ig
temp%grid%iy = jg
temp%grid%iz = kg
temp%grid%mx = nx
temp%grid%my = ny
temp%grid%mz = nz
temp%grid%iu = 1 + ncell
temp%grid%bw = bwaux
temp%grid%be = beaux
temp%grid%bs = bsaux
temp%grid%bn = bnaux
temp%grid%bb = bbaux
temp%grid%bt = btaux
m1 = temp%grid%mx + 1 + 2*nbc
m2 = temp%grid%my + 1 + 2*nbc
m3 = temp%grid%mz + 1 + 2*nbc
ncell = ncell + m1*m2*m3
nullify(temp%next)
curr%next => temp
curr => temp
end do
return
end subroutine insert_linked_list_grids
I expect that valgrind is warning you that when the subroutine returns temp goes out of scope and is, in effect, reaped, but the memory pointed to by temp is not reaped; this looks like a canonical memory leak to me.
You could deallocate temp before the subroutine ends.
Or you could make temp an allocatable array in which case it is the compiler's responsibility to generate code which reaps the memory allocated when the subroutine returns. In general, with a modern (Fortran 2003) compiler allocatable is a better route to managing memory dynamically than pointer because the compiler takes care of memory deallocation. Of course, there are some cases where only a pointer will do.
I am a Newbie to Fortran, facing a problem within a Do loop. I am programming a Fortran Code for a MEX File to be used within Matlab.
I assume it has a problem with the definition of k and z, but I don't see why. Maybe you guys have a hint for me what I am doing wrong. Thank you very much!
Error Message and Code
innerloops.F
do k = 1, 4
1
Error: Non-numeric character in statement label at (1)
innerloops.F
do k = 1, 4
1
Error: Unclassifiable statement at (1)
innerloops.F
do z = 1, 25
1
Error: Non-numeric character in statement label at (1)
innerloops.F
do z = 1, 25
Error: Unclassifiable statement at (1)
C Computational routine
subroutine innerloops(J,c1,c2,c3,c4,n1,n2,n3,n4,y,m,n)
mwSize m, n
integer k, z
real*8 J(m,n), y(4,1), c1, c2, c3, c4, n1, n2, n3, n4
real*8 QuadRuleX(25,2)
real*8 QuadRuleW(25,1)
real*8 X(5,1), r, t
real*8 P, c_h, n_h
integer h = 10
C Gaussian Points
X(1) = -.906179
X(2) = -.538469
X(3) = 0
X(4) = .538469
X(5) = .906179
C Corresponding QuadRule points
QuadRuleX(1,1) = X(1)
QuadRuleX(1,2) = X(1)
C .... (snipped it here for readability)
C Corresponding weights
QuadRuleW(1) = Y(1)*Y(1)
QuadRuleW(2) = Y(2)*Y(1)
C .... (snipped it here for readability)
do k = 1, 4
do z = 1, 25
r = QuadRuleX(z,1)
t = QuadRuleX(z,2)
P = shape(k,r,t)
c_h = c1*shape(k,r,t)
n_h = n1*shape(k,r,t)
y(k,1) = (P*((((h-1)*c_h)/(h-1)*c_h+1))*n_h*(2-n_h)-n_h)
continue
continue
return
end do
end subroutine innerloops
C defining the shape functions
Function shape(q,c,d)
implicit none
real q,c,d,P
if (q == 1) then
P = 1/4*(c-1)*(d-1)
else if (q == 2) then
P = -1/4*(c+1)*(d-1)
else if (q == 3) then
P = 1/4*(c+1)*(d+1)
else if (q == 4) then
P = -1/4*(c-1)*(d+1)
endif
return
end Function shape
By using a .F suffix the compiler by default assumes that you are using a fixed format source code. In fixed format certain columns are reserved for special purposes. Here it appears that your "do" has been mistakenly put into a column reserved for statement label (columns 1 through 5). Your statement has to fit between column 7 and 72 in a fixed-format fortran file. This is what the compiler was complaining about. As mentioned by others, your code also contain other errors that need to be fixed.
To make things simpler, you can use a free format instead by changing the suffix to .f90 and replacing the "C" comment indicator with "!".