static char rcsid[] = "$Id: omniQReal.c,v 1.17 2001/02/05 11:34:26 m-hirano Exp $";
/* 
 * $RWC_Release: Omni-1.6 $
 * $RWC_Copyright:
 *  Omni Compiler Software Version 1.5-1.6
 *  Copyright (C) 2002 PC Cluster Consortium
 *  
 *  This software is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License version
 *  2.1 published by the Free Software Foundation.
 *  
 *  Omni Compiler Software Version 1.0-1.4
 *  Copyright (C) 1999, 2000, 2001.
 *   Tsukuba Research Center, Real World Computing Partnership, Japan.
 *  
 *  Please check the Copyright and License information in the files named
 *  COPYRIGHT and LICENSE under the top  directory of the Omni Compiler
 *  Software release kit.
 *  
 *  
 *  $
 */
#ifdef ENABLE_QREAL

#include "f2c.h"

#ifndef __GNUC__
# if HAVE_ALLOCA_H
#  include <alloca.h>
# else
#  ifdef OMNI_OS_AIX
#pragma alloca
#  else
#   ifndef alloca /* predefined by HP cc +Olibcalls */
void *  alloca _ANSI_ARGS_((size_t));
#   endif /* !alloca */
#  endif /* OMNI_OS_AIX */
# endif /* HAVE_ALLOCA_H */
#endif /* !__GNUC__ */


#ifndef TYQREAL
#define TYQREAL 15
#endif /* !TYQREAL */


#if !defined(OMNI_QREAL_NEED_GAP_MEMBER) && defined(MPFT_CAST)
# define USE_MPF_STRUCT_P
#endif /* !OMNI_QREAL_NEED_GAP_MEMBER && MPFT_CAST */


extern ftnlen f__typesize[];

#define QLIM_BIT (OMNI_SIZEOF_QLIM_T * CHAR_BIT)
#define EXTRA_OUTPUT_PREC (QLIM_BIT * 2)

int gmpLimbSize = OMNI_QLIM_LEN;
int gmpPrecisionInBits = OMNI_QREAL_PREC;
int precOutputInBits = OMNI_QREAL_PREC + EXTRA_OUTPUT_PREC;
int precDecimalDigits = 0;
int sizeOfQRealT = sizeof(_omQReal_t);

static _omQReal_t *__d5__;	/* '0.5' constant for round off */

#if 0
static void	__qrDump _ANSI_ARGS_((_omQReal_t *v, FILE *out));

static void
__qrDump(v, out)
     _omQReal_t *v;
     FILE *out;
{
    int i;
    int sz = (v->_mp_size < 0) ? -(v->_mp_size) : v->_mp_size;
    fprintf(out, "QRdump:prec=%3d:size=%3d:exp=%3d:limb=0x",
	    v->_mp_prec, v->_mp_size, v->_mp_exp);
    for (i = 0; i < sz; i++) {
#if (OMNI_SIZEOF_QLIM_T > 4)
	fprintf(out, "%016qx:", v->_mp_d[i]);
#else
	fprintf(out, "%08x:", v->_mp_d[i]);
#endif /* (OMNI_SIZEOF_QLIM_T > 4) */
    }
    fprintf(out, "\n");
}
#endif


#ifdef QS_FUNCS
void
QRinit(qPtr)
     _omQReal_t *qPtr;
{
    qPtr->_mp_prec = gmpLimbSize - 1;
    qPtr->_mp_size = gmpLimbSize;
    qPtr->_mp_exp = 0;
    qPtr->_mp_d = &(qPtr->_omLimb[0]);
}
#else
#define QRinit(qPtr) \
{ \
  ((qPtr)->_mp_prec) = gmpLimbSize - 1; \
  ((qPtr)->_mp_size) = gmpLimbSize; \
  ((qPtr)->_mp_exp) = 0; \
  ((qPtr)->_mp_d) = &((qPtr)->_omLimb[0]); \
}
#endif /* QS_FUNCS */


