/**************************************************************************/
/*                                                                        */
/*                                 Sources                                */
/*                                from  the                               */
/*                           XSC SOFTWARE PACKAGE                         */
/*                                                                        */
/*                Copyright (c) 1997 University of Karlsruhe              */
/*                     Institute for Appl. Mathematics                    */
/*                                                                        */
/* This program is free software for non-commercial use. For details, see */
/* the file LICENSE.XSC, distributed with this software package.          */
/*                                                                        */
/* This program is distributed WITHOUT ANY WARRANTY. For details, see the */
/* file LICENSE.XSC, distributed with this software package.              */
/*                                                                        */
/**************************************************************************/

/* RCS $Id: b_ltor.c,v 1.2 1997/09/25 17:04:19 ae59 Exp $ */
/*
$Log: b_ltor.c,v $
 * Revision 1.2  1997/09/25  17:04:19  ae59
 * Copyright-message
 *
 * Revision 1.1  1994/01/27  13:21:32  ae59
 * Put under RCS control
 *
 */
/****************************************************************/
/*                                                              */
/*      Filename        : b_ltor.c                              */
/*                                                              */
/*      Entries         : a_btyp b_ltor(i,r,rnd)                */
/*                        multiprecision i;                     */
/*                        a_real *r;                            */
/*                        a_intg rnd;                           */
/*                                                              */
/*      Arguments       : i    = long value                     */
/*                        r    = real value                     */
/*                        rnd  = rounding                       */
/*                               <0 : downwards                 */
/*                               =0 : nearest                   */
/*                               >0 : upwards                   */
/*                                                              */
/*      Function value  : error code                            */
/*                                                              */
/*      Description     : convert long to real value.           */
/*                                                              */
/*      Note            : long value mantissa must not exceed   */
/*                        three digits.                         */
/*                                                              */
/*      Date            : 1991-08-05                            */
/*      1991-08-05 : variable carry not used                    */
/*      1991-07-31 : consider rounding bits according to b_maxl */
/*      1991-07-17 : consider rounding bit if zero              */
/*      1991-06-20 : rounding considered for short results      */
/*      1991-04-22 : real assignment replaced by R_ASSIGN()     */
/*      1991-02-13 : E_TPUSH/E_TPOPP                            */
/*      1991-01-07 : union q removed                            */
/*      1990-07-16 : LINT_ARGS prototype                        */
/****************************************************************/

#ifndef ALL_IN_ONE
#ifdef AIX
#include "/u/p88c/runtime/o_defs.h"
#else
#include "o_defs.h"
#endif
#define local
extern a_real *r_sero;
extern a_real *r_zero;
extern a_real *r_eps_;
extern a_real *r_meps;
extern a_btyp b_maxl;
#endif

#ifdef LINT_ARGS
local a_btyp b_ltor(multiprecision i,a_real *r,a_intg rnd)
#else
local a_btyp b_ltor(i,r,rnd)

multiprecision i;
a_real *r;
a_intg rnd;
#endif
        {
        a_btyp rc,rc1,mant[BSIZE];
        a_intg expo,k;
        a_bool sign;

        E_TPUSH("b_ltor")

        /* number is zero                                       */
        if (i->z)
           {
           if (rnd<0)
              {
              if (i->r && i->s)
                 R_ASSIGN(*r,*r_meps);
              else
                 R_ASSIGN(*r,*r_zero);
              }
           else if (rnd>0)
              {
              if (i->r && i->s==0)
                 R_ASSIGN(*r,*r_eps_);
              else if (i->s)
                 R_ASSIGN(*r,*r_sero);
              else
                 R_ASSIGN(*r,*r_zero);
              }
           else
              R_ASSIGN(*r,*r_zero);

           E_TPOPP("b_ltor")
           return(NO_ERROR);
           }

        /* sign and exponent of real value */
        sign = i->s;
        expo = (i->e<<LOG_B_LENGTH)+EXPO_SHIFT;

        /* mantissa digits of real value */
        for (k=0;k<i->l && k<BSIZE-1;k++) mant[k] = i->m[k];
        if (i->l>=BSIZE)
           {

           /* rounding outward required */
           if ((rnd>0 && sign==0) || (rnd<0 && sign))
              {

              /* at least one trailing bit assumed */
              if (i->l<b_maxl) mant[BSIZE-1] = MSB;

              else
                 {

                 /* rounding bits may cause carry */
                 for (k = BSIZE;k<b_maxl-1;k++)
                    if (mant[k]!=MAX_BASETYPE) break;

                 /* no carry possible */
                 if (k<b_maxl-1) mant[BSIZE-1] = MSB;
                 else
                    {

                    /* no carry occurred */
                    if (mant[k]+i->r>=i->r) mant[BSIZE-1] = MSB;

                    /* carry occurred */
                    else
                       {
                       /* add carry to mantissa */
                       if (b_bcad((a_intg)(BSIZE-1),mant))
                          {
                          mant[0] = LSB;
                          expo += B_LENGTH;
                          }

                       /* non-zero remainder mantiassa */
                       if (k+1<i->l || mant[k]+i->r>ZERO)
                          mant[BSIZE-1] = MSB;
                       }
                    }
                 }
              }
           }
        else /* i->l<BSIZE */
           {

           /* clear all remaining mantissa positions in mant */
           while (k<BSIZE) mant[k++] = ZERO;

           /* rounding outward required */
           if ((rnd>0 && sign==0) || (rnd<0 && sign))
              {

              /* consider all rounding bits */
              if (i->r)
                 {
                 if ((mant[b_maxl-1] += i->r)<i->r)
                    {
                    if (b_bcad((a_intg)(b_maxl-1),mant))
                       {
                       mant[0] = LSB;
                       expo += B_LENGTH;
                       }
                    }
                 }
              }
           }

        /* normalization of mantissa                            */
        if (SHFT_MASK & *mant)
           {
           do {
              b_shr1(mant,BSIZE);
              expo++;
              }
           while (SHFT_MASK & *mant);
           }
        else if ((HIDDEN_BIT & *mant)==ZERO)
           {
           k = 1;
           while ((HIDDEN_BIT & (*mant<<k))==ZERO) k++;
           b_shlu(mant,BSIZE,k);
           expo -= k;
           }

        /* adjust denormalized number and check inexact data    */
        rc = b_adj(mant,&expo);

        /* round mantissa                                       */
        if (rnd<0) rc1 = b_rndd(mant,&expo,sign);
        else if (rnd>0) rc1 = b_rndu(mant,&expo,sign);
        else rc1 = b_rndn(mant,&expo);

        /* compose result                                       */
        b_comp(r,expo,mant,sign);

        if (rc==ZERO) rc = rc1;

        E_TPOPP("b_ltor")
        return(rc);
        }
