/**************************************************************************/
/*                                                                        */
/*                                 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: r_frac.c,v 1.2 1997/09/25 17:46:40 ae59 Exp $ */
/*
$Log: r_frac.c,v $
 * Revision 1.2  1997/09/25  17:46:40  ae59
 * Copyright-message
 *
 * Revision 1.1  1994/01/27  13:24:00  ae59
 * Put under RCS control
 *
 */
/****************************************************************/
/*                                                              */
/*      Filename        : r_frac.c                              */
/*                                                              */
/*      Entries         : a_real r_frac(a)                      */
/*                        a_real a;                             */
/*                                                              */
/*      Arguments       : a = IEEE value                        */
/*                                                              */
/*      Description     : Fraction part of IEEE number.         */
/*                                                              */
/*      Date            : 1992-01-21                            */
/****************************************************************/

#ifndef ALL_IN_ONE
#ifdef AIX
#include "/u/p88c/runtime/o_defs.h"
#else
#include "o_defs.h"
#endif
#define local
#endif

#ifdef LINT_ARGS
local a_real r_frac(a_real a)
#else
local a_real r_frac(a)

a_real a;
#endif
        {
        a_btyp expo;
        a_btyp *ptra;

        E_TPUSH("r_frac")

        /* special value */
        if ((expo = (ptra = ((a_btyp *)&a))[B_HPART] & EXPO_MASK)==EXPO_MASK)
           {
           if (((ptra[B_HPART] & EXPO_MASK) | ptra[B_LPART])!=0)
              {
              if (SIGNALING(ptra[B_HPART]))
                 {
                 e_trap(INV_OP+E_IEEE,4,E_TMSG,5,E_TDBL+E_TEXT(7),ptra);
                 ptra[B_HPART] = SET_QUIET(EXPO_MASK);
                 ptra[B_LPART] = INV_OP;
                 }
              }
           }

        /* number has fraction part */
        else if (expo>=0x3ff00000)
           {
           a_btyp a0,a1;

           /* number does not posses fraction part since >=2**52 */
           if (expo>=0x43300000) 
              {
              a0 = ptra[B_HPART] & MSB;
              expo = a1 = 0;
              }

           /* determine fraction */
           else
              {
              int s;
   
              a0 = ptra[B_HPART] & MANT_HIGH;
              a1 = ptra[B_LPART];
   
              /* clear all integer bits by shifting */
              s = ((int)(expo>>EXPO_SHIFT))-CHARAC;
              if (s>=B_LENGTH) 
                 {
                 a0 = (a1<<(s-B_LENGTH)) & MANT_HIGH;
                 a1 = 0;
                 }
              else if (s!=0)
                 {
                 a0 = ((a0<<s) & MANT_HIGH) | (a1>>(B_LENGTH-s));
                 a1 <<= s;
                 }
   
              /* determine exponent if non-zero fraction part */
              if ((a0|a1)!=0)
                 {
                 expo = 0x3ff00000;
                 while ((a0 & HIDDEN_BIT)==0)
                    {
                    expo -= HIDDEN_BIT;
                    a0 = (a0<<1) | (a1>>(B_LENGTH-1));
                    a1 <<= 1;
                    }
                 }
              else
                 {
                 expo = 0;
                 }
              }
   
           /* construct number */
           ptra[B_HPART] = (ptra[B_HPART] & MSB) | expo | (a0 & MANT_HIGH);
           ptra[B_LPART] = a1;
           }

        E_TPOPP("r_frac")
        return(a);
        }
