Commit cda7a8e6 authored by Thomas Jahns's avatar Thomas Jahns 🤸
Browse files

Factor-out step of C/Fortran glue code separation.

parent d73c5415
......@@ -56,6 +56,7 @@ libscalesppm_la_SOURCES=ppm/scales_ppm.f90 \
ppm/ppm_set_partition_base.f90 \
ppm/ppm_set_partition_base.h \
ppm/ppm_set_partition_base_c.c \
ppm/ppm_set_partition_base_cf.c \
solver/solver_public.f90 \
solver/solver_internal.f90 \
solver/solver_config.f90 \
......@@ -83,7 +84,9 @@ libscalesppm_la_SOURCES=ppm/scales_ppm.f90 \
core/ppm_math_extensions.f90 \
core/ppm_real_sp_dp_edit_descriptor.f90 \
core/ppm_math_extensions_c.c \
core/ppm_math_extensions_cf.c \
core/ppm_math_extensions_ddp_c.c \
core/ppm_math_extensions_ddp_cf.c \
core/ppm_math_extensions.h \
core/ppm_math_extensions_internal.f90 \
core/ppm_fpu_underflow.h \
......@@ -95,8 +98,10 @@ libscalesppm_la_SOURCES=ppm/scales_ppm.f90 \
core/ppm_irand_internal.f90 \
core/ppm_random.f90 \
core/ppm_random.h \
core/ppm_random_cf.c \
core/ppm_random_c.c \
core/ppm_omp_assign.h \
core/ppm_random_mt_cf.c \
core/ppm_random_mt_c.c \
core/ppm_f90_io_lun.f90 \
core/ppm_strio.f90 \
......@@ -162,6 +167,7 @@ EXTRA_libscalesppm_la_SOURCES = ppm/ppm_graph_partition_mpi.f90 \
core/ppm_extents_mp.f90 \
core/ppm_ncdf_dump.f90 core/ppm_ncdf_dump_wrappers.f90 \
core/errhandler.c core/errhandler.h \
core/errhandler_cf.c \
crypto/md5.c crypto/md5.h \
core/ppm_std_type_kinds_mp_c.c \
core/ppm_std_type_kinds_mp.h \
......@@ -279,13 +285,16 @@ endif
libscalesppm_la_SOURCES += \
core/errhandler.c \
core/errhandler_cf.c \
core/errhandler.h \
core/ppm_xmpi.c \
core/ppm_extents_mp.f90 \
core/ppm_extents_mp_c.c \
core/ppm_extents_mp_cf.c \
core/ppm_extents_mp.h \
core/ppm_std_type_kinds_mp.f90 \
core/ppm_std_type_kinds_mp_c.c \
core/ppm_std_type_kinds_mp_cf.c \
core/ppm_std_type_kinds_mp.h \
core/ppm_math_extensions_ddp_mp_c.c \
\
......
/*
* errhandler.c --- install abort(2) as MPI error handler to yield a
* core file which can be inspected with a debugger
/**
* errhandler_cf.c --- install abort(2) as MPI error handler to yield a
* core file which can be inspected with a
* debugger, Fortran wrapper function
*
*
* Copyright (C) 2010 Thomas Jahns <jahns@dkrz.de>
* Copyright (C) 2021 Thomas Jahns <jahns@dkrz.de>
*
* Version: 1.0
* Keywords:
......@@ -42,26 +44,10 @@
#include "config.h"
#endif
#include <stdlib.h>
#include <mpi.h>
#include "errhandler.h"
#include "cfortran.h"
#include "core/core.h"
#include "core/errhandler.h"
void
PPM_set_mpi_abort_handler(MPI_Comm comm)
{
MPI_Errhandler errh;
#if MPI_VERSION > 2 || MPI_VERSION == 2 && MPI_SUBVERSION >= 2
#define MPI_Comm_errhandler_fn MPI_Comm_errhandler_function
#endif
if (MPI_Comm_create_errhandler((MPI_Comm_errhandler_fn *)abort,
&errh) != MPI_SUCCESS)
PPM_abort(comm, "Error handler creation failed.", __FILE__, __LINE__);
if (MPI_Comm_set_errhandler(comm, errh) != MPI_SUCCESS)
PPM_abort(comm, "Error handler setup failed.", __FILE__, __LINE__);
}
static void
PPM_set_mpi_abort_handler_f(MPI_Fint *comm_f)
......@@ -74,15 +60,12 @@ PPM_set_mpi_abort_handler_f(MPI_Fint *comm_f)
PPM_set_mpi_abort_handler(comm_c);
}
FCALLSCSUB1(PPM_set_mpi_abort_handler_f, PPM_SET_MPI_ABORT_HANDLER,
ppm_set_mpi_abort_handler, PVOID)
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
* license-markup: "doxygen"
* license-default: "bsd"
* End:
*/
/**
* @file ppm_extents_mp_c.c --- build MPI datatype for PPM_extent struct
* @file ppm_extents_mp_cf.c --- build MPI datatype for PPM_extent
* struct, Fortran wrapper
*
* @copyright (C) 2014 Thomas Jahns <jahns@dkrz.de>
* @copyright (C) 2021 Thomas Jahns <jahns@dkrz.de>
*
* @author Thomas Jahns <jahns@dkrz.de>
*/
......@@ -41,70 +42,20 @@
#include "config.h"
#endif
#include <assert.h>
#include <stdbool.h>
#include <stdlib.h>
#include <mpi.h>
#include "core/ppm_visibility.h"
#define FCALLSC_QUALIFIER PPM_DSO_INTERNAL
#include "cfortran.h"
#include "core/ppm_visibility.h"
#include "core/ppm_extents_mp.h"
#include "core/ppm_xfuncs.h"
MPI_Datatype PPM_extent_mp = MPI_DATATYPE_NULL;
void
PPM_create_extents_mp(void)
{
#pragma omp single
if (PPM_extent_mp == MPI_DATATYPE_NULL)
{
MPI_Datatype elemtype;
#if MPI_VERSION > 2 || ( MPI_VERSION == 2 && MPI_SUBVERSION > 1 )
elemtype = MPI_INT32_T;
#else
xmpi(MPI_Type_match_size(MPI_TYPECLASS_INTEGER, sizeof (int32_t), &elemtype));
#endif
xmpi(MPI_Type_contiguous(2, elemtype, &PPM_extent_mp));
xmpi(MPI_Type_commit(&PPM_extent_mp));
MPI_Comm comm_self_clone;
xmpi(MPI_Comm_dup(MPI_COMM_SELF, &comm_self_clone));
enum {
msg_count = 5,
};
struct PPM_extent a[msg_count] = { { 123456, 78901 } }, b[msg_count];
for (size_t i = 1; i < msg_count; ++i)
a[i] = (struct PPM_extent){ a[0].first + 333 * (int32_t)i,
a[0].size + 555 * (int32_t)i };
xmpi(MPI_Sendrecv(a, msg_count, PPM_extent_mp, 0, 1,
b, msg_count, PPM_extent_mp, 0, 1,
comm_self_clone, MPI_STATUS_IGNORE));
xmpi(MPI_Comm_free(&comm_self_clone));
bool transfer_worked = true;
for (size_t i = 0; i < msg_count; ++i)
transfer_worked &= (a[i].first == b[i].first) & (a[i].size == b[i].size);
assert(transfer_worked);
}
}
FCALLSCSUB0(PPM_create_extents_mp,PPM_CREATE_EXTENTS_MP,ppm_create_extents_mp)
void
PPM_destroy_extents_mp(void)
{
#pragma omp single
if (PPM_extent_mp != MPI_DATATYPE_NULL)
MPI_Type_free(&PPM_extent_mp);
}
FCALLSCSUB0(PPM_destroy_extents_mp,PPM_DESTROY_EXTENTS_MP,
ppm_destroy_extents_mp)
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
* license-markup: "doxygen"
* license-default: "bsd"
* End:
*/
/*
* @file ppm_math_extensions_c.c
* @brief C low-level functions required for ppm_math_extensions
* @file ppm_math_extensions_cf.c
* @brief Fortran wrapper for ppm_math_extensions
*
* Copyright (C) 2012 Thomas Jahns <jahns@dkrz.de>
*
......@@ -50,18 +50,11 @@
#include <inttypes.h>
#include <math.h>
#include <stdbool.h>
#include "ppm_math_extensions.h"
#include "cfortran.h"
#include "xpfpa_func.h"
#include "ppm_fpu_underflow.h"
void
PPM_fpu_save_cw(uint32_t *fpu_cw)
{
xpfpa_save(fpu_cw);
}
static inline void
PPM_fpu_save_cw_f(int *fpu_cw)
......@@ -71,23 +64,6 @@ PPM_fpu_save_cw_f(int *fpu_cw)
FCALLSCSUB1(PPM_fpu_save_cw_f,PPM_FPU_SAVE_CW,ppm_fpu_save_cw,PINT)
void
PPM_fpu_set_precision(enum precision fpu_precision, uint32_t *old_fpu_cw)
{
switch (fpu_precision)
{
case PPM_FPU_PRECISION_SP:
xpfpa_switch_single(old_fpu_cw);
break;
case PPM_FPU_PRECISION_DP:
xpfpa_switch_double(old_fpu_cw);
break;
case PPM_FPU_PRECISION_EP:
xpfpa_switch_double_extended(old_fpu_cw);
break;
}
}
static inline void
PPM_fpu_set_precision_f(int fpu_precision, int *old_fpu_cw)
{
......@@ -96,12 +72,6 @@ PPM_fpu_set_precision_f(int fpu_precision, int *old_fpu_cw)
FCALLSCSUB2(PPM_fpu_set_precision_f,PPM_FPU_SET_PRECISION_C,ppm_fpu_set_precision_c,INT,PINT)
void
PPM_fpu_restore_cw(const uint32_t fpu_cw)
{
xpfpa_restore(fpu_cw);
}
static inline void
PPM_fpu_restore_cw_f(const int fpu_cw)
{
......@@ -110,34 +80,15 @@ PPM_fpu_restore_cw_f(const int fpu_cw)
FCALLSCSUB1(PPM_fpu_restore_cw_f,PPM_FPU_RESTORE_CW,ppm_fpu_restore_cw,INT)
void
PPM_fpu_set_abrupt_underflow(uint32_t *old_mxcsr, bool abrupt_underflow)
{
uint32_t set_flags
= abrupt_underflow ? 1 << PPM_FTZ_BIT | 1 << PPM_DAZ_BIT | 1 << PPM_DM_BIT
: 1 << PPM_DM_BIT,
clear_flags
= abrupt_underflow ? 0U : 1 << PPM_FTZ_BIT | 1 << PPM_DAZ_BIT;
PPM_ADJUST_MXCSR(old_mxcsr, clear_flags, set_flags);
}
static inline void
PPM_fpu_set_abrupt_underflow_f(int *old_mxcsr, int abrupt_underflow)
{
PPM_fpu_set_abrupt_underflow((uint32_t *)old_mxcsr, abrupt_underflow);
}
FCALLSCSUB2(PPM_fpu_set_abrupt_underflow_f,PPM_FPU_SET_APRUPT_UNDERFLOW_C,
ppm_fpu_set_abrupt_underflow_c,PINT,LOGICAL)
void
PPM_fpu_save_mxcsr(uint32_t *old_mxcsr)
{
PPM_SAVE_MXCSR(&old_mxcsr);
}
static inline void
PPM_fpu_save_mxcsr_f(int *old_mxcsr)
{
......@@ -148,12 +99,6 @@ FCALLSCSUB1(PPM_fpu_save_mxcsr_f,PPM_FPU_SAVE_MXCSR,
ppm_fpu_save_mxcsr,PINT)
void
PPM_fpu_restore_mxcsr(uint32_t old_mxcsr)
{
PPM_RESTORE_MXCSR(&old_mxcsr);
}
static inline void
PPM_fpu_restore_mxcsr_f(int old_mxcsr)
{
......
/**
* @file ppm_math_extensions_c.c
* @brief C low-level functions required for ppm_math_extensions
* @file ppm_math_extensions_cf.c
* @brief Fortran wrappers for ppm_math_extensions
* DDP summation functionality
*
* Copyright (C) 2012 Thomas Jahns <jahns@dkrz.de>
......@@ -45,52 +45,9 @@
#include <inttypes.h>
#include <complex.h>
#include "ppm_visibility.h"
#include "ppm_math_extensions.h"
#include "cfortran.h"
#include "xpfpa_func.h"
#include "ppm_fpu_underflow.h"
#pragma STDC CX_LIMITED_RANGE ON
#ifdef __INTEL_COMPILER
#if __INTEL_COMPILER == 9999 && __INTEL_COMPILER_BUILD_DATE == 20110811
#pragma float_control(precise, on)
#elif __INTEL_COMPILER < 1400 || __INTEL_COMPILER >= 1600
#pragma float_control(precise, on)
#else
#pragma GCC optimize ("-fp-model=source")
#endif
#endif
double complex PPM_DSO_API_EXPORT
PPM_ddp_sum_dp(size_t n, const double *a)
{
#ifdef NEED_PRECISION_CONTROL
uint32_t old_fpu_cw;
xpfpa_switch_double(&old_fpu_cw);
#endif
#ifdef NEED_UNDERFLOW_CONTROL
uint32_t old_mxcsr;
PPM_ENABLE_DENORMALS(&old_mxcsr);
#endif
double cr = 0.0, ci = 0.0;
for (size_t i = 0; i < n; ++i)
{
double t1 = a[i] + cr,
e = t1 - a[i],
t2 = ((cr - e) + (a[i] - (t1 - e))) + ci;
cr = t1 + t2;
ci = t2 - ((t1 + t2) - t1);
}
double complex s = cr + ci * I;
#ifdef NEED_UNDERFLOW_CONTROL
PPM_RESTORE_MXCSR(&old_mxcsr);
#endif
#ifdef NEED_PRECISION_CONTROL
xpfpa_restore(old_fpu_cw);
#endif
return s;
}
static inline void
PPM_ddp_sum_dp_f2c(int n, const double *a, double *s)
......@@ -101,32 +58,6 @@ PPM_ddp_sum_dp_f2c(int n, const double *a, double *s)
FCALLSCSUB3(PPM_ddp_sum_dp_f2c,PPM_DDP_SUM_DP,ppm_ddp_sum_dp,
INT,DOUBLEV,DOUBLEV)
double complex PPM_DSO_API_EXPORT
PPM_ddp_add_dp_dp(double a, double b)
{
#ifdef NEED_PRECISION_CONTROL
uint32_t old_fpu_cw;
xpfpa_switch_double(&old_fpu_cw);
#endif
#ifdef NEED_UNDERFLOW_CONTROL
uint32_t old_mxcsr;
PPM_ENABLE_DENORMALS(&old_mxcsr);
#endif
double t1 = a + b,
e = t1 - a,
t2 = (b - e) + (a - (t1 - e)),
cr = t1 + t2,
ci = t2 - ((t1 + t2) - t1);
double complex s = cr + ci * I;
#ifdef NEED_UNDERFLOW_CONTROL
PPM_RESTORE_MXCSR(&old_mxcsr);
#endif
#ifdef NEED_PRECISION_CONTROL
xpfpa_restore(old_fpu_cw);
#endif
return s;
}
static inline void
PPM_ddp_add_dp_dp_f2c(double a, double b, double *s)
{
......@@ -136,33 +67,6 @@ PPM_ddp_add_dp_dp_f2c(double a, double b, double *s)
FCALLSCSUB3(PPM_ddp_add_dp_dp_f2c,PPM_DDP_ADD_DP_DP,ppm_ddp_add_dp_dp,
DOUBLE,DOUBLE,DOUBLEV)
double complex PPM_DSO_API_EXPORT
PPM_ddp_add_ddp_ddp(double complex a, double complex b)
{
#ifdef NEED_PRECISION_CONTROL
uint32_t old_fpu_cw;
xpfpa_switch_double(&old_fpu_cw);
#endif
#ifdef NEED_UNDERFLOW_CONTROL
uint32_t old_mxcsr;
PPM_ENABLE_DENORMALS(&old_mxcsr);
#endif
double ar = creal(a), br = creal(b),
t1 = ar + br,
e = t1 - ar,
t2 = (br - e) + (ar - (t1 - e)) + cimag(a) + cimag(b),
cr = t1 + t2,
ci = t2 - ((t1 + t2) - t1);
double complex s = cr + ci * I;
#ifdef NEED_UNDERFLOW_CONTROL
PPM_RESTORE_MXCSR(&old_mxcsr);
#endif
#ifdef NEED_PRECISION_CONTROL
xpfpa_restore(old_fpu_cw);
#endif
return s;
}
static inline void
PPM_ddp_add_ddp_ddp_f2c(const double *a, const double *b, double *s)
{
......
/**
* @file ppm_random_c.c
* @brief C routines to use pseudo-random number generator in Fortran
* @file ppm_random_cf.c
* @brief Fortran wrapper code for PRNG
*
* @copyright Copyright (C) 2011 Thomas Jahns <jahns@dkrz.de>
* @copyright Copyright (C) 2021 Thomas Jahns <jahns@dkrz.de>
*
* @version 1.0
* @author Thomas Jahns <jahns@dkrz.de>
......@@ -38,24 +38,13 @@
* LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include <assert.h>
#include <limits.h>
#include <math.h>
#ifdef HAVE_STDINT_H
#include <stdint.h>
#endif
#include <stdio.h>
#include <stdlib.h>
#include <cfortran.h>
#include "core.h"
#include "yarandom.h"
#include "ppm_random.h"
#include "ppm_extents.h"
#include "cfortran.h"
#ifdef INT64_T_IS_LONG_LONG
#define INT64 LONGLONG
......@@ -69,41 +58,13 @@
#define INT64VVV LONGVVV
#endif
int
PPM_irand(void)
{
uint32_t i;
while ((i = PPM_ya_random()) == UINT32_C(-2147483648))
;
return (int)i;
}
#include "ppm_random.h"
FCALLSCFUN0(INT,PPM_irand,PPM_IRAND,ppm_irand)
int
PPM_irandp(void)
{
uint32_t i = PPM_ya_random() & ((UINT32_C(1)<<31) - UINT32_C(1));
return (int)i;
}
FCALLSCFUN0(INT,PPM_irand,PPM_IRAND,ppm_irand)
FCALLSCFUN0(INT,PPM_irandp,PPM_IRANDP,ppm_irandp)
int
PPM_irandr(struct PPM_iinterval range)
{
uint32_t i;
uint32_t range_size = (uint32_t)range.last + (uint32_t)INT_MIN
- (uint32_t)range.first + UINT32_C(1) + (uint32_t)INT_MIN;
uint32_t range_max_multiple;
assert(range.last >= range.first);
range_max_multiple = (((uint32_t)-1) / range_size) * range_size;
while ((i = PPM_ya_random()) > range_max_multiple)
;
i = (i % range_size) + (uint32_t)range.first;
return (int)i;
}
static inline int
PPM_irandr_f(struct PPM_iinterval *range)
{
......@@ -112,14 +73,6 @@ PPM_irandr_f(struct PPM_iinterval *range)
FCALLSCFUN1(INT,PPM_irandr_f,PPM_IRANDR,ppm_irandr,PVOID)
void
PPM_irand_a(int *a, size_t n)
{
size_t i;
for (i = 0; i < n; ++i)
a[i] = PPM_irand();
}
static inline void
PPM_irand_a_f(int *a, int n)
{
......@@ -131,14 +84,6 @@ FCALLSCSUB2(PPM_irand_a_f,PPM_IRAND_A,ppm_irand_a,INTV,INT)
FCALLSCSUB2(PPM_irand_a_f,PPM_IRAND_A_2D,ppm_irand_a_2d,INTVV,INT)
FCALLSCSUB2(PPM_irand_a_f,PPM_IRAND_A_3D,ppm_irand_a_3d,INTVVV,INT)
void
PPM_irandp_a(int *a, size_t n)
{
size_t i;
for (i = 0; i < n; ++i)
a[i] = PPM_irandp();
}
static inline void
PPM_irandp_a_f(int *a, int n)
{
......@@ -150,14 +95,6 @@ FCALLSCSUB2(PPM_irandp_a_f,PPM_IRANDP_A,ppm_irandp_a,INTV,INT)
FCALLSCSUB2(PPM_irandp_a_f,PPM_IRANDP_A_2D,ppm_irandp_a_2d,INTVV,INT)
FCALLSCSUB2(PPM_irandp_a_f,PPM_IRANDP_A_3D,ppm_irandp_a_3d,INTVVV,INT)
void
PPM_irandr_a(int *a, size_t n, struct PPM_iinterval range)
{
size_t i;
for (i = 0; i < n; ++i)
a[i] = PPM_irandr(range);
}
static inline void
PPM_irandr_a_f(int *a, int n, struct PPM_iinterval *range)
{
......@@ -169,41 +106,11 @@ FCALLSCSUB3(PPM_irandr_a_f,PPM_IRANDR_A,ppm_irandr_a,INTV,INT,PVOID)
FCALLSCSUB3(PPM_irandr_a_f,PPM_IRANDR_A_2D,ppm_irandr_a_2d,INTVV,INT,PVOID)
FCALLSCSUB3(PPM_irandr_a_f,PPM_IRANDR_A_3D,ppm_irandr_a_3d,INTVVV,INT,PVOID)
int64_t
PPM_irand8(void)
{
uint64_t i;
while ((i = PPM_ya_random64()) == UINT64_C(-9223372036854775808))
;
return (int64_t)i;
}
FCALLSCFUN0(INT64,PPM_irand8,PPM_IRAND8,ppm_irand8)
int64_t
PPM_irandp8(void)
{
uint64_t i = PPM_ya_random64() & ((UINT64_C(1)<<63) - UINT64_C(1));
return (int64_t)i;
}
FCALLSCFUN0(INT64,PPM_irandp8,PPM_IRANDP8,ppm_irandp8)
int64_t
PPM_irandr8(struct PPM_iinterval64 range)
{
uint64_t i;
uint64_t range_size = (uint64_t)range.last + (uint64_t)INT64_MIN
- (uint64_t)range.first + UINT64_C(1) + (uint64_t)INT64_MIN;
uint64_t range_max_multiple;
assert(range.last >= range.first);
range_max_multiple = (((uint64_t)-1) / range_size) * range_size;
while ((i = PPM_ya_random64()) > range_max_multiple)
;
i = (i % range_size) + (uint64_t)range.first;
return (int)i;
}
static inline int64_t
PPM_irandr8_f(struct PPM_iinterval64 *range)
{
......@@ -212,14 +119,6 @@ PPM_irandr8_f(struct PPM_iinterval64 *range)
FCALLSCFUN1(INT64,PPM_irandr8_f,PPM_IRANDR8,ppm_irandr8,PVOID)
void
PPM_irand8_a(int64_t *a, size_t n)
{
size_t i;
for (i = 0; i < n; ++i)
a[i] = PPM_irand8();
}
static inline void
PPM_irand8_a_f(int64_t *a, int n)
{
......@@ -231,14 +130,6 @@ FCALLSCSUB2(PPM_irand8_a_f,PPM_IRAND8_A,ppm_irand8_a,INT64V,INT)
FCALLSCSUB2(PPM_irand8_a_f,PPM_IRAND8_A_2D,ppm_irand8_a_2d,INT64VV,INT)
FCALLSCSUB2(PPM_irand8_a_f,PPM_IRAND8_A_3D,ppm_irand8_a_3d,INT64VVV,INT)
void
PPM_irandp8_a(int64_t *a, size_t n)
{
size_t i;
for (i = 0; i < n; ++i)
a[i] = PPM_irandp8();
}
static inline void
PPM_irandp8_a_f(int64_t *a, int n)
{
......@@ -250,14 +141,6 @@ FCALLSCSUB2(PPM_irandp8_a_f,PPM_IRANDP8_A,ppm_irandp8_a,INT64V,INT)
FCALLSCSUB2(PPM_irandp8_a_f,PPM_IRANDP8_A_2D,ppm_irandp8_a_2d,INT64VV,INT)
FCALLSCSUB2(PPM_irandp8_a_f,PPM_IRANDP8_A_3D,ppm_irandp8_a_3d,INT64VVV,INT)
void
PPM_irandr8_a(int64_t *a, size_t n,