Function with more arguments and integration - function

I have I simple problem but I cannot find a solution anywhere.
I have to integrate a function (for example using a Simpson's rule subroutine) but I am obliged to pass to my function more than one argument: one is the variable that I want to integrate later and another one is just a value coming from a different calculation which I cannot perform inside the function.
The problem is that the Simpson subroutine only accept f(x) to perform the integral and not f(x,y).
After Vladimir suggestions I modified the code.
Below the example:
Program main2
!------------------------------------------------------------------
! Integration of a function using Simpson rule
! with doubling number of intervals
!------------------------------------------------------------------
! to compile:
! gfortran main2.f90 -o simp2
implicit none
double precision r, rb, rmin, rmax, rstep, integral, eps
double precision F_int
integer nint, i, rbins
double precision t
rbins = 4
rmin = 0.0
rmax = 4.0
rstep = (rmax-rmin)/rbins
rb = rmin
eps = 1.0e-8
func = 0.0
t=2.0
do i=1,rbins
call func(rb,t,res)
write(*,*)'r, f(rb) (in main) = ', rb, res
!test = F_int(rb)
!write(*,*)'test F_int (in loop) = ', test
call simpson2(F_int(rb),rmin,rb,eps,integral,nint)
write(*,*)'r, integral = ', rb, integral
rb = rb+rstep
end do
end program main2
subroutine func(x,y,res)
!----------------------------------------
! Real Function
!----------------------------------------
implicit none
double precision res
double precision, intent(in) :: x
double precision y
res = 2.0*x + y
write(*,*)'f(x,y) (in func) = ',res
return
end subroutine func
function F_int(x)
!Function to integrate
implicit none
double precision F_int, res
double precision, intent(in) :: x
double precision y
call func(x,y,res)
F_int = res
end function F_int
Subroutine simpson2(f,a,b,eps,integral,nint)
!==========================================================
! Integration of f(x) on [a,b]
! Method: Simpson rule with doubling number of intervals
! till error = coeff*|I_n - I_2n| < eps
! written by: Alex Godunov (October 2009)
!----------------------------------------------------------
! IN:
! f - Function to integrate (supplied by a user)
! a - Lower limit of integration
! b - Upper limit of integration
! eps - tolerance
! OUT:
! integral - Result of integration
! nint - number of intervals to achieve accuracy
!==========================================================
implicit none
double precision f, a, b, eps, integral
double precision sn, s2n, h, x
integer nint
double precision, parameter :: coeff = 1.0/15.0 ! error estimate coeff
integer, parameter :: nmax=1048576 ! max number of intervals
integer n, i
! evaluate integral for 2 intervals (three points)
h = (b-a)/2.0
sn = (1.0/3.0)*h*(f(a)+4.0*f(a+h)+f(b))
write(*,*)'a, b, h, sn (in simp) = ', a, b, h, sn
! loop over number of intervals (starting from 4 intervals)
n=4
do while (n <= nmax)
s2n = 0.0
h = (b-a)/dfloat(n)
do i=2, n-2, 2
x = a+dfloat(i)*h
s2n = s2n + 2.0*f(x) + 4.0*f(x+h)
end do
s2n = (s2n + f(a) + f(b) + 4.0*f(a+h))*h/3.0
if(coeff*abs(s2n-sn) <= eps) then
integral = s2n + coeff*(s2n-sn)
nint = n
exit
end if
sn = s2n
n = n*2
end do
return
end subroutine simpson2
I think I'm pretty close to the solution but I cannot figure it out...
If I call simpson2(F_int, ..) without putting the argument in F_int I receive this message:
call simpson2(F_int,rmin,rb,eps,integral,nint)
1
Warning: Expected a procedure for argument 'f' at (1)
Any help?
Thanks in advance!

Now you have a code we can work with, good job!
You need to tell the compiler, that F_int is a function. That can be done by
external F_int
but it is much better to learn Fortran 90 and use modules or at least interface blocks.
module my_functions
implicit none
contains
subroutine func(x,y,res)
!----------------------------------------
! Real Function
!----------------------------------------
implicit none
double precision res
double precision, intent(in) :: x
double precision y
res = 2.0*x + y
write(*,*)'f(x,y) (in func) = ',res
return
end subroutine func
function F_int(x)
!Function to integrate
implicit none
double precision F_int, res
double precision, intent(in) :: x
double precision y
call func(x,y,res)
F_int = res
end function F_int
end module
Now you can easily use the module and integrate the function
use my_functions
call simpson2(F_int,rmin,rb,eps,integral,nint)
But you will find that F_int still does not know what y is! It has it's own y with undefined value! You should put y into the module instead so that everyone can see it.
module my_functions
implicit none
double precision :: y
contains
Don't forget to remove all other declarations of y! Both in function F_int and in the main program. Probably it is also better to call it differently.
Don't forget to set the value of y somewhere inside your main loop!

Related

Reading function pointer from file in Fortran

I am trying to externally specify which function should be called. In the following code, getEnvelope is called with the chosen envelope gaussian. I would however want to read from a file which specific envelope is used rather than coding env => gaussian.
Is there a way to do this? Or is there another preferred way?
module laser
implicit none
abstract interface
double precision function envelope(t, tau) result(f)
double precision, intent(in) :: t, tau
end function envelope
end interface
contains
double precision function getEnvelope(env, t, tau) result(f)
procedure(envelope) :: env
double precision, intent(in) :: t, tau
f = env(t, tau)
end function getEnvelope
double precision function gaussian(t, tau) result(f)
double precision, intent(in) :: t, tau
f = exp(-2.d0*log(2.d0)*(t/tau)**2.d0)
end function gaussian
end module laser
program main
use laser
implicit none
procedure(envelope), pointer :: env
double precision :: f
double precision :: t, tau
env => gaussian
t = 1.d0
tau = 200.d0
f = getEnvelope(env, t, tau)
end program main

Using matrices as arguments in functions and as output in subroutines in Fortran

I was trying to create a program that requires me to use matrices as input for functions and subroutines and also requires me to take matrix as subroutine output in Fortran. But, I've encountered multiple errors while doing so. I am not able to understand the source of these errors and hence how to fix them.
I'm confident of the logic but I seem to be making errors in dealing with the matrices.
Program to solve system of linear equations(Gauss elimination with partial pivoting)
Code:
program solving_equations
implicit none
real, allocatable :: a(:,:),interchanged(:,:)
real, allocatable :: x(:)
real addition,multiplying_term,alpha,maximum
integer i,j,row,rth_ele,f_maxfinder,k,n,s,inte
read(*,*)n
allocate( a( n,(n+1) ) )
allocate( x(n) )
allocate( interchanged( n,(n+1) ) )
do i=1,n
read(*,*)( a(i,j),j=1,(n+1) )
end do
do rth_ele= 1,(n-1)
row=f_maxfinder( a , n , rth_ele )
if (row==rth_ele) then
continue
else
call interchanger(a,rth_ele,row,n,interchanged)
a = interchanged
end if
do i= (rth_ele+1) , n
! once i is fixed, multiplying term is fixed too
multiplying_term=( a(i,rth_ele)/a(rth_ele,rth_ele) )
do j=1,(n+1)
a(i,j)=a(i,j)-a(rth_ele,j)*multiplying_term
end do
end do
end do
x(n)=a(n,n+1)/a(n,n)
do i=(n-1),1,-1
addition=0.0
do s=n , (i+1) , -1
addition=addition+a(i,s)*x(s)
end do
x(i)= ( ( a(i,n+1)- addition )/a(i,i) )
end do
do i=1,n
print*,x(i)
end do
endprogram solving_equations
!=================
function f_maxfinder(a,n,rth_ele)
integer inte,f_maxfinder
real maximum
maximum=a(rth_ele,rth_ele)
do inte=n,nint(rth_ele+1),-1
if( a(inte,rth_ele) > maximum ) then
maximum = a(inte,rth_ele)
f_maxfinder=inte
else
continue
end if
end do
end
subroutine interchanger( a,rth_ele,row,n,interchanged )
integer i
real alpha
real, allocatable :: interchanged(:,:)
allocate( interchanged( n,(n+1) ) )
do i=1,n+1
alpha=a(row,i)
a(row,i)=a(rth_ele,i)
a(rth_ele,i)=alpha
end do
do i=1,n
do j=1,(n+1)
interchanged(i,j)=a(i,j)
end do
end do
end
Errors:
row=f_maxfinder( a , n , rth_ele )
1
Warning: Rank mismatch in argument 'a' at (1) (scalar and rank-2)
a(row,i)=a(rth_ele,i)
Error: The function result on the lhs of the assignment at (1) must have the pointer attribute.
a(rth_ele,i)=alpha
Error: The function result on the lhs of the assignment at (1) must have the pointer attribute.
call interchanger(a,rth_ele,row,n,interchanged)
1
Error: Explicit interface required for 'interchanger' at (1): allocatable argument
Thanks!
You're missing a declaration of a as an array in f_maxfinder. implicit none is your friend - be sure to use it all the time.
interchanger has a dummy argument interchanged that is an allocatable, assumed-shape array. This requires that an explicit interface to interchanger be visible in the caller. (See my post https://stevelionel.com/drfortran/2012/01/05/doctor-fortran-gets-explicit-again/ for more on this.
The interface issue could be solved by putting the subroutines in a module and adding a use of the module in the main program.
By the way, there's no need to make a allocatable in f_maxfinder, as you are not allocating or deallocating it. It is still an assumed-shape array so the explicit interface is still required.
Here is a working example taking into account #SteveLionel's advice and the following comments:
Always use implicit none, at least once in the main program and don't forget to pass the -warn flag to the compiler.
Either use a module for functions and subroutines, then add use <module> to the main program, or simply use contains and include them inside the main program as I did below.
The interchanged array is already alcated in the main program, you don't need to re-allocate it in the interchanger subroutine, just pass it as an assumed-shape array.
Remove unused variables; alpha, maximum, k, inte.
Define a in f_maxfinder function.
Function type is better written in front of the function name for readability; see your definition of f_maxfinder and don't declare the function again in main program, unless you're using an explicit interface.
The nint procedure accepts real input, you don't need it here.
Finally add any missing variable declarations in your function/subroutine.
program solving_equations
implicit none
real, allocatable :: a(:,:), interchanged(:,:), x(:)
real :: addition, multiplying_term
integer :: i, j, row, rth_ele, n, s
read (*,*) n
allocate ( a( n,(n+1) ) )
allocate ( x( n ) )
allocate ( interchanged( n,(n+1) ) )
do i = 1,n
do j = 1,(n+1)
read (*,*) a(i,j)
end do
end do
do rth_ele = 1,(n-1)
row = f_maxfinder( a , n , rth_ele )
if (row == rth_ele) then
continue
else
call interchanger(a, rth_ele, row, n, interchanged)
a = interchanged
end if
do i = (rth_ele+1) , n
! once i is fixed, multiplying term is fixed too
multiplying_term = a(i,rth_ele) / a(rth_ele,rth_ele)
do j = 1,(n+1)
a(i,j) = a(i,j) - a(rth_ele,j) * multiplying_term
end do
end do
end do
x(n) = a(n,n+1) / a(n,n)
do i = (n-1),1,-1
addition = 0.0
do s = n,(i+1),-1
addition = addition + a(i,s) * x(s)
end do
x(i)= (a(i,n+1) - addition) / a(i,i)
end do
do i = 1,n
print *, x(i)
end do
contains
integer function f_maxfinder(a, n, rth_ele)
integer :: n, rth_ele, inte
real :: maximum, a(:,:)
maximum = a(rth_ele,rth_ele)
do inte = n,rth_ele+1,-1
if (a(inte,rth_ele) > maximum) then
maximum = a(inte,rth_ele)
f_maxfinder = inte
else
continue
end if
end do
end
subroutine interchanger( a, rth_ele, row, n, interchanged )
integer :: i, rth_ele, row, n
real :: alpha, a(:,:), interchanged(:,:)
do i = 1,n+1
alpha = a(row,i)
a(row,i) = a(rth_ele,i)
a(rth_ele,i) = alpha
end do
do i = 1,n
do j = 1,(n+1)
interchanged(i,j) = a(i,j)
end do
end do
end
end program solving_equations
Entering a sample 3-by-4 array, you get the following output (check the results, you know your algorithm):
3
4
3
6
3
7
4
6
7
4
4
2
0
2.05263186
-2.15789509
0.210526198
Process returned 0 (0x0) execution time : 1.051 s
Press any key to continue.

Adding a print statement in a Fortran 90 function this do not work [duplicate]

I'm trying to learn Fortran (unfortunately a necessity for my research group) - one of the tasks I set myself was to package one of the necessary functions (Associated Legendre polynomials) from the Numerical Recipes book into a fortran 03 compliant module. The original program (f77) has some error handling in the form of the following:
if(m.lt.0.or.m.gt.1.or.abs(x).gt.1)pause 'bad arguments in plgndr'
Pause seems to have been deprecated since f77 as using this line gives me a compiling error, so I tried the following:
module sha_helper
implicit none
public :: plgndr, factorial!, ylm
contains
! numerical recipes Associated Legendre Polynomials rewritten for f03
function plgndr(l,m,x) result(res_plgndr)
integer, intent(in) :: l, m
real, intent(in) :: x
real :: res_plgndr, fact, pll, pmm, pmmp1, somx2
integer :: i,ll
if (m.lt.0.or.m.gt.l.or.abs(x).gt.1) then
write (*, *) "bad arguments to plgndr, aborting", m, x
res_plgndr=-10e6 !return a ridiculous value
else
pmm = 1.
if (m.gt.0) then
somx2 = sqrt((1.-x)*(1.+x))
fact = 1.
do i = 1, m
pmm = -pmm*fact*somx2
fact = fact+2
end do
end if
if (l.eq.m) then
res_plgndr = pmm
else
pmmp1 = x*(2*m+1)*pmm
if(l.eq.m+1) then
res_plgndr = pmmp1
else
do ll = m+2, l
pll = (x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m)
pmm = pmmp1
pmmp1 = pll
end do
res_plgndr = pll
end if
end if
end if
end function plgndr
recursive function factorial(n) result(factorial_result)
integer, intent(in) :: n
integer, parameter :: RegInt_K = selected_int_kind(20) !should be enough for the factorials I am using
integer (kind = RegInt_K) :: factorial_result
if (n <= 0) then
factorial_result = 1
else
factorial_result = n * factorial(n-1)
end if
end function factorial
! function ylm(l,m,theta,phi) result(res_ylm)
! integer, intent(in) :: l, m
! real, intent(in) :: theta, phi
! real :: res_ylm, front_block
! real, parameter :: pi = 3.1415926536
! front_block = sqrt((2*l+1)*factorial(l-abs(m))/(4*pi*))
! end function ylm
end module sha_helper
The main code after the else works, but if I execute my main program and call the function with bad values, the program freezes before executing the print statement. I know that the print statement is the problem, as commenting it out allows the function to execute normally, returning -10e6 as the value. Ideally, I would like the program to crash after giving a user readable error message, as giving bad values to the plgndr function is a fatal error for the program. The function plgndr is being used by the program sha_lmc. Currently all this does is read some arrays and then print a value of plgndr for testing (early days). The function ylm in the module sha_helper is also not finished, hence it is commented out. The code compiles using gfortran sha_helper.f03 sha_lmc.f03 -o sha_lmc, and
gfortran --version
GNU Fortran (GCC) 4.8.2
!Spherical Harmonic Bayesian Analysis testbed for Lagrangian Dynamical Monte Carlo
program sha_analysis
use sha_helper
implicit none
!Analysis Parameters
integer, parameter :: harm_order = 6
integer, parameter :: harm_array_length = (harm_order+1)**2
real, parameter :: coeff_lo = -0.1, coeff_hi = 0.1, data_err = 0.01 !for now, data_err fixed rather than heirarchical
!Monte Carlo Parameters
integer, parameter :: run = 100000, burn = 50000, thin = 100
real, parameter :: L = 1.0, e = 1.0
!Variables needed by the program
integer :: points, r, h, p, counter = 1
real, dimension(:), allocatable :: x, y, z
real, dimension(harm_array_length) :: l_index_list, m_index_list
real, dimension(:,:), allocatable :: g_matrix
!Open the file, allocate the x,y,z arrays and read the file
open(1, file = 'Average_H_M_C_PcP_boschi_1200.xyz', status = 'old')
read(1,*) points
allocate(x(points))
allocate(y(points))
allocate(z(points))
print *, "Number of Points: ", points
readloop: do r = 1, points
read(1,*) x(r), y(r), z(r)
end do readloop
!Set up the forwards model
allocate(g_matrix(harm_array_length,points))
!Generate the l and m values of spherical harmonics
hloop: do h = 0, harm_order
ploop: do p = -h,h
l_index_list(counter) = h
m_index_list(counter) = p
counter = counter + 1
end do ploop
end do hloop
print *, plgndr(1,2,0.1)
!print *, ylm(1,1,0.1,0.1)
end program sha_analysis
Your program does what is known as recursive IO - the initial call to plgndr is in the output item list of an IO statement (a print statement) [directing output to the console] - inside that function you then also attempt to execute another IO statement [that outputs to the console]. This is not permitted - see 9.11p2 and p3 of F2003 or 9.12p2 of F2008.
A solution is to separate the function invocation from the io statement in the main program, i.e.
REAL :: a_temporary
...
a_temporary = plgndr(1,2,0.1)
PRINT *, a_temporary
Other alternatives in F2008 (but not F2003 - hence the [ ] parts in the first paragraph) include directing the output from the function to a different logical unit (note that WRITE (*, ... and PRINT ... reference the same unit).
In F2008 you could also replace the WRITE statement with a STOP statement with a message (the message must be a constant - which wouldn't let you report the problematic values).
The potential for inadvertently invoking recursive IO is part of the reason that some programming styles discourage conducting IO in functions.
Try:
if (m.lt.0.or.m.gt.l.or.abs(x).gt.1) then
write (*, *) "bad arguments to plgndr, aborting", m, x
stop
else
...
end if

General purpose runge-kutta function for second order differential equations in Modern Fortran

How to make a function func2(func1,t,y0) which receives another function func1 as an argument, but where func1 is a function that returns a 1D real(kind=8), dimension(:) array?
I have the following code written in Matlab, and I would like to write an equivalent one in Modern Fortran for speed and portability. I have written one for first order differential equations, but I'm struggling with the task of writing the code for a code for second and higher order differential equations because the external variable corresponding to differential equations must return an array with dimension(:). I want a code to be general purpose, i.e. I want a function or subroutine to which I can pass any differential equation.
The MatLab code is:
%---------------------------------------------------------------------------
clear all
close all
clc
t = [0:0.01:20]';
y0 = [2, 0]';
y = func_runge_kutta(#func_my_ode,t,y0);
function dy=func_my_ode(t,y)
% Second order differential equation y'' - (1-y^2)*y'+y = 0
dy = zeros(size(y));
dy(1) = y(2);
dy(2) = (1-y(1)^2)*y(2)-y(1);
end
function y = func_runge_kutta(func_my_ode,t,y0)
y = zeros(length(t),length(y0));
y(1,:) = y0';
for i=1:(length(t)-1)
h = t(i+1)-t(i);
F_1 = func_my_ode(t(i),y(i,:)');
F_2 = func_my_ode(t(i)+h/2,y(i,:)'+h/2*F_1);
F_3 = func_my_ode(t(i)+h/2,y(i,:)'+h/2*F_2);
F_4 = func_my_ode(t(i)+h,y(i,:)'+h*F_3);
y(i+1,:) = y(i,:)+h/6*(F_1+2*F_2+2*F_3+F_4)';
end
end
%---------------------------------------------------------------------------
If a function returns an array its interface must be explicit in the caller. The easiest way to achieve this for a dummy argument function is to use the PROCEDURE statement to clone the interface from a function that may be used as an actual argument. Starting with your code, translating to Fortran and adding declarations, we get:
module everything
use ISO_FORTRAN_ENV, only : wp => REAL64
implicit none
contains
function func_my_ode_1(t,y) result(dy)
! Second order differential equation y'' - (1-y**2)*y'+y = 0
real(wp) t
real(wp) y(:)
real(wp) dy(size(y))
dy(1) = y(2);
dy(2) = (1-y(1)**2)*y(2)-y(1);
end
function func_runge_kutta(func_my_ode,t,y0) result(y)
procedure(func_my_ode_1) func_my_ode
real(wp) t(:)
real(wp) y0(:)
real(wp) y(size(t),size(y0))
integer i
real(wp) h
real(wp) F_1(size(y0)),F_2(size(y0)),F_3(size(y0)),F_4(size(y0))
y(1,:) = y0;
do i=1,(size(t)-1)
h = t(i+1)-t(i);
F_1 = func_my_ode(t(i),y(i,:));
F_2 = func_my_ode(t(i)+h/2,y(i,:)+h/2*F_1);
F_3 = func_my_ode(t(i)+h/2,y(i,:)+h/2*F_2);
F_4 = func_my_ode(t(i)+h,y(i,:)+h*F_3);
y(i+1,:) = y(i,:)+h/6*(F_1+2*F_2+2*F_3+F_4);
end do
end
end module everything
program main
!clear all
!close all
!clc
use everything
implicit none
real(wp), allocatable :: t(:)
real(wp), allocatable :: y0(:)
real(wp), allocatable :: y(:,:)
integer i
integer iunit
t = [(0+0.01_wp*i,i=0,nint(20/0.01_wp))];
y0 = [2, 0];
y = func_runge_kutta(func_my_ode_1,t,y0);
open(newunit=iunit,file='rk4.txt',status='replace')
do i = 1,size(t)
write(iunit,*) t(i),y(i,1)
end do
end program main
I had Matlab read the data file and it plotted the same picture as the original Matlab program would have, had it plotted its results.

Double-precision error using Dislin

I get the following error when trying to compile:
call qplot (Z, B, m + 1)
1
Error: Type mismatch in argument 'x' at (1); passed REAL(8) to REAL(4)
Everything seems to be in double precision so I can't help but think it is a Dislin error, especially considering that it appears with reference to a Dislin statement. What am I doing wrong? My code is the following:
program test
use dislin
integer :: i
integer, parameter :: n = 2
integer, parameter :: m = 5000
real (kind = 8) :: X(n + 1), Z(0:m), B(0:m)
X(1) = 1.D0
X(2) = 0.D0
X(3) = 2.D0
do i = 0, m
Z(i) = -1.D0 + (2.D0*i) / m
B(i) = f(Z(i))
end do
call qplot (Z, B, m + 1)
read(*,*)
contains
real (kind = 8) function f(t)
implicit none
real (kind = 8), intent(in) :: t
real (kind = 8), parameter :: pi = Atan(1.D0)*4.D0
f = cos(pi*t)
end function f
end program
From the DISLIN manual I read that qplot requires (single precision) floats:
QPLOT connects data points with lines.
The call is: CALL QPLOT (XRAY, YRAY, N) level 0, 1
or: void qplot (const float *xray, const float *yray, int n);
XRAY, YRAY are arrays that contain X- and Y-coordinates.
N is the number of data points.
So you need to convert Z and B to real:
call qplot (real(Z), real(B), m + 1)
Instead of using fixed numbers for the kind of numbers (which vary between compilers), please consider using the ISO_Fortran_env module and the pre-defined constants REAL32 and REAL64.
The qplot routine requires a default real. You can convert your data
call qplot(real(Z), real(B), m + 1)
I second the remark with kind = 8, it is very ugly, if you insist on 8 at least declare a constant
integer, parameter :: rp = 8
and use
real(rp) ::
As the first two answers explain, the standard versions of the dislin routines require single precision arguments. I find it most convenient to use these since I may have single or double arguments, using the real technique to convert the type of double variables. It seems unlikely that the lost precision will be perceptible on a graph. However, if you wish to work exclusively in double precision, there is an alternative set of routines. They have the same names, but take double precision arguments. To obtain them, link in the library "dislin_d".