Use Fortran subroutine in R? Undefined symbol - r

This is a follow up to my previous question. I wrapped my Fortran code in a module and now it compiles when I run:
R CMD SHLIB ./Fortran/Fpi.f90
This is my Fortran code:
Module Fpi
IMPLICIT NONE
contains
subroutine pi(avepi, DARTS, ROUNDS)
double precision, intent(out) :: avepi
integer, intent(in) :: DARTS, ROUNDS
integer :: MASTER, rank, i, n
integer, allocatable :: seed(:)
double precision :: pi_est, homepi, pirecv, pisum, dboard
! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)
avepi = 0
do i = 0, ROUNDS-1
pi_est = dboard(DARTS)
! calculate the average value of pi over all iterations
avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi
double precision function dboard(darts)
integer, intent(in) :: darts
double precision :: x_coord, y_coord
integer :: score, n
score = 0
do n = 1, darts
call random_number(x_coord)
call random_number(y_coord)
if ((x_coord**2 + y_coord**2) <= 1.0d0) then
score = score + 1
end if
end do
dboard = 4.0d0*score/darts
end function
end module Fpi
I'm trying to run this in R:
mypi <- function(DARTS, ROUNDS) {
dyn.load("./Fortran/Fpi.so")
retvals <- .Fortran("pi", DARTS = as.integer(DARTS) , ROUNDS = as.integer(ROUNDS), avepi = as.numeric(1))
return(retvals$avepi)
}
mypi(DARTS = 50000, ROUNDS = 10)
and I get this error:
Error in dyn.load("./Fortran/Fpi.so") :
unable to load shared object '/home/ignacio/local/projects/PI/./Fortran/Fpi.so':
/home/ignacio/local/projects/PI/./Fortran/Fpi.so: undefined symbol: dboard_

Your problem comes down to the declaration of dboard:
double precision :: pi_est, homepi, pirecv, pisum, dboard
Here you are saying that dboard is an external function, rather than a module procedure. This explains why there is a symbol dboard_ coming into play. You want to remove that:
double precision :: pi_est, homepi, pirecv, pisum
and instead rely, in pi on the module procedure-ness of dboard: pi already knows about it without this declaration.
Now, beyond that, because pi is in a module there is going to be some name mangling going on for that subroutine itself. I'd solve this problem by making pi itself a (C) interoperable procedure.
Module Fpi
IMPLICIT NONE
contains
subroutine pi(avepi, DARTS, ROUNDS) bind(C)
use, intrinsic :: iso_c_binding, only : c_double, c_int
real(c_double), intent(out) :: avepi
integer(c_int), intent(in) :: DARTS, ROUNDS
...
and then using .C rather than .Fortran.
You can keep pi and dboard in the module, and this latter needn't even be interoperable.

Try to fix the name of the fortran call inside the R function. You typed "pi" where it should be "Fpi". Also, why not bring the function to your path instead of passing a long path inside the function?
mypi <- function(DARTS, ROUNDS) {
dyn.load("./Fortran/Fpi.so")
retvals <- .Fortran("Fpi", DARTS = as.integer(DARTS) , ROUNDS = as.integer(ROUNDS), answer = as.numeric(1))
return(retvals$answer)
}
mypi(DARTS = 50000, ROUNDS = 10)

Aparently I cannot wrap the subroutines in a module. This fortran code is working:
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
double precision :: x_coord, y_coord
integer :: score, n
score = 0
do n = 1, darts
call random_number(x_coord)
call random_number(y_coord)
if ((x_coord**2 + y_coord**2) <= 1.0d0) then
score = score + 1
end if
end do
dartsscore = 4.0d0*score/darts
end subroutine dboard
subroutine pi(avepi, DARTS, ROUNDS)
implicit none
double precision, intent(out) :: avepi
integer, intent(in) :: DARTS, ROUNDS
integer :: MASTER, rank, i, n
integer, allocatable :: seed(:)
double precision :: pi_est, homepi, pirecv, pisum
interface
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
end subroutine dboard
end interface
! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)
avepi = 0
do i = 0, ROUNDS-1
call dboard(darts, pi_est)
! calculate the average value of pi over all iterations
avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi
and this is the R code:
system("R CMD SHLIB ./Fortran/Fpi.f90")
mypi <- function(DARTS, ROUNDS) {
dyn.load("./Fortran/Fpi.so")
retvals <- .Fortran("pi", avepi = as.numeric(1), DARTS = as.integer(DARTS), ROUNDS = as.integer(ROUNDS))
return(retvals$avepi)
}
mypi(DARTS = 50000, ROUNDS = 10)

