Error in Fortran: attempt to call a routine with argument number four as a real (kind=1) when a procedure was required - fortran

I have never done programming in my life and this is my very first code for a uni assignment, I get no errors in the compiling stage but myh program does not run saying that I have the error in the title, guess the problem is when I call the subroutine. Can anyone help me? It is my first code and it is really frustrating. Thank you.
!NUMERICAL COMPUTATION OF INCOMPRESSIBLE COUETTE FLOW USING FINITE DIFFERENCE METHOD
!IMPLICIT APPROACH
!MODEL EQUATION
!PARTIAL(U)/PARTIAL(T)=1/RE*(PARTIAL(U) SQUARE/PARTIAL(Y) SQUARE)
!DEFINE VARIABLES
IMPLICIT NONE
!VELOCITY U AT TIME T, VELOCITY UNEW AT TIME T+1, TIME T
!MAXIMUM 1000 POINTS
REAL V(1000)
REAL VNEW(1000)
REAL T
!GRID SPACING DY, GRID POINTS N+1
REAL DY
INTEGER N
!TIME STEP
REAL DT
!FLOW REYNOLDS NUMBER IN THE MODEL EQUATION
REAL ALPHA
!TOTAL SIMULATION TIME - LOOP NUMBER
INTEGER REP, I, J
!COEFFICIENTS IN LINEAR EQUATION MATRIX, SOURCE TERM K, DIAGONAL B, NON-DIAGONAL A
REAL S(1000), B, A
!INITIALIZATION OF DATA
DATA ALPHA/5000.0/
DATA N/100/
DATA REP/3000/
!CALCULATION OF GRID SPACING
DY=1.0/N
!CALCULATION OF TIME STEP DELTA T, CAN BE LARGER THAN THAT IN AN EXPLICIT METHOD
DT=0.5*RE*DY*DY
DT=ALPHA*DY*DY
!INITIAL CONDITIONS OF VELOCITY PROFILE
!BOTTOM AND INNER POINTS
DO I=1,N
V(I)=0.0
ENDDO
!POINT AT MOVING PLATE
V(N+1)=1.0
!BOUNDARY CONDITIONS AT LOWER AND UPPER POINTS ON PLATE
V(1)=0.0
V(N+1)=1.0
!CALCULATION OF DIAGONAL B AND NON-DIAGONAL A IN LINEAR EQUATION MATRIX
B=1.0+DT/DY/DY/ALPHA
A=-(DT)/2.0/DY/DY/ALPHA
!INITIAL COMPUTATION TIME
T=0.0
!ENTER MAIN LOOP TO MARCH IN TIME DIRECTION
DO I=1,REP
!SIMULATION TIME INCREASE BY DELTA T EACH STEP
T=T+DT
!USE IMPLICIT METHOD TO UPDATE GRID POINT VALUES FOR ALL INTERNAL GRIDS ONLY
!TWO BOUNDARY GRID POINTS VALUES ARE CONSTANT WITHIN THE WHOLE SIMULATION
!CALCULATION OF SOURCE TERM IN LINEAR EQUATION
DO J=2,N
S(J)=(1.0-DT/DY/DY/ALPHA)*V(J)+DT/2.0/DY/DY/ALPHA*V(J+1)+V(J-1)
ENDDO
!INCLUDE BOUNDARY CONDITIONS FOR TWO POINTS NEAR BOUDNARY
S(2)=S(2)-A*V(1)
S(N)=S(N)-A*V(N+1)
!USE SOURCE TERM K, DIAGONAL B, NON-DIAGONAL A, ORDER OF MATRIX N, TO SOLVE LINEAR EQUATION TO GET UPDATED VELOCITY
!CHECK ON INTERNET HOW TO SOLVE THIS BECUASE THIS COMPILER
!DOES NOT SOLVE IT, SOLVE LINEAR EQUATIONS BY A LINEAR SOLVER, FIND AND DOWNLOAD THE MATH LIBRARY FOR THIS COMPILER
CALL SR1(A,B,N,S,VNEW)
!REPLACE OLD VELOCITY VALUES WITH NEW VALUES.
!SINCE UNEW IS FROM UNEW(1), UNEW(2)......., UNEW(N-1), WE SHOULD RE-ARRANGE NUMBERS AS FOLLOWS
DO J=1,N-1
V(J+1)=VNEW(J)
ENDDO
!RETURN TO MAIN LOOP HERE
ENDDO
PRINT*,'HERE'
!OUTPUT VELOCITY PROFILES AT THE END OF COMPUTATION
!CREATE OUPUT FILE NAME
OPEN(15,FILE='PLEASEWORK')
!WRITE GRID POINTS AND VELOCITY VALUES
DO I=1,N+1
WRITE(15,10) V(I),(I-1)*DY
10 FORMAT(2F12.3)
ENDDO
CLOSE(15)
!DISPLAY INFORMATION ON SCREEN
!WRITE(*,*) 'THE OUTPUT VELOCITY IS AFTER', ITER, ' TIME STEPS'
!TERMINATION OF COMPUTER PROGRAM
STOP
END
!!!!!!!!
!!!!!!!!!!!!
!!!!!!!!!
SUBROUTINE SR1(A,B,N,S,VNEW)
REAL DIAGM(N), DIAGU(N), DIAGL(N)
REAL SS(N)
DO J=1,N-1
SS(J)=S(J+1)
ENDDO
DO I=1,N
DIAGM(i)=B
!Sets main diagonal as B for every value of i
IF (I==0) then
DIAGU(I)=A
DIAGL(I)=0
! No lower diagonal coefficient when i = 0
ELSE IF (I==N) THEN
DIAGU(I)=0
! No upper diagonal coefficient when i = Num
DIAGL(I)=A
ELSE
DIAGU(I)=A
! For all other points there is an upper diagonal coefficient
DIAGL(I)=A
! For all other points there is a lower diagonal coefficient
ENDIF
ENDDO
!CALL STANDARD FORTRAN MATH LIBRARY TO SOLVE LINEAR EQUATION AND GET SOLUTION VECTOR X(N-1)
CALL SR2 (DIAGL,DIAGM,DIAGU,SS,VNEW,N-2)
!RETURN TO MAIN PROGRAM AND X(N-1) IS FEEDED INTO UNEW(N-1)
RETURN
END SUBROUTINE
!!!!!!!!!!!!!!!
!!!!!!!!!!!
!!!!!!!!!!!
SUBROUTINE SR2 (A,B,C,D,Z,N)
!a - sub-diagonal (means it is the diagonal below the main diagonal)
!b - the main diagonal
!c - sup-diagonal (means it is the diagonal above the main diagonal)
!K - right part
!UNEW - the answer
!E - number of equations
INTEGER N
REAL A(N), B(N), C(N), D(N)
REAL CP(N), DP(N), Z(N)
REAL M
INTEGER I
DATA M/1/
!initialize c-prime and d-prime
CP(1) = C(1)/B(1)
DP(1) = D(1)/B(1)
!solve for vectors c-prime and d-prime
DO I=2,N
M=b(i)-CP(I-1)*(A(I))
CP(I)=C(I)/M
DP(I)=(D(I)-DP(I-1)*A(I))/M
ENDDO
!initialize UNEW
Z(N)=DP(N)
!solve for x from the vectors c-prime and d-prime
DO I=N-1, 1, -1
Z(I)=DP(I)-CP(I)*Z(I+1)
ENDDO
END SUBROUTINE