#ifdef QS_FUNCS
void
QRsane(qPtr)
     _omQReal_t *qPtr;
{
    qPtr->_mp_d = &(qPtr->_omLimb[0]);
}
#else
#define QRsane(qPtr) \
{ \
  ((qPtr)->_mp_d) = &((qPtr)->_omLimb[0]); \
}
#endif /* QS_FUNCS */

static void *	gmpAlloc _ANSI_ARGS_((size_t sz));
static void *	gmpRealloc _ANSI_ARGS_((void *ptr, size_t oSz, size_t nSz));
static void	gmpFree _ANSI_ARGS_((void *ptr, size_t sz));

static void *
gmpAlloc(sz)
     size_t sz;
{
  fprintf(stderr, "debug: Alloc\n");
    return (void *)malloc(sz);
}

static void *
gmpRealloc(ptr, oSz, nSz)
     void *ptr;
     size_t oSz, nSz;
{
  fprintf(stderr, "debug:Realloc\n");
    return (void *)realloc(ptr, nSz);
}

static void
gmpFree(ptr, sz)
     void *ptr;
     size_t sz;
{
  fprintf(stderr, "debug:Free\n");
    (void)free(ptr);
}

void
_ompf77_QReal_init(qPrecInBits, qLimbSize, sizeOfQReal_t)
     int qPrecInBits;
     int qLimbSize;
     int sizeOfQReal_t;
{
    mpf_t tmp;
    int gPrec;
    double d;

#if 0
    mp_set_memory_functions(gmpAlloc, gmpRealloc, gmpFree);
#endif

    mpf_set_default_prec((unsigned long int)qPrecInBits);
    mpf_init(tmp);
    
    gPrec = (int)(((__mpf_struct *)(&tmp))->_mp_prec + 1);
    if (qLimbSize != gPrec) {
	sig_die("Limb size calulated by compiler frontend is differ from runtime calculated value.", 1);
	mpf_clear(tmp);
	return;
    }

    mpf_clear(tmp);

    gmpLimbSize = qLimbSize;
    gmpPrecisionInBits = qPrecInBits;
    precOutputInBits = qPrecInBits + EXTRA_OUTPUT_PREC;

    d = (double)(((double)precOutputInBits) * log10(2.0));
    precDecimalDigits = (int)d + 2;

    sizeOfQRealT = sizeOfQReal_t;

    f__typesize[TYQREAL] = sizeOfQRealT;

    __d5__ = (_omQReal_t *)malloc(sizeOfQRealT);
    QRinit(__d5__);

    mpf_init_set_d((mpf_ptr)__d5__, (double)0.5);
}


int
mpfNaN(mPtr)
     mpf_t *mPtr;
{
    __mpf_struct *fPtr = (__mpf_struct *)mPtr;

    if ((fPtr->_mp_prec + 1) != gmpLimbSize) {
	return 1;
    }
    return 0;
}


int
QRNaN(qPtr)
     _omQReal_t *qPtr;
{
    if ((qPtr->_mp_prec + 1) != gmpLimbSize) {
	return 1;
    }
    return 0;
}


void
mpf2QR(src, dst)
     mpf_t *src;
     _omQReal_t *dst;
{
    __mpf_struct *sPtr = (__mpf_struct *)src;

#if 0
    if ((sPtr->_mp_prec + 1) != gmpLimbSize) {
	fprintf(stderr, "debug: src prec wrong.\n");
	abort();
    }
#endif
    dst->_mp_prec = sPtr->_mp_prec;
    dst->_mp_size = sPtr->_mp_size;
    dst->_mp_exp = sPtr->_mp_exp;
    dst->_mp_d = &(dst->_omLimb[0]);
    memcpy((char *)dst->_mp_d, (char *)sPtr->_mp_d,
	   OMNI_SIZEOF_QLIM_T * gmpLimbSize);
}