Related

Store all r combinations of a list

I need a general program in fortran to obtain all possible combinations of r elements in a list of n elements. I have found this code that prints all the combinations (r=3, n =5) but I need them to be stored in an array.
I tried to record them as rows near the write statement but it does not work. Turning the recursive subprogram into a recursive function is also not working.
program combinations
implicit none
integer, parameter :: m_max = 3
integer, parameter :: n_max = 5
integer, dimension (m_max) :: comb
character (*), parameter :: fmt = '(i0' // repeat (', 1x, i0', m_max - 1) // ')'
call gen (1)
contains
recursive subroutine gen (m)
implicit none
integer, intent (in) :: m
integer :: n
if (m > m_max) then
write (*, fmt) comb
else
do n = 1, n_max
if ((m == 1) .or. (n > comb (m - 1))) then
comb (m) = n
call gen (m + 1)
end if
end do
end if
end subroutine gen
end program combinations
Firstly, mixing global variables and recursive procedures is a good way to cause a lot of unnecessary confusion and debugging, so let's turn comb and n_max into procedure arguments, use size(comb) to give m_max, and for now replace fmt with *:
program combinations
implicit none
integer :: comb(3)
call gen(comb, 1, 5)
contains
recursive subroutine gen(comb, m, n_max)
integer, intent(inout) :: comb(:)
integer, intent(in) :: m
integer, intent(in) :: n_max
integer :: n
if (m > size(comb)) then
write (*, *) comb
else
do n = 1, n_max
if ((m == 1) .or. (n > comb(m - 1))) then
comb(m) = n
call gen(comb, m+1, n_max)
end if
end do
end if
end subroutine gen
end program combinations
The next thing to note is there's a subtle bug in your code. The line
if ((m == 1) .or. (n > comb (m - 1))) then
isn't guaranteed to work if m=1. Fortran does not guarantee short-circuiting of logical operators, so even if (m == 1) evaluates to .true., the (n > comb (m - 1)) could be evaluated, causing a segfault. Let's get around this by introducing a variable n_min, and calculating it correctly:
recursive subroutine gen(comb, m, n_max)
integer, intent(inout) :: comb(:)
integer, intent(in) :: m
integer, intent(in) :: n_max
integer :: n
integer :: n_min
if (m > size(comb)) then
write (*, *) comb
else
if (m == 1) then
n_min = 1
else
n_min = comb(m-1) + 1
endif
do n = n_min, n_max
comb(m) = n
call gen (comb, m+1, n_max)
end do
end if
end subroutine gen
Okay, now we can start thinking about returning the combinations from gen. To do this, let's change gen from a subroutine into a function, and have it return a 2-D array. We're going to need to append one 2-D array onto another, so let's write a function to do that now:
function append_combinations(input, new_combinations) result(output)
integer, intent(in) :: input(:,:)
integer, intent(in) :: new_combinations(:,:)
integer, allocatable :: output(:,:)
allocate(output(size(input,1), size(input,2)+size(new_combinations,2)))
output(:, :size(input,2)) = input
output(:, size(input,2)+1:) = new_combinations
end function
and now the whole program looks like
program combinations
implicit none
integer :: comb(3)
integer, allocatable :: combs(:,:)
integer :: i
combs = gen(comb, 1, 5)
write(*, *) ""
do i=1,size(combs,2)
write(*, *) combs(:,i)
enddo
contains
recursive function gen(comb, m, n_max) result(combs)
integer, intent(inout) :: comb(:)
integer, intent(in) :: m
integer, intent(in) :: n_max
integer, allocatable :: combs(:,:)
integer :: n
integer :: n_min
integer, allocatable :: new_combs(:,:)
if (m > size(comb)) then
write (*, *) comb
combs = reshape(comb, [size(comb),1])
else
if (m == 1) then
n_min = 1
else
n_min = comb(m-1) + 1
endif
allocate(combs(size(comb), 0))
do n = n_min, n_max
comb(m) = n
new_combs = gen(comb, m+1, n_max)
combs = append_combinations(combs, new_combs)
end do
end if
end function gen
function append_combinations(input, new_combinations) result(output)
integer, intent(in) :: input(:,:)
integer, intent(in) :: new_combinations(:,:)
integer, allocatable :: output(:,:)
allocate(output(size(input,1), size(input,2)+size(new_combinations,2)))
output(:, :size(input,2)) = input
output(:, size(input,2)+1:) = new_combinations
end function
end program combinations

