Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
Thomas Jahns
PPM
Commits
e961f96f
Commit
e961f96f
authored
Mar 02, 2021
by
Thomas Jahns
🤸
Browse files
Restore C-side of API.
parent
cda7a8e6
Changes
8
Hide whitespace changes
Inline
Side-by-side
src/core/errhandler.c
0 → 100644
View file @
e961f96f
/*
* errhandler.c --- install abort(2) as MPI error handler to yield a
* core file which can be inspected with a debugger
*
* Copyright (C) 2010 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 <stdlib.h>
#include <mpi.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
)
{
#ifdef USE_MPI
MPI_Comm
comm_c
=
MPI_Comm_f2c
((
MPI_Fint
)
*
comm_f
);
#else
MPI_Comm
comm_c
=
*
comm_f
;
#endif
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:
*/
src/core/ppm_extents_mp_c.c
0 → 100644
View file @
e961f96f
/**
* @file ppm_extents_mp_c.c --- build MPI datatype for PPM_extent struct
*
* @copyright (C) 2014 Thomas Jahns <jahns@dkrz.de>
*
* @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 <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_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:
*/
src/core/ppm_math_extensions_c.c
0 → 100644
View file @
e961f96f
/*
* @file ppm_math_extensions_c.c
* @brief C low-level functions required for ppm_math_extensions
*
* 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.
*
* Commentary:
*
*
*
* Code:
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#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
)
{
PPM_fpu_save_cw
((
uint32_t
*
)
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
)
{
PPM_fpu_set_precision
((
enum
precision
)
fpu_precision
,
(
uint32_t
*
)
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
)
{
PPM_fpu_restore_cw
((
uint32_t
)
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
)
{
PPM_fpu_save_mxcsr
((
uint32_t
*
)
old_mxcsr
);
}
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
)
{
PPM_fpu_restore_mxcsr
((
uint32_t
)
old_mxcsr
);
}
FCALLSCSUB1
(
PPM_fpu_restore_mxcsr_f
,
PPM_FPU_RESTORE_MXCSR
,
ppm_fpu_restore_mxcsr
,
INT
)
static
inline
void
PPM_assign_nan_dp
(
double
*
v
)
{
*
v
=
NAN
;
}
FCALLSCSUB1
(
PPM_assign_nan_dp
,
PPM_PPM_ASSIGN_NAN_DP
,
ppm_assign_nan_dp
,
PDOUBLE
)
static
inline
void
PPM_assign_nan_sp
(
float
*
v
)
{
*
v
=
NAN
;
}
FCALLSCSUB1
(
PPM_assign_nan_sp
,
PPM_PPM_ASSIGN_NAN_SP
,
ppm_assign_nan_sp
,
PFLOAT
)
/*
* Local Variables:
* license-markup: "doxygen"
* license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
* license-default: "bsd"
* End:
*/
src/core/ppm_math_extensions_ddp_c.c
0 → 100644
View file @
e961f96f
/**
* @file ppm_math_extensions_c.c
* @brief C low-level functions required for ppm_math_extensions
* DDP summation functionality
*
* 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 <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
)
{
*
(
double
complex
*
)
s
=
PPM_ddp_sum_dp
((
size_t
)
n
,
a
);
}
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
)
{
*
(
double
complex
*
)
s
=
PPM_ddp_add_dp_dp
(
a
,
b
);
}
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
)
{
*
(
double
complex
*
)
s
=
PPM_ddp_add_ddp_ddp
(
*
(
double
complex
*
)
a
,
*
(
double
complex
*
)
b
);
}
FCALLSCSUB3
(
PPM_ddp_add_ddp_ddp_f2c
,
PPM_DDP_ADD_DDP_DDP
,
ppm_ddp_add_ddp_ddp
,
DOUBLEV
,
DOUBLEV
,
DOUBLEV
)
/*
* Local Variables:
* license-markup: "doxygen"
* license-project-url: "https://www.dkrz.de/redmine/projects/scales-ppm"
* license-default: "bsd"
* End:
*/
src/core/ppm_random_c.c
0 → 100644
View file @
e961f96f
/**
* @file ppm_random_c.c
* @brief C routines to use pseudo-random number generator in Fortran
*
* @copyright Copyright (C) 2011 Thomas Jahns <jahns@dkrz.de>
*
* @version 1.0
* @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.
*
*/
#ifdef HAVE_CONFIG_H
#include "config.h"
#endif
#include <assert.h>
#include <limits.h>
#include <math.h>
#ifdef HAVE_STDINT_H
#include <stdint.h>