Related
The following Fortran code fails (random result), but replacing the call to mysum by abc=abc+1
gives the correct result. How to make OpenMP recognizing the reduction in a subprogram?
program reduc
use omp_lib
implicit none
integer :: abc=0, icount
call OMP_set_num_threads(8)
!$omp parallel private (icount) reduction(+:abc)
!$omp do
do icount = 1,8
!abc = abc + 1
call mysum(OMP_get_thread_num())
end do
!$omp end do
!$omp end parallel
print*,"abc at end: ",abc
contains
subroutine mysum(omp_rank)
integer :: omp_rank
abc = abc + 1
print*,"OMP rank: ", omp_rank, " abc: ", abc
endsubroutine mysum
end program reduc
I also tried to put !$omp threadprivate (abc) into mysum, which was rejected with
"Error: Symbol 'abc' at (1) has no IMPLICIT type.", which is of course not true.
Because of the reduction, the original variable abc is privatised in each thread, but abc in the contained subroutine always refers to the original, non privatised variable.
The solution is to pass it as an argument:
subroutine mysum(omp_rank,abc)
integer, intent(in) :: omp_rank
integer, intent(inout) :: abc
abc = abc + 1
print*,"OMP rank: ", omp_rank, " abc: ", abc
endsubroutine mysum
How can I access a function on device via a function pointer?
In below code I am trying to access init0 or init1 using function pointer init. The code does work as intended if OpenACC is not enabled during compilation. However, it fails when compiled with OpenACC. Below code is saved as stackOverflow2.f95:
module modTest2
use openacc
implicit none
type :: Container
sequence
integer :: n
integer, allocatable :: arr(:)
end type Container
interface Container
procedure :: new_Container
end interface
abstract interface
integer function function_template (i)
integer, intent (in) :: i
end function function_template
end interface
contains
type(Container) function new_Container(n)
integer, intent(in) :: n
allocate(new_Container%arr(n))
end function new_Container
end module modTest2
program test2
use modTest2
implicit none
integer :: n, x, i
type(Container) :: c
procedure(function_template), pointer :: init
print *, "Enter array size: "
read *, n
print *, "Allocating..."
c = Container(n)
print *, "Allocation complete!"
print *, "Enter initialization type (x): "
read *, x
print *, "Initializing..."
select case (x)
case (0)
init => init0
case default
init => init1
end select
!$acc data copyin(c) copyout(c%arr)
!$acc parallel loop present(c)
do i = 1, n
c%arr(i) = init(i)
end do
!$acc end data
print *, "Initialization complete..."
do i = 1, n
print *, i, c%arr(i)
end do
contains
integer function init0(i)
!$acc routine
integer, intent(in) :: i
init0 = 10*i
end function init0
integer function init1(i)
!$acc routine
integer, intent(in) :: i
init1 = 20*i
end function init1
end program test2
Correct output is seen without OpenACC:
$ gfortran -c stackOverflow2.f95
$ gfortran stackOverflow2.o -o a.out
$ ./a.out
Enter array size:
3
Allocating...
Allocation complete!
Enter initialization type (x):
0
Initializing...
Initialization complete...
1 10
2 20
3 30
Incorrect output is seen below with OpenACC (Note that NVIDIA compiler is used here):
$ /opt/nvidia/hpc_sdk/Linux_x86_64/22.1/compilers/bin/nvfortran stackOverflow2.f95 -acc; ./a.out
Enter array size:
3
Allocating...
Allocation complete!
Enter initialization type (x):
0
Initializing...
Initialization complete...
1 0
2 0
3 0
Sorry but function pointers (along with C++ virtual functions) are not yet supported on the device. Adding the compiler feedback flag (-Minfo=accel), you'll see the following message:
% nvfortran -acc -Minfo=accel test.f90
test2:
62, Generating copyout(c%arr(:)) [if not already present]
Generating copyin(c) [if not already present]
65, Accelerator restriction: Indirect function/procedure calls are not supported
The problem being that indirect functions require a device jump table and runtime dynamic linking which is currently unavailable. While I don't have a timeline, we are exploring options on how to offer this support in the future.
Using gfortran-11 with the below did the trick:
module modTest2
use openacc
implicit none
type :: Container
sequence
integer :: n
integer, allocatable :: arr(:)
end type Container
interface Container
procedure :: new_Container
end interface
abstract interface
integer function function_template (i)
integer, intent (in) :: i
end function function_template
end interface
contains
type(Container) function new_Container(n)
integer, intent(in) :: n
allocate(new_Container%arr(n))
end function new_Container
end module modTest2
program test2
use modTest2
implicit none
integer :: n, x, i
type(Container) :: c
procedure(function_template), pointer :: init
print *, "Enter array size: "
read *, n
print *, "Allocating..."
c = Container(n)
print *, "Allocation complete!"
print *, "Enter initialization type (x): "
read *, x
print *, "Initializing..."
select case (x)
case (0)
init => init0
case default
init => init1
end select
!$acc enter data copyin(c)
!$acc enter data create(c%arr)
!$acc parallel loop present(c)
do i = 1, n
c%arr(i) = init(i)
end do
!$acc exit data copyout(c%arr)
!$acc exit data delete(c)
print *, "Initialization complete..."
do i = 1, n
print *, i, c%arr(i)
end do
contains
integer function init0(i)
!$acc routine
integer, intent(in) :: i
init0 = 10*i
end function init0
integer function init1(i)
!$acc routine
integer, intent(in) :: i
init1 = 20*i
end function init1
end program test2
Here's the output:
$ gfortran-11 -fopenacc stackOverflow2.f95
$ gfortran-11 -fopenacc stackOverflow2.o -o stackOverflow2
$ ./stackOverflow2
Enter array size:
4
Allocating...
Allocation complete!
Enter initialization type (x):
0
Initializing...
Initialization complete...
1 10
2 20
3 30
4 40
$ ./stackOverflow2
Enter array size:
4
Allocating...
Allocation complete!
Enter initialization type (x):
9
Initializing...
Initialization complete...
1 20
2 40
3 60
4 80
Let's say I want to perform an operation in my main program (in Fortran). And lets say that operation is finding minimum number in a 1D array. I wish to do so by passing the array into the call subroutine and the subroutine will print the minimum value on the screen. There are different ways or algorithms to find minimum value in an array. Lets say I have 100 different methods: Method1, Method2..... Method100. Now I want to try using each one of these methods separately (I don't want to try all of them at once, but one method in each run). I don't want to create 100 different subroutines and change the code every time to decide which one to call, rather I want to mention in the input file which one I want to choose. So basically, the computer has to read the input file (to know which method to use) and perform the task using the specified method amongst different methods available.
I can write a Subroutine dump all the methods into that subroutine and put an IF condition to choose among various methods. But IF conditions are in efficient particularly on GPUs, I want to know the most efficient way of doing this.
MAIN PROGRAM
INTEGER Method !will be read from input file
Array = [12,5,3,4,1,7,4,3]
call print_Minimum(Array)
END PROGRAM
SUBROUTINE print_Minimum(Array)
IF (METHOD == 1)
<method 1 code>
ELSE IF (METHOD == 2)
<method 2 code>
:
:
:
:
ELSE IF (METHOD == 100)
<method100 code>
END IF
END SUBROUTINE
Thanks in advance.
This is probably best done using a function pointer and/or functions as arguments.
You can set a function pointer to a certain function and do this in your nested ifs and you can pass functions as arguments.
Both methods are implemented in the following example.
module minimum_mod
implicit none
private
public :: get_min_t, naive_min, time_min_function
abstract interface
integer pure function get_min_t(X)
integer, intent(in) :: X(:)
end function
end interface
contains
subroutine time_min_function(f, X)
procedure(get_min_t) :: f
integer, intent(in) :: X(:)
integer :: res
res = f(X)
write(*, *) res
end subroutine
integer pure function naive_min(X)
integer, intent(in) :: X(:)
integer :: i
naive_min = huge(naive_min)
do i = 1, size(X)
naive_min = min(naive_min, X(i))
end do
end function
end module
program time_min_finders
use minimum_mod, only: get_min_t, naive_min, time_min_function
implicit none
integer, parameter :: test_set(5) = [1, 10, 3, 5, 7]
procedure(get_min_t), pointer :: f
f => naive_min
call time_min_function(f, test_set)
end program
PS: Note that you can now do all the timinig logic inside time_min_function.
You can create an array of a derived type that contains a function pointer, effectively an array of function pointers. Then in principle you could initialize the function pointers to point at all of your test functions so that you could refer to each function by its index without having to test with a SELECT CASE of IF block: this is the typical Fortran way. However, either I've got the syntax for initialization wrong or my old version of gfortran just isn't capable, so I had to initialize one at a time. Sigh.
module minfuncs
implicit none
abstract interface
function func(array)
integer, intent(in) :: array(:)
integer func
end function func
end interface
type func_node
procedure(func), NOPASS, pointer :: f
end type func_node
! type(func_node) :: method(5) = [func_node(min_1),func_node(min_2), &
! func_node(min_3),func_node(min_4),func_node(min_5)]
contains
function min_1(array)
integer, intent(in) :: array(:)
integer min_1
integer i
min_1 = array(1)
do i = 2, size(array)
min_1 = min(min_1,array(i))
end do
end function min_1
function min_2(array)
integer, intent(in) :: array(:)
integer min_2
integer i
min_2 = array(1)
do i = 8, size(array), 7
min_2 = min(min_2,array(i-6),array(i-5),array(i-4), &
array(i-3),array(i-2),array(i-1),array(i))
end do
do i = i-6, size(array)
min_2 = min(min_2, array(i))
end do
end function min_2
function min_3(array)
integer, intent(in) :: array(:)
integer min_3
integer i
min_3 = array(1)
do i = 2, size(array)
min_3 = min_3-dim(min_3,array(i))
end do
end function min_3
function min_4(array)
integer, intent(in) :: array(:)
integer min_4
integer ymm(8)
integer i
if(size(array) >= 8) then
ymm = array(1:8)
do i = 16, size(array), 8
ymm = min(ymm,array(i-7:i))
end do
min_4 = minval([ymm,array(i-7:size(array))])
else
min_4 = minval(array)
end if
end function min_4
function min_5(array)
integer, intent(in) :: array(:)
integer min_5
min_5 = minval(array)
end function min_5
end module minfuncs
program test
use minfuncs
implicit none
integer, parameter :: N = 75
integer i
integer :: A(N) = modulo(5*[(i,i=1,N)]**2,163)
! type(func_node) :: method(5) = [func_node(min_1),func_node(min_2), &
! func_node(min_3),func_node(min_4),func_node(min_5)]
type(func_node) method(5)
method(1)%f => min_1
method(2)%f => min_2
method(3)%f => min_3
method(4)%f => min_4
method(5)%f => min_5
do i = 1, size(method)
write(*,*) method(i)%f(A)
end do
end program test
Output:
2
2
2
2
2
What is the best method when you need interchange the values in two polymorphic elements? (Using standard fortran 2008).
I'm sending an example (please try don't modify the type variables).
The problems that I have using intel compiler v.19 and gfortran 8.1 in windows are different.
Here a complete example. Look at the subroutine where I have defined the swap procedure. Currently is activate the version that works in GFortran but I have error with intel compiler. If you comment this part and uncomment the lines for ifort, then works for intel and not for gfortran....
Program Check
implicit none
!> Type definitions
Type :: Refl_Type
integer,dimension(:), allocatable :: H
integer :: Mult =0
End Type Refl_Type
Type :: RefList_Type
integer :: Nref
class(refl_Type), dimension(:), allocatable :: Reflections
end Type RefList_Type
Type(RefList_Type) :: List
Type(Refl_Type), dimension(3) :: Refl_Ini
!> Variables
integer :: i
!> Init
Refl_Ini(1)%H=[1, 0, 0]; Refl_Ini(1)%Mult=1
Refl_Ini(2)%H=[0, 2, 0]; Refl_Ini(2)%Mult=2
Refl_Ini(3)%H=[0, 0, 3]; Refl_Ini(3)%Mult=3
List%Nref=3
List%Reflections=Refl_Ini
!> Print Step:1
do i=1, List%Nref
print '(i3,2x,3i4,2x,i3)', i,List%Reflections(i)%H, List%Reflections(i)%Mult
end do
print*,' '
print*,' '
!> Swap
call Swap_Elements_List(List, 1, 3)
!> Print Step:2
do i=1, List%Nref
print '(i3,2x,3i4,2x,i3)', i,List%Reflections(i)%H, List%Reflections(i)%Mult
end do
Contains
Subroutine Swap_Elements_List(List, i, j)
!---- Argument ----!
type (RefList_Type), intent(in out) :: List
integer, intent(in) :: i,j
!---- Local Variables ----!
class(Refl_Type), allocatable :: tmp
!> IFort
!tmp=List%reflections(i)
!List%reflections(i)=List%reflections(j)
!List%reflections(j)=tmp
!> Gfortran
associate(t1 => list%reflections(i), t2 => list%reflections(j), tt => tmp)
tt=t1
t1=t2
t2=tt
end associate
End Subroutine Swap_Elements_List
End Program Check
Any suggestion?
Compiling the original code with gfortran-8.2 gives
test.f90:34:6:
List%reflections(i)=List%reflections(j) !!<---
1
Error: Nonallocatable variable must not be polymorphic in
intrinsic assignment at (1) - check that there is a
matching specific subroutine for '=' operator
I think this is because List % reflections(i) is not separately allocatable (even though List % reflections itself is allocatable as an array of uniform type). This point seems to be discussed in detail, e.g., in this Q/A page, which suggests two alternative approaches: (A) convince the compiler that all elements will be of the same type; or (B) use an (array) container.
If we use the "container" approach, I think we can use move_alloc() to swap two polymorphic objects (without knowing the dynamic type). For example, a bit modified version of the original code may be
program main
implicit none
type :: Refl_t
integer, allocatable :: H(:)
endtype
type, extends(Refl_t) :: ExtRefl_t
real :: foo
endtype
type :: RefList_t
class(Refl_t), allocatable :: refl
endtype
type(RefList_t) :: list( 3 )
call init()
print *, "Before:"
call output()
call swap( 1, 2 )
print *, "After:"
call output()
contains
subroutine swap( i, j )
integer, intent(in) :: i, j
class(Refl_t), allocatable :: tmp
call move_alloc( from= list( i )% refl, to= tmp )
call move_alloc( from= list( j )% refl, to= list( i )% refl )
call move_alloc( from= tmp, to= list( j )% refl )
end
subroutine init()
integer i
do i = 1, 3
allocate( ExtRefl_t :: list( i ) % refl )
select type( x => list( i ) % refl )
type is ( ExtRefl_t )
x % H = [ i, i * 10 ]
x % foo = i * 100
endselect
enddo
end
subroutine output()
integer i
do i = 1, 3
select type( x => list( i ) % refl )
type is ( ExtRefl_t )
print *, "i = ", i, " : H = ", x % H, " foo = ", x % foo
endselect
enddo
end
end program
Result (gfortran-8.2):
Before:
i = 1 : H = 1 10 foo = 100.000000
i = 2 : H = 2 20 foo = 200.000000
i = 3 : H = 3 30 foo = 300.000000
After:
i = 1 : H = 2 20 foo = 200.000000
i = 2 : H = 1 10 foo = 100.000000
i = 3 : H = 3 30 foo = 300.000000
I think we could also use polymorphic assignment for the above swap() routine, for example:
subroutine swap( i, j )
integer, intent(in) :: i, j
class(Refl_t), allocatable :: tmp
tmp = list( i ) % refl
list( i ) % refl = list( j ) % refl
list( j ) % refl = tmp
end
This compiles with gfortran-8.2, but gives a strange result... (a possible compiler bug?). I guess newer compilers like GCC-9 or Intel Fortran may give an expected result.
On the other hand, if we use a polymorphic array, we may need to use select type explicitly for swapping the two elements. (But I hope there is a different approach...) The code may then look like:
program main
implicit none
type :: Refl_t
integer, allocatable :: H(:)
endtype
type, extends(Refl_t) :: ExtRefl_t
real :: foo
endtype
class(Refl_t), allocatable :: refls( : )
allocate( ExtRefl_t :: refls( 3 ) )
call init()
print *, "Before:"
call output()
call swap( 1, 2 )
print *, "After:"
call output()
contains
subroutine swap( i, j )
integer, intent(in) :: i, j
selecttype ( refls )
type is ( ExtRefl_t )
block
type(ExtRefl_t) :: tmp
tmp = refls( i ) !<-- assignment of concrete type
refls( i ) = refls( j )
refls( j ) = tmp
endblock
class default
stop
endselect
end
subroutine init()
integer i
select type( refls )
type is ( ExtRefl_t )
do i = 1, 3
refls( i ) % H = [ i, i * 10 ]
refls( i ) % foo = i * 100
enddo
endselect
end
subroutine output()
integer i
select type( refls )
type is ( ExtRefl_t )
do i = 1, 3
print *, "i = ", i, " : H = ", refls( i ) % H, &
" foo = ", refls( i ) % foo
enddo
endselect
end
end program
(The result is the same as above.)
The answer by roygvib summarizes the problem well. If this assignment is to be performed in user's code where the types are known or are known to be from a small set of possible types, one can just protect the assignment by the select type typeguard.
The real problem happens in a generic code that is written without the knowledge of the user's derived types. Therefore it may have no access to possible user-defined assignments. I suggest a possible solution using a callback procedure. Basically, the user defines an assignment or swap procedure which is then called by the library code.
subroutine sub_that_needs_assignments(array, assign)
class(*) :: array
interface
subroutne assign(out, in)
end subroutine
end interface
call assign(array(i), array(i+1))
!or you can even assign a new elemnt from somewhere else
! possibly protect by same_type_as()
end subroutine
in the user's code
subroutine assign_my_type(out, in)
class(*), ... :: out
class(*), ... :: in
select type (out)
type is (my_type)
select type (in) ! not always necessary
type is (in)
out = in
end select
end select
!add appropriate error checking
end subroutine
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