Commit 3257a070 authored by Thomas Jahns's avatar Thomas Jahns 🤸
Browse files

Align core functionality with PPM.

parent ca406216
......@@ -121,6 +121,7 @@ libyaxt_c_la_SOURCES = \
core/core.h \
core/ppm_xfuncs.h \
core/symprefix.h \
core/ppm_visibility.h \
core/xmalloc.c \
core/xstdio.c \
ensure_array_size.c \
......@@ -152,6 +153,7 @@ libyaxt_la_SOURCES = \
xt_ut_c.c \
xt_ut_c.h \
yaxt_f2c.c \
core/core_cf.c \
xt_slice_c_loc.inc \
xt_mpi_f.f90 \
xt_core_f.f90 \
......
......@@ -66,21 +66,26 @@
#pragma GCC diagnostic pop
#endif
#include "core.h"
#include "symprefix.h"
#ifdef USE_MPI
#include <mpi.h>
#endif
#include "core/ppm_visibility.h"
#include "core/core.h"
#include "core/symprefix.h"
MPI_Comm SymPrefix(default_comm) = MPI_COMM_WORLD;
#define XT_F2C_Data COMMON_BLOCK(XT_F2C_DATA,xt_f2c_data)
#define F2C_Data COMMON_BLOCK(SYMPREFIX(F2C_DATA),symprefix(f2c_data))
typedef struct
{
MPI_Fint xt_default_comm;
} XT_F2C_Def;
MPI_Fint symprefix(default_comm);
} SymPrefix(F2C_Def);
COMMON_BLOCK_DEF(XT_F2C_Def,XT_F2C_Data);
COMMON_BLOCK_DEF(SymPrefix(F2C_Def),F2C_Data);
XT_F2C_Def XT_F2C_Data;
SymPrefix(F2C_Def) F2C_Data;
void
SymPrefix(set_default_comm)(MPI_Comm comm)
......@@ -92,20 +97,23 @@ SymPrefix(set_default_comm)(MPI_Comm comm)
comm_f = comm;
#endif
SymPrefix(default_comm) = comm;
XT_F2C_Data.xt_default_comm = comm_f;
F2C_Data.symprefix(default_comm) = comm_f;
}
void
SymPrefix(abort_default)(MPI_Comm comm, const char *msg, const char *source, int line)
{
int flag = 0;
fprintf(stderr, "Fatal error in %s, line %d: %s\n", source, line, msg);
#ifdef USE_MPI
#if defined (__xlC__) && defined (_AIX)
#pragma omp critical
#endif
if (MPI_Initialized(&flag) == MPI_SUCCESS && flag)
if (SymPrefix(mpi_calls_are_allowed)())
MPI_Abort(comm, 1);
else
abort();
#else
(void)comm;
#endif
abort();
}
......
......@@ -110,7 +110,7 @@ extern MPI_Comm SymPrefix(default_comm);
* This function
* prints the message argument and file and line of the error
* to standard error, and
* calls either MPI_Abort or abort depending on wether
* calls either MPI_Abort or abort depending on whether
* MPI is initialized.
* @param comm MPI communcator object to use on call to MPI_Abort
* @param msg message text to print
......@@ -131,6 +131,16 @@ SymPrefix(set_default_comm)(MPI_Comm comm);
#define die(msg) \
SymPrefix(abort)(SymPrefix(default_comm), (msg), __FILE__, __LINE__)
#ifdef USE_MPI
static inline int
SymPrefix(mpi_calls_are_allowed)(void)
{
int init_flag = 0, finished_flag = 0;
return MPI_Initialized(&init_flag) == MPI_SUCCESS && init_flag
&& MPI_Finalized(&finished_flag) == MPI_SUCCESS && !finished_flag;
}
#endif
#endif
/*
* Local Variables:
......
/*
* @file core_cf.c
* @brief ScalES-PPM core library C/Fortran interface
*
* Copyright (C) 2012 Thomas Jahns <jahns@dkrz.de>
*
* @version 1.0
* Keywords:
* @author Thomas Jahns <jahns@dkrz.de>
* Maintainer: Thomas Jahns <jahns@dkrz.de>
* URL: https://www.dkrz.de/redmine/projects/scales-ppm
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* Neither the name of the DKRZ GmbH nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
* IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
* OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
* 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 <stdio.h>
#define FCALLSC_QUALIFIER PPM_DSO_INTERNAL
#include "cfortran.h"
#include "core/ppm_visibility.h"
#include "core.h"
static void
SymPrefix(set_default_comm_f)(MPI_Fint *comm_f)
{
#if defined(USE_MPI)
int flag = 0;
MPI_Comm comm_c;
#if defined (__xlC__) && defined (_AIX)
#pragma omp critical
#endif
comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
MPI_Comm_f2c(*comm_f):SymPrefix(default_comm);
#else
MPI_Comm comm_c = *comm_f;
#endif
SymPrefix(default_comm) = comm_c;
}
FCALLSCSUB1(SymPrefix(set_default_comm_f), SYMPREFIX(SET_DEFAULT_COMM),
symprefix(set_default_comm), PVOID)
static void
abort_f(MPI_Fint *comm_f, const char *msg,
const char *source, int line)
{
MPI_Comm comm_c = MPI_COMM_NULL;
#if defined(USE_MPI)
int flag = 0;
#if defined (__xlC__) && defined (_AIX)
#pragma omp critical
#endif
if (MPI_Initialized(&flag) == MPI_SUCCESS && flag)
comm_c = MPI_Comm_f2c(*comm_f);
#else
comm_c = *comm_f;
#endif
SymPrefix(abort)(comm_c, msg, source, line);
}
FCALLSCSUB4(abort_f, SYMPREFIX(ABORT), symprefix(abort),
PVOID, STRING, STRING, INT)
static void
SymPrefix(abort_handler_wrapper)(MPI_Comm comm, const char msg[],
const char source[], int line)
__attribute__((noreturn));
static void
SymPrefix(set_abort_handler_f)(void (*abort_handler)());
#undef ROUTINE_1
#define ROUTINE_1 (void (*)())
FCALLSCSUB1(SymPrefix(set_abort_handler_f), SYMPREFIX(SET_ABORT_HANDLER),
symprefix(set_abort_handler), ROUTINE)
static void
abort_default_f(MPI_Fint *comm_f, const char *msg, const char *source,
int line)
{
#if defined(USE_MPI)
int flag = 0;
MPI_Comm comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
MPI_Comm_f2c(*comm_f):SymPrefix(default_comm);
#else
MPI_Comm comm_c = *comm_f;
#endif
SymPrefix(abort_default)(comm_c, msg, source, line);
}
#undef FCALLSC_QUALIFIER
#define FCALLSC_QUALIFIER
FCALLSCSUB4(abort_default_f,SYMPREFIX(ABORT_DEFAULT),
symprefix(abort_default),
PVOID,STRING,STRING,INT)
/* this must be the last piece of code in the file because we
* redefine a cfortran.h internal here, to allow calls to Fortran
* function pointers */
#undef CFC_
#define CFC_(UN,LN) (UN)
#undef CFextern
#define CFextern typedef
__attribute__((noreturn))
PROTOCCALLSFSUB4(*SymPrefix(fortran_abort_func),,PVOID,STRING,STRING,INT)
#undef CFextern
#define CFextern static
static SymPrefix(fortran_abort_func) SymPrefix(fortran_abort_fp);
static void
SymPrefix(set_abort_handler_f)(void (*abort_handler)())
{
SymPrefix(fortran_abort_fp)
= (SymPrefix(fortran_abort_func))abort_handler;
SymPrefix(abort) = SymPrefix(abort_handler_wrapper);
}
static void
SymPrefix(abort_handler_wrapper)(MPI_Comm comm, const char msg[],
const char source[], int line)
{
#if defined(USE_MPI)
int flag = 0;
MPI_Fint comm_f;
#if defined (__xlC__) && defined (_AIX)
#pragma omp critical
#endif
comm_f = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
MPI_Comm_c2f(comm):(MPI_Fint)0;
#else
MPI_Fint comm_f = comm;
#endif
/* cfortran.h does not understand const char * */
char *msg_arg = (char *)msg, *source_arg = (char *)source;
#undef CPPPROTOCLSFSUB14
#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
CCALLSFSUB4(*SymPrefix(fortran_abort_fp),,PVOID,STRING,STRING,INT,
&comm_f, msg_arg, source_arg, line);
}
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
* license-markup: "doxygen"
* license-default: "bsd"
* End:
*/
/**
* @file ppm_visibility.h
*
* @copyright Copyright (C) 2018 Thomas Jahns <jahns@dkrz.de>
*
* @author Thomas Jahns <jahns@dkrz.de>
*/
/*
* Keywords:
* Maintainer: Thomas Jahns <jahns@dkrz.de>
* URL: https://www.dkrz.de/redmine/projects/scales-ppm
*
* Redistribution and use in source and binary forms, with or without
* modification, are permitted provided that the following conditions are
* met:
*
* Redistributions of source code must retain the above copyright notice,
* this list of conditions and the following disclaimer.
*
* Redistributions in binary form must reproduce the above copyright
* notice, this list of conditions and the following disclaimer in the
* documentation and/or other materials provided with the distribution.
*
* Neither the name of the DKRZ GmbH nor the names of its contributors
* may be used to endorse or promote products derived from this software
* without specific prior written permission.
*
* THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
* IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
* TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
* PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
* OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
* EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
* PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
* PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
* 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.
*/
#ifndef PPM_VISIBILITY_H
#define PPM_VISIBILITY_H
#ifdef HAVE_CONFIG_H
#include <config.h>
#endif
#if (defined _WIN32 || defined __CYGWIN__) && defined __PIC__
# define PPM_DSO_API_EXPORT __declspec(dllexport)
# define PPM_DSO_INTERNAL
#else
# if (defined __GNUC__ \
&& (__GNUC__ > 4 || __GNUC__ == 4 && __GNUC_MINOR__ > 1) \
&& defined __PIC__)
# define PPM_DSO_API_EXPORT __attribute__ ((visibility ("default")))
# define PPM_DSO_INTERNAL __attribute__ ((visibility ("hidden")))
# else
# define PPM_DSO_API_EXPORT
# define PPM_DSO_INTERNAL
# endif
#endif
#endif
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
* license-markup: "doxygen"
* license-default: "bsd"
* c-basic-offset: 2
* coding: utf-8
* indent-tabs-mode: nil
* show-trailing-whitespace: t
* require-trailing-newline: t
* End:
*/
......@@ -110,6 +110,9 @@ MODULE xt_core
SUBROUTINE xt_finalize() BIND(C, name='xt_finalize')
END SUBROUTINE xt_finalize
SUBROUTINE xt_restore_default_abort_hndl
END SUBROUTINE xt_restore_default_abort_hndl
END INTERFACE
INTERFACE xt_abort
......@@ -142,6 +145,8 @@ MODULE xt_core
EXTERNAL :: xt_slice_c_loc
PUBLIC :: set_abort_handler, xt_restore_default_abort_hndl
CONTAINS
SUBROUTINE xt_abort4(comm, msg, source, line)
......@@ -206,6 +211,25 @@ CONTAINS
.AND. .NOT. (ABS(a%size) == 1 .AND. ABS(a%size) == ABS(b%size)))
END FUNCTION xt_pos_ext_ne
!> set routine f to use as abort function which is called on xt_abort
SUBROUTINE set_abort_handler(f)
INTERFACE
SUBROUTINE f(comm, msg, source, line)
INTEGER, INTENT(in) :: comm, line
CHARACTER(len=*), INTENT(in) :: msg, source
END SUBROUTINE f
SUBROUTINE xt_set_abort_handler(f)
INTERFACE
SUBROUTINE f(comm, msg, source, line)
INTEGER, INTENT(in) :: comm, line
CHARACTER(len=*), INTENT(in) :: msg, source
END SUBROUTINE f
END INTERFACE
END SUBROUTINE xt_set_abort_handler
END INTERFACE
CALL xt_set_abort_handler(f)
END SUBROUTINE set_abort_handler
END MODULE xt_core
!
! Local Variables:
......
......@@ -53,7 +53,8 @@ MODULE yaxt
USE xt_core, ONLY: i4, xt_int_kind, xt_int_mpidt, &
xt_abort, xt_initialize, xt_get_default_comm, xt_stripe, xt_bounds, &
char, xt_finalize, xt_initialized, xt_finalized, xt_slice_c_loc, &
xt_pos_ext, OPERATOR(/=), OPERATOR(==)
xt_pos_ext, OPERATOR(/=), OPERATOR(==), &
xt_set_abort_handler => set_abort_handler, xt_restore_default_abort_hndl
USE xt_sort, ONLY: xt_sort_int, xt_sort_index, xt_sort_idxpos, &
xt_sort_permutation
USE xt_idxlist_abstract, ONLY: &
......@@ -118,6 +119,7 @@ MODULE yaxt
PUBLIC :: xt_initialize, xt_finalize, xt_abort, xt_get_default_comm, &
xt_initialized, xt_finalized, &
xt_set_abort_handler, xt_restore_default_abort_hndl, &
xt_int_kind, xt_int_mpidt, xt_stripe, xt_bounds, xt_pos_ext, &
xt_sort_int, xt_sort_index, xt_sort_idxpos, xt_sort_permutation, &
xt_idxlist, xt_idxlist_delete, &
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment