I have the following Fortran program. But I don't understand why the output is 4 instead of 1. I am using GNU 6.4 Fortran compiler:
program aa
implicit none
real, pointer, dimension(:,:) :: t => null()
integer :: i,j
allocate(t(0:100,20))
do i = 0, 100
do j = 1, 20
t(i,j) = i*j
end do
end do
call te(t(1:,:))
stop
contains
subroutine te(a)
implicit none
real,dimension(:,:),pointer,intent(in) :: a
print *, a(1,1)
end subroutine te
end program aa
The Intel compiler 18.0.2 returns the error message
/pt.f90(17): error #7121: A ptr dummy may only be argument associated with a ptr, and this array element or section does not inherit the POINTER attr from its parent array. [T]
call te(t(1:,:))
Change the line in your subroutine to
real,dimension(:,:),intent(in) :: a
and all is good.
Related
I wrote a recursive program on Fortran to calculate the combinations of npoints of ndim dimensions as follows. I first wrote this program on MATLAB and it was perfectly running. But in Fortran, my problem is that after the first iteration it is assigning absurd values for the list of points, with no explanation. Could somebody give me a hand?
PROGRAM MAIN
IMPLICIT NONE
INTEGER :: ndim, k, npontos, contador,i,iterate, TEST
integer, dimension(:), allocatable :: pontos
print*, ' '
print*, 'npoints?'
read *, npontos
print*, 'ndim?'
read *, ndim
k=1
contador = 1
open(450,file= 'combination.out',form='formatted',status='unknown')
write(450,100) 'Comb ','stat ',(' pt ',i,' ',i=1,ndim)
write(450,120) ('XXXXXXXXXX ',i=1,ndim+1)
allocate(pontos(ndim))
do i=1,4
pontos(i)=i
end do
TEST = iterate(pontos, ndim, npontos,k,contador)
end program MAIN
recursive integer function iterate(pontos, ndim, npontos, k,contador)
implicit NONE
integer, intent(in) :: ndim, k, npontos
integer,dimension(:) :: pontos
integer contador,inic,i,j,m
if (k.eq.ndim) then
inic=pontos(ndim)
do i = pontos(ndim),npontos
pontos(k)= i
write(*,*) pontos(:)
contador=contador+1
end do
pontos(ndim)= inic + 1
else
inic = pontos (k)
do j = pontos(k),(npontos-ndim+k)
pontos(k)=j
pontos= iterate(pontos, ndim, npontos, k+1,contador)
end do
end if
pontos(k)=inic+1;
if (pontos(k).gt.(npontos-ndim+k+1)) then
do m =k+1,ndim
pontos(m)=pontos(m-1)+1
end do
end if
end function iterate
There are too many issues in that code... I stopped debugging it. This is what I got so far, it's too much for a comment.
This doesn't make sense:
pontos= iterate(pontos, ndim, npontos, k+1,contador)
You are changing pontos inside iterate, and never set a return value within the function.
You need to a) provide a result statement for recursive functions (and actually set it) or b) convert it to a subroutine. Since you are modifying at least one dummy argument, you should go with b).
Since you are using assumed-shape dummy arguments, you need to specify an interface to the function/subroutine, either explicitly or with a module.
Neither format 100 nor format 120 are specified in your code.
I have a type that stores an array:
type data
type(someType) pointer :: someTypePtr(:)
end type
I assign something to someTypePtr with
type(data), intent(inout) :: this
integer, intent(in) :: lb, ub
type(someType), target, intent(in) :: sometype(lb:ub)
this%someTypePtr => sometype
Later on I create a c_ptr pointing to the instance I just reffered to as this. When I cast this pointer back to a fortran type afterwards, the lower bound starts with 0:
type(c_ptr) :: ptr
type(someType) :: data
call c_f_pointer(ptr, data)
write(*,*) lbound(data%someTypePtr) !will give 0
Is there something similar to reshape to change the someTypePtr back to it's original lbound:ubound?
It is strange, it should be 1, not 0. Anyway, you can remap the pointer afterwards:
use iso_c_binding
real(c_float), pointer :: ptr(:)
type(c_ptr) :: ptr_c
allocate(ptr(5:6))
ptr_c = c_loc(ptr(lbound(ptr)))
call c_f_pointer(ptr_c, ptr, [2])
print *, lbound(ptr)
ptr(5:6) => ptr
print *, lbound(ptr)
end
run:
> ./a.out
1
5
I understand the interface command can be used to pass a a function into a subroutine. So for example in the main program I'd define some function and then pass it to some subroutine like:
MainProgran
Use ....
Implicit None
Type decorations etc
Interface
Function test(x,y)
REAL, INTENT(IN) :: x, y
REAL :: test
END function
End Interface
Call Subroutine( limit1, limit2, test, Ans)
End MainProgram
Is this the correct way of doing this? I'm quite stuck! Also within the Subroutine is there anything I need to put to let it know that a function is coming in? The Subroutine in this case will be a library so I don't want to have to keep recompiling it to change the function.
Module:
module fmod
interface
function f_interf(x,y)
real, intent(in) :: x, y
real :: f_interf
end function
end interface
contains
function f_sum(x,y)
real, intent(in) :: x, y
real f_sum
f_sum = x + y
end function
function f_subst(x,y)
real, intent(in) :: x, y
real f_subst
f_subst = x - y
end function
subroutine subr(limit1, limit2, func, ans)
real limit1, limit2
procedure(f_interf) func
real ans
ans = func(limit1, limit2)
end subroutine
end module
main program:
program pass_func
use fmod
Implicit None
real ans, limit1, limit2
limit1 = 1.0
limit2 = 2.0
call subr( limit1, limit2, f_subst, ans)
write(*,*) ans
call subr( limit1, limit2, f_sum, ans)
write(*,*) ans
end program pass_func
and output:
-1.000000
3.000000
A simple way to do this is to go old school and just leave the function external:
program main
real f,z
external f
call subr(f,z)
write(*,*)z
end
real function f(x)
real x
f=x**2
end
! below possibly in a precompiled library:
subroutine subr(f,y)
real f,y
y=f(2.)
end
out: 4
Of course with this approach you can not use advanced language features that require an explicit interface. **
On the other hand if you are interfacing with standard libraries that need function arguments this is I think the only way.
** per MSB's comment you can handle that issue with an interface block in the subroutine,
for example if we want to pass a function that returns an array:
function f(x)
real x,f(2)
f(1)=x
f(2)=x**2
end
as in the first example f is an external function, and the sub can be in
a precompiled library:
subroutine subr(g,y)
interface
function g(x)
real x,g(2)
end function
end interface
real y,z(2)
z=g(2.)
y=z(1)+z(2)
end
out: 6
As noted, this is only strictly necessary if relying on language features that need the interface.
The most elegant way I know of right now is to put your functions into a module so that you don't have to do construct interface but simply use 'external'. Here is a example to do that.
It covers different situations using subroutine or function as arguments for subroutine or function.
Notice if you want to pass array as argument without receiving null arraies, here is a tip to do that.
Module part:
module func_arg_test
!I used ifort to compile but other compilers should also be fine.
!Written by Kee
!Feb 20, 2017
contains
!-------------------------
real function func_func(f, arg)
!========================================
!This shows how to pass number as argument
!========================================
implicit none
real, external::f !Use external to indicate the f is a name of a function
real::arg
func_func=f(arg)
end function func_func
real function func_sub(subr, arg)
!========================================
!This shows how to pass subroutine as arg to function
!========================================
implicit none
external::subr !Use external to indicate subr is a subroutine
real::arg
call sub(arg)
func_sub = arg
end function func_sub
subroutine sub_func(f,arg)
!========================================
!This shows how to pass function as argument
!in subroutine
!========================================
real::arg
real,external::f
arg = f(arg)
end subroutine sub_func
subroutine sub_sub(subr,arg)
!========================================
!This shows how to pass subroutine as argument
!in subroutine
!========================================
real::arg
external::subr
call subr(arg)
end subroutine sub_sub
real function funcmat(f, mat)
!========================================
!This shows how to pass matrix as argument
!========================================
implicit none
real, external::f
real,dimension(:)::mat!Here memory for mat is already allocated when mat is
!passed in, so don't need specific size
integer::sizeinfo
sizeinfo = size(mat)
funcmat = f(mat,sizeinfo)
end function funcmat
!--------------------------
real function f1(arg)
!This test function double the number arg
implicit none
real::arg
f1 = arg*2
return
end function f1
real function f2(arg)
!This test function square the number arg
implicit none
real::arg
f2 = arg*arg
return
end function f2
real function fmat(mat,sizeinfo)
!This test function sum up all elements in the mat
implicit none
integer::sizeinfo!This is the method I come up with to get around the
!restriction.
real,dimension(sizeinfo)::mat!This mat cannot be undetermined, otherwise it
!won't recevie mat correctly. I don't know why yet.
fmat = sum(mat)
end function fmat
subroutine sub(arg)
real::arg
arg = arg*3
end subroutine sub
end module
Main program:
program main
use func_arg_test
implicit none
real::a = 5d0
real::output
real, dimension(:),allocatable::mat
write(*,*) 'value of a=',a
output = func_func(f1,a)
write(*,*) 'a is doubled'
write(*,*) output
output = func_func(f2,a)
write(*,*) 'a is squared'
write(*,*) output
output = func_sub(sub,a)
write(*,*) 'a is tripled and overwritten'
write(*,*) output
call sub_func(f2,a)
write(*,*) 'a is squared and overwritten'
write(*,*) a
call sub_sub(sub,a)
write(*,*) 'a is tripled and overwritten'
write(*,*) a
allocate(mat(3))
mat = (/1d0,10d0,1d0/)!The allocatable arrray has to have a determined shape before
!pass as arguemnt
write(*,*) '1D matrix:',mat
write(*,*) 'Summation of the matrix:'
output = funcmat(fmat,mat)!elements of mat are summed
write(*,*) output
end program
And the result is:
value of a= 5.000000
a is doubled
10.00000
a is squared
25.00000
a is tripled and overwritten
15.00000
a is squared and overwritten
225.0000
a is tripled and overwritten
675.0000
1D matrix: 1.000000 10.00000 1.000000
Summation of the matrix:
12.00000
I am new to Fortran. I am writing a program in Fortran 90 to get non-zero elements of an array and put them into a new array using pointer function as following:
program prog
implicit none
integer, target :: a(5)
integer :: i
integer, pointer :: nz(:)
a(1) = 1
a(2) = 0
a(3) = 0
a(4) = 2
a(5) = 3
nz => non_zeros(a)
do i=1, size(nz)
write(*,*) nz(i)
end do
contains
function non_zeros(a)
integer, target :: a(:)
integer, pointer:: non_zeros(:)
integer :: n, i, j
n = count(a .ne. 0)
allocate(non_zeros(n))
j = 0
do i=1, m
if (a(i) .ne. 0) then
j = j + 1
non_zeros(j) => a(i)
end if
end do
end function non_zeros
end program prog
during compiling I got the error:
non_zeros(j) => a(i)
1
Error: Expected bounds specification for 'non_zeros' at (1)
Can you please tell me what did I do wrong? Thank you in advance!
Update of my question: According to the explanation of High Performance Mark, I defined a derived type:
program prog
implicit none
integer, target :: a(5)
type dt
integer, pointer :: x
end type
type(dt), allocatable :: nz(:)
a(1) = 1
a(2) = 0
a(3) = 0
a(4) = 2
a(5) = 3
nz = non_zeros(a)
contains
function non_zeros(a)
integer, target :: a(:)
type(dt), allocatable :: non_zeros(:)
integer :: n, i, j
n = count(a .ne. 0)
allocate(non_zeros(n))
j = 0
do i=1, m
if (a(i) .ne. 0) then
j = j + 1
non_zeros(j)%x => a(i)
end if
end do
end function non_zeros
end program prog
Now program works and gives the desired results. However, I did not use pointer function in this case, since my function returns an allocatable array of pointers, not pointer to an array. Is there any way to use pointer function here? Thank you
To get the non-zero elements of a into a new array you could simply declare
integer, dimension(:), allocatable :: non_zeros
and then populate that with the statement
non_zeros = pack(a,a/=0)
and avoid fiddling around with pointers entirely. This relies on a feature introduced in the 2003 standard, but it is implemented by all (I think) the current crop of Fortran compilers on the market.
The code that you have written looks to me as if you want nz to be an array of pointers, with each element in nz pointing to a non-zero element of a. If I'm right, you've misunderstood what a statement such as
integer, pointer :: nz(:)
declares. It does not declare an array of pointers to integers, it declares a pointer to an array of integers. When you write
non_zeros(j) => a(i)
you're making the mistake of trying to set an element of non_zeros to point to an element of a.
The error message is misleading here because the compiler interprets non_zeros(j) as a syntactically-incorrect bounds-spec or bounds-remapping, but the error is semantic, the compiler doesn't understand your misunderstanding of Fortran.
I have a program I want to parallelize using MPI. I have not worked with MPI before.
The program calculates the behavior for a large numer of objects over time. The data of
these objects is stored in arrays, e.g. double precision :: body_x(10000) for the x coordinate.
To calculate the behavior of an object the information about all other objects is needed,
so every thread needs to hold all data but will only update a portion of it. But before the
new timestep every thread needs to get the information from all other threads.
As I understand MPI_Allgather could be used for this, but it needs a send buffer and a
recive buffer. How can I synchronize an array over different threads if each thread updated
a different part of the array? Do I have to send the whole array from each thread to the
master in a recive buffer, update the specific part of the masters array and after all
threads have sent their data re-broadcast from the master?
This is a pretty basic question, but I'm very new to MPI and all examples I found are
pretty simple and do not cover this. Thanks for any help.
Pseudo-Example (assuming Fortran-Style vectors with first index 1):
(Yes the send/recive would better be done non-blocking, this is for the sake of simplicity)
if (master) then
readInputFile
end if
MPI_Bcast(numberOfObject)
allocate body_arrays(numberOfObjects)
if (master) then
fill body_arrays ! with the data from the input file
end if
MPI_Bcast(body_arrays)
objectsPerThread = numberOfObjects / threadCount
myStart = threadID * objectsPerThread + 1
myEnd = (threadID + 1) * objectsPerThread
do while (t < t_end)
do i = myStart, myEnd
do stuff for body_arrays(i)
end do
! here is the question
if (.not. master)
MPI_Send(body_arrays, toMaster)
else
do i = 1, threadCount - 1
MPI_Recive(body_arrays_recive, senderID)
body_arrays(senderID*objectsPerThread+1, (senderId+1)*objectsPerThread) = body_arrays_recive(senderID*objectsPerThread+1, (senderId+1)*objectsPerThread)
end if
MPI_Bcast(body_arrays)
! ----
t = t + dt
end do
It sounds like you want MPI_Allgather. To avoid needing a separate send buffer, you may be able to use the MPI_IN_PLACE value. That tells MPI to use the same buffer for both send and receive.
See http://mpi-forum.org/docs/mpi-2.2/mpi22-report/node99.htm#Node99
The array chunks from all processes can be combined using a call to MPI_Allgatherv. The following is a complete example in Fortran. It defines an array of size 50. Then each process sets a chunk of that array to some complex number. Finally, the call to MPI_allgatherv pulls all the chunks together. The calculations of the chunk sizes, and some of the parameters that need to be passed to MPI_allgatherv are encapsulated in the mpi_split routine.
program test
use mpi
implicit none
integer, parameter :: idp = 8
integer, parameter :: n_tasks = 11
real(idp), parameter :: zero = 0.0d0
complex(idp), parameter :: czero = cmplx(zero, zero, kind=idp)
integer :: mpi_n_procs, mpi_proc_id, error
integer :: i, i_from, i_to
complex(idp) :: c(-5:5)
real(idp) :: split_size
integer, allocatable :: recvcount(:), displs(:)
call MPI_Init(error)
call MPI_Comm_size(MPI_COMM_WORLD, mpi_n_procs, error)
call MPI_Comm_rank(MPI_COMM_WORLD, mpi_proc_id, error)
allocate(recvcount(mpi_n_procs))
allocate(displs(mpi_n_procs))
i_from = -5
i_to = 5
! each process covers only part of the array
call mpi_split(i_from, i_to, counts=recvcount, displs=displs)
write(*,*) "ID", mpi_proc_id,":", i_from, "..", i_to
if (mpi_proc_id == 0) then
write(*,*) "Counts: ", recvcount
write(*,*) "Displs: ", displs
end if
c(:) = czero
do i = i_from, i_to
c(i) = cmplx(real(i, idp), real(i+1, idp), kind=idp)
end do
call MPI_Allgatherv(c(i_from), i_to-i_from+1, MPI_DOUBLE_COMPLEX, c, &
& recvcount, displs, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, &
& error)
if (mpi_proc_id == 0) then
do i = -5, 5
write(*,*) i, ":", c(i)
end do
end if
deallocate(recvcount, displs)
call MPI_Finalize(error)
contains
!! #description: split the range (a,b) into equal chunks, where each chunk is
!! handled by a different MPI process
!! #param: a On input, the lower bound of an array to be processed. On
!! output, the lower index of the chunk that the MPI process
!! `proc_id` should process
!! #param: b On input, the upper bound of an array. On, output the
!! upper index of the chunk that process `proc_id` should
!! process.
!! #param: n_procs The total number of available processes. If not given,
!! this is determined automatically from the MPI environment.
!! #param: proc_id The (zero-based) process ID (`0 <= proc_id < n_procs`). If
!! not given, the ID of the current MPI process
!! #param: counts If given, must be of size `n_procs`. On output, the chunk
!! size for each MPI process
!! #param: displs If given, must be of size `n_procs`. On output, the offset
!! if the first index processed by each MPI process, relative
!! to the input value of `a`
subroutine mpi_split(a, b, n_procs, proc_id, counts, displs)
integer, intent(inout) :: a
integer, intent(inout) :: b
integer, optional, intent(in) :: n_procs
integer, optional, intent(in) :: proc_id
integer, optional, intent(inout) :: counts(:)
integer, optional, intent(inout) :: displs(:)
integer :: mpi_n_procs, n_tasks, mpi_proc_id, error
integer :: aa, bb
real(idp) :: split_size
logical :: mpi_is_initialized
mpi_n_procs = 1
if (present(n_procs)) mpi_n_procs = n_procs
mpi_proc_id = 0
if (present(proc_id)) mpi_proc_id = proc_id
if (.not. present(n_procs)) then
call MPI_Comm_size(MPI_COMM_WORLD, mpi_n_procs, error)
end if
if (.not. present(proc_id)) then
call MPI_Comm_rank(MPI_COMM_WORLD, mpi_proc_id, error)
end if
aa = a
bb = b
n_tasks = bb - aa + 1
split_size = real(n_tasks, idp) / real(max(mpi_n_procs, 1), idp)
a = nint(mpi_proc_id * split_size) + aa
b = min(aa + nint((mpi_proc_id+1) * split_size) - 1, bb)
if (present(counts)) then
do mpi_proc_id = 0, mpi_n_procs-1
counts(mpi_proc_id+1) = max(nint((mpi_proc_id+1) * split_size) &
& - nint((mpi_proc_id) * split_size), 0)
end do
end if
if (present(displs)) then
do mpi_proc_id = 0, mpi_n_procs-1
displs(mpi_proc_id+1) = min(nint(mpi_proc_id * split_size), bb-aa)
end do
end if
end subroutine mpi_split
end program