You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
502 lines
12 KiB
502 lines
12 KiB
/*
|
|
* src/c_qd.cc
|
|
*
|
|
* This work was supported by the Director, Office of Science, Division
|
|
* of Mathematical, Information, and Computational Sciences of the
|
|
* U.S. Department of Energy under contract number DE-AC03-76SF00098.
|
|
*
|
|
* Copyright (c) 2000-2001
|
|
*
|
|
* Contains C wrapper function for quad-double precision arithmetic.
|
|
* This can be used from fortran code.
|
|
*/
|
|
#include "config.h"
|
|
#ifdef HAVE_FORTRAN
|
|
|
|
#include <cstring>
|
|
|
|
#include "config.h"
|
|
#include <qd/qd_real.h>
|
|
#include <qd/c_qd.h>
|
|
|
|
#define f_qd_add FC_FUNC_(f_qd_add, F_QD_ADD)
|
|
#define f_qd_add_qd_dd FC_FUNC_(f_qd_add_qd_dd, F_QD_ADD_QD_DD)
|
|
#define f_qd_add_qd_d FC_FUNC_(f_qd_add_qd_d, F_QD_ADD_QD_D)
|
|
|
|
#define f_qd_sub FC_FUNC_(f_qd_sub, F_QD_SUB)
|
|
#define f_qd_sub_dd_qd FC_FUNC_(f_qd_sub_dd_qd, F_QD_SUB_DD_QD)
|
|
#define f_qd_sub_qd_dd FC_FUNC_(f_qd_sub_qd_dd, F_QD_SUB_QD_DD)
|
|
#define f_qd_sub_d_qd FC_FUNC_(f_qd_sub_d_qd, F_QD_SUB_D_QD)
|
|
#define f_qd_sub_qd_d FC_FUNC_(f_qd_sub_qd_d, F_QD_SUB_QD_D)
|
|
|
|
#define f_qd_mul FC_FUNC_(f_qd_mul, F_QD_MUL)
|
|
#define f_qd_mul_qd_dd FC_FUNC_(f_qd_mul_qd_dd, F_QD_MUL_QD_DD)
|
|
#define f_qd_mul_qd_d FC_FUNC_(f_qd_mul_qd_d, F_QD_MUL_QD_D)
|
|
|
|
#define f_qd_div FC_FUNC_(f_qd_div, F_QD_DIV)
|
|
#define f_qd_div_dd_qd FC_FUNC_(f_qd_div_dd_qd, F_QD_DIV_DD_QD)
|
|
#define f_qd_div_qd_dd FC_FUNC_(f_qd_div_qd_dd, F_QD_DIV_QD_DD)
|
|
#define f_qd_div_d_qd FC_FUNC_(f_qd_div_d_qd, F_QD_DIV_D_QD)
|
|
#define f_qd_div_qd_d FC_FUNC_(f_qd_div_qd_d, F_QD_DIV_QD_D)
|
|
|
|
#define f_qd_sqrt FC_FUNC_(f_qd_sqrt, F_QD_SQRT)
|
|
#define f_qd_sqr FC_FUNC_(f_qd_sqr, F_QD_SQR)
|
|
|
|
#define f_qd_abs FC_FUNC_(f_qd_abs, F_QD_ABS)
|
|
|
|
#define f_qd_npwr FC_FUNC_(f_qd_npwr, F_QD_NPWR)
|
|
#define f_qd_nroot FC_FUNC_(f_qd_nroot, F_QD_NROOT)
|
|
|
|
#define f_qd_nint FC_FUNC_(f_qd_nint, F_QD_NINT)
|
|
#define f_qd_aint FC_FUNC_(f_qd_aint, F_QD_AINT)
|
|
#define f_qd_floor FC_FUNC_(f_qd_floor, F_QD_FLOOR)
|
|
#define f_qd_ceil FC_FUNC_(f_qd_ceil, F_QD_CEIL)
|
|
|
|
#define f_qd_exp FC_FUNC_(f_qd_exp, F_QD_EXP)
|
|
#define f_qd_log FC_FUNC_(f_qd_log, F_QD_LOG)
|
|
#define f_qd_log10 FC_FUNC_(f_qd_log10, F_QD_LOG10)
|
|
|
|
#define f_qd_sin FC_FUNC_(f_qd_sin, F_QD_SIN)
|
|
#define f_qd_cos FC_FUNC_(f_qd_cos, F_QD_COS)
|
|
#define f_qd_tan FC_FUNC_(f_qd_tan, F_QD_TAN)
|
|
|
|
#define f_qd_asin FC_FUNC_(f_qd_asin, F_QD_ASIN)
|
|
#define f_qd_acos FC_FUNC_(f_qd_acos, F_QD_ACOS)
|
|
#define f_qd_atan FC_FUNC_(f_qd_atan, F_QD_ATAN)
|
|
#define f_qd_atan2 FC_FUNC_(f_qd_atan2, F_QD_ATAN2)
|
|
|
|
#define f_qd_sinh FC_FUNC_(f_qd_sinh, F_QD_SINH)
|
|
#define f_qd_cosh FC_FUNC_(f_qd_cosh, F_QD_COSH)
|
|
#define f_qd_tanh FC_FUNC_(f_qd_tanh, F_QD_TANH)
|
|
|
|
#define f_qd_asinh FC_FUNC_(f_qd_asinh, F_QD_ASINH)
|
|
#define f_qd_acosh FC_FUNC_(f_qd_acosh, F_QD_ACOSH)
|
|
#define f_qd_atanh FC_FUNC_(f_qd_atanh, F_QD_ATANH)
|
|
|
|
#define f_qd_sincos FC_FUNC_(f_qd_sincos, F_QD_SINCOS)
|
|
#define f_qd_sincosh FC_FUNC_(f_qd_sincosh, F_QD_SINCOSH)
|
|
|
|
#define f_qd_swrite FC_FUNC_(f_qd_swrite, F_QD_SWRITE)
|
|
#define f_qd_write FC_FUNC_(f_qd_write, F_QD_WRITE)
|
|
|
|
#define f_qd_neg FC_FUNC_(f_qd_neg, F_QD_NEG)
|
|
#define f_qd_rand FC_FUNC_(f_qd_rand, F_QD_RAND)
|
|
#define f_qd_comp FC_FUNC_(f_qd_comp, F_QD_COMP)
|
|
#define f_qd_comp_qd_d FC_FUNC_(f_qd_comp_qd_d, F_QD_COMP_QD_D)
|
|
|
|
#define f_qd_pi FC_FUNC_(f_qd_pi, F_QD_PI)
|
|
#define f_qd_nan FC_FUNC_(f_qd_nan, F_QD_NAN)
|
|
|
|
#define TO_DOUBLE_PTR(a, ptr) ptr[0] = a.x[0]; ptr[1] = a.x[1]; \
|
|
ptr[2] = a.x[2]; ptr[3] = a.x[3];
|
|
|
|
extern "C" {
|
|
|
|
|
|
|
|
/* add */
|
|
void f_qd_add(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) + qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_add_qd_dd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) + dd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_add_qd_d(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) + *b;
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
|
|
|
|
|
|
/* sub */
|
|
void f_qd_sub(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) - qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_sub_qd_dd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) - dd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_sub_dd_qd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = dd_real(a) - qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_sub_qd_d(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) - *b;
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_sub_d_qd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = *a - qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
|
|
|
|
|
|
/* mul */
|
|
void f_qd_mul(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) * qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_mul_qd_dd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) * dd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_mul_qd_d(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) * *b;
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
|
|
|
|
|
|
/* div */
|
|
void f_qd_div(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) / qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_div_qd_dd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) / dd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_div_dd_qd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = dd_real(a) / qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_div_qd_d(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = qd_real(a) / *b;
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
void f_qd_div_d_qd(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = *a / qd_real(b);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
|
|
|
|
|
|
|
|
/* selfadd */
|
|
void f_qd_selfadd(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb += qd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfadd_dd(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb += dd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfadd_d(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb += *a;
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
|
|
|
|
/* selfsub */
|
|
void f_qd_selfsub(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb -= qd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfsub_dd(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb -= dd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfsub_d(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb -= *a;
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
|
|
|
|
/* selfmul */
|
|
void f_qd_selfmul(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb *= qd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfmul_dd(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb *= dd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfmul_d(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb *= *a;
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
|
|
|
|
/* selfdiv */
|
|
void f_qd_selfdiv(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb /= qd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfdiv_dd(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb /= dd_real(a);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_selfdiv_d(const double *a, double *b) {
|
|
qd_real bb(b);
|
|
bb /= *a;
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
|
|
|
|
void f_qd_sqrt(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = sqrt(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_sqr(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = sqr(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_abs(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = abs(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_npwr(double *a, int *n, double *b) {
|
|
qd_real bb;
|
|
bb = npwr(qd_real(a), *n);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_nroot(double *a, int *n, double *b) {
|
|
qd_real bb;
|
|
bb = nroot(qd_real(a), *n);
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_nint(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = nint(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_aint(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = aint(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_floor(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = floor(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_ceil(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = ceil(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_log(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = log(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_log10(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = log10(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_exp(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = exp(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_sin(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = sin(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_cos(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = cos(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_tan(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = tan(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_asin(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = asin(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_acos(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = acos(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_atan(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = atan(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_atan2(const double *a, const double *b, double *c) {
|
|
qd_real cc;
|
|
cc = atan2(qd_real(a), qd_real(b));
|
|
TO_DOUBLE_PTR(cc, c);
|
|
}
|
|
|
|
void f_qd_sinh(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = sinh(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_cosh(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = cosh(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_tanh(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = tanh(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_asinh(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = asinh(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_acosh(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = acosh(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
void f_qd_atanh(const double *a, double *b) {
|
|
qd_real bb;
|
|
bb = atanh(qd_real(a));
|
|
TO_DOUBLE_PTR(bb, b);
|
|
}
|
|
|
|
void f_qd_sincos(const double *a, double *s, double *c) {
|
|
qd_real ss, cc;
|
|
sincos(qd_real(a), ss, cc);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
TO_DOUBLE_PTR(ss, s);
|
|
}
|
|
|
|
void f_qd_sincosh(const double *a, double *s, double *c) {
|
|
qd_real ss, cc;
|
|
sincosh(qd_real(a), ss, cc);
|
|
TO_DOUBLE_PTR(cc, c);
|
|
TO_DOUBLE_PTR(ss, s);
|
|
}
|
|
|
|
/* Writes a dd_real into a character array of length maxlen, with
|
|
* the given precision. The rest of the array will be filled with
|
|
* spaces. Parameter maxlen should at least be precision + 7
|
|
* characters. Prec can be zero to put out the defaut number of
|
|
* digits. */
|
|
void f_qd_swrite(const double *a, int *precision, char *s, int *maxlen) {
|
|
int prec = *precision;
|
|
if (prec <= 0 || prec > qd_real::_ndigits) prec = qd_real::_ndigits;
|
|
std::ios_base::fmtflags fmt = static_cast<std::ios_base::fmtflags>(0);
|
|
std::string str = qd_real(a).to_string(prec, 0, fmt, false, true);
|
|
|
|
int len = 0;
|
|
if (a[0] < 0.0) {
|
|
strncpy(&s[len], str.c_str(), *maxlen - len);
|
|
} else {
|
|
s[len++] = ' ';
|
|
strncpy(&s[len], str.c_str(), *maxlen - len);
|
|
}
|
|
|
|
len += str.length();
|
|
for (int i = len; i < *maxlen; i++)
|
|
s[i] = ' ';
|
|
}
|
|
|
|
void f_qd_write(const double *a) {
|
|
std::cout << qd_real(a) << std::endl;
|
|
}
|
|
|
|
void f_qd_neg(const double *a, double *b) {
|
|
b[0] = -a[0];
|
|
b[1] = -a[1];
|
|
b[2] = -a[2];
|
|
b[3] = -a[3];
|
|
}
|
|
|
|
void f_qd_rand(double *a) {
|
|
qd_real aa;
|
|
aa = qdrand();
|
|
TO_DOUBLE_PTR(aa, a);
|
|
}
|
|
|
|
void f_qd_comp(const double *a, const double *b, int *result) {
|
|
qd_real aa(a), bb(b);
|
|
if (aa < bb)
|
|
*result = -1;
|
|
else if (aa > bb)
|
|
*result = 1;
|
|
else
|
|
*result = 0;
|
|
}
|
|
|
|
void f_qd_comp_qd_d(const double *a, const double *b, int *result) {
|
|
qd_real aa(a);
|
|
if (aa < *b)
|
|
*result = -1;
|
|
else if (aa > *b)
|
|
*result = 1;
|
|
else
|
|
*result = 0;
|
|
}
|
|
|
|
void f_qd_comp_d_qd(const double *a, const double *b, int *result) {
|
|
qd_real bb(b);
|
|
if (*a < bb)
|
|
*result = -1;
|
|
else if (*a > bb)
|
|
*result = 1;
|
|
else
|
|
*result = 0;
|
|
}
|
|
|
|
void f_qd_pi(double *a) {
|
|
TO_DOUBLE_PTR(qd_real::_pi, a);
|
|
}
|
|
|
|
void f_qd_nan(double *a) {
|
|
TO_DOUBLE_PTR(qd_real::_nan, a);
|
|
}
|
|
|
|
}
|
|
|
|
#endif /* HAVE_FORTRAN */
|
|
|