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.
Related
I want to calculate the mean square displacements (MSDs) for some particles in 2D space. From what I understand, the MSD is the measure of the displacements for each particle over the trajectory: I'm using the definition that <(∆r(∆t))^2> = 1/N ∑r_i^2 (∆t) where N is the number of particles.
A displacement is calculated as
x_1 = x(t_1), x_2 = x(t_1 + ∆t), ∆x_1(∆t) = x_2 - x_1
y_1 = y(t_1), y_2 = y(t_1 + ∆t), ∆y_1(∆t) = y_2 - y_1
...
x_i = x(t_i), x_i+1 = x(t_i + ∆t), ∆x_i(∆t) = x_i+1 - x_i
y_i = y(t_i), y_i+1 = y(t_i + ∆t), ∆y_i(∆t) = y_i+1 - y_i
The square displacement (∆r)^2 is the sum of the displacements in each dimension. Then the mean is taken.
How do I implement this? I tried the following, but as others have pointed out here it's not correct.
PROGRAM CALC
IMPLICIT NONE
INTEGER :: J,N,T,NPARTICLES,NSTEPS
REAL(8) :: SUM,DX,DY
REAL(8),ALLOCATABLE :: X(:,:),Y(:,:)
REAL(8),ALLOCATABLE :: MSD(:)
! INPUT
NSTEPS = 101
NPARTICLES = 500
ALLOCATE ( X(NPARTICLES,0:NSTEPS-1) )
ALLOCATE ( Y(NPARTICLES,0:NSTEPS-1) )
ALLOCATE ( MSD(0:NSTEPS-1) )
X = 0.0D0
Y = 0.0D0
DX = 0.0D0
DY = 0.0D0
OPEN(UNIT=50,FILE='TRAJECTORY',STATUS='UNKNOWN',ACTION='READ')
DO T = 0,NSTEPS-1
DO J = 1,NPARTICLES
READ(50,*) X(J,T), Y(J,T)
END DO
SUM = 0.0D0
MSD = 0.0D0
DO WHILE (NSTEPS < T)
DO N = 1,NPARTICLES
DX = X(N,T+1) - X(N,T)
DY = Y(N,T+1) - Y(N,T)
SUM = SUM + (DX**2 + DY**2)
END DO
END DO
MSD(T) = SUM / NPARTICLES
END DO
CLOSE(5)
DEALLOCATE(X)
DEALLOCATE(Y)
OPEN(UNIT=60,FILE='msd.dat',STATUS='UNKNOWN')
DO T = 0,NSTEPS-1
WRITE(60,*) T,MSD(T)
END DO
CLOSE(60)
DEALLOCATE(MSD)
END PROGRAM CALC
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've written a program that successfully shows a simple limit cycle for the Duffing equation. However, I now need to plot the Poincaré section for this case.
I need to do this by taking snapshots of the Phase-Space diagram at regular time intervals, such that t*omega = 2*pi*n. As I have omega set to 1 for this case, this is just when t = 2*pi*n. I've attempted this, but am not getting the Poincaré section I expect.
Here's my code:
program rungekutta
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer :: i, n
real(kind=dp) z, y, t, A, C, D, B, omega, h
open(unit=100, file="rungekutta.dat",status='replace')
n = 0
!constants
omega = 1.0_dp
A = 0.25_dp
B = 1.0_dp
C = 0.1_dp
D = 1.0_dp
y = 0.0_dp
z = 0.0_dp
t = 0.0_dp
do i=1,1000
call rk2(z, y, t, n)
n = n + 1.0_dp
write(100,*) y, z
end do
contains
subroutine rk2(z, y, t, n) !subroutine to implement runge-kutta algorithm
implicit none
integer, parameter :: dp = selected_real_kind(15,300)
integer, intent(inout) :: n
real(kind=dp) :: k1y, k1z, k2y, k2z, y, z, t, pi
pi = 4.0*ATAN(1.0)
h = 0.1_dp
t = n*2*pi
k1y = dydt(y,z,t)*h
k1z = dzdt(y,z,t)*h
k2z = dzdt(y + (0.5_dp*k1y), z + (0.5_dp*k1z), t + (0.5_dp*h))*h
k2y = dydt(y, z +(0.5_dp*k1z), t)*h
y = y + k2y
z = z + k2z
end subroutine
!2nd order ODE split into 2 for coupled Runge-Kutta, useful to define 2
functions
function dzdt(y,z,t)
real(kind=dp) :: y, z, t, dzdt
dzdt = -A*y**3.0_dp + B*y - C*z + D*sin(omega*t)
end function
function dydt(y,z,t)
real(kind=dp) :: z, dydt, y, t
dydt = z
end function
end program
I have also attached an image of what my Poincaré section looks like:
.
This is y on the x axis vs dydt.
And an image of what I'd expect:
In your rk2 routine you perform one step of step length 0.1. Thus the plot is the full trajectory of the solution at that resolution. However the intend seems to be to integrate over a full period length. This would require a loop in that routine.
In other words, what you want is the plot of (y(n*T), z(n*T)) where T is one of the periods of the system, per your code T=2*p. What you actually compute is (y(n*h), z(n*h)) where h=0.1 is the step size of a single step of RK2.
Also the arguments of k2y need to be corrected as per the comment of user5713492
With a corrected integrator you should get something like the following picture:
where the red squares are the points at t=n*2*pi. The indicated step size by the dots on the solution curve is the same h=0.1, the integration is over t=0..300.
def RK2(f,u,times,subdiv = 1):
uout = np.zeros((len(times),)+u.shape)
uout[0] = u;
for k in range(len(times)-1):
t = times[k]
h = (times[k+1]-times[k])/subdiv
for j in range(subdiv):
k1 = f(u,t)*h
k2 = f(u+0.5*k1, t+0.5*h)*h
u, t = u+k2, t+h
uout[k+1]=u
return uout
def plotphase(A,B,C,D):
def derivs(u,t): y,z = u; return np.array([ z, -A*y**3 + B*y - C*z + D*np.sin(t) ])
N=60
u0 = np.array([0.0, 0.0])
t = np.arange(0,300,2*np.pi/N);
u = RK2(derivs, u0, t, subdiv = 10)
plt.plot(u[:-2*N,0],u[:-2*N,1],'.--y', u[-2*N:,0],u[-2*N:,1], '.-b', lw=0.5, ms=2);
plt.plot(u[::N,0],u[::N,1],'rs', ms=4); plt.grid(); plt.show()
plotphase(0.25, 1.0, 0.1, 1.0)
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.
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.