As george says in a comment, the problem is with the subroutine SR1. So that this isn't just a CW-stealing-a-comment answer I'll also expand a bit.
The way things are structured SR1 is a different scope from the main program. The IMPLICIT NONE in the main program doesn't apply to the subroutine, so A, B, N, S and VNEW are all implicitly typed. Apart from N,which is an integer, they are (scalar) reals.
The reference to S(J+1), as george says, means that S is not only a scalar real, but also a function. Remember that SR1 is a different scope and no information is passed from the caller to the callee about types, shapes, etc.. Further, that the dummy argument in SR1 called A happens to be same name as the actual argument in the call doesn't mean that the callee "knows" things. Your call to SR2 with the VNEW is also a problem for the same reason.
The question is tagged as "fortran77" so there isn't too much you can do to ensure there is a lot of checking going on, but there may well be compiler options and as you can use IMPLICIT NONE (not Fortran 77) that would detect your problems.
But, the question is also tagged "fortran" and "fortran95" so I'll point out that there are far better ways to detect the issues, using more modern features. Look at interfaces, modules and internal procedures.

Related

Foucault Pendulum simulation

Program Foucault
IMPLICIT NONE
REAL,DIMENSION(:),ALLOCATABLE :: t, x,y
REAL,PARAMETER :: pi=3.14159265358979323846, g=9.81
REAL :: L, vitessea, lat, h, omega, beta
INTEGER :: i , zeta
zeta=1000
Allocate(x(zeta),y(zeta),t(zeta))
L=67.
lat=49/180*pi
omega=sqrt(g/L)
h=0.01
Do i= 1,zeta
IF(i==1 .OR. i==2) THEN
t(1)=0.0
t(2)=0.0
x(1)=0.1
x(2)=1
y(1)=0.0
y(2)=0.0
ELSE
t(i+1)=real(i)*h
x(i+1)=(-omega**2*x(i)+2.0*((y(i)-y(i-1))/h)*latang(lat))*h**2+2.0*x(i)-x(i-1)
y(i+1)=(-omega**2*y(i)-2.0*((x(i)-x(i-1))/h)*latang(lat))*h**2+2.0*y(i)-y(i-1)
END IF
WRITE(40,*) t(i), x(i)
WRITE(60,*) t(i), y(i)
WRITE(50,*) x(i), y(i)
END DO
Contains
REAL Function latang(alpha)
REAL, INTENT(IN) :: alpha
REAL :: sol
latang=2*pi*sin(alpha)/86400
END FUNCTION
End Program Foucault
I'm trying to code the original Foucault Pendulum in Paris. My code seems to be working but so far, I could only get the below right graphic, "the flower" evolution. Therefore, I changed my parameters constantly to get the left graphic but I couldn't.
I took parameters of Foucault Pendulum installed in Paris with L=67, angular velocity of earth =2*pi/86400 and latitude of 49/180*pi.
My initial conditions are as written in the code. I tried a way range of parameters varying all of my initial conditions, my latitude and angular velocity but i couldn't get the left desired results.
I used Foucault differential equations as below : i coded them with Finite difference method (more simple than Runge-Kutta) by replacing the 2nd order derivation by its central finite difference. And the first order one by it's backward finite difference. By then, i build my loop by isolating x(i+1) and y(i+1) in both equations.
My code is very sensitive to parameters such as h (=derivation step), earth angular velocity and latitude (which is normal). I tried to change a way big range of parameters from a big h step to a small one, to a minimal and high latitude, initial conditions...etc but i couldn't ever get the left graphic which i rather need.
What could be made to get the left one ?
I was able to get the two charts, by speeding up the earth's rotation 120× fold, and allowing the simulation to run for 32 swings of the pendulum. Also, I noticed that Euler integration added energy to the system making for bad results, so I reverted to a standard RK4 implementation.
and here is the code I used to solve this ODE:
program FoucaultOde
implicit none
integer, parameter :: sp = kind(1.0), dp = kind(1d0)
! Constants
real, parameter :: g=9.80665, pi =3.1415926536
! Variables
real, allocatable :: y(:,:), yp(:), k0(:),k1(:),k2(:),k3(:)
real :: lat, omega, h, L, earth, period
real :: t0,x0,y0,vx0,vy0
integer :: i, zeta, f1, swings
! Code starts here
swings = 32
zeta = 400*swings
L = 67
lat = 49*pi/180
period = 24*60*60 ! period = 86400
earth = (2*pi*sin(lat)/period)*120 !120 multiplier for roation
omega = sqrt(g/L)
allocate(y(5,zeta))
allocate(yp(5), k0(5),k1(5),k2(5),k3(5))
! make pendulum complete 'swings' cycles in 'zeta' steps
h = swings*2*pi/(omega*zeta)
t0 = 0
x0 = 0.5 ! Initial displacement
y0 = 0
vx0 = 0
vy0 = 0
! Initial conditions in the state vector Y
Y(:,1) = [t0,x0,y0,vx0,vy0]
do i=2, zeta
! Euler method (single step)
! Yp = ode(Y(:,i-1))
! Runge-Kutta method (four steps)
k0 = ode(Y(:,i-1))
k1 = ode(Y(:,i-1) + h/2*k0)
k2 = ode(Y(:,i-1) + h/2*k1)
k3 = ode(Y(:,i-1) + h*k2)
Yp = (k0+2*k1+2*k2+k3)/6
! Take a step
Y(:,i) = Y(:,i-1) + h*Yp
end do
open( newunit=f1, file='results.csv', status = 'replace', pad='no')
! write header
write (f1, '(a15,a,a15,a,a15,a,a15,a,a15)') 't',',', 'x',',','y',',', 'vx',',','vy'
! write rows of data, comma-separated
do i=1, zeta
write (f1, '(g,a,g,a,g,a,g,a,g)') y(1,i),',',y(2,i),',',y(3,i),',',y(4,i),',',y(5,i)
end do
close(f1)
contains
function ode(Y) result(Yp)
real, intent(in) :: Y(5)
real :: Yp(5), t,px,py,vx,vy,ax,ay
! Read state vector Y to component values
t = Y(1)
px = Y(2)
py = Y(3)
vx = Y(4)
vy = Y(5)
! Reference paper:
! http://www.legi.grenoble-inp.fr/people/Achim.Wirth/final_version.pdf
ax = -(omega**2)*px + 2*vy*earth ! (equation 53)
ay = -(omega**2)*py - 2*vx*earth ! (equation 54)
! State vector rate. Note, rate of time is aways 1.0
Yp = [1.0, vx, vy, ax, ay]
end function
end program FoucaultOde
The resulting file results.csv looks like this for me (for checking)
t, x, y, vx, vy
.000000 , 5.000000 , .000000 , .000000 , .000000
.4105792E-01, 4.999383 , .1112020E-06, -.3004657E-01, .8124921E-05
.8211584E-01, 4.997533 , .8895339E-06, -.6008571E-01, .3249567E-04
.1231738 , 4.994450 , .3001796E-05, -.9011002E-01, .7310022E-04
.1642317 , 4.990134 , .7114130E-05, -.1201121 , .1299185E-03
.2052896 , 4.984587 , .1389169E-04, -.1500844 , .2029225E-03
.2463475 , 4.977810 , .2399832E-04, -.1800197 , .2920761E-03
.2874054 , 4.969805 , .3809619E-04, -.2099106 , .3973353E-03
...
from which I plotted the 2nd and 3rd columns in one chart, and the 4th and 5th for the second chart.
There is one thing that may be wrong depending on how you manage different step sizes, and an observation on the physics of the real-world example. With the initialization of the arrays, you imply an initial velocity of about 0.9/0.01=90 [m/s] in x direction away from the center. To get compatible results for different step sizes, you would need to adapt the calculation of x(2). However, in the graphs the plot starts from a point with zero velocity. This you can implement to first order by setting x(2)=x(1)=1. As the used integration method is also first order, this is sufficient.
For the second point, note that one can write the system using complex coordinates z=x+iy as
z'' = -w^2*z - 2*i*E*z', E = Omega*sin(theta)
This is a linear ODE with constant coefficients, the solution of it is
z(t) = exp(-i*E*t) * (A*cos(w1*t)+B*sin(w1*t)), w1 = sqrt(w^2+E^2)
This describes a pendulum motion of frequency w1 whose plane rotates with frequency E clockwise. The grand rotation has period T=2*pi/E, during which w1*T/(2*pi)=w1/E pendulum swings occur.
Now insert your numbers, w=sqrt(g/L)=0.383 and E=2*pi*sin(49°)/86400=5.49e-05, so that essentially w1=w. The number of pendulum cycles per full rotation is w/E=6972, so that you can expect a densely filled circle in the plot. Or a very narrow double wedge if only a few cycles are plotted. As each cycle takes 2*pi/w=16.4 [s], and the integration goes 1000 steps of step size 0.01, in the plot as it is you can expect a swing forth and part of the swing back.
To be more realistic, set the initial velocity to zero, that is, the pendulum is taken to its start position and then let go. Also increase the time to 30 [s] to have more than one pendulum cycle in the plot.
It from this we can see that the solutions converge, and with some imagination, that they converge linearly.
To get a plot like in the cited images, one needs a much smaller fraction of w/E, counting the swings, it has to be around 15. Note that you can not get this ratio anywhere on earth with a realistically scaled pendulum. So set w=pi, E=pi/16 and integrate over 15 time units using the first order method.
This detoriorates really fast, even for the smallest step size with 40 points in a pendulum cycle.
For a better result, increase the local truncation order to the next higher by using the central difference in the first derivative approximation.
z(i+1) - 2*z(i) + z(i-1) = -w^2*z(i)*dt^2 - i*E*(z(i+1)-z(i-1))*dt
z(i+1) = ( 2*z(i) - z(i-1) - w^2*z(i)*dt^2 + i*E*z(i-1)*dt ) / (1+i*E*dt)
The division by the complex number can also be easily carried out in the real components of the trajectory,
! x(i+1)-2*x(i)+x(i-1) = h^2*(-omega**2*x(i)) + h*earth*(y(i+1)-y(i-1))
! y(i+1)-2*y(i)+y(i-1) = h^2*(-omega**2*y(i)) - h*earth*(x(i+1)-x(i-1))
t(i) = t(i-1) + h
cx = (2-(h*omega)**2)*x(i) - x(i-1) - h*earth*y(i-1)
cy = (2-(h*omega)**2)*y(i) - y(i-1) + h*earth*x(i-1)
den = 1+(h*earth)**2
x(i+1) = (cx + h*earth*cy)/den
y(i+1) = (cy - h*earth*cx)/den
Now to respect the increased order, also the initial points need to have an order of accuracy more, using again zero initial speed, this gives in the second order Taylor expansion
z(2) = z(1) - 0.5*w^2*z(1)*dt^2
All the step sizes that gave deviating and structurally deteriorating results in the first order method now give a visually identical, structurally stable results in this second order method.