void
QR2mpf(src, dst)
     _omQReal_t *src;
     mpf_t *dst;
{
    __mpf_struct *dPtr = (__mpf_struct *)dst;

#if 0
    if ((src->_mp_prec + 1) != gmpLimbSize) {
	fprintf(stderr, "debug: src prec wrong.\n");
	abort();
    }
#endif
    dPtr->_mp_prec = src->_mp_prec;
    dPtr->_mp_size = src->_mp_size;
    dPtr->_mp_exp = src->_mp_exp;
    src->_mp_d = &(src->_omLimb[0]);
    memcpy((char *)dPtr->_mp_d, (char *)src->_mp_d,
	   OMNI_SIZEOF_QLIM_T * gmpLimbSize);
}


void
_long2QR(src, dst)
     signed long int *src;
     _omQReal_t *dst;
{
#ifdef USE_MPF_STRUCT_P
    QRinit(dst);
    mpf_set_si((mpf_ptr)dst, *src);
#else
    mpf_t nVal;

    mpf_init_set_si(nVal, *src);
    mpf2QR(&nVal, dst);
    mpf_clear(nVal);
#endif /* USE_MPF_STRUCT_P */
}


void
_double2QR(src, dst)
     double *src;
     _omQReal_t *dst;
{
#ifdef USE_MPF_STRUCT_P
    QRinit(dst);
    mpf_set_d((mpf_ptr)dst, *src);
#else
    mpf_t nVal;

    mpf_init_set_d(nVal, *src);
    mpf2QR(&nVal, dst);
    mpf_clear(nVal);
#endif /* USE_MPF_STRUCT_P */
}


void
_str2QR(str, dst)
     char *str;
     _omQReal_t *dst;
{
#ifdef USE_MPF_STRUCT_P
    QRinit(dst);
    mpf_set_str((mpf_ptr)dst, str, 10);
#else
    mpf_t nVal;

    mpf_init_set_str(nVal, str, 10);
    mpf2QR(&nVal, dst);
    mpf_clear(nVal);
#endif /* USE_MPF_STRUCT_P */
}


void
_QR2double(src, dst)
     _omQReal_t *src;
     double *dst;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(src);
    *dst = mpf_get_d((mpf_ptr)src);
#else
    mpf_t nVal;
    
    mpf_init(nVal);
    QR2mpf(src, &nVal);
    *dst = mpf_get_d(nVal);
    mpf_clear(nVal);
#endif /* USE_MPF_STRUCT_P */
}


void
_QRneg(q0, a)
     _omQReal_t *q0, *a;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    if (q0 != a) {
	QRinit(a);
    }
    mpf_neg((mpf_ptr)a, (mpf_srcptr)q0);
#else
    mpf_t q0V, aV;

    mpf_init(q0V);
    mpf_init(aV);

    QR2mpf(q0, &q0V);
    
    mpf_neg(aV, q0V);

    mpf2QR(&aV, a);

    mpf_clear(q0V);
    mpf_clear(aV);
#endif /* USE_MPF_STRUCT_P */
}


/*
 * Intrinsics:
 *	1st args:	return val addr.
 *	after 2nd:	func args.
 */

/*
 * abs
 */
void
_QRabs(a, q0)
     _omQReal_t *a, *q0;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    if (q0 != a) {
	QRinit(a);
    }
    mpf_abs((mpf_ptr)a, (mpf_srcptr)q0);
#else
    mpf_t q0V, aV;

    mpf_init(q0V);
    mpf_init(aV);

    QR2mpf(q0, &q0V);
    
    mpf_abs(aV, q0V);

    mpf2QR(&aV, a);

    mpf_clear(q0V);
    mpf_clear(aV);
#endif /* USE_MPF_STRUCT_P */
}

/*
 * sqrt
 */
