Yet Another eXchange Tool 0.11.4
Loading...
Searching...
No Matches
core_cf.c
Go to the documentation of this file.
1/*
2 * @file core_cf.c
3 * @brief ScalES-PPM core library C/Fortran interface
4 *
5 * Copyright (C) 2012 Thomas Jahns <jahns@dkrz.de>
6 *
7 * @version 1.0
8 * Keywords:
9 * @author Thomas Jahns <jahns@dkrz.de>
10 * Maintainer: Thomas Jahns <jahns@dkrz.de>
11 * URL: https://swprojects.dkrz.de/redmine/projects/scales-ppm
12 *
13 * Redistribution and use in source and binary forms, with or without
14 * modification, are permitted provided that the following conditions are
15 * met:
16 *
17 * Redistributions of source code must retain the above copyright notice,
18 * this list of conditions and the following disclaimer.
19 *
20 * Redistributions in binary form must reproduce the above copyright
21 * notice, this list of conditions and the following disclaimer in the
22 * documentation and/or other materials provided with the distribution.
23 *
24 * Neither the name of the DKRZ GmbH nor the names of its contributors
25 * may be used to endorse or promote products derived from this software
26 * without specific prior written permission.
27 *
28 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
29 * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
30 * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
31 * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
32 * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
33 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
34 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
35 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
36 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
37 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
38 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
39 */
40
41#ifdef HAVE_CONFIG_H
42# include <config.h>
43#endif
44#include <stdio.h>
45
46#define FCALLSC_QUALIFIER PPM_DSO_INTERNAL
47
48#if defined __clang__
49# pragma GCC diagnostic push
50# pragma GCC diagnostic ignored "-Wreserved-id-macro"
51#endif
52#define CF_USE_ALLOCA 1
53#include <cfortran.h>
54#if defined __clang__
55# pragma GCC diagnostic pop
56#endif
57
58
59#include "core/ppm_visibility.h"
60#include "core.h"
61
62static void
64{
65#if defined(USE_MPI)
66 int flag = 0;
67 MPI_Comm comm_c;
68#if defined (__xlC__) && defined (_AIX)
69#pragma omp critical
70#endif
71 comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
72 MPI_Comm_f2c(*comm_f):SymPrefix(default_comm);
73#else
74 MPI_Comm comm_c = *comm_f;
75#endif
76 SymPrefix(default_comm) = comm_c;
77}
78
81
82static void
83abort_f(MPI_Fint *comm_f, const char *msg,
84 const char *source, int line)
85 __attribute__((noreturn));
86
87static void
88abort_f(MPI_Fint *comm_f, const char *msg,
89 const char *source, int line)
90{
91 MPI_Comm comm_c = MPI_COMM_NULL;
92#if defined(USE_MPI)
93 int flag = 0;
94#if defined (__xlC__) && defined (_AIX)
95#pragma omp critical
96#endif
97 if (MPI_Initialized(&flag) == MPI_SUCCESS && flag)
98 comm_c = MPI_Comm_f2c(*comm_f);
99#else
100 comm_c = *comm_f;
101#endif
102 SymPrefix(abort)(comm_c, msg, source, line);
103}
104
105#undef CFattributes
106#define CFattributes __attribute__((noreturn))
107FCALLSCSUB4(abort_f, SYMPREFIX(ABORT), symprefix(abort),
108 PVOID, STRING, STRING, INT)
109
110static void
111pure_abort_f(MPI_Fint *ierror, MPI_Fint *comm_f, const char *msg,
112 const char *source, int line)
113 __attribute__((noreturn));
114
115static void
116pure_abort_f(MPI_Fint *ierror, MPI_Fint *comm_f, const char *msg,
117 const char *source, int line)
118{
119 *ierror = -1;
120 abort_f(comm_f, msg, source, line);
121}
122
123FCALLSCSUB5(pure_abort_f, SYMPREFIX(ABORT_PURE), symprefix(abort_pure),
124 PVOID, PVOID, STRING, STRING, INT)
125
126#undef CFattributes
127#define CFattributes
128
129static void
130SymPrefix(abort_handler_wrapper)(MPI_Comm comm, const char msg[],
131 const char source[], int line)
132 __attribute__((noreturn));
133
134static void
135SymPrefix(set_abort_handler_f)(void (*abort_handler)(void));
136
137#undef ROUTINE_1
138#define ROUTINE_1 (void (*)(void))
139FCALLSCSUB1(SymPrefix(set_abort_handler_f), SYMPREFIX(SET_ABORT_HANDLER),
140 symprefix(set_abort_handler), ROUTINE)
141
142static void
143abort_default_f(MPI_Fint *comm_f, const char *msg, const char *source,
144 int line)
145 __attribute__((noreturn));
146
147static void
148abort_default_f(MPI_Fint *comm_f, const char *msg, const char *source,
149 int line)
150{
151#if defined(USE_MPI)
152 int flag = 0;
153 MPI_Comm comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
154 MPI_Comm_f2c(*comm_f):SymPrefix(default_comm);
155#else
156 MPI_Comm comm_c = *comm_f;
157#endif
158 SymPrefix(abort_default)(comm_c, msg, source, line);
159}
160
161#undef FCALLSC_QUALIFIER
162#define FCALLSC_QUALIFIER
163
165 SYMPREFIX(RESTORE_DEFAULT_ABORT_HNDL),
166 symprefix(restore_default_abort_hndl))
167
168#undef CFattributes
169#define CFattributes __attribute__((noreturn))
170FCALLSCSUB4(abort_default_f,SYMPREFIX(ABORT_DEFAULT),
172 PVOID,STRING,STRING,INT)
173#undef CFattributes
174#define CFattributes
175
176/* this must be the last piece of code in the file because we
177 * redefine a cfortran.h internal here, to allow calls to Fortran
178 * function pointers */
179#undef CFC_
180#define CFC_(UN,LN) (UN)
181#undef CFextern
182#define CFextern typedef
183__attribute__((noreturn))
184PROTOCCALLSFSUB4(*SymPrefix(fortran_abort_func),,PVOID,STRING,STRING,INT)
185#undef CFextern
186
187static SymPrefix(fortran_abort_func) SymPrefix(fortran_abort_fp);
188
189static void
190SymPrefix(set_abort_handler_f)(void (*abort_handler)(void))
191{
192 SymPrefix(fortran_abort_fp)
193 = (SymPrefix(fortran_abort_func))abort_handler;
195}
196
197static void
199 const char source[], int line)
200{
201#if defined(USE_MPI)
202 int flag = 0;
203 MPI_Fint comm_f;
204#if defined (__xlC__) && defined (_AIX)
205#pragma omp critical
206#endif
207 comm_f = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
208 MPI_Comm_c2f(comm):(MPI_Fint)0;
209#else
210 MPI_Fint comm_f = comm;
211#endif
212 /* cfortran.h does not understand const char * */
213 char *msg_arg = (char *)(void *)msg, *source_arg = (char *)(void *)source;
214#undef CPPPROTOCLSFSUB14
215#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
216 CCALLSFSUB4(*SymPrefix(fortran_abort_fp),,PVOID,STRING,STRING,INT,
217 &comm_f, msg_arg, source_arg, line);
218}
219
220/*
221 * Local Variables:
222 * license-project-url: "https://swprojects.dkrz.de/redmine/projects/scales-ppm"
223 * license-markup: "doxygen"
224 * license-default: "bsd"
225 * End:
226 */
void SymPrefix abort_default(MPI_Comm comm, const char *msg, const char *source, int line)
Definition core.c:116
@ MPI_COMM_NULL
Definition core.h:74
int MPI_Fint
Definition core.h:68
void SymPrefix set_default_comm(MPI_Comm comm)
int MPI_Comm
Definition core.h:64
void SymPrefix restore_default_abort_handler(void)
#define __attribute__(x)
Definition core.h:82
FCALLSCSUB4(abort_f, SYMPREFIX(ABORT), symprefix(abort), PVOID, STRING, STRING, INT)
Definition core_cf.c:107
static void SymPrefix set_default_comm_f(MPI_Fint *comm_f)
Definition core_cf.c:63
static void SymPrefix abort_handler_wrapper(MPI_Comm comm, const char msg[], const char source[], int line)
Definition core_cf.c:198
FCALLSCSUB1(SymPrefix(set_default_comm_f), SYMPREFIX(SET_DEFAULT_COMM), symprefix(set_default_comm), PVOID)
Definition core_cf.c:79
FCALLSCSUB5(pure_abort_f, SYMPREFIX(ABORT_PURE), symprefix(abort_pure), PVOID, PVOID, STRING, STRING, INT)
Definition core_cf.c:123
FCALLSCSUB0(SymPrefix(restore_default_abort_handler), SYMPREFIX(RESTORE_DEFAULT_ABORT_HNDL), symprefix(restore_default_abort_hndl))
Definition core_cf.c:164
#define SymPrefix(symbol)
Definition symprefix.h:53
#define symprefix(symbol)
Definition symprefix.h:55
#define SYMPREFIX(symbol)
Definition symprefix.h:51