Efficient way to calculate distance function

I have a 3D matrix (dimension nx,nz,ny) which corresponds to a physical domain. This matrix contains a continuous field from -1 (phase 1) to +1 (phase 2); the interface between the two phases is the level 0 of this field.
Now, I want to calculate efficiently the signed distance function from the interface for every point in the domain.
I tried two possibilities (sgn is the sign of my field, with values +1,0,-1, xyz contains the grid as triplets of x,y,z at each point and dist is the signed distance function I want to calculate).
double precision, dimension(nx,nz,ny) :: dist,sgn,eudist
integer :: i,j,k
double precision :: seed,posit,tmp(nx)
do j=1,ny
do k=1,nz
do i=1,nx
seed=sgn(i,k,j)
! look for interface
eudist=(xyz(:,:,:,1)-x(i))**2+(xyz(:,:,:,2)-z(k))**2+(xyz(:,:,:,3)-y(j))**2
! find min within mask
posit=minval(eudist,seed*sgn.le.0)
! tmp fits in cache, small speed-up
tmp(i)=-seed*dsqrt(posit)
enddo
dist(:,k,j)=tmp
enddo
enddo
I also tried a second version, which is quite similar to the above one but it calculates the Euclidean distance only in a subset of the whole matrix. With this second version there is some speed up, but it is still too slow. I would like to know whether there is a more efficient way to calculate the distance function.
Second version:
double precision, dimension(nx,nz,ny) :: dist,sgn
double precision, allocatable, dimension(:,:,:) :: eudist
integer :: i,j,k , ii,jj,kk
integer :: il,iu,jl,ju,kl,ku
double precision :: seed, deltax,deltay,deltaz,tmp(nx)
deltax=max(int(nx/4),1)
deltay=max(int(ny/4),1)
deltaz=max(int(nz/2),1)
allocate(eudist(2*deltax+1,2*deltaz+1,2*deltay+1))
do j=1,ny
do k=1,nz
do i=1,nx
! look for closest point in box 2*deltax+1,2*deltaz+1,2*deltay+1
il=max(1,i-deltax)
iu=min(nx,i+deltax)
jl=max(1,j-deltay)
ju=min(ny,j+deltay)
kl=max(1,k-deltaz)
ku=min(nz,k+deltaz)
eudist(:,1:ku-kl+1,:)=(xyz(il:iu,kl:ku,jl:ju,1)-x(i))**2 &
& +(xyz(il:iu,kl:ku,jl:ju,2)-z(k))**2 &
& +(xyz(il:iu,kl:ku,jl:ju,3)-y(j))**2
seed=sgn(i,k,j)
tmp(i)=minval(eudist(:,1:ku-kl+1,:),seed*sgn(il:iu,kl:ku,jl:ju).le.0)
tmp(i)=-seed*dsqrt(tmp(i))
enddo
dist(:,k,j)=tmp
enddo
enddo
eudist: Euclidean distance between the point i,k,j and any other point in a box 2*deltax+1,2*deltaz+1,2*deltay+1 centered in i,k,j. This reduces computational cost, as the distance is calculated only in a subset of the whole grid (here I am assuming that the subset is large enough to contain an interfacial point).
After Vladimir suggestion (x,y,z are the axes determining grid position, xyz(i,k,j)=(x(i),z(k),y(j)) ):
double precision, dimension(nx,nz,ny) :: dist,sgn
double precision :: x(nx), y(ny), z(nz)
double precision, allocatable, dimension(:,:,:) :: eudist
double precision, allocatable, dimension(:) :: xd,yd,zd
integer :: i,j,k , ii,jj,kk
integer :: il,iu,jl,ju,kl,ku
double precision :: seed, deltax,deltay,deltaz,tmp(nx)
deltax=max(int(nx/4),1)
deltay=max(int(ny/4),1)
deltaz=max(int(nz/2),1)
allocate(eudist(2*deltax+1,2*deltaz+1,2*deltay+1))
allocate(xd(2*deltax+1))
allocate(yd(2*deltay+1))
allocate(zd(2*deltaz+1))
do j=1,ny
do k=1,nz
do i=1,nx
! look for closest point in box 2*deltax+1,2*deltaz+1,2*deltay+1
il=max(1,i-deltax)
iu=min(nx,i+deltax)
jl=max(1,j-deltay)
ju=min(ny,j+deltay)
kl=max(1,k-deltaz)
ku=min(nz,k+deltaz)
do ii=1,iu-il+1
xd(ii)=(xyz(il+ii-1)-x(i))**2
end do
do jj=1,ju-jl+1
yd(jj)=(y(jj+jl-1)-y(j))**2
end do
do kk=1,ku-kl+1
zd(kk)=(z(kk+kl-1)-z(k))**2
end do
do jj=1,ju-jl+1
do kk=1,ku-kl+1
do ii=1,iu-il+1
eudist(ii,kk,jj)=xd(ii)+yd(jj)+zd(kk)
enddo
enddo
enddo
seed=sgn(i,k,j)
tmp(i)=minval(eudist(:,1:ku-kl+1,:),seed*sgn(il:iu,kl:ku,jl:ju).le.0)
tmp(i)=-seed*dsqrt(tmp(i))
enddo
dist(:,k,j)=tmp
enddo
enddo
EDIT: more information on the problem at hand.
The grid is an orthogonal grid mapped to a matrix. The number of points of this grid is of the order of 1000 in each direction (in total about 1 billion points).
My goal is switching from a sign function (+1,0,-1) to a signed distance function in the entire grid in an efficient way.
I would still do what I suggested, no matter if you do that on a subset or across the whole plane. Take advantage of the orthogonal grid, it is a great thing to have
do j=1,ny
do k=1,nz
do i=1,nx
! look for closest point in box 2*deltax+1,2*deltaz+1,2*deltay+1
il=max(1,i-deltax)
iu=min(nx,i+deltax)
jl=max(1,j-deltay)
ju=min(ny,j+deltay)
kl=max(1,k-deltaz)
ku=min(nz,k+deltaz)
do ii = il,iu
xd(i) = (xyz(ii,kl:ku,jl:ju,1)-x(i))**2
end do
do jj = jl,ju
yd(i) = (xyz(il:iu,kl:ku,jj,2)-y(j))**2
end do
do kk = kl,ku
zd(k) = (xyz(il:iu,kk,jl:ju,3)-z(k))**2
end do
do jj = jl,ju
do kk = kl,ku
do ii = il,iu
eudist(il:iu,kl:ku,jl:ju) = xd(ii) + yd(jj) + zd(kk)
end do
end do
end do
....
enddo
dist(:,k,j)=tmp
enddo
enddo
Consider separating the whole thing that is inside the outer triple loop into a subroutine or a function. It would not be faster, but it would be much more readable. Especially for us here, It would be enough for us here to only deal with that function, the outer loop is just a confusing extra layer.

Fortan code for Monte Carlo Integration within boundary point a and b

I understand Monte carlo simulation is for estimating area by plotting random points and calculating the ration between the points outside the curve and inside the curve.
I have well calculated the value of pi assuming radius of curve to be unity.
Here is the code
program pi
implicit none
integer :: count, n, i
real :: r, x, y
count = 0
n=500
CALL RANDOM_SEED
DO i = 1, n
CALL RANDOM_NUMBER(x)
CALL RANDOM_NUMBER(y)
IF (x*x + y*Y <1.0) count = count + 1
END DO
r = 4 * REAL(count)/n
print *, r
end program pi
But to find integration , Textbook says to apply same idea. But I'm lost on How to write a code if I want to find the integration of
f(x)=sqrt(1+x**2) over a = 1 and b = 5
Before when radius was one, I did assume point falling inside by condition x*2+y**2 but How can I solve above one?
Any help is extremely helpful
I will write the code first and then explain:
Program integral
implicit none
real f
integer, parameter:: a=1, b=5, Nmc=10000000 !a the lower bound, b the upper bound, Nmc the size of the sampling (the higher, the more accurate the result)
real:: x, SUM=0
do i=1,Nmc !Starting MC sampling
call RANDOM_NUMBER(x) !generating random number x in range [0,1]
x=a+x*(b-a) !converting x to be in range [a,b]
SUM=SUM+f(x) !summing all values of f(x). EDIT: SUM is also an instrinsic function in Fortran so don't call your variable this, I named it so, to illustrate its purpose
enddo
print*, (b-a)*(SUM/Nmc) !final result of your integral
end program integral
function f(x) !defining your function
implicit none
real, intent(in):: x
real:: f
f=sqrt(1+x**2)
end function f
So what's happening:
The integral can be written as
. where:
(this g(x) is a uniform probability distribution of the variable x in [a,b]). And we can write the integral as:
where .
So, finally, we get that the integral should be:
So, all you have to do is generate a random number in the range [a,b] and then calcualte the value of your function for this x. Then do this lots of times (Nmc times), and calculate the sum. Then just divide with Nmc, to find the average and then multiply with (b-a). And this is what the code does.
There's lots of stuff on the internet for this. here's one example that visualizes it pretty nice
EDIT: Second way, that is the same as the Pi method:
Nin=0 !Number of points inside the function (under the curve)
do i=1,Nmc
call random_number(x)
call random_number(y)
x=a+x*(b-a)
y=f_min+y(f_max-f_min)
if (f(x)<y) Nin=Nin+1
enddo
print*, (f_max-f_min)*(b-a)*(real(Nin)/Nmc)
All of this, you could then enclose it in an outer do loop summing the (f_max-f_min)(b-a)(real(Nin)/Nmc) and in the end printing its average.
For this example, what you do is essentially creating an enclosing box from a to b (x dimension) and from f_min to f_max (y dimension) and then doing a sampling of points inside this area and counting the points that are in the function (Nin).Obviously you will have to know the minimum (f_min) and maximum (f_max) value of your function in the range [a,b]. Alternatively you could use arbitrarily low/high values for your f_min f_max but then you will be wasting a lot of points and your error will be bigger.

