Yet Another eXchange Tool  0.9.0
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://www.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 #include "cfortran.h"
49 
50 #include "core/ppm_visibility.h"
51 #include "core.h"
52 
53 static void
55 {
56 #if defined(USE_MPI)
57  int flag = 0;
58  MPI_Comm comm_c;
59 #if defined (__xlC__) && defined (_AIX)
60 #pragma omp critical
61 #endif
62  comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
63  MPI_Comm_f2c(*comm_f):SymPrefix(default_comm);
64 #else
65  MPI_Comm comm_c = *comm_f;
66 #endif
67  SymPrefix(default_comm) = comm_c;
68 }
69 
72 
73 static void
74 abort_f(MPI_Fint *comm_f, const char *msg,
75  const char *source, int line)
76 {
77  MPI_Comm comm_c = MPI_COMM_NULL;
78 #if defined(USE_MPI)
79  int flag = 0;
80 #if defined (__xlC__) && defined (_AIX)
81 #pragma omp critical
82 #endif
83  if (MPI_Initialized(&flag) == MPI_SUCCESS && flag)
84  comm_c = MPI_Comm_f2c(*comm_f);
85 #else
86  comm_c = *comm_f;
87 #endif
88  SymPrefix(abort)(comm_c, msg, source, line);
89 }
90 
91 FCALLSCSUB4(abort_f, SYMPREFIX(ABORT), symprefix(abort),
92  PVOID, STRING, STRING, INT)
93 
94 static void
95 SymPrefix(abort_handler_wrapper)(MPI_Comm comm, const char msg[],
96  const char source[], int line)
97  __attribute__((noreturn));
98 
99 static void
100 SymPrefix(set_abort_handler_f)(void (*abort_handler)());
101 
102 #undef ROUTINE_1
103 #define ROUTINE_1 (void (*)())
104 FCALLSCSUB1(SymPrefix(set_abort_handler_f), SYMPREFIX(SET_ABORT_HANDLER),
105  symprefix(set_abort_handler), ROUTINE)
106 
107 static void
108 abort_default_f(MPI_Fint *comm_f, const char *msg, const char *source,
109  int line)
110 {
111 #if defined(USE_MPI)
112  int flag = 0;
113  MPI_Comm comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
114  MPI_Comm_f2c(*comm_f):SymPrefix(default_comm);
115 #else
116  MPI_Comm comm_c = *comm_f;
117 #endif
118  SymPrefix(abort_default)(comm_c, msg, source, line);
119 }
120 
121 #undef FCALLSC_QUALIFIER
122 #define FCALLSC_QUALIFIER
123 
124 #if (defined __GNUC__ && __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 5))\
125  || (defined __clang__)
126 #pragma GCC diagnostic push
127 #pragma GCC diagnostic ignored "-Wmissing-prototypes"
128 #endif
130  SYMPREFIX(RESTORE_DEFAULT_ABORT_HNDL),
131  symprefix(restore_default_abort_hndl))
132 #if (defined __GNUC__ && __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ > 5))\
133  || (defined __clang__)
134 #pragma GCC diagnostic pop
135 #endif
136 
137 FCALLSCSUB4(abort_default_f,SYMPREFIX(ABORT_DEFAULT),
139  PVOID,STRING,STRING,INT)
140 
141 /* this must be the last piece of code in the file because we
142  * redefine a cfortran.h internal here, to allow calls to Fortran
143  * function pointers */
144 #undef CFC_
145 #define CFC_(UN,LN) (UN)
146 #undef CFextern
147 #define CFextern typedef
148 __attribute__((noreturn))
149 PROTOCCALLSFSUB4(*SymPrefix(fortran_abort_func),,PVOID,STRING,STRING,INT)
150 #undef CFextern
151 #define CFextern static
152 
153 static SymPrefix(fortran_abort_func) SymPrefix(fortran_abort_fp);
154 
155 static void
156 SymPrefix(set_abort_handler_f)(void (*abort_handler)())
157 {
158  SymPrefix(fortran_abort_fp)
159  = (SymPrefix(fortran_abort_func))abort_handler;
161 }
162 
163 static void
164 SymPrefix(abort_handler_wrapper)(MPI_Comm comm, const char msg[],
165  const char source[], int line)
166 {
167 #if defined(USE_MPI)
168  int flag = 0;
169  MPI_Fint comm_f;
170 #if defined (__xlC__) && defined (_AIX)
171 #pragma omp critical
172 #endif
173  comm_f = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
174  MPI_Comm_c2f(comm):(MPI_Fint)0;
175 #else
176  MPI_Fint comm_f = comm;
177 #endif
178  /* cfortran.h does not understand const char * */
179  char *msg_arg = (char *)msg, *source_arg = (char *)source;
180 #undef CPPPROTOCLSFSUB14
181 #define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
182  CCALLSFSUB4(*SymPrefix(fortran_abort_fp),,PVOID,STRING,STRING,INT,
183  &comm_f, msg_arg, source_arg, line);
184 }
185 
186 /*
187  * Local Variables:
188  * license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
189  * license-markup: "doxygen"
190  * license-default: "bsd"
191  * End:
192  */
void SymPrefix() abort_default(MPI_Comm comm, const char *msg, const char *source, int line)
Definition: core.c:110
@ MPI_COMM_NULL
Definition: core.h:74
int MPI_Fint
Definition: core.h:68
void SymPrefix() restore_default_abort_handler(void)
int MPI_Comm
Definition: core.h:64
void SymPrefix() set_default_comm(MPI_Comm comm)
#define __attribute__(x)
Definition: core.h:82
FCALLSCSUB4(abort_f, SYMPREFIX(ABORT), symprefix(abort), PVOID, STRING, STRING, INT)
Definition: core_cf.c:91
static void SymPrefix() set_default_comm_f(MPI_Fint *comm_f)
Definition: core_cf.c:54
static void SymPrefix() abort_handler_wrapper(MPI_Comm comm, const char msg[], const char source[], int line)
Definition: core_cf.c:164
FCALLSCSUB1(SymPrefix(set_default_comm_f), SYMPREFIX(SET_DEFAULT_COMM), symprefix(set_default_comm), PVOID)
Definition: core_cf.c:70
FCALLSCSUB0(SymPrefix(restore_default_abort_handler), SYMPREFIX(RESTORE_DEFAULT_ABORT_HNDL), symprefix(restore_default_abort_hndl))
Definition: core_cf.c:129
subroutine, public set_abort_handler(f)
set routine f to use as abort function which is called on xt_abort
Definition: xt_core_f.f90:216
#define SymPrefix(symbol)
Definition: symprefix.h:53
#define symprefix(symbol)
Definition: symprefix.h:55
#define SYMPREFIX(symbol)
Definition: symprefix.h:51