void
_QRsqrt(a, q0)
     _omQReal_t *a, *q0;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    if (q0 != a) {
	QRinit(a);
    }
    mpf_sqrt((mpf_ptr)a, (mpf_srcptr)q0);
#else
    mpf_t q0V, aV;

    mpf_init(q0V);
    mpf_init(aV);

    QR2mpf(q0, &q0V);
    
    mpf_sqrt(aV, q0V);

    mpf2QR(&aV, a);

    mpf_clear(q0V);
    mpf_clear(aV);
#endif /* USE_MPF_STRUCT_P */
}

/*
 * aint ... round downwards to the nearest integer.
 */
void
_QRaint(a, q0)
     _omQReal_t *a, *q0;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    if (q0 != a) {
	QRinit(a);
    }

    if (mpf_sgn((mpf_srcptr)q0) > 0) {
	mpf_floor((mpf_ptr)a, (mpf_srcptr)q0);
    } else {
	mpf_neg((mpf_ptr)a, (mpf_srcptr)q0);
	mpf_floor((mpf_ptr)a, (mpf_srcptr)a);
	mpf_neg((mpf_ptr)a, (mpf_srcptr)a);
    }
#else
    mpf_t q0V, aV;
    mpf_init(q0V);
    mpf_init(aV);
    QR2mpf(q0, &q0V);

    if (mpf_sgn(q0V) > 0) {
	mpf_floor(aV, q0V);
    } else {
	mpf_neg(aV, q0V);
	mpf_floor(aV, aV);
	mpf_neg(aV, aV);
    }

    mpf2QR(&aV, a);
    mpf_clear(q0V);
    mpf_clear(aV);
#endif /* USE_MPF_STRUCT_P */
}


/*
 * anint ... round off to the nearest integer
 */
void
_QRanint(a, q0)
     _omQReal_t *a, *q0;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    if (q0 != a) {
	QRinit(a);
    }

    if (mpf_sgn((mpf_srcptr)q0) >= 0) {
	mpf_add((mpf_ptr)a, (mpf_srcptr)__d5__, (mpf_srcptr)q0);
	mpf_floor((mpf_ptr)a, (mpf_srcptr)a);
    } else {
	mpf_sub((mpf_ptr)a, (mpf_srcptr)__d5__, (mpf_srcptr)q0);
	mpf_floor((mpf_ptr)a, (mpf_srcptr)a);
	mpf_neg((mpf_ptr)a, (mpf_srcptr)a);
    }
#else
    mpf_t q0V, aV;
    mpf_init(q0V);
    mpf_init(aV);
    QR2mpf(q0, &q0V);

    if (mpf_sgn(q0V) >= 0) {
	mpf_add(aV, (mpf_srcptr)__d5__, q0V);
	mpf_floor(aV, aV);
    } else {
	mpf_sub(aV, (mpf_srcptr)__d5__, q0V);
	mpf_floor(aV, aV);
	mpf_neg(aV, aV);
    }

    mpf2QR(&aV, a);
    mpf_clear(q0V);
    mpf_clear(aV);
#endif /* USE_MPF_STRUCT_P */
}


/*
 * nint ... round off to the nearest integer, and return it as an integer
 */
int
_QRnint(q0)
     _omQReal_t *q0;
{
    double d;
    _omQReal_t *a = (_omQReal_t *)alloca(sizeOfQRealT);    

    _QRanint(a, q0);
    _QR2double(a, &d);

    return (int)d;
}


/*
 * modulo
 */
void
_QRmod(a, q0, q1)
     _omQReal_t *a, *q0, *q1;
{
    _omQReal_t *iDiv = (_omQReal_t *)alloca(sizeOfQRealT);

    _QRdiv(q0, q1, iDiv);
    _QRaint(iDiv, iDiv);
    _QRmul(iDiv, q1, iDiv);
    _QRsub(q0, iDiv, a);
}


/*
 * sign ... change a sign of q0 according to q1
 */