Discrete Fourier Transform seems to be printing incorrect answers?

I am attempting to write a program that calculates the discrete fourier transform of a set of given data. I've sampled a sine wave, so my set is (pi/2,2*pi,3*pi/2,2*pi). Here is my program:
program DFT
implicit none
integer :: k, N, x, y, j, r, l
integer, parameter :: dp = selected_real_kind(15,300)
real, allocatable,dimension(:) :: h, rst
integer, dimension(:,:), allocatable :: W
real(kind=dp) :: pi
open(unit=100, file="dft.dat",status='replace')
N = 4
allocate(h(N))
allocate(rst(N))
allocate(W(-N/2:N/2,1:N))
pi = 3.14159265359
do k=1,N
h(k) = k*(pi*0.5)
end do
do j = -N/2,N/2
do k = 1, N
W(j,k) = EXP((2.0_dp*pi*cmplx(0.0_dp,1.0_dp)*j*k)/N)
end do
end do
rst = matmul(W,h)
!print *, h, w
write(100,*) rst
end program
And this prints out the array rst as:
0.00000000 0.00000000 15.7079639 0.00000000 0.00000000
Using an online calculator, the results should be:
15.7+0j -3.14+3.14j -3.14+0j -3.14-3.14j
I'm not sure why rst is 1 entry too long either.
Can anyone spot why it's printing out 0 for 3/4 of the results? I notice that 15.7 appears in both the actual answers and my result.
Thank you
Even though the question has been answered and accepted, the program given has so many problems that I had to say...
The input given is not a sine wave, it's a linear function of time. Kind of like a 1-based ramp input.
For DFTs the indices normally are considered to go from 0:N-1, not 1:N.
For W the Nyquist frequency is represented twice, as -N/2 and N/2. Again it would have been normal to number the rows 0:N-1, BTW, this is why you have an extra output in your rst vector.
pi is double precision but only initialized to 12 significant figures. It's hard to tell if there's a typo in your value of pi which is why many would use 4*atan(1.0_dp) or acos(-1.0_dp).
Notice that h(N) is actually going to end up as the zero time input, which is one reason the whole world indices DFT vectors from zero.
The expression cmplx(0.0_dp,1.0_dp) is sort of futile because the CMPLX intrinsic always returns a single precision result if the third optional KIND= argument is not present. As a complex literal, (0.0_dp,1.0_dp) would be double precision. However, you could as well use (0,1) because it's exactly representable in single precision and would be converted to double precision when it gets multiplied by the growing product on its left. Also 2.0_dp could have been represented successfully as 2 with less clutter.
The expression EXP((2.0_dp*pi*cmplx(0.0_dp,1.0_dp)*j*k)/N) is appropriate for inverse DFT, disregarding normalization. Thus I would have written the whole thing more cleanly and correctly as EXP(-2*pi*(0,1)*j*k/N). Then the output should have been directly comparable to what the online calculator printed out.
Fortran does complex numbers for you but you must declare the appropriate variables as complex. Try
complex, allocatable,dimension(:) :: rst
complex, dimension(:,:), allocatable :: W

