Related
Background
I am trying to use the Basic Model Interface (BMI) to initialize the dflowfm model (that I have compiled from source to produce executables and shared libraries) from a fortran program.
I was able to do this successfully using a python wrapper by openearth.
However, on my fortran program, this fails with a segmentation fault that doesn't tell me much.
After some digging around, I (think) I was able to locate the source code that points to the function/subroutine that I want to call to initialize the model.
Any help is highly appreciated!
Issue
Below is my fortran program where I try to call the routine from the shared library as both a subroutine and function. Both fail with the error: forrtl: severe (174): SIGSEGV, segmentation fault occurred pointing the trace to the function/subroutine call. Here is the full trace:
forrtl: severe (174): SIGSEGV, segmentation fault occurred
Image PC Routine Line Source
libpthread-2.31.s 00007F04C9E19140 Unknown Unknown Unknown
libdflowfm.so.0.0 00007F04CB517080 Unknown Unknown Unknown
libdflowfm.so.0.0 00007F04CB517319 Unknown Unknown Unknown
testbmifort 000000000040F2E1 MAIN__ 39 bmi_fort-test.f90
testbmifort 000000000040F25D Unknown Unknown Unknown
libc-2.31.so 00007F04C9C4CD0A __libc_start_main Unknown Unknown
testbmifort 000000000040F17A Unknown Unknown Unknown
Debugging trace:
39 call init(sharedDLLHandle, c_config_file, strln)
(gdb) n
Program received signal SIGSEGV, Segmentation fault.
0x00007f03c2181080 in GetDllProcedure () from /opt/dflowfm/lib/libdflowfm.so.0
(gdb) bt
#0 0x00007f03c2181080 in GetDllProcedure () from /opt/dflowfm/lib/libdflowfm.so.0
#1 0x00007f03c2181319 in bmi_initialize_ () from /opt/dflowfm/lib/libdflowfm.so.0
#2 0x000000000040f384 in test_df_bmi () at bmi_fort-test.f90:39
#3 0x000000000040f25d in main ()
#4 0x00007f03c08b6d0a in __libc_start_main (main=0x40f240 <main>, argc=1, argv=0x7fff9bf4d658, init=<optimized out>, fini=<optimized out>, rtld_fini=<optimized out>, stack_end=0x7fff9bf4d648)
at ../csu/libc-start.c:308
#5 0x000000000040f17a in _start ()
bmi_fort-test.f90
compiled as ifort bmi_fort-test.f90 -L/opt/dflowfm/lib/ -ldflowfm -o testbmifort -traceback -warn interface -O0
(in case you are wondering the shared library has been compiled with ifort too)
module bmi
use iso_c_binding
implicit none
integer(C_INT64_T), BIND(C, name="MAXSTRLEN") :: MAXSTRLEN
! interface
! integer(C_INT64_T) function init(config) result(iresult) bind(C, name='bmi_initialize_')
! use iso_c_binding
! character*(c_char) :: config
! end function
! end interface
interface
subroutine init(sharedDLLHandle, config, strln) bind(C, name='bmi_initialize_')
use iso_c_binding
type(c_ptr), value :: sharedDLLHandle
! integer(C_INT64_T), pointer :: dll_ptr
character*(c_char) :: config
integer(c_int) :: strln
end subroutine
end interface
end module bmi
program test_df_bmi
use iso_c_binding
use bmi
type(c_ptr) :: sharedDLLHandle
! integer(C_INT64_T), pointer :: dll_ptr
character*(c_char) :: c_config_file
character(*), parameter :: config_file = "/home/bmi-python/test_data/e02_f14_c040_westerscheldt/westerscheldt.mdu"
integer(C_INT64_T) :: iresult
integer(c_int) :: strln
c_config_file = "/home/bmi-python/test_data/e02_f14_c040_westerscheldt/westerscheldt.mdu"
strln = len(config_file)
! iresult = init(c_config_file)
call init(sharedDLLHandle, c_config_file, strln)
end program test_df_bmi
The shortened output from the command nm -D /opt/dflowfm/lib/libdflowfm.so reveals the existence of the procedure I wish to call: 00000000015a5300 T bmi_initialize_.
If I understand correctly from a few stackoverflow posts, the underscore at the end must mean it is a C routine.
Now, here are some scraps from the source files that I think resulted in the production of the routine I wish to call (the entire source tree is too huge to attach; I did an expression search in the source tree to filter out all the places that could be relevant and traced them back to these two snippets from two source files):
sf1.f90 (source)
...
!> The initialize() function accepts a string argument that
!! gives the name (and path) of its "main input file", called
!! a configuration file. This function should perform all tasks
!! that are to take place before entering the model's time loop.
integer(c_int) function initialize(c_config_file) result(c_iresult) bind(C, name="initialize")
!DEC$ ATTRIBUTES DLLEXPORT :: initialize
use iso_c_binding, only: c_char
...
character(kind=c_char),intent(in) :: c_config_file(MAXSTRLEN)
character(len=strlen(c_config_file)) :: config_file
! Extra local variables
integer :: inerr ! number of the initialisation error
...
c_iresult = 0 ! TODO: is this return value BMI-compliant?
#ifdef HAVE_MPI
...
! Store the name
config_file = char_array_to_string(c_config_file, strlen(c_config_file))
! Now we can initialize with the config_file
...
! TODO: check why these are needed to avoid a segfault
KNX = 8
MXB = 10
MAXLAN = 500
MAXPOL = MAXLAN
...
CALL INIDAT()
call api_loadmodel(config_file)
...
c_iresult = flowinit()
time_user = tstart_user
! Just terminate if we get an error....
! if (inerr > 0) stop
! initialize = 0
end function initialize
...
sf2.c (source)
...
long STDCALL BMI_INITIALIZE(int64_t * sharedDLLHandle,
char * config_file,
int config_file_len)
{
typedef (STDCALL * MyProc)(chvoid *ar *);
MyProc proc = (MyProc)GetDllProcedure(sharedDLLHandle, "initialize");
long error = -1;
char * c_config_file = strFcpy(config_file, config_file_len);
RemoveTrailingBlanks_dll(c_config_file);
if (proc != NULL)
{
error = 0;
(void *)(*proc)(c_config_file);
}
free(c_config_file); c_config_file = NULL;
return error;
}
...
Side question:
Is there a way to check the necessary arguments and data types of the arguments of this routine from the shared library?
Additional info
This is the python program that was successfully able to initialize and run the model using the library:
df_bmi-test.py
import bmi.wrapper as bw
dflowfm = bw.BMIWrapper(engine='dflowfm', configfile='test_data/retracted/path.mdu')
dflowfm.initialize()
Here is the part of bmi.wrapper (source) I think is relevant to set this up:
...
def wrap(func):
"""Return wrapped function with type conversion and sanity checks.
"""
#functools.wraps(func, assigned=('restype', 'argtypes'))
def wrapped(*args):
if len(args) != len(func.argtypes):
logger.warn("{} {} not of same length",
args, func.argtypes)
typed_args = []
for (arg, argtype) in zip(args, func.argtypes):
if argtype == c_char_p:
# create a string buffer for strings
typed_arg = create_string_buffer(arg)
else:
# for other types, use the type to do the conversion
if hasattr(argtype, 'contents'):
# type is a pointer
typed_arg = argtype(argtype._type_(arg))
else:
typed_arg = argtype(arg)
typed_args.append(typed_arg)
result = func(*typed_args)
if hasattr(result, 'contents'):
return result.contents
else:
return result
return wrapped
...
def _load_library(self):
"""Return the fortran library, loaded with """
path = self._library_path()
logger.info("Loading library from path {}".format(path))
library_dir = os.path.dirname(path)
if platform.system() == 'Windows':
import win32api
olddir = os.getcwd()
os.chdir(library_dir)
win32api.SetDllDirectory('.')
result = cdll.LoadLibrary(path)
if platform.system() == 'Windows':
os.chdir(olddir)
return result
def initialize(self, configfile=None):
"""Initialize and load the Fortran library (and model, if applicable).
The Fortran library is loaded and ctypes is used to annotate functions
inside the library. The Fortran library's initialization is called.
Normally a path to an ``*.ini`` model file is passed to the
:meth:`__init__`. If so, that model is loaded. Note that
:meth:`_load_model` changes the working directory to that of the model.
"""
if configfile is not None:
self.configfile = configfile
try:
self.configfile
except AttributeError:
raise ValueError("Specify configfile during construction or during initialize")
abs_name = os.path.abspath(self.configfile)
os.chdir(os.path.dirname(self.configfile) or '.')
logmsg = "Loading model {} in directory {}".format(
self.configfile,
os.path.abspath(os.getcwd())
)
logger.info(logmsg)
# Fortran init function.
self.library.initialize.argtypes = [c_char_p]
self.library.initialize.restype = None
# initialize by abs_name because we already chdirred
# if configfile is a relative path we would have a problem
ierr = wrap(self.library.initialize)(abs_name)
if ierr:
errormsg = "Loading model {config} failed with exit code {code}"
raise RuntimeError(errormsg.format(config=self.configfile,
code=ierr))
...
I am wondering what is the correct way of interfacing with C, when the C methods have optional arguments (i.e. you are allowed to pass NULL) and you want the optional arguments to propage to the Fortran API.
Is there a benefit in including the optional keyword in both the Fortran method's argument list and the interface block? see: err_c argument in null_return_f90>C_API.
Is it legal to initialise a local variable with an optional input variable and pass that to the C interface? (this feels wrong, it doesn't feel like it should work, yet it does). see: name_c variable, its initialisation and input to C_API in null_str_f90 subroutine.
I have provided a MWE below demonstrating what I am asking and as far as I can tell, the answers to my questions are 1. it doesn't matter 2. yes, but I am not entirely convinced they are correct, especially 2.
If there is a better way on how to write the Fortran API I would be open to that as well, but what I cannot do is edit the C API.
Related post: Calling Fortran subroutines with optional arguments from C++
MWE
program main
use, intrinsic :: iso_c_binding
implicit none
integer(c_int) :: err
call null_str_f90("abc")
call null_str_f90()
print*, repeat("*", 10)
call null_return_f90()
call null_return_f90(err)
print*, "error code:", err
contains
function istring_(o) result(v)
character(len=*), intent(in) :: o
character(len=:, kind=c_char), allocatable :: v
v = trim(o)//c_null_char
end function istring_
subroutine null_return_f90(err)
interface
subroutine C_API(err_c) bind(C, name="null_return")
use, intrinsic :: iso_c_binding
integer(c_int), optional, intent(out) :: err_c ! 1. does the optional do anything?
end subroutine C_API
end interface
integer(c_int), optional, intent(out) :: err
call C_API(err_c=err) ! 1. Is this safe & portable?
end subroutine null_return_f90
subroutine null_str_f90(str)
interface
subroutine C_API(str_c) bind(C, name="null_str")
use, intrinsic :: iso_c_binding
character(len=1, kind=c_char), dimension(*), optional, intent(in) :: str_c
end subroutine C_API
end interface
character(len=*), intent(in), optional :: str
! Local variables
character(len=:, kind=c_char), allocatable :: name_c
if (present(str)) name_c = istring_(str)
call C_API(str_c=name_c) ! 2. Is this safe & portable?
end subroutine null_str_f90
end program main
#include <stdio.h>
void null_str(const char *str) {
if (str) {
printf("str is present: str is %s\n", str);
} else {
printf("str is not present\n");
}
}
void null_return(int *opt) {
if (opt) {
*opt = 1;
} else {
printf("opt is not present\n");
}
}
Compiling
Turn on aggressive non-IEEE compliant optimisations to ensure this will still work.
gcc -c -Ofast -Wall null_args.c -o null_args.o
gfortran -Ofast -Wall null_args.o null_args.f90 -o null_args
./null_args
Output
str is present: str is abc
str is not present
**********
opt is not present
error code: 1
**********
For null_return_f90 and its C_API, we must have err_c in that latter as an optional argument. Without it being optional, we cannot associate an absent err with it in that call. If it is optional, then it's fine to use the optional and not present actual argument err.
Looking at the subroutine null_str_f90 we have the following:
character(len=:, kind=c_char), allocatable :: name_c
if (present(str)) name_c = istring_(str)
call C_API(str_c=name_c) ! 2. Is this safe & portable?
Your concern is that if the actual argument str is not present, then name_c is undefined1 when it comes to the call to C_API. This is true, but is not a concern.
name_c remains not allocated rather than simply undefined. An allocatable actual argument which is not allocated (or a pointer which is not associated) is allowed to be associated with an ordinary optional dummy argument. In this case it will be treated as a not present actual argument, just as if it weren't given at all.
1 You state "uninitialized" but definition and initialization are very different things, and initialization is not relevant to this case.
Keeping in mind that function arguments:
in C they are passed by value, hence, they are unchanged on output; the only way to change a variable which is not the function's return value, is to pass a pointer to it (your int* err_c is a pointer to integer(s))
in Fortran they are passed by reference by default, unless otherwise specified (value keyword).
whenever you write a Fortran interface to a C function that involves a pointer, you have these options:
Copy the C approach, set it as a pointer
type(c_ptr), intent(in), value :: c_err
You can always shape it to an appropriate Fortran derived type and shape by using c_f_pointer, and/or access the C pointer of a Fortran target variable using c_loc
You lose information about the original type (int) in this case
Use the Fortran approach, i.e. reference that pointer to a given type, shape, intent. For example in your case, you could use any of
integer(c_int), intent(out) :: c_err
integer(c_int), intent(out) :: c_err(*)
Note that the C routine, per se, doesn't tell you which one is right, but the Fortran compiler will check it.
Now you're trying to use the optional keyword to hide the fact of a C pointer being NULL as opposed to a Fortran variable being present or not. The C standard does not allow for optional inputs; while the Fortran standard does not like null stuff. It seems like even Fortran standard gurus do not fully agree on what's allowed by the standard or not (see here), I'd go with using the optional keyword in the interface only if that's useful on the Fortran side.
See this example:
module test_c_opt
use iso_c_binding
implicit none
interface
! Pass-by-reference interface
subroutine C_reference(err_c,message) bind(C, name="null_return")
import c_int,c_char
integer(c_int), intent(out) :: err_c
character(len=1,kind=c_char), intent(in) :: message(*)
end subroutine C_reference
subroutine C_reference_arr(err_c,message) bind(C, name="null_return")
import c_int,c_char
integer(c_int), intent(out) :: err_c(*)
character(len=1,kind=c_char), intent(in) :: message(*)
end subroutine C_reference_arr
! Pass-by-value interface
subroutine C_value(err_c,message) bind(C, name="null_return")
import c_ptr,c_char
type(c_ptr), intent(in), value :: err_c
character(len=1,kind=c_char), intent(in) :: message(*)
end subroutine C_value
end interface
end module test_c_opt
program test
use test_c_opt
use iso_c_binding
implicit none
integer(c_int), target :: ierr,ierr10(10)
integer(c_int), allocatable, target :: ierra,ierra10(:)
character(len=255,kind=c_char) :: msg
msg = 'reference, static' //c_null_char; call C_reference(ierr,msg)
msg = 'value , static' //c_null_char; call C_value(c_loc(ierr),msg)
msg = 'reference, not alloc' //c_null_char; call C_reference(ierra,msg)
msg = 'value , not alloc' //c_null_char; call C_value(c_loc(ierra),msg)
allocate(ierra)
msg = 'reference, allocated' //c_null_char; call C_reference(ierra,msg)
msg = 'value , allocated' //c_null_char; call C_value(c_loc(ierra),msg)
msg = 'reference, not alloc(10)' //c_null_char; call C_reference_arr(ierra10,msg)
allocate(ierra10(10))
msg = 'reference, alloc(10)' //c_null_char; call C_reference_arr(ierra10,msg)
print *, 'from fortran, ierra(10)=',ierra10
!msg = 'reference, static(10)'//c_null_char; call C_reference(ierr10,msg) ! error: fortran checks this is not a scalar
msg = 'value , static(10)'//c_null_char; call C_value(c_loc(ierr10),msg)
end program test
#include <stdio.h>
void null_return(int *opt, char* message) {
if (opt) {
*opt = 1;
printf("when [%s], opt is present, set opt=%d \n", message, *opt);
} else {
printf("when [%s], opt is not present\n");
}
}
it works in all cases without optional anyways, which prints (gfortran-12)
when [reference, static], opt is present, set opt=1
when [value , static], opt is present, set opt=1
when [reference, not alloc], opt is not present
when [value , not alloc], opt is not present
when [reference, allocated], opt is present, set opt=1
when [value , allocated], opt is present, set opt=1
when [reference, not alloc(10)], opt is not present
when [reference, alloc(10)], opt is present, set opt=1
from fortran, ierra(10)= 1 0 0 0 0 0 0 0 0 0
when [value , static(10)], opt is present, set opt=1
I am writing a little dlopen-based plugin mechanism and I'd like to show how to implement a "hello world" plugin in various languages.
Fortran is next. My Fortran days are a bit behind (at the time it was spelled FORTRAN77).
I'd like to do the equivalent C hello world, with Fortran ISO_C_BINDING mechanism:
#include <stdlib.h>
#include <stdio.h>
typedef struct {
const char *name;
void *svcLocator;
} Alg_t;
// c_alg_new returns a new Alg_t C-algorithm.
void *c_alg_new(const char *name, void *svcLocator) {
Alg_t *ctx = (Alg_t*)malloc(sizeof(Alg_t));
ctx->name = name;
ctx->svcLocator = svcLocator;
return (void*)ctx;
}
// c_alg_del deletes an Alg_t C-algorithm.
void c_alg_del(void *self) {
free(self);
return;
}
int c_alg_ini(void *self) {
Alg_t *ctx = (Alg_t*)self;
fprintf(stdout, ">>> initialize [%s]...\n", ctx->name);
fprintf(stdout, ">>> initialize [%s]... [done]\n", ctx->name);
return 0;
}
int c_alg_exe(void *self) {
Alg_t *ctx = (Alg_t*)self;
fprintf(stdout, ">>> execute [%s]...\n", ctx->name);
fprintf(stdout, ">>> execute [%s]... [done]\n", ctx->name);
return 0;
}
int c_alg_fin(void *self) {
Alg_t *ctx = (Alg_t*)self;
fprintf(stdout, ">>> finalize [%s]...\n", ctx->name);
fprintf(stdout, ">>> finalize [%s]... [done]\n", ctx->name);
return 0;
}
here is what I have right now:
program foo
use, intrinsic :: iso_c_binding, only : c_int, c_ptr, c_char, c_null_char
implicit none (type, external)
type, bind(C) :: Alg
character(kind=c_char) :: name(1000)
type (c_ptr) :: svcloc
end type Alg
!! function f_alg_new() result(ctx)
!! type(Alg) :: ctx
!! end function
end program
the idea is to have another component dlopen a given .so, locate some "well known" symbols and require:
a symbol to instantiate plugin components
a symbol to delete a plugin component
a trio of symbols to initialize, execute, finalize plugin components.
the plugin components would be instantiated by the "manager" of plugin components.
I am a bit at loss as how to write the f_alg_new, f_alg_del and f_alg_{ini,exe,fin} Fortran equivalents.
any hint?
EDIT
on the plugin manager side, here is some mock up code:
void foo(void *lib) {
// load "component-new" symbol
void *cnew = dlsym(lib, "f_alg_new");
if (cnew == NULL) { ... }
void *cdel = dlsym(lib, "f_alg_del");
if (cdel == NULL) { ... }
void *cini = dlsym(lib, "f_alg_ini");
if (cini == NULL) { ... }
// etc...
// create a new Fortran, C, Go, ... component
void *ctx = (*cnew)("f-alg-0", NULL);
// initialize it:
int err = (*cini)(ctx);
if (err != 0) { ... }
for (int ievent=0; ievent < NEVTS; ievent++) {
int err = (*cexe)(ctx);
if (err != 0) { ... }
}
// finalize it:
err = (*cfin)(ctx);
if (err != 0) { ... }
// destroy/clean-up
(*cdel)(ctx);
}
memory allocated by the plugin is managed plugin-side (hence the xyz_new and xyz_del hooks), and the "main" program only schedules the execution of these hooks on the opaque address returned by the xyz_new hook.
I managed to get something working:
lib.f90
!! function f_alg_new creates a new alg value.
type(c_ptr) function f_alg_new(name, svc) bind(C) result(cptr)
use, intrinsic :: iso_c_binding
use falg
implicit none
character(kind=c_char),dimension(*), intent(in) :: name(1024)
type (c_ptr), intent(in), value :: svc
type (alg), pointer :: ctx
integer :: len
allocate(ctx)
len=0
do
if (name(len+1) == c_null_char) exit
len = len + 1
ctx%name(len) = name(len)
end do
ctx%len = len
cptr = c_loc(ctx)
end function
!! function f_alg_del destroys the alg value.
subroutine f_alg_del(cptr) bind(C)
use, intrinsic :: iso_c_binding
use falg
implicit none
type (c_ptr), intent(in), value :: cptr
type (alg), pointer :: ctx
call c_f_pointer(cptr, ctx)
deallocate(ctx)
end subroutine
integer(c_int) function f_alg_ini(cptr) bind(C) result(sc)
use, intrinsic :: iso_c_binding
use falg
implicit none
type (c_ptr), intent(in), value :: cptr
type (alg), pointer :: ctx
call c_f_pointer(cptr, ctx)
print *,"initialize... [", ctx%name(1:ctx%len), "]"
print *,"initialize... [", ctx%name(1:ctx%len), "] [done]"
sc = 0
end function
integer(c_int) function f_alg_exe(cptr) bind(C) result(sc)
use, intrinsic :: iso_c_binding
use falg
implicit none
type (c_ptr), intent(in), value :: cptr
type (alg), pointer :: ctx
call c_f_pointer(cptr, ctx)
print *,"execute... [", ctx%name(1:ctx%len), "]"
print *,"execute... [", ctx%name(1:ctx%len), "] [done]"
sc = 0
end function
integer(c_int) function f_alg_fin(cptr) bind(C) result(sc)
use, intrinsic :: iso_c_binding
use falg
implicit none
type (c_ptr), intent(in), value :: cptr
type (alg), pointer :: ctx
call c_f_pointer(cptr, ctx)
print *,"finalize... [", ctx%name(1:ctx%len), "]"
print *,"finalize... [", ctx%name(1:ctx%len), "] [done]"
sc = 0
end function
falg.f90
module falg
use, intrinsic :: iso_c_binding, only : c_ptr, c_size_t, c_char, c_loc
implicit none
type, bind(C) :: alg
character(kind=c_char) :: name(1024)
integer(c_size_t) :: len
type (c_ptr) :: svcloc
end type alg
end module falg
suggestions for better handling of the name field of alg appreciated :)
(as well as improvements on general style and stuff)
Problem statement
The main part of my code is in C (called from Python). The C-part calls functions written in Fortran. Possible errors are propagated using an error-code and an error-string with a description of the error.
The problem is that I cannot seem to get the correct interface to write the string in Fortran and read/copy/manipulate it in C. The code below outlines what I want to do, the comments with marked with * ... * indicate where extensions are needed.
C
// global variable: read from Python if an error is encountered
char* error_string;
// template for the Fortan-subroutine
void fortran_calculation_( double* , int* );
int heavy_calculation( double* x )
{
int error_code;
// ... some code ...
// * should accept and write "error_string" *
fortran_calculation_( x , &error_code );
if ( error_code )
{
error_string = "TO BE WRITTEN BY FORTRAN > REMOVE!!";
return 1;
}
// ... some code ...
return 0;
}
Fortran
subroutine fortran_calculation_(x,error_code)
implicit none
! * include "error_string" as argument *
real*8 :: x
integer :: error_code
! ... some code ...
if ( ... ) then
! * write "error_string" *
error_code = 1
return
end if
return
end subroutine
I've tried many things, but I cannot seem to get it working...
You have two problems. One, how to access a C global variable from Fortran. This one is relatively straightforward, create an interface in a module with iso_c_binding. See https://gcc.gnu.org/onlinedocs/gfortran/Interoperable-Global-Variables.html for an example.
However, the trickier problem is that you have defined your error_string as a pointer to char. That means that your Fortran code must allocate the string before writing to it. The Fortran allocatable and pointer variables work with descriptors, not raw pointers, so you must first create an interface to the C malloc function. Only after that you can write to it. Something like:
module my_error_string
use iso_c_binding
interface
type(c_ptr) function c_malloc(size) bind(C, name="malloc")
use iso_c_binding
integer(kind=c_size_t), value :: size
end function c_malloc
end interface
type(c_ptr), bind(C) :: error_string
contains
subroutine write_error(str)
character(len=*) :: str
character, pointer :: fstr(:)
integer(c_size_t) :: strlen
integer :: i
strlen = len(str, kind=c_size_t) + 1_c_size_t
error_string = c_malloc(strlen)
if (.not. c_associated(error_string)) then
call perror("error_string is a null pointer => malloc failed?!")
stop 1
end if
call c_f_pointer(error_string, fstr, shape=[strlen])
do i = 1, len(str)
fstr(i) = str(i:i)
end do
fstr(strlen) = c_null_char
end subroutine write_error
end module my_error_string
(It might be simple to change the interface such that you instead pass an allocated C string to the Fortran function to fill in, or perhaps use a callback function. But the above works, if that's what you want.)
Here is a shamefully ugly "solution" to your problem, based on the design you provided.
main.c:
#include <stdio.h>
#include <string.h>
char error_string_[512];
void fortan_calculation_( double*, int*, int* );
int main() {
double d = 2.5;
int l, i = 3;
memset( error_string_, 0, 512 );
fortan_calculation_( &d, &i, &l );
error_string_[l] = 0;
printf( "After call: '%s'\n", error_string_ );
}
error.f90:
subroutine fortan_calculation( d, i, l )
implicit none
character(512) str
common /error_string/ str
double precision d
integer i, l
str = "Hello world!"
l = len_trim( str )
end subroutine fortan_calculation
Compilation and test:
$ gcc -c main.c
$ gfortran -c error.f90
$ gcc main.o error.o -lgfortran
$ ./a.out
After call: 'Hello world!'
But that is just disgusting code: it assumes a lot of (arguably) common practices for Fortran compilers, whereas it exists some ways of linking properly C and Fortran using the iso_c_binding Fortran module.
I'll have a look and see if I can come up with a proper solution to that.
EDIT: actually, there's a nice SO page about that available.
I'm trying to call the GSL rountine CQUAD from Fortran. My idea was to write a .c subroutine that calls the gsl rountine and depends on a function and bounds. Two problems: I have only very little idea about c and fortrans iso_c_binding. My attempt is as follows:
A simple calling program (similar to M.S.B's post in No output from a Fortran program using the Gnu Scientific Library via a c wrapper ):
program test
use iso_c_binding
interface
function my_cquad (f,a,b) bind(c)
import
real (kind=c_double) :: my_cquad
interface
function f(x) bind(c)
import
real(kind=c_double) :: f,x
end function
end interface
real (kind=c_double) :: a,b
end function my_cquad
end interface
real (kind=c_double) :: y,a,b
a=0. ; b=1.
y=my_cquad(g,a,b)
print*,y
stop
contains
function g(x) bind(C)
real(kind=c_double) :: g,x
g=sin(x)/x
return
end function g
end program test
The .c subroutine (basically taken from the example given by the author of CQUAD in https://scicomp.stackexchange.com/questions/4730/numerical-integration-handling-nans-c-fortran):
#include <stdio.h>
#include <gsl/gsl_integration.h>
double my_cquad ( double my_f() , double a , double b )
{
gsl_function f;
gsl_integration_cquad_workspace *ws = NULL;
double res, abserr;
size_t neval;
/* Prepare the function. */
f.function = my_f;
f.params = NULL;
/* Initialize the workspace. */
if ( ( ws = gsl_integration_cquad_workspace_alloc( 200 ) ) == NULL ) {
printf( "call to gsl_integration_cquad_workspace_alloc failed.\n" );
abort();
}
/* Call the integrator. */
if ( gsl_integration_cquad( &f, a , b , 1.0e-10 , 1.0e-10 , ws , &res , &abserr , &neval ) != 0 ) {
printf( "call to gsl_integration_cquad failed.\n" );
abort();
}
/* Free the workspace. */
gsl_integration_cquad_workspace_free( ws );
/* Bye. */
return res;
}
The .c subroutine alone seems to work fine. This can be tested with:
double g (double x)
{
return sin(x)/x;
}
int main () {
double y;
y=my_cquad(g,0.,1.);
printf("y: %2.18f\n", y);
return 0;
}
But together with the .f90 calling program, at the moment it compiles but at runtime I get a segmentation fault that I don't quite get.
Additionally, it would of course be good to have some kind of wrapper that creates a c-type function depending on a fortran type function. I'm thinking about something like:
function f_to_c(f) bind(c)
real(kind=c_double) :: f_to_c
real(kind=8) :: f
f_to_c=real(f,kind=c_double)
end function
But this desn't cover the dummy variables.
Thanks in advance and very sorry for the amount of code.
Beware, according to the Fortran standard internal functions shall not have the bind(C) attribute. I moved the function to a module.
The a and b must be passed by value to my_cquad and x to the integrated function:
module functions_to_integrate
use iso_c_binding
contains
function g(x) bind(C)
real(kind=c_double) :: g
real(kind=c_double), value :: x
g = sin(x)/x
end function g
end module
program test
use iso_c_binding
use functions_to_integrate
interface
function my_cquad (f,a,b) bind(c)
import
real (kind=c_double) :: my_cquad
interface
function f(x) bind(c)
import
real(kind=c_double) :: f
real(kind=c_double), value :: x
end function
end interface
real (kind=c_double), value :: a,b
end function my_cquad
end interface
real (kind=c_double) :: y,a,b
a = 0 ; b = 1
y = my_cquad(g,a,b)
print *,y
end program test
test:
> gfortran my_cquad.c test_cquad.f90 -lgsl -lopenblas
> ./a.out
0.94608307036718275
This is an example of a wrapper to a normal Fortran function (please do not use kind=8 for many reasons explained in another questions):
module functions_to_integrate
use iso_fortran_env
use iso_c_binding
integer, parameter :: wp = real64
contains
pure function g(x)
real(kind=wp) :: g
real(kind=wp), intent(in) :: x
g = sin(x)/x
end function g
function g_to_c(x) bind(C)
real(kind=c_double) :: g_to_c
real(kind=c_double), value :: x
g_to_c = real(g(x),kind=c_double)
end function
end module
program test
use iso_c_binding
use functions_to_integrate
interface
function my_cquad (f,a,b) bind(c)
import
real (kind=c_double) :: my_cquad
interface
function f(x) bind(c)
import
real(kind=c_double) :: f
real(kind=c_double), value :: x
end function
end interface
real (kind=c_double), value :: a,b
end function my_cquad
end interface
real (kind=c_double) :: y,a,b
a = 0 ; b = 1
y = my_cquad(g_to_c,a,b)
print *,y
end program test
P.S. I also deleted your stop and return statement before the end. Somehow it is always driving me mad, but that may be just my OCD. I was too used to see it in old programs coming from ancient times.
P.P.S: You may wish to see the FGSL interface package linked by Vincius Miranda http://www.lrz.de/services/software/mathematik/gsl/fortran/ . I knew about that one, but I tried mainly to point out the errors so that you can make similar interfaces yourself, where no ready-made package is available.