void
_QRsign(a, q0, q1)
     _omQReal_t *a, *q0, *q1;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    QRsane(q1);
    if (a != q0 && a != q1) {
	QRinit(a);
    }

    mpf_abs((mpf_ptr)a, (mpf_srcptr)q0);
    if (mpf_sgn(q1) < 0) {
	mpf_neg((mpf_ptr)a, (mpf_srcptr)a);
    }

#else
    mpf_t aV, qOV, q1V;
    mpf_init(aV);
    mpf_init(q0V);
    mpf_init(q1V);
    QR2mpf(q0, &q0V);
    QR2mpf(q1, &q1V);

    mpf_abs(aV, q0V);
    if (mpf_sgn(q1V) < 0) {
	mpf_neg(aV, aV);
    }

    mpf2QR(&aV, a);
    mpf_clear(aV);
    mpf_clear(q0V);
    mpf_clear(q1V);
#endif /* USE_MPF_STRUCT_P */
}


/*
 * dim ... difference between q0 and q1
 */
void
_QRdim(a, q0, q1)
     _omQReal_t *a, *q0, *q1;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    QRsane(q1);
    if (a != q0 && a != q1) {
	QRinit(a);
    }

    if (mpf_cmp((mpf_srcptr)q0, (mpf_srcptr)q1) > 0) {
	mpf_sub((mpf_ptr)a, (mpf_srcptr)q0, (mpf_srcptr)q1);
    } else {
	mpf_set_d((mpf_ptr)a, 0.0);
    }

#else
    mpf_t aV, qOV, q1V;
    mpf_init(aV);
    mpf_init(q0V);
    mpf_init(q1V);
    QR2mpf(q0, &q0V);
    QR2mpf(q1, &q1V);

    if (mpf_cmp(q0V, q1V) > 0) {
	mpf_sub(aV, q0V, q1V);
    } else {
	mpf_set_d(aV, 0.0);
    }

    mpf2QR(&aV, a);
    mpf_clear(aV);
    mpf_clear(q0V);
    mpf_clear(q1V);
#endif /* USE_MPF_STRUCT_P */
}


/*
 * add/sub/mul/div:
 *	last args:		return val addr.
 *	1st - (last -1):	func args.
 */

#ifdef USE_MPF_STRUCT_P

# define CALL_MPF(func, ret, opl0, opl1) \
{ \
  QRsane(opl0); \
  QRsane(opl1); \
  if (ret != (opl0) && ret != (opl1)) { \
    QRinit(ret); \
  } \
  func((mpf_ptr)(ret), (mpf_srcptr)(opl0), (mpf_srcptr)(opl1)); \
}

#else

# define CALL_MPF(func, ret, opl0, opl1) \
{ \
  mpf_t retV, opl0V, opl1V; \
  mpf_init(retV); \
  mpf_init(opl0V); \
  mpf_init(opl1V); \
  QR2mpf((opl0), &opl0V); \
  QR2mpf((opl1), &opl1V); \
  func((retV), (opl0V), (opl1V)); \
  mpf2QR(&retV, (ret)); \
  mpf_clear(retV); \
  mpf_clear(opl0V); \
  mpf_clear(opl1V); \
}

#endif /* USE_MPF_STRUCT_P */

void
_QRadd(q0, q1, a)
     _omQReal_t *q0, *q1, *a;
{
    CALL_MPF(mpf_add, a, q0, q1);
}

void
_QRsub(q0, q1, a)
     _omQReal_t *q0, *q1, *a;
{
    CALL_MPF(mpf_sub, a, q0, q1);
}


void
outStr(v)
     mpf_t *v;
{
    mp_exp_t exp;
    char *str = mpf_get_str(NULL, &exp, 10, 0, *v);
    if (str[0] == '-') {
	fprintf(stderr, "outStr: -0.%s0E%d\n", str + 1, (int)exp);
    } else {
	fprintf(stderr, "outStr: 0.%s0E%d\n", str, (int)exp);
    }
    free(str);
}