Gamma function implementation not producing correct values

Function programmed in Fortran 95 to compute values of the Gamma function from mathematics is not producing the correct values.
I am trying to implement a recursive function in Fortran 95 that computes values of the Gamma function using the Lanczos approximation (yes I know that there is an intrinsic function for this in the 2003 standard and later). I've followed the standard formula very closely so I'm not certain what is wrong. Correct values for the Gamma function are crucial for some other numerical computations I am doing involving the numerical computation of the Jacobi polynomials by means of a recursion relation.
program testGam
implicit none
integer, parameter :: dp = selected_real_kind(15,307)
real(dp), parameter :: pi = 3.14159265358979324
real(dp), dimension(10) :: xGam, Gam
integer :: n
xGam = (/ -3.5, -2.5, -1.5, -0.5, 0.5, 1.5, 2.5, 3.5, 4.5, 5.5 /)
do n = 1,10
Gam(n) = GammaFun(xGam(n))
end do
do n = 1,10
write(*,*) xGam(n), Gam(n)
end do
contains
recursive function GammaFun(x) result(G)
real(dp), intent(in) :: x
real(dp) :: G
real(dp), dimension(0:8), parameter :: q = &
(/ 0.99999999999980993, 676.5203681218851, -1259.1392167224028, &
771.32342877765313, -176.61502916214059, 12.507343278686905, &
-0.13857109526572012, 9.9843695780195716e-6, 1.5056327351493116e-7 /)
real(dp) :: t, w, xx
integer :: n
xx = x
if ( xx < 0.5_dp ) then
G = pi / ( sin(pi*xx)*GammaFun(1.0_dp - xx) )
else
xx = xx - 1.0_dp
t = q(0)
do n = 1,9
t = t + q(n) / (xx + real(n, dp))
end do
w = xx + 7.5_dp
G = sqrt(2.0_dp*pi)*(w**(xx + 0.5_dp))*exp(-w)*t
end if
end function GammaFun
end program testGam
Whereas this code should be producing correct values for the Gamma function over the whole real line, it seems only to produce a constant value close to 122 regardless of the input. I suspect that there is some weird floating point arithmetic issue that I am not seeing.
There are two obvious issues with your code
Most seriously the code accesses an array out of bounds at line 42, i.e. in the loop
do n = 1,9
t = t + q(n) / (xx + real(n, dp))
end do
You have mixed up your precision somewhat, with some of the constants being of kind dp, other being of default kind
Making what I believe are the appropriate fixes to these your program compiles, links and runs correctly, at least as far as I can see. See below:
ian#eris:~/work/stackoverflow$ cat g.f90
program testGam
implicit none
integer, parameter :: dp = selected_real_kind(15,307)
real(dp), parameter :: pi = 3.14159265358979324_dp
real(dp), dimension(10) :: xGam, Gam
integer :: n
xGam = (/ -3.5_dp, -2.5_dp, -1.5_dp, -0.5_dp, 0.5_dp, 1.5_dp, 2.5_dp, 3.5_dp, 4.5_dp, 5.5_dp /)
do n = 1,10
Gam(n) = GammaFun(xGam(n))
end do
do n = 1,10
write(*,*) xGam(n), Gam(n), gamma( xGam( n ) ), Abs( Gam( n ) - gamma( xGam( n ) ) )
end do
contains
recursive function GammaFun(x) result(G)
real(dp), intent(in) :: x
real(dp) :: G
real(dp), dimension(0:8), parameter :: q = &
(/ 0.99999999999980993_dp, 676.5203681218851_dp, -1259.1392167224028_dp, &
771.32342877765313_dp, -176.61502916214059_dp, 12.507343278686905_dp, &
-0.13857109526572012_dp, 9.9843695780195716e-6_dp, 1.5056327351493116e-7_dp /)
real(dp) :: t, w, xx
integer :: n
xx = x
if ( xx < 0.5_dp ) then
G = pi / ( sin(pi*xx)*GammaFun(1.0_dp - xx) )
else
xx = xx - 1.0_dp
t = q(0)
do n = 1,8
t = t + q(n) / (xx + real(n, dp))
end do
w = xx + 7.5_dp
G = sqrt(2.0_dp*pi)*(w**(xx + 0.5_dp))*exp(-w)*t
end if
end function GammaFun
end program testGam
ian#eris:~/work/stackoverflow$ gfortran -O -std=f2008 -Wall -Wextra -fcheck=all g.f90
ian#eris:~/work/stackoverflow$ ./a.out
-3.5000000000000000 0.27008820585226917 0.27008820585226906 1.1102230246251565E-016
-2.5000000000000000 -0.94530872048294168 -0.94530872048294179 1.1102230246251565E-016
-1.5000000000000000 2.3632718012073521 2.3632718012073548 2.6645352591003757E-015
-0.50000000000000000 -3.5449077018110295 -3.5449077018110318 2.2204460492503131E-015
0.50000000000000000 1.7724538509055159 1.7724538509055161 2.2204460492503131E-016
1.5000000000000000 0.88622692545275861 0.88622692545275805 5.5511151231257827E-016
2.5000000000000000 1.3293403881791384 1.3293403881791370 1.3322676295501878E-015
3.5000000000000000 3.3233509704478430 3.3233509704478426 4.4408920985006262E-016
4.5000000000000000 11.631728396567446 11.631728396567450 3.5527136788005009E-015
5.5000000000000000 52.342777784553583 52.342777784553519 6.3948846218409017E-014
ian#eris:~/work/stackoverflow$