What's wrong with this Fortran 90-95 code for simulating water flow through non-saturated soil? [closed]

Closed. This question needs debugging details. It is not currently accepting answers.
Edit the question to include desired behavior, a specific problem or error, and the shortest code necessary to reproduce the problem. This will help others answer the question.
Closed 8 years ago.
Improve this question
I've been working for many days trying to find out what's wrong with this code. It's used for modelling water flow through non saturated soil. The equations system is in the form of a tridiagonal matrix, which is solved with the Thomas Algorithm. I have the solution, and the code is not representing it. For example, node A should be a curve that goes from the initial condition of aprox -100 cm to aprox -20 cm. It's a long code, but I'd be tremendously thankful if someone helped me in this one.
program EcuacionRichards
implicit none
!Declaring variables
integer, parameter :: nodos = 100
integer :: i, it, max_it, nodo_a, nodo_b, nodo_c, nodo_d, it_bajo, it_alto
double precision, dimension(1:nodos) :: H, H_ant, C, K, theta, theta_ant, aa, bb, cc, dd, rr, th_ant
double precision :: dz, zbot, tfin, dt, rz, Ksup, Kinf, t, th_lisimetro, h_lisimetro
double precision :: q_ent, tol_h, tol_th, cambio_h, cambio_th
double precision :: mult_alto, mult_bajo, maxdt, mindt, qlibre
logical lisimetro
!Hydraulic Parameters
double precision :: theta_sat=0.43 !cm/cm
double precision :: theta_res=0.078 !cm/cm
double precision :: alpha=0.0325 !1/cm
double precision :: n=1.346
double precision :: m
double precision :: K_sat=86.4 !cm/d
!Grid and iteration parameters
lisimetro=.true.
dt=0.01 !days
zbot=160 !depth of the column in cm
dz=zbot/nodos !cm
tfin=30 !days
max_it=500 !max number of Picard iterations
tol_h=0.1 !tolerance for H iteration, cm
tol_th=0.001 !tolerance for theta iteration, 1/1
it_bajo=3 !minimum recommended number of iterations
it_alto=7 !maximum recommended number of iterations
mult_bajo=1.3 !time multiplicator for low iterations
mult_alto=0.7 !time multiplicator for low iterations
maxdt=0.5 !max value for dt
mindt=0.001 !min value for dt
m=1-1/n
!Initializing other variables
th_lisimetro=0.32
h_lisimetro=HfTH(th_lisimetro)
nodo_a=nodos
nodo_b=2*nodos/3
nodo_c=nodos/3
nodo_d=1
!*********Initial Conditions************************************************************
call theta_ini(theta,nodos) !Fill array with initial moisture values
do i=1,nodos
H(i)=HfTH(theta(i))
call actualiza(H(i), theta(i), C(i), K(i))
end do
!************* OPEN WRITING FILES ************************************************
open(unit=1,file='succion2.txt')
open(unit=2,file='humedad2.txt')
open(unit=3,file='conducti2.txt')
open(unit=4,file='parametr2.txt')
write(4,'("dt(días) =",f7.4)') dt
write(4,'("dz(cm) =",f7.4)') dz
write(4,'("nodos =",i5)') nodos
write(4,'("altura(cm) =",f8.3)') zbot
write(4,'("tfin(días) =",f7.2)') tfin
write(4,'("theta_sat =",f7.4)') theta_sat
write(4,'("theta_res =",f7.4)') theta_res
write(4,'("K_saturada =",g11.3)') K_sat
write(4,'("n =",f7.4)') n
write(4,'("m =",f7.5)') m
write(4,'("alpha =",f7.5)') alpha
write(4,'("max_it =",i4)') max_it
close(4)
write(1,*) "T(días) H_a(cm) H_b(cm) H_c(cm) H_d(cm)"
write(2,*) "T(días) th_a(cm) th_b(cm) th_c(cm) th_d(cm)"
write(3,*) "T(días) K_a(cm/d) K_b(cm/d) K_c(cm/d) K_d(cm/d)"
!*************TIME LOOP**********************************************************************************************
t=0.d0
do while ((t.le.tfin).and.(dt.gt.0))
rz=dz/dt
t=t+dt
theta_ant=theta !Previous time
!Water flow that enters at the top (constant)
q_ent=0.1 !cm/dia
!************* PICARD LOOP ******************************************
Picard:do it=1,max_it
if(it.eq.max_it) pause "MAXIMUM ITERATIONS REACHED"
!Interior Nodes
do i=2, nodos-1
Ksup=2*(K(i+1)*K(i))/(K(i+1)+K(i))
Kinf=2*(K(i-1)*K(i))/(K(i-1)+K(i))
aa(i)=-Kinf/dz !K(i-1/2)
cc(i)=-Ksup/dz !K(i+1/2)
bb(i)=rz*C(i)-aa(i)-cc(i)
rr(i)=rz*C(i)*h(i)-rz*(theta(i)-theta_ant(i))+Ksup-Kinf
end do
!Inferior Node
if (lisimetro) then
!Changing inferior node
if (theta(1).lt.th_lisimetro) then
!Water flow 0, Neumann
Ksup=2*(K(1)*K(2))/(K(1)+K(2))
aa(1)=0
cc(1)=-Ksup/dz
bb(1)=-cc(1)
rr(1)=Ksup
else
!H(1)=0 condition, Dirichlet
Ksup=2*(K(1)*K(2))/(K(1)+K(2))
aa(1)=0
bb(1)=1
cc(1)=0
rr(1)=h_lisimetro
aa(2)=0
rr(2)=rr(2)+Ksup/dz*(h_lisimetro)
end if
else
!Inferior node, free drainage, Neumann
Ksup=2*(K(1)*K(2))/(K(1)+K(2))
qlibre=-K(1)
aa(1)=0
cc(1)=-Ksup/dz
bb(1)=-cc(1)
rr(1)=Ksup+qlibre
end if
!Superior node, known water flow
Kinf=2*(K(nodos)*K(nodos-1))/(K(nodos)+K(nodos-1))
aa(nodos)=-Kinf/dz
cc(nodos)=0
bb(nodos)=0.5*rz*C(nodos)-aa(nodos)
rr(nodos)=0.5*rz*C(nodos)*h(nodos)-0.5*rz*(theta(nodos)-theta_ant(nodos))-Kinf-q_ent
call tridiag(aa,bb,cc,rr,dd,nodos)
!Suction modification and H functions actualization
h_ant=h
th_ant=theta !Save iteration
h=dd !Advance to next iteration
do i=1,nodos
call actualiza(H(i),theta(i), C(i), K(i))
end do
!End of iterations condition
cambio_h=maxval(dabs(h-h_ant))
cambio_th=maxval(dabs(theta-th_ant))
if((cambio_h.lt.tol_h).and.(cambio_th.lt.tol_th)) then
if(.true.) then !(t.eq.tprint)
write (1,'(f8.3,f9.3,f9.3,f9.3,f9.3)') t,H(nodo_a),H(nodo_b),H(nodo_c),H(nodo_d)
write (2,'(f8.3,f7.4,f7.4,f7.4,f7.4)') t,theta(nodo_a),theta(nodo_b),theta(nodo_c),theta(nodo_d)
write (3,'(f8.3,g11.4,g11.4,g11.4,g11.4)') t,k(nodo_a),k(nodo_b),k(nodo_c),k(nodo_d)
end if
if (it.lt.it_bajo) dt=min(dt*mult_bajo,maxdt)
if (it.gt.it_alto) dt=max(dt*mult_alto,mindt)
exit Picard
else
cycle Picard
end if
end do Picard !Picard loop end
if ((tfin-t).le.1E-4) t=huge(1.d0)
end do
!Time Loop End***************************************************************
!******** Close files
close(1)
close(2)
close(3)
!********END OF PROGRAM**********************************************************
!******************************************************************************
!Subroutines and functions
contains
!Initial moistures assignment
subroutine theta_ini(theta,nodos)
integer :: nodos
double precision, dimension(1:nodos) :: theta
integer i
do i=1, nodos
theta(i)=0.30
end do
end subroutine theta_ini
!Subroutine that actualizes salues according to pressure
subroutine actualiza(p,theta,c,k)
double precision p, theta, c, k
double precision se, te
if(p.lt.0) then
te=1+(-alpha*p)**n
se=te**(-m)
theta=theta_res+(theta_sat-theta_res)*se
K=K_sat*se**(0.5)*(1-(1-se**(1/m))**m)**2
c=((alpha**n)*(theta_sat-theta_res)*n*m*(-p)**(n-1))/(te**(m+1)) !d(theta)/dh
else
theta=theta_sat
K=K_sat
c=0
end if
return
end subroutine actualiza
!Tridiag(alpha,beta, gamma, Resto, delta, nodos)
subroutine tridiag(a,b,c,d,x,n)
implicit none
! a - sub-diagonal (means it is the diagonal below the main diagonal)
! b - the main diagonal
! c - sup-diagonal (means it is the diagonal above the main diagonal)
! d - right part
! x - the answer
! n - number of equations
integer,intent(in) :: n
double precision,dimension(n),intent(in) :: a,b,c,d
double precision,dimension(n),intent(out) :: x
double precision,dimension(n) :: cp,dp
double precision :: m
integer i
! initialize c-prime and d-prime
cp(1) = c(1)/b(1)
dp(1) = d(1)/b(1)
! solve for vectors c-prime and d-prime
do i = 2,n
m = b(i)-cp(i-1)*a(i)
cp(i) = c(i)/m
dp(i) = (d(i)-dp(i-1)*a(i))/m
enddo
! initialize x
x(n) = dp(n)
! solve for x from the vectors c-prime and d-prime
do i = n-1, 1, -1
x(i) = dp(i)-cp(i)*x(i+1)
end do
end subroutine tridiag
!Head in terms of moisture
Function HfTH(humedad)
double precision HfTH
double precision humedad
if (humedad.lt.theta_sat) then
HfTH=-1/alpha*(((humedad-theta_res)/(theta_sat-theta_res))**(-1/m)-1)**(1/n) !cm
else
HfTH=0
end if
Return
end function HfTH
end program EcuacionRichards
I can see any number of problems with your code but my attention span is limited so here is just the most egregious
You declare a bunch of variables to be double precision, for example, theta_sat, yet you initialise them with literals of default kind. The statement
double precision :: theta_sat=0.43 !cm/cm
does not make 0.43 a double precision real. Well, to be accurate, it might but on most compilers, and whenever the compilation does not set default real variables to kind double precision, it doesn't. It is almost certain that 0.43 is a 4-byte real while theta_sat is an 8-byte real and you cannot rely on the compiler to set theta_sat to be the 8-byte value closest to 0.43.
In modern Fortran double precision is still available for backward compatibility, but deprecated in favour of specifying the kind of a variable with a kind type. SO is replete with suggestions of how to do this. My favourite is to use the constants defined in the intrinsic module iso_fortran_env, like this:
use, intrinsic :: iso_fortran_env
then declare variables like this:
real(real64) :: theta_sat=0.43_real64 !cm/cm
note the appending of the kind specification _real64 to the value.
Whether your algorithm is sensitive enough that this mistake on your part materially affects the results I don't know.
Finally, you tell us that the program is not correct but you are silent on the way(s) in which it is not correct.