void
_QRmul(q0, q1, a)
     _omQReal_t *q0, *q1, *a;
{
#if 0
# define CALL_MPFMUL(func, ret, opl0, opl1) \
    mpf_t retV, opl0V, opl1V; \
    fprintf(stderr, "debug: mpf_mul !\n"); \
    mpf_init(retV); \
    mpf_init(opl0V); \
    mpf_init(opl1V); \
    QR2mpf((opl0), &opl0V); \
    outStr(&opl0V); \
    QR2mpf((opl1), &opl1V); \
    outStr(&opl1V); \
    func((retV), (opl0V), (opl1V)); \

    CALL_MPFMUL(mpf_mul, a, q0, q1);

    outStr(&opl0V);
    outStr(&opl1V);
    outStr(&retV);
    mpf2QR(&retV, a);

    mpf_clear(retV);
    mpf_clear(opl0V);
    mpf_clear(opl1V);

#undef CALL_MPFMUL
#else
    CALL_MPF(mpf_mul, a, q0, q1);
#endif
}

void
_QRdiv(q0, q1, a)
     _omQReal_t *q0, *q1, *a;
{
    CALL_MPF(mpf_div, a, q0, q1);
}

#undef CALL_MPF


/*
 * compare
 */
int
_QRcmp(q0, q1)
     _omQReal_t *q0, *q1;
{
#ifdef USE_MPF_STRUCT_P
    QRsane(q0);
    QRsane(q1);
    return mpf_cmp((mpf_srcptr)q0, (mpf_srcptr)q1);
#else
    mpf_t q0V, q1V;
    int ret;

    mpf_init(q0V);
    mpf_init(q1V);

    QR2mpf(q0, &q0V);
    QR2mpf(q1, &q1V);

    ret = mpf_cmp(q0V, q1V);
    
    mpf_clear(q0V);
    mpf_clear(q1V);

    return ret;
#endif /* USE_MPF_STRUCT_P */
}


/*
 * power ... quad ** integer
 */
void
_QRpow_qi(q0, l0, a)
     _omQReal_t *q0;
     signed long int *l0;
     _omQReal_t *a;
{
#ifdef USE_MPF_STRUCT_P
    signed long int i;
    signed long int n = *l0;

    QRsane(q0);
    if (a != q0) {
	QRinit(a);
    }

    mpf_set_d((mpf_ptr)a, (double)1.0);

    if (n == 0) {
	goto done;
    } else if (n < 0) {
	if (mpf_sgn((mpf_srcptr)q0) == 0) {
	    sig_die("zero raised to negative power, divide by zero", 1);
	    goto errorDone;
	}
	n = -n;
	mpf_div((mpf_ptr)q0, (mpf_srcptr)a, (mpf_srcptr)q0);
    }
    for (i = 0; i < n; i++) {
	mpf_mul((mpf_ptr)a, (mpf_srcptr)a, (mpf_srcptr)q0);
    }

    done:
    errorDone:
    return;
#else
    signed long int i;
    signed long int n = *l0;
    mpf_t q0V, aV;

    mpf_init(q0V);
    mpf_init_set_d(aV, (double)1.0);

    QR2mpf(q0, &q0V);

    if (n == 0) {
	goto done;
    } else if (n < 0) {
	if (mpf_sgn(q0V) == 0) {
	    sig_die("zero raised to negative power, divide by zero", 1);
	    goto errorDone;
	}
	n = -n;
	mpf_div(q0V, aV, q0V);
    }
    for (i = 0; i < n; i++) {
	mpf_mul(aV, aV, q0V);
    }

    done:
    mpf2QR(&aV, a);
    errorDone:
    mpf_clear(q0V);
    mpf_clear(aV);
#endif /* USE_MPF_STRUCT_P */
}

#endif /* ENABLE_QREAL */