Writing R package that call Fortran library

I'm trying to write an R package that calls a Fortran subroutine. I'm using Rstudio package template that creates a bunch of files and directories automatically.
In ./R/ I have a single file, Fpi.R
Fpi <- function(DARTS, ROUNDS) {
if (!is.loaded('Fpi')) {
dyn.load("./src/Fpi.so")
}
retvals <- .Fortran("pi", avepi = as.numeric(1), DARTS = as.integer(DARTS), ROUNDS = as.integer(ROUNDS))
return(retvals$avepi)
}
In ./src/ I have Fpi.f90
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
double precision :: x_coord, y_coord
integer :: score, n
score = 0
do n = 1, darts
call random_number(x_coord)
call random_number(y_coord)
if ((x_coord**2 + y_coord**2) <= 1.0d0) then
score = score + 1
end if
end do
dartsscore = 4.0d0*score/darts
end subroutine dboard
subroutine pi(avepi, DARTS, ROUNDS)
implicit none
double precision, intent(out) :: avepi
integer, intent(in) :: DARTS, ROUNDS
integer :: MASTER, rank, i, n
integer, allocatable :: seed(:)
double precision :: pi_est, homepi, pirecv, pisum
interface
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
end subroutine dboard
end interface
! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)
avepi = 0
do i = 0, ROUNDS-1
call dboard(darts, pi_est)
! calculate the average value of pi over all iterations
avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi
I also have the generic DESCRIPTION and NAMESPACE files that rstudio generates.
I can build and load the library but when I try to use it I get this error:
> library(MyPi)
> Fpi(DARTS = 100, ROUNDS = 100)
Error in .Fortran("pi", avepi = as.numeric(1), DARTS = as.integer(DARTS), :
"pi" not resolved from current namespace (MyPi)
How can I fix this? Thanks!
I just had to add one line to my NAMESPACE
useDynLib(Fpi)

using a Fortran module in R?

I am able to use a fortran subroutine in R as long as I don't have it inside a module.For example:
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
double precision :: x_coord, y_coord
integer :: score, n
score = 0
do n = 1, darts
call random_number(x_coord)
call random_number(y_coord)
if ((x_coord**2 + y_coord**2) <= 1.0d0) then
score = score + 1
end if
end do
dartsscore = 4.0d0*score/darts
end subroutine dboard
subroutine pi(avepi, DARTS, ROUNDS)
implicit none
double precision, intent(out) :: avepi
integer, intent(in) :: DARTS, ROUNDS
integer :: MASTER, rank, i, n
integer, allocatable :: seed(:)
double precision :: pi_est, homepi, pirecv, pisum
interface
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
end subroutine dboard
end interface
! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)
avepi = 0
do i = 0, ROUNDS-1
call dboard(darts, pi_est)
! calculate the average value of pi over all iterations
avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi
Can be compiled for R with:
R CMD SHLIB ./Fortran/Fpi.f90
and I can run it in R with:
mypi <- function(DARTS, ROUNDS) {
dyn.load("./Fortran/Fpi.so")
retvals <- .Fortran("pi", avepi = as.numeric(1), DARTS = as.integer(DARTS), ROUNDS = as.integer(ROUNDS))
return(retvals$avepi)
}
mypi(DARTS = 50000, ROUNDS = 10)
I would like to write my fortran subroutines inside a module. I thought this was not possible, but #roygvib and #francescalus mentioned it is in one of my previous questions
How do you do the "attaching bind("c",name=...)" thing that #roygvib mentioned in that post?
Thanks!
I made the changes suggested in the comments:
Module Fortranpi
IMPLICIT NONE
contains
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
double precision :: x_coord, y_coord
integer :: score, n
score = 0
do n = 1, darts
call random_number(x_coord)
call random_number(y_coord)
if ((x_coord**2 + y_coord**2) <= 1.0d0) then
score = score + 1
end if
end do
dartsscore = 4.0d0*score/darts
end subroutine dboard
subroutine pi(avepi, DARTS, ROUNDS) bind(C, name="pi_")
implicit none
double precision, intent(out) :: avepi
integer, intent(in) :: DARTS, ROUNDS
integer :: MASTER, rank, i, n
integer, allocatable :: seed(:)
double precision :: pi_est, homepi, pirecv, pisum
interface
subroutine dboard(darts, dartsscore)
implicit none
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
end subroutine dboard
end interface
! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)
avepi = 0
do i = 0, ROUNDS-1
call dboard(darts, pi_est)
! calculate the average value of pi over all iterations
avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi
end module Fortranpi
When I try to build the package with Rstudio I get these errors:
==> R CMD INSTALL --no-multiarch --with-keep.source MyPi
* installing to library ‘/home/ignacio/R/x86_64-pc-linux-gnu-library/3.2’
make: Nothing to be done for 'all'.
* installing *source* package ‘MyPi’ ...
** libs
installing to /home/ignacio/R/x86_64-pc-linux-gnu-library/3.2/MyPi/libs
** R
** preparing package for lazy loading
** help
*** installing help indices
** building package indices
** testing if installed package can be loaded
Error in library.dynam(lib, package, package.lib) :
shared object ‘Fortranpi.so’ not found
Error: loading failed
Execution halted
ERROR: loading failed
* removing ‘/home/ignacio/R/x86_64-pc-linux-gnu-library/3.2/MyPi’
* restoring previous ‘/home/ignacio/R/x86_64-pc-linux-gnu-library/3.2/MyPi’
Exited with status 1.
I believe the problem could be the NAMESPACE
useDynLib(Fpi)
exportPattern("^[[:alpha:]]+")
Thanks to #roygvib and #francescalus this is my working module:
Module Fortranpi
IMPLICIT NONE
contains
subroutine dboard(darts, dartsscore)
integer, intent(in) :: darts
double precision, intent(out) :: dartsscore
double precision :: x_coord, y_coord
integer :: score, n
score = 0
do n = 1, darts
call random_number(x_coord)
call random_number(y_coord)
if ((x_coord**2 + y_coord**2) <= 1.0d0) then
score = score + 1
end if
end do
dartsscore = 4.0d0*score/darts
end subroutine dboard
subroutine pi(avepi, DARTS, ROUNDS) bind(C, name="pi_")
use, intrinsic :: iso_c_binding, only : c_double, c_int
real(c_double), intent(out) :: avepi
integer(c_int), intent(in) :: DARTS, ROUNDS
integer :: MASTER, rank, i, n
integer, allocatable :: seed(:)
double precision :: pi_est, homepi, pirecv, pisum
! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)
avepi = 0
do i = 0, ROUNDS-1
call dboard(darts, pi_est)
! calculate the average value of pi over all iterations
avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi
end module Fortranpi

Call FORTRAN subroutine with allocatables in R?

This is a follow-up question to my previous Fortran question.
I have a working Fortran program that has a subroutine that filters an array. This is the program:
program test
integer, parameter :: n = 3
integer, parameter :: m = 4
double precision, dimension(n,m) :: A
double precision, dimension(:,:), allocatable :: B
A(1,:) = [11, 22, 43, 55]
A(2,:) = [15, 56, 65, 63]
A(3,:) = [54, 56, 32, 78]
print*, 'A :'
print*, int(A)
CALL extractB(A, B)
print*, 'B'
print*, int(B)
contains
subroutine extractB(A, B)
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(:,:), allocatable :: B
integer :: nrowB, i, pos
nrowB = count( A(:,2)==56)
allocate( B(nrowB, size(A,2)-1 ) )
pos = 1
do i = 1, size(A,1)
if(A(i,2)==56)then
B(pos,1) = A(i,1)
B(pos,2:) = A(i,3:)
pos = pos+1
end if
end do
end subroutine extractB
end program
The program compiles, runs, and it does what it has to do very well.
I want to call the extractB subroutine with R. I have asked similar questions and found was able to make them work, but this one is somehow different and not working.
My fortran subrutine is in the mytest.f90 file and has this code:
subroutine extractB(A, B)
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(:,:), allocatable :: B
integer :: nrowB, i, pos
nrowB = count( A(:,2)==56)
allocate( B(nrowB, size(A,2)-1 ) )
pos = 1
do i = 1, size(A,1)
if(A(i,2)==56)then
B(pos,1) = A(i,1)
B(pos,2:) = A(i,3:)
pos = pos+1
end if
end do
end subroutine extractB
I compile it in R and load the library with these commands:
system("R CMD SHLIB ./Fortran/mytest.f90")
dyn.load("./Fortran/mytest.so")
Then, in R, i create and pass a data frame to the subroutine
A = data.frame(c(11,15,54), c(22,56,56), c(43,65,32), c(55,63,78))
X<-.Fortran("extractB", A = unlist(A), B = numeric(6))
After that R crashes
*** caught segfault ***
address (nil), cause 'unknown'
Traceback:
1: .Fortran("extractB", A = unlist(A), B = numeric(6))
Possible actions:
1: abort (with core dump, if enabled)
2: normal R exit
3: exit R without saving workspace
4: exit R saving workspace
Selection:
If I change the subroutine by removing setting the dimensions by hand:
subroutine extract(A, B)
implicit none
double precision, dimension(3,4), intent(in) :: A
double precision, dimension(2,3) :: B
integer :: i, pos
pos = 1
do i = 1, size(A,1)
if(A(i,2)==56)then
B(pos,1) = A(i,1)
B(pos,2:) = A(i,3:)
pos = pos+1
end if
end do
end subroutine extract
recompile the library, and reload it. I can run
X<-.Fortran("extract", A = unlist(A), B = numeric(6))
dim(X$A) <- dim(A)
dim(X$B) <- c(2,3)
and get what I want
> X
$A
[,1] [,2] [,3] [,4]
[1,] 11 22 43 55
[2,] 15 56 65 63
[3,] 54 56 32 78
$B
[,1] [,2] [,3]
[1,] 15 65 63
[2,] 54 32 78
Any way of fixing this?
Thanks a lot for the help!
Though, as Vladimir F pointed out, this will not work with allocatables like this, you can allocate memory, that can be used by another language in Fortran. But you should use the pointer attribute in that case. However, you will not be able to make use of assumed shape arrays either. Instead of inferring the size of A, you should pass it in explicitly.
If you are willing to change the interface for this, you can get your functionality with something along these lines, (see also M. S. B.s answer to a related question):
subroutine extractB(A_ptr, lenX, lenY, B_ptr, nrowB) bind(c,name=extractB)
use iso_c_binding
implicit none
type(c_ptr), value :: A_ptr
integer(kind=c_int), value :: lenX, lenY
type(c_ptr) :: B_ptr
integer(kind=c_int) :: nrowB
real(kind=c_double), pointer :: A(:,:)
real(kind=c_double), pointer :: B(:,:)
integer :: i, pos
c_f_pointer(A_ptr, A, [lenX, lenY])
nrowB = count( A(:,2)==56)
allocate( B(nrowB, size(A,2)-1 ) )
!...
B_ptr = c_loc(B)
end subroutine extractB

Resources