<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<meta http-equiv="Content-Type" content="text/xhtml;charset=UTF-8"/>
<title>SphinxBase: src/libsphinxbase/util/slamch.c Source File</title>
<link href="tabs.css" rel="stylesheet" type="text/css"/>
<link href="navtree.css" rel="stylesheet" type="text/css"/>
<script type="text/javascript" src="jquery.js"></script>
<script type="text/javascript" src="navtree.js"></script>
<script type="text/javascript" src="resize.js"></script>
<script type="text/javascript">
$(document).ready(initResizable);
</script>
<link href="doxygen.css" rel="stylesheet" type="text/css"/>
</head>
<body>
<!-- Generated by Doxygen 1.7.3 -->
<div id="top">
<div id="titlearea">
<table cellspacing="0" cellpadding="0">
<tbody>
<tr style="height: 56px;">
<td style="padding-left: 0.5em;">
<div id="projectname">SphinxBase <span id="projectnumber">0.6</span></div>
</td>
</tr>
</tbody>
</table>
</div>
<div id="navrow1" class="tabs">
<ul class="tablist">
<li><a href="index.html"><span>Main Page</span></a></li>
<li><a href="pages.html"><span>Related Pages</span></a></li>
<li><a href="annotated.html"><span>Data Structures</span></a></li>
<li class="current"><a href="files.html"><span>Files</span></a></li>
</ul>
</div>
<div id="navrow2" class="tabs2">
<ul class="tablist">
<li><a href="files.html"><span>File List</span></a></li>
<li><a href="globals.html"><span>Globals</span></a></li>
</ul>
</div>
</div>
<div id="side-nav" class="ui-resizable side-nav-resizable">
<div id="nav-tree">
<div id="nav-tree-contents">
</div>
</div>
<div id="splitbar" style="-moz-user-select:none;"
class="ui-resizable-handle">
</div>
</div>
<script type="text/javascript">
initNavTree('slamch_8c.html','');
</script>
<div id="doc-content">
<div class="header">
<div class="headertitle">
<h1>src/libsphinxbase/util/slamch.c</h1> </div>
</div>
<div class="contents">
<div class="fragment"><pre class="fragment"><a name="l00001"></a>00001 <span class="comment">/* src/slamch.f -- translated by f2c (version 20050501).</span>
<a name="l00002"></a>00002 <span class="comment"> You must link the resulting object file with libf2c:</span>
<a name="l00003"></a>00003 <span class="comment"> on Microsoft Windows system, link with libf2c.lib;</span>
<a name="l00004"></a>00004 <span class="comment"> on Linux or Unix systems, link with .../path/to/libf2c.a -lm</span>
<a name="l00005"></a>00005 <span class="comment"> or, if you install libf2c.a in a standard place, with -lf2c -lm</span>
<a name="l00006"></a>00006 <span class="comment"> -- in that order, at the end of the command line, as in</span>
<a name="l00007"></a>00007 <span class="comment"> cc *.o -lf2c -lm</span>
<a name="l00008"></a>00008 <span class="comment"> Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,</span>
<a name="l00009"></a>00009 <span class="comment"></span>
<a name="l00010"></a>00010 <span class="comment"> http://www.netlib.org/f2c/libf2c.zip</span>
<a name="l00011"></a>00011 <span class="comment">*/</span>
<a name="l00012"></a>00012
<a name="l00013"></a>00013 <span class="preprocessor">#include "sphinxbase/f2c.h"</span>
<a name="l00014"></a>00014
<a name="l00015"></a>00015 <span class="preprocessor">#ifdef _MSC_VER</span>
<a name="l00016"></a>00016 <span class="preprocessor"></span><span class="preprocessor">#pragma warning (disable: 4244)</span>
<a name="l00017"></a>00017 <span class="preprocessor"></span><span class="preprocessor">#endif</span>
<a name="l00018"></a>00018 <span class="preprocessor"></span>
<a name="l00019"></a>00019 <span class="comment">/* Table of constant values */</span>
<a name="l00020"></a>00020
<a name="l00021"></a>00021 <span class="keyword">static</span> integer c__1 = 1;
<a name="l00022"></a>00022 <span class="keyword">static</span> real c_b32 = 0.f;
<a name="l00023"></a>00023
<a name="l00024"></a>00024 doublereal
<a name="l00025"></a>00025 slamch_(<span class="keywordtype">char</span> *cmach, ftnlen cmach_len)
<a name="l00026"></a>00026 {
<a name="l00027"></a>00027 <span class="comment">/* Initialized data */</span>
<a name="l00028"></a>00028
<a name="l00029"></a>00029 <span class="keyword">static</span> logical first = TRUE_;
<a name="l00030"></a>00030
<a name="l00031"></a>00031 <span class="comment">/* System generated locals */</span>
<a name="l00032"></a>00032 integer i__1;
<a name="l00033"></a>00033 real ret_val;
<a name="l00034"></a>00034
<a name="l00035"></a>00035 <span class="comment">/* Builtin functions */</span>
<a name="l00036"></a>00036 <span class="keywordtype">double</span> pow_ri(real *, integer *);
<a name="l00037"></a>00037
<a name="l00038"></a>00038 <span class="comment">/* Local variables */</span>
<a name="l00039"></a>00039 <span class="keyword">static</span> real t;
<a name="l00040"></a>00040 <span class="keyword">static</span> integer it;
<a name="l00041"></a>00041 <span class="keyword">static</span> real rnd, eps, base;
<a name="l00042"></a>00042 <span class="keyword">static</span> integer beta;
<a name="l00043"></a>00043 <span class="keyword">static</span> real emin, prec, emax;
<a name="l00044"></a>00044 <span class="keyword">static</span> integer imin, imax;
<a name="l00045"></a>00045 <span class="keyword">static</span> logical lrnd;
<a name="l00046"></a>00046 <span class="keyword">static</span> real rmin, rmax, rmach;
<a name="l00047"></a>00047 <span class="keyword">extern</span> logical lsame_(<span class="keywordtype">char</span> *, <span class="keywordtype">char</span> *, ftnlen, ftnlen);
<a name="l00048"></a>00048 <span class="keyword">static</span> real small, sfmin;
<a name="l00049"></a>00049 <span class="keyword">extern</span> <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span> slamc2_(integer *, integer *, logical *, real
<a name="l00050"></a>00050 *, integer *, real *, integer *,
<a name="l00051"></a>00051 real *);
<a name="l00052"></a>00052
<a name="l00053"></a>00053
<a name="l00054"></a>00054 <span class="comment">/* -- LAPACK auxiliary routine (version 3.0) -- */</span>
<a name="l00055"></a>00055 <span class="comment">/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */</span>
<a name="l00056"></a>00056 <span class="comment">/* Courant Institute, Argonne National Lab, and Rice University */</span>
<a name="l00057"></a>00057 <span class="comment">/* October 31, 1992 */</span>
<a name="l00058"></a>00058
<a name="l00059"></a>00059 <span class="comment">/* .. Scalar Arguments .. */</span>
<a name="l00060"></a>00060 <span class="comment">/* .. */</span>
<a name="l00061"></a>00061
<a name="l00062"></a>00062 <span class="comment">/* Purpose */</span>
<a name="l00063"></a>00063 <span class="comment">/* ======= */</span>
<a name="l00064"></a>00064
<a name="l00065"></a>00065 <span class="comment">/* SLAMCH determines single precision machine parameters. */</span>
<a name="l00066"></a>00066
<a name="l00067"></a>00067 <span class="comment">/* Arguments */</span>
<a name="l00068"></a>00068 <span class="comment">/* ========= */</span>
<a name="l00069"></a>00069
<a name="l00070"></a>00070 <span class="comment">/* CMACH (input) CHARACTER*1 */</span>
<a name="l00071"></a>00071 <span class="comment">/* Specifies the value to be returned by SLAMCH: */</span>
<a name="l00072"></a>00072 <span class="comment">/* = 'E' or 'e', SLAMCH := eps */</span>
<a name="l00073"></a>00073 <span class="comment">/* = 'S' or 's , SLAMCH := sfmin */</span>
<a name="l00074"></a>00074 <span class="comment">/* = 'B' or 'b', SLAMCH := base */</span>
<a name="l00075"></a>00075 <span class="comment">/* = 'P' or 'p', SLAMCH := eps*base */</span>
<a name="l00076"></a>00076 <span class="comment">/* = 'N' or 'n', SLAMCH := t */</span>
<a name="l00077"></a>00077 <span class="comment">/* = 'R' or 'r', SLAMCH := rnd */</span>
<a name="l00078"></a>00078 <span class="comment">/* = 'M' or 'm', SLAMCH := emin */</span>
<a name="l00079"></a>00079 <span class="comment">/* = 'U' or 'u', SLAMCH := rmin */</span>
<a name="l00080"></a>00080 <span class="comment">/* = 'L' or 'l', SLAMCH := emax */</span>
<a name="l00081"></a>00081 <span class="comment">/* = 'O' or 'o', SLAMCH := rmax */</span>
<a name="l00082"></a>00082
<a name="l00083"></a>00083 <span class="comment">/* where */</span>
<a name="l00084"></a>00084
<a name="l00085"></a>00085 <span class="comment">/* eps = relative machine precision */</span>
<a name="l00086"></a>00086 <span class="comment">/* sfmin = safe minimum, such that 1/sfmin does not overflow */</span>
<a name="l00087"></a>00087 <span class="comment">/* base = base of the machine */</span>
<a name="l00088"></a>00088 <span class="comment">/* prec = eps*base */</span>
<a name="l00089"></a>00089 <span class="comment">/* t = number of (base) digits in the mantissa */</span>
<a name="l00090"></a>00090 <span class="comment">/* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise */</span>
<a name="l00091"></a>00091 <span class="comment">/* emin = minimum exponent before (gradual) underflow */</span>
<a name="l00092"></a>00092 <span class="comment">/* rmin = underflow threshold - base**(emin-1) */</span>
<a name="l00093"></a>00093 <span class="comment">/* emax = largest exponent before overflow */</span>
<a name="l00094"></a>00094 <span class="comment">/* rmax = overflow threshold - (base**emax)*(1-eps) */</span>
<a name="l00095"></a>00095
<a name="l00096"></a>00096 <span class="comment">/* ===================================================================== */</span>
<a name="l00097"></a>00097
<a name="l00098"></a>00098 <span class="comment">/* .. Parameters .. */</span>
<a name="l00099"></a>00099 <span class="comment">/* .. */</span>
<a name="l00100"></a>00100 <span class="comment">/* .. Local Scalars .. */</span>
<a name="l00101"></a>00101 <span class="comment">/* .. */</span>
<a name="l00102"></a>00102 <span class="comment">/* .. External Functions .. */</span>
<a name="l00103"></a>00103 <span class="comment">/* .. */</span>
<a name="l00104"></a>00104 <span class="comment">/* .. External Subroutines .. */</span>
<a name="l00105"></a>00105 <span class="comment">/* .. */</span>
<a name="l00106"></a>00106 <span class="comment">/* .. Save statement .. */</span>
<a name="l00107"></a>00107 <span class="comment">/* .. */</span>
<a name="l00108"></a>00108 <span class="comment">/* .. Data statements .. */</span>
<a name="l00109"></a>00109 <span class="comment">/* .. */</span>
<a name="l00110"></a>00110 <span class="comment">/* .. Executable Statements .. */</span>
<a name="l00111"></a>00111
<a name="l00112"></a>00112 <span class="keywordflow">if</span> (first) {
<a name="l00113"></a>00113 first = FALSE_;
<a name="l00114"></a>00114 slamc2_(&beta, &it, &lrnd, &eps, &imin, &rmin, &imax, &rmax);
<a name="l00115"></a>00115 base = (real) beta;
<a name="l00116"></a>00116 t = (real) it;
<a name="l00117"></a>00117 <span class="keywordflow">if</span> (lrnd) {
<a name="l00118"></a>00118 rnd = 1.f;
<a name="l00119"></a>00119 i__1 = 1 - it;
<a name="l00120"></a>00120 eps = pow_ri(&base, &i__1) / 2;
<a name="l00121"></a>00121 }
<a name="l00122"></a>00122 <span class="keywordflow">else</span> {
<a name="l00123"></a>00123 rnd = 0.f;
<a name="l00124"></a>00124 i__1 = 1 - it;
<a name="l00125"></a>00125 eps = pow_ri(&base, &i__1);
<a name="l00126"></a>00126 }
<a name="l00127"></a>00127 prec = eps * base;
<a name="l00128"></a>00128 emin = (real) imin;
<a name="l00129"></a>00129 emax = (real) imax;
<a name="l00130"></a>00130 sfmin = rmin;
<a name="l00131"></a>00131 small = 1.f / rmax;
<a name="l00132"></a>00132 <span class="keywordflow">if</span> (small >= sfmin) {
<a name="l00133"></a>00133
<a name="l00134"></a>00134 <span class="comment">/* Use SMALL plus a bit, to avoid the possibility of rounding */</span>
<a name="l00135"></a>00135 <span class="comment">/* causing overflow when computing 1/sfmin. */</span>
<a name="l00136"></a>00136
<a name="l00137"></a>00137 sfmin = small * (eps + 1.f);
<a name="l00138"></a>00138 }
<a name="l00139"></a>00139 }
<a name="l00140"></a>00140
<a name="l00141"></a>00141 <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"E"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00142"></a>00142 rmach = eps;
<a name="l00143"></a>00143 }
<a name="l00144"></a>00144 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"S"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00145"></a>00145 rmach = sfmin;
<a name="l00146"></a>00146 }
<a name="l00147"></a>00147 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"B"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00148"></a>00148 rmach = base;
<a name="l00149"></a>00149 }
<a name="l00150"></a>00150 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"P"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00151"></a>00151 rmach = prec;
<a name="l00152"></a>00152 }
<a name="l00153"></a>00153 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"N"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00154"></a>00154 rmach = t;
<a name="l00155"></a>00155 }
<a name="l00156"></a>00156 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"R"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00157"></a>00157 rmach = rnd;
<a name="l00158"></a>00158 }
<a name="l00159"></a>00159 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"M"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00160"></a>00160 rmach = emin;
<a name="l00161"></a>00161 }
<a name="l00162"></a>00162 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"U"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00163"></a>00163 rmach = rmin;
<a name="l00164"></a>00164 }
<a name="l00165"></a>00165 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"L"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00166"></a>00166 rmach = emax;
<a name="l00167"></a>00167 }
<a name="l00168"></a>00168 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (lsame_(cmach, <span class="stringliteral">"O"</span>, (ftnlen) 1, (ftnlen) 1)) {
<a name="l00169"></a>00169 rmach = rmax;
<a name="l00170"></a>00170 }
<a name="l00171"></a>00171
<a name="l00172"></a>00172 ret_val = rmach;
<a name="l00173"></a>00173 <span class="keywordflow">return</span> ret_val;
<a name="l00174"></a>00174
<a name="l00175"></a>00175 <span class="comment">/* End of SLAMCH */</span>
<a name="l00176"></a>00176
<a name="l00177"></a>00177 } <span class="comment">/* slamch_ */</span>
<a name="l00178"></a>00178
<a name="l00179"></a>00179
<a name="l00180"></a>00180 <span class="comment">/* *********************************************************************** */</span>
<a name="l00181"></a>00181
<a name="l00182"></a>00182 <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span>
<a name="l00183"></a>00183 slamc1_(integer * beta, integer * t, logical * rnd, logical * ieee1)
<a name="l00184"></a>00184 {
<a name="l00185"></a>00185 <span class="comment">/* Initialized data */</span>
<a name="l00186"></a>00186
<a name="l00187"></a>00187 <span class="keyword">static</span> logical first = TRUE_;
<a name="l00188"></a>00188
<a name="l00189"></a>00189 <span class="comment">/* System generated locals */</span>
<a name="l00190"></a>00190 real r__1, r__2;
<a name="l00191"></a>00191
<a name="l00192"></a>00192 <span class="comment">/* Local variables */</span>
<a name="l00193"></a>00193 <span class="keyword">static</span> real a, b, c__, f, t1, t2;
<a name="l00194"></a>00194 <span class="keyword">static</span> integer lt;
<a name="l00195"></a>00195 <span class="keyword">static</span> real one, qtr;
<a name="l00196"></a>00196 <span class="keyword">static</span> logical lrnd;
<a name="l00197"></a>00197 <span class="keyword">static</span> integer lbeta;
<a name="l00198"></a>00198 <span class="keyword">static</span> real savec;
<a name="l00199"></a>00199 <span class="keyword">static</span> logical lieee1;
<a name="l00200"></a>00200 <span class="keyword">extern</span> doublereal slamc3_(real *, real *);
<a name="l00201"></a>00201
<a name="l00202"></a>00202
<a name="l00203"></a>00203 <span class="comment">/* -- LAPACK auxiliary routine (version 3.0) -- */</span>
<a name="l00204"></a>00204 <span class="comment">/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */</span>
<a name="l00205"></a>00205 <span class="comment">/* Courant Institute, Argonne National Lab, and Rice University */</span>
<a name="l00206"></a>00206 <span class="comment">/* October 31, 1992 */</span>
<a name="l00207"></a>00207
<a name="l00208"></a>00208 <span class="comment">/* .. Scalar Arguments .. */</span>
<a name="l00209"></a>00209 <span class="comment">/* .. */</span>
<a name="l00210"></a>00210
<a name="l00211"></a>00211 <span class="comment">/* Purpose */</span>
<a name="l00212"></a>00212 <span class="comment">/* ======= */</span>
<a name="l00213"></a>00213
<a name="l00214"></a>00214 <span class="comment">/* SLAMC1 determines the machine parameters given by BETA, T, RND, and */</span>
<a name="l00215"></a>00215 <span class="comment">/* IEEE1. */</span>
<a name="l00216"></a>00216
<a name="l00217"></a>00217 <span class="comment">/* Arguments */</span>
<a name="l00218"></a>00218 <span class="comment">/* ========= */</span>
<a name="l00219"></a>00219
<a name="l00220"></a>00220 <span class="comment">/* BETA (output) INTEGER */</span>
<a name="l00221"></a>00221 <span class="comment">/* The base of the machine. */</span>
<a name="l00222"></a>00222
<a name="l00223"></a>00223 <span class="comment">/* T (output) INTEGER */</span>
<a name="l00224"></a>00224 <span class="comment">/* The number of ( BETA ) digits in the mantissa. */</span>
<a name="l00225"></a>00225
<a name="l00226"></a>00226 <span class="comment">/* RND (output) LOGICAL */</span>
<a name="l00227"></a>00227 <span class="comment">/* Specifies whether proper rounding ( RND = .TRUE. ) or */</span>
<a name="l00228"></a>00228 <span class="comment">/* chopping ( RND = .FALSE. ) occurs in addition. This may not */</span>
<a name="l00229"></a>00229 <span class="comment">/* be a reliable guide to the way in which the machine performs */</span>
<a name="l00230"></a>00230 <span class="comment">/* its arithmetic. */</span>
<a name="l00231"></a>00231
<a name="l00232"></a>00232 <span class="comment">/* IEEE1 (output) LOGICAL */</span>
<a name="l00233"></a>00233 <span class="comment">/* Specifies whether rounding appears to be done in the IEEE */</span>
<a name="l00234"></a>00234 <span class="comment">/* 'round to nearest' style. */</span>
<a name="l00235"></a>00235
<a name="l00236"></a>00236 <span class="comment">/* Further Details */</span>
<a name="l00237"></a>00237 <span class="comment">/* =============== */</span>
<a name="l00238"></a>00238
<a name="l00239"></a>00239 <span class="comment">/* The routine is based on the routine ENVRON by Malcolm and */</span>
<a name="l00240"></a>00240 <span class="comment">/* incorporates suggestions by Gentleman and Marovich. See */</span>
<a name="l00241"></a>00241
<a name="l00242"></a>00242 <span class="comment">/* Malcolm M. A. (1972) Algorithms to reveal properties of */</span>
<a name="l00243"></a>00243 <span class="comment">/* floating-point arithmetic. Comms. of the ACM, 15, 949-951. */</span>
<a name="l00244"></a>00244
<a name="l00245"></a>00245 <span class="comment">/* Gentleman W. M. and Marovich S. B. (1974) More on algorithms */</span>
<a name="l00246"></a>00246 <span class="comment">/* that reveal properties of floating point arithmetic units. */</span>
<a name="l00247"></a>00247 <span class="comment">/* Comms. of the ACM, 17, 276-277. */</span>
<a name="l00248"></a>00248
<a name="l00249"></a>00249 <span class="comment">/* ===================================================================== */</span>
<a name="l00250"></a>00250
<a name="l00251"></a>00251 <span class="comment">/* .. Local Scalars .. */</span>
<a name="l00252"></a>00252 <span class="comment">/* .. */</span>
<a name="l00253"></a>00253 <span class="comment">/* .. External Functions .. */</span>
<a name="l00254"></a>00254 <span class="comment">/* .. */</span>
<a name="l00255"></a>00255 <span class="comment">/* .. Save statement .. */</span>
<a name="l00256"></a>00256 <span class="comment">/* .. */</span>
<a name="l00257"></a>00257 <span class="comment">/* .. Data statements .. */</span>
<a name="l00258"></a>00258 <span class="comment">/* .. */</span>
<a name="l00259"></a>00259 <span class="comment">/* .. Executable Statements .. */</span>
<a name="l00260"></a>00260
<a name="l00261"></a>00261 <span class="keywordflow">if</span> (first) {
<a name="l00262"></a>00262 first = FALSE_;
<a name="l00263"></a>00263 one = 1.f;
<a name="l00264"></a>00264
<a name="l00265"></a>00265 <span class="comment">/* LBETA, LIEEE1, LT and LRND are the local values of BETA, */</span>
<a name="l00266"></a>00266 <span class="comment">/* IEEE1, T and RND. */</span>
<a name="l00267"></a>00267
<a name="l00268"></a>00268 <span class="comment">/* Throughout this routine we use the function SLAMC3 to ensure */</span>
<a name="l00269"></a>00269 <span class="comment">/* that relevant values are stored and not held in registers, or */</span>
<a name="l00270"></a>00270 <span class="comment">/* are not affected by optimizers. */</span>
<a name="l00271"></a>00271
<a name="l00272"></a>00272 <span class="comment">/* Compute a = 2.0**m with the smallest positive integer m such */</span>
<a name="l00273"></a>00273 <span class="comment">/* that */</span>
<a name="l00274"></a>00274
<a name="l00275"></a>00275 <span class="comment">/* fl( a + 1.0 ) = a. */</span>
<a name="l00276"></a>00276
<a name="l00277"></a>00277 a = 1.f;
<a name="l00278"></a>00278 c__ = 1.f;
<a name="l00279"></a>00279
<a name="l00280"></a>00280 <span class="comment">/* + WHILE( C.EQ.ONE )LOOP */</span>
<a name="l00281"></a>00281 L10:
<a name="l00282"></a>00282 <span class="keywordflow">if</span> (c__ == one) {
<a name="l00283"></a>00283 a *= 2;
<a name="l00284"></a>00284 c__ = slamc3_(&a, &one);
<a name="l00285"></a>00285 r__1 = -a;
<a name="l00286"></a>00286 c__ = slamc3_(&c__, &r__1);
<a name="l00287"></a>00287 <span class="keywordflow">goto</span> L10;
<a name="l00288"></a>00288 }
<a name="l00289"></a>00289 <span class="comment">/* + END WHILE */</span>
<a name="l00290"></a>00290
<a name="l00291"></a>00291 <span class="comment">/* Now compute b = 2.0**m with the smallest positive integer m */</span>
<a name="l00292"></a>00292 <span class="comment">/* such that */</span>
<a name="l00293"></a>00293
<a name="l00294"></a>00294 <span class="comment">/* fl( a + b ) .gt. a. */</span>
<a name="l00295"></a>00295
<a name="l00296"></a>00296 b = 1.f;
<a name="l00297"></a>00297 c__ = slamc3_(&a, &b);
<a name="l00298"></a>00298
<a name="l00299"></a>00299 <span class="comment">/* + WHILE( C.EQ.A )LOOP */</span>
<a name="l00300"></a>00300 L20:
<a name="l00301"></a>00301 <span class="keywordflow">if</span> (c__ == a) {
<a name="l00302"></a>00302 b *= 2;
<a name="l00303"></a>00303 c__ = slamc3_(&a, &b);
<a name="l00304"></a>00304 <span class="keywordflow">goto</span> L20;
<a name="l00305"></a>00305 }
<a name="l00306"></a>00306 <span class="comment">/* + END WHILE */</span>
<a name="l00307"></a>00307
<a name="l00308"></a>00308 <span class="comment">/* Now compute the base. a and c are neighbouring floating point */</span>
<a name="l00309"></a>00309 <span class="comment">/* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so */</span>
<a name="l00310"></a>00310 <span class="comment">/* their difference is beta. Adding 0.25 to c is to ensure that it */</span>
<a name="l00311"></a>00311 <span class="comment">/* is truncated to beta and not ( beta - 1 ). */</span>
<a name="l00312"></a>00312
<a name="l00313"></a>00313 qtr = one / 4;
<a name="l00314"></a>00314 savec = c__;
<a name="l00315"></a>00315 r__1 = -a;
<a name="l00316"></a>00316 c__ = slamc3_(&c__, &r__1);
<a name="l00317"></a>00317 lbeta = c__ + qtr;
<a name="l00318"></a>00318
<a name="l00319"></a>00319 <span class="comment">/* Now determine whether rounding or chopping occurs, by adding a */</span>
<a name="l00320"></a>00320 <span class="comment">/* bit less than beta/2 and a bit more than beta/2 to a. */</span>
<a name="l00321"></a>00321
<a name="l00322"></a>00322 b = (real) lbeta;
<a name="l00323"></a>00323 r__1 = b / 2;
<a name="l00324"></a>00324 r__2 = -b / 100;
<a name="l00325"></a>00325 f = slamc3_(&r__1, &r__2);
<a name="l00326"></a>00326 c__ = slamc3_(&f, &a);
<a name="l00327"></a>00327 <span class="keywordflow">if</span> (c__ == a) {
<a name="l00328"></a>00328 lrnd = TRUE_;
<a name="l00329"></a>00329 }
<a name="l00330"></a>00330 <span class="keywordflow">else</span> {
<a name="l00331"></a>00331 lrnd = FALSE_;
<a name="l00332"></a>00332 }
<a name="l00333"></a>00333 r__1 = b / 2;
<a name="l00334"></a>00334 r__2 = b / 100;
<a name="l00335"></a>00335 f = slamc3_(&r__1, &r__2);
<a name="l00336"></a>00336 c__ = slamc3_(&f, &a);
<a name="l00337"></a>00337 <span class="keywordflow">if</span> (lrnd && c__ == a) {
<a name="l00338"></a>00338 lrnd = FALSE_;
<a name="l00339"></a>00339 }
<a name="l00340"></a>00340
<a name="l00341"></a>00341 <span class="comment">/* Try and decide whether rounding is done in the IEEE 'round to */</span>
<a name="l00342"></a>00342 <span class="comment">/* nearest' style. B/2 is half a unit in the last place of the two */</span>
<a name="l00343"></a>00343 <span class="comment">/* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit */</span>
<a name="l00344"></a>00344 <span class="comment">/* zero, and SAVEC is odd. Thus adding B/2 to A should not change */</span>
<a name="l00345"></a>00345 <span class="comment">/* A, but adding B/2 to SAVEC should change SAVEC. */</span>
<a name="l00346"></a>00346
<a name="l00347"></a>00347 r__1 = b / 2;
<a name="l00348"></a>00348 t1 = slamc3_(&r__1, &a);
<a name="l00349"></a>00349 r__1 = b / 2;
<a name="l00350"></a>00350 t2 = slamc3_(&r__1, &savec);
<a name="l00351"></a>00351 lieee1 = t1 == a && t2 > savec && lrnd;
<a name="l00352"></a>00352
<a name="l00353"></a>00353 <span class="comment">/* Now find the mantissa, t. It should be the integer part of */</span>
<a name="l00354"></a>00354 <span class="comment">/* log to the base beta of a, however it is safer to determine t */</span>
<a name="l00355"></a>00355 <span class="comment">/* by powering. So we find t as the smallest positive integer for */</span>
<a name="l00356"></a>00356 <span class="comment">/* which */</span>
<a name="l00357"></a>00357
<a name="l00358"></a>00358 <span class="comment">/* fl( beta**t + 1.0 ) = 1.0. */</span>
<a name="l00359"></a>00359
<a name="l00360"></a>00360 lt = 0;
<a name="l00361"></a>00361 a = 1.f;
<a name="l00362"></a>00362 c__ = 1.f;
<a name="l00363"></a>00363
<a name="l00364"></a>00364 <span class="comment">/* + WHILE( C.EQ.ONE )LOOP */</span>
<a name="l00365"></a>00365 L30:
<a name="l00366"></a>00366 <span class="keywordflow">if</span> (c__ == one) {
<a name="l00367"></a>00367 ++lt;
<a name="l00368"></a>00368 a *= lbeta;
<a name="l00369"></a>00369 c__ = slamc3_(&a, &one);
<a name="l00370"></a>00370 r__1 = -a;
<a name="l00371"></a>00371 c__ = slamc3_(&c__, &r__1);
<a name="l00372"></a>00372 <span class="keywordflow">goto</span> L30;
<a name="l00373"></a>00373 }
<a name="l00374"></a>00374 <span class="comment">/* + END WHILE */</span>
<a name="l00375"></a>00375
<a name="l00376"></a>00376 }
<a name="l00377"></a>00377
<a name="l00378"></a>00378 *beta = lbeta;
<a name="l00379"></a>00379 *t = lt;
<a name="l00380"></a>00380 *rnd = lrnd;
<a name="l00381"></a>00381 *ieee1 = lieee1;
<a name="l00382"></a>00382 <span class="keywordflow">return</span> 0;
<a name="l00383"></a>00383
<a name="l00384"></a>00384 <span class="comment">/* End of SLAMC1 */</span>
<a name="l00385"></a>00385
<a name="l00386"></a>00386 } <span class="comment">/* slamc1_ */</span>
<a name="l00387"></a>00387
<a name="l00388"></a>00388
<a name="l00389"></a>00389 <span class="comment">/* *********************************************************************** */</span>
<a name="l00390"></a>00390
<a name="l00391"></a>00391 <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span>
<a name="l00392"></a>00392 slamc2_(integer * beta, integer * t, logical * rnd, real *
<a name="l00393"></a>00393 eps, integer * emin, real * rmin, integer * emax, real * rmax)
<a name="l00394"></a>00394 {
<a name="l00395"></a>00395 <span class="comment">/* Initialized data */</span>
<a name="l00396"></a>00396
<a name="l00397"></a>00397 <span class="keyword">static</span> logical first = TRUE_;
<a name="l00398"></a>00398 <span class="keyword">static</span> logical iwarn = FALSE_;
<a name="l00399"></a>00399
<a name="l00400"></a>00400 <span class="comment">/* Format strings */</span>
<a name="l00401"></a>00401 <span class="keyword">static</span> <span class="keywordtype">char</span> fmt_9999[] =
<a name="l00402"></a>00402 <span class="stringliteral">"(//\002 WARNING. The value EMIN may be incorre"</span>
<a name="l00403"></a>00403 <span class="stringliteral">"ct:-\002,\002 EMIN = \002,i8,/\002 If, after inspection, the va"</span>
<a name="l00404"></a>00404 <span class="stringliteral">"lue EMIN looks\002,\002 acceptable please comment out \002,/\002"</span>
<a name="l00405"></a>00405 <span class="stringliteral">" the IF block as marked within the code of routine\002,\002 SLAM"</span>
<a name="l00406"></a>00406 <span class="stringliteral">"C2,\002,/\002 otherwise supply EMIN explicitly.\002,/)"</span>;
<a name="l00407"></a>00407
<a name="l00408"></a>00408 <span class="comment">/* System generated locals */</span>
<a name="l00409"></a>00409 integer i__1;
<a name="l00410"></a>00410 real r__1, r__2, r__3, r__4, r__5;
<a name="l00411"></a>00411
<a name="l00412"></a>00412 <span class="comment">/* Builtin functions */</span>
<a name="l00413"></a>00413 <span class="keywordtype">double</span> pow_ri(real *, integer *);
<a name="l00414"></a>00414 integer s_wsfe(<a class="code" href="structcilist.html">cilist</a> *), do_fio(integer *, <span class="keywordtype">char</span> *, ftnlen),
<a name="l00415"></a>00415 e_wsfe(<span class="keywordtype">void</span>);
<a name="l00416"></a>00416
<a name="l00417"></a>00417 <span class="comment">/* Local variables */</span>
<a name="l00418"></a>00418 <span class="keyword">static</span> real a, b, c__;
<a name="l00419"></a>00419 <span class="keyword">static</span> integer i__, lt;
<a name="l00420"></a>00420 <span class="keyword">static</span> real one, two;
<a name="l00421"></a>00421 <span class="keyword">static</span> logical ieee;
<a name="l00422"></a>00422 <span class="keyword">static</span> real half;
<a name="l00423"></a>00423 <span class="keyword">static</span> logical lrnd;
<a name="l00424"></a>00424 <span class="keyword">static</span> real leps, zero;
<a name="l00425"></a>00425 <span class="keyword">static</span> integer lbeta;
<a name="l00426"></a>00426 <span class="keyword">static</span> real rbase;
<a name="l00427"></a>00427 <span class="keyword">static</span> integer lemin, lemax, gnmin;
<a name="l00428"></a>00428 <span class="keyword">static</span> real small;
<a name="l00429"></a>00429 <span class="keyword">static</span> integer gpmin;
<a name="l00430"></a>00430 <span class="keyword">static</span> real third, lrmin, lrmax, sixth;
<a name="l00431"></a>00431 <span class="keyword">static</span> logical lieee1;
<a name="l00432"></a>00432 <span class="keyword">extern</span> <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span> slamc1_(integer *, integer *, logical *,
<a name="l00433"></a>00433 logical *);
<a name="l00434"></a>00434 <span class="keyword">extern</span> doublereal slamc3_(real *, real *);
<a name="l00435"></a>00435 <span class="keyword">extern</span> <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span> slamc4_(integer *, real *, integer *),
<a name="l00436"></a>00436 slamc5_(integer *, integer *, integer *, logical *, integer *,
<a name="l00437"></a>00437 real *);
<a name="l00438"></a>00438 <span class="keyword">static</span> integer ngnmin, ngpmin;
<a name="l00439"></a>00439
<a name="l00440"></a>00440 <span class="comment">/* Fortran I/O blocks */</span>
<a name="l00441"></a>00441 <span class="keyword">static</span> <a class="code" href="structcilist.html">cilist</a> io___58 = { 0, 6, 0, fmt_9999, 0 };
<a name="l00442"></a>00442
<a name="l00443"></a>00443
<a name="l00444"></a>00444
<a name="l00445"></a>00445 <span class="comment">/* -- LAPACK auxiliary routine (version 3.0) -- */</span>
<a name="l00446"></a>00446 <span class="comment">/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */</span>
<a name="l00447"></a>00447 <span class="comment">/* Courant Institute, Argonne National Lab, and Rice University */</span>
<a name="l00448"></a>00448 <span class="comment">/* October 31, 1992 */</span>
<a name="l00449"></a>00449
<a name="l00450"></a>00450 <span class="comment">/* .. Scalar Arguments .. */</span>
<a name="l00451"></a>00451 <span class="comment">/* .. */</span>
<a name="l00452"></a>00452
<a name="l00453"></a>00453 <span class="comment">/* Purpose */</span>
<a name="l00454"></a>00454 <span class="comment">/* ======= */</span>
<a name="l00455"></a>00455
<a name="l00456"></a>00456 <span class="comment">/* SLAMC2 determines the machine parameters specified in its argument */</span>
<a name="l00457"></a>00457 <span class="comment">/* list. */</span>
<a name="l00458"></a>00458
<a name="l00459"></a>00459 <span class="comment">/* Arguments */</span>
<a name="l00460"></a>00460 <span class="comment">/* ========= */</span>
<a name="l00461"></a>00461
<a name="l00462"></a>00462 <span class="comment">/* BETA (output) INTEGER */</span>
<a name="l00463"></a>00463 <span class="comment">/* The base of the machine. */</span>
<a name="l00464"></a>00464
<a name="l00465"></a>00465 <span class="comment">/* T (output) INTEGER */</span>
<a name="l00466"></a>00466 <span class="comment">/* The number of ( BETA ) digits in the mantissa. */</span>
<a name="l00467"></a>00467
<a name="l00468"></a>00468 <span class="comment">/* RND (output) LOGICAL */</span>
<a name="l00469"></a>00469 <span class="comment">/* Specifies whether proper rounding ( RND = .TRUE. ) or */</span>
<a name="l00470"></a>00470 <span class="comment">/* chopping ( RND = .FALSE. ) occurs in addition. This may not */</span>
<a name="l00471"></a>00471 <span class="comment">/* be a reliable guide to the way in which the machine performs */</span>
<a name="l00472"></a>00472 <span class="comment">/* its arithmetic. */</span>
<a name="l00473"></a>00473
<a name="l00474"></a>00474 <span class="comment">/* EPS (output) REAL */</span>
<a name="l00475"></a>00475 <span class="comment">/* The smallest positive number such that */</span>
<a name="l00476"></a>00476
<a name="l00477"></a>00477 <span class="comment">/* fl( 1.0 - EPS ) .LT. 1.0, */</span>
<a name="l00478"></a>00478
<a name="l00479"></a>00479 <span class="comment">/* where fl denotes the computed value. */</span>
<a name="l00480"></a>00480
<a name="l00481"></a>00481 <span class="comment">/* EMIN (output) INTEGER */</span>
<a name="l00482"></a>00482 <span class="comment">/* The minimum exponent before (gradual) underflow occurs. */</span>
<a name="l00483"></a>00483
<a name="l00484"></a>00484 <span class="comment">/* RMIN (output) REAL */</span>
<a name="l00485"></a>00485 <span class="comment">/* The smallest normalized number for the machine, given by */</span>
<a name="l00486"></a>00486 <span class="comment">/* BASE**( EMIN - 1 ), where BASE is the floating point value */</span>
<a name="l00487"></a>00487 <span class="comment">/* of BETA. */</span>
<a name="l00488"></a>00488
<a name="l00489"></a>00489 <span class="comment">/* EMAX (output) INTEGER */</span>
<a name="l00490"></a>00490 <span class="comment">/* The maximum exponent before overflow occurs. */</span>
<a name="l00491"></a>00491
<a name="l00492"></a>00492 <span class="comment">/* RMAX (output) REAL */</span>
<a name="l00493"></a>00493 <span class="comment">/* The largest positive number for the machine, given by */</span>
<a name="l00494"></a>00494 <span class="comment">/* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point */</span>
<a name="l00495"></a>00495 <span class="comment">/* value of BETA. */</span>
<a name="l00496"></a>00496
<a name="l00497"></a>00497 <span class="comment">/* Further Details */</span>
<a name="l00498"></a>00498 <span class="comment">/* =============== */</span>
<a name="l00499"></a>00499
<a name="l00500"></a>00500 <span class="comment">/* The computation of EPS is based on a routine PARANOIA by */</span>
<a name="l00501"></a>00501 <span class="comment">/* W. Kahan of the University of California at Berkeley. */</span>
<a name="l00502"></a>00502
<a name="l00503"></a>00503 <span class="comment">/* ===================================================================== */</span>
<a name="l00504"></a>00504
<a name="l00505"></a>00505 <span class="comment">/* .. Local Scalars .. */</span>
<a name="l00506"></a>00506 <span class="comment">/* .. */</span>
<a name="l00507"></a>00507 <span class="comment">/* .. External Functions .. */</span>
<a name="l00508"></a>00508 <span class="comment">/* .. */</span>
<a name="l00509"></a>00509 <span class="comment">/* .. External Subroutines .. */</span>
<a name="l00510"></a>00510 <span class="comment">/* .. */</span>
<a name="l00511"></a>00511 <span class="comment">/* .. Intrinsic Functions .. */</span>
<a name="l00512"></a>00512 <span class="comment">/* .. */</span>
<a name="l00513"></a>00513 <span class="comment">/* .. Save statement .. */</span>
<a name="l00514"></a>00514 <span class="comment">/* .. */</span>
<a name="l00515"></a>00515 <span class="comment">/* .. Data statements .. */</span>
<a name="l00516"></a>00516 <span class="comment">/* .. */</span>
<a name="l00517"></a>00517 <span class="comment">/* .. Executable Statements .. */</span>
<a name="l00518"></a>00518
<a name="l00519"></a>00519 <span class="keywordflow">if</span> (first) {
<a name="l00520"></a>00520 first = FALSE_;
<a name="l00521"></a>00521 zero = 0.f;
<a name="l00522"></a>00522 one = 1.f;
<a name="l00523"></a>00523 two = 2.f;
<a name="l00524"></a>00524
<a name="l00525"></a>00525 <span class="comment">/* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of */</span>
<a name="l00526"></a>00526 <span class="comment">/* BETA, T, RND, EPS, EMIN and RMIN. */</span>
<a name="l00527"></a>00527
<a name="l00528"></a>00528 <span class="comment">/* Throughout this routine we use the function SLAMC3 to ensure */</span>
<a name="l00529"></a>00529 <span class="comment">/* that relevant values are stored and not held in registers, or */</span>
<a name="l00530"></a>00530 <span class="comment">/* are not affected by optimizers. */</span>
<a name="l00531"></a>00531
<a name="l00532"></a>00532 <span class="comment">/* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1. */</span>
<a name="l00533"></a>00533
<a name="l00534"></a>00534 slamc1_(&lbeta, &lt, &lrnd, &lieee1);
<a name="l00535"></a>00535
<a name="l00536"></a>00536 <span class="comment">/* Start to find EPS. */</span>
<a name="l00537"></a>00537
<a name="l00538"></a>00538 b = (real) lbeta;
<a name="l00539"></a>00539 i__1 = -lt;
<a name="l00540"></a>00540 a = pow_ri(&b, &i__1);
<a name="l00541"></a>00541 leps = a;
<a name="l00542"></a>00542
<a name="l00543"></a>00543 <span class="comment">/* Try some tricks to see whether or not this is the correct EPS. */</span>
<a name="l00544"></a>00544
<a name="l00545"></a>00545 b = two / 3;
<a name="l00546"></a>00546 half = one / 2;
<a name="l00547"></a>00547 r__1 = -half;
<a name="l00548"></a>00548 sixth = slamc3_(&b, &r__1);
<a name="l00549"></a>00549 third = slamc3_(&sixth, &sixth);
<a name="l00550"></a>00550 r__1 = -half;
<a name="l00551"></a>00551 b = slamc3_(&third, &r__1);
<a name="l00552"></a>00552 b = slamc3_(&b, &sixth);
<a name="l00553"></a>00553 b = dabs(b);
<a name="l00554"></a>00554 <span class="keywordflow">if</span> (b < leps) {
<a name="l00555"></a>00555 b = leps;
<a name="l00556"></a>00556 }
<a name="l00557"></a>00557
<a name="l00558"></a>00558 leps = 1.f;
<a name="l00559"></a>00559
<a name="l00560"></a>00560 <span class="comment">/* + WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP */</span>
<a name="l00561"></a>00561 L10:
<a name="l00562"></a>00562 <span class="keywordflow">if</span> (leps > b && b > zero) {
<a name="l00563"></a>00563 leps = b;
<a name="l00564"></a>00564 r__1 = half * leps;
<a name="l00565"></a>00565 <span class="comment">/* Computing 5th power */</span>
<a name="l00566"></a>00566 r__3 = two, r__4 = r__3, r__3 *= r__3;
<a name="l00567"></a>00567 <span class="comment">/* Computing 2nd power */</span>
<a name="l00568"></a>00568 r__5 = leps;
<a name="l00569"></a>00569 r__2 = r__4 * (r__3 * r__3) * (r__5 * r__5);
<a name="l00570"></a>00570 c__ = slamc3_(&r__1, &r__2);
<a name="l00571"></a>00571 r__1 = -c__;
<a name="l00572"></a>00572 c__ = slamc3_(&half, &r__1);
<a name="l00573"></a>00573 b = slamc3_(&half, &c__);
<a name="l00574"></a>00574 r__1 = -b;
<a name="l00575"></a>00575 c__ = slamc3_(&half, &r__1);
<a name="l00576"></a>00576 b = slamc3_(&half, &c__);
<a name="l00577"></a>00577 <span class="keywordflow">goto</span> L10;
<a name="l00578"></a>00578 }
<a name="l00579"></a>00579 <span class="comment">/* + END WHILE */</span>
<a name="l00580"></a>00580
<a name="l00581"></a>00581 <span class="keywordflow">if</span> (a < leps) {
<a name="l00582"></a>00582 leps = a;
<a name="l00583"></a>00583 }
<a name="l00584"></a>00584
<a name="l00585"></a>00585 <span class="comment">/* Computation of EPS complete. */</span>
<a name="l00586"></a>00586
<a name="l00587"></a>00587 <span class="comment">/* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)). */</span>
<a name="l00588"></a>00588 <span class="comment">/* Keep dividing A by BETA until (gradual) underflow occurs. This */</span>
<a name="l00589"></a>00589 <span class="comment">/* is detected when we cannot recover the previous A. */</span>
<a name="l00590"></a>00590
<a name="l00591"></a>00591 rbase = one / lbeta;
<a name="l00592"></a>00592 small = one;
<a name="l00593"></a>00593 <span class="keywordflow">for</span> (i__ = 1; i__ <= 3; ++i__) {
<a name="l00594"></a>00594 r__1 = small * rbase;
<a name="l00595"></a>00595 small = slamc3_(&r__1, &zero);
<a name="l00596"></a>00596 <span class="comment">/* L20: */</span>
<a name="l00597"></a>00597 }
<a name="l00598"></a>00598 a = slamc3_(&one, &small);
<a name="l00599"></a>00599 slamc4_(&ngpmin, &one, &lbeta);
<a name="l00600"></a>00600 r__1 = -one;
<a name="l00601"></a>00601 slamc4_(&ngnmin, &r__1, &lbeta);
<a name="l00602"></a>00602 slamc4_(&gpmin, &a, &lbeta);
<a name="l00603"></a>00603 r__1 = -a;
<a name="l00604"></a>00604 slamc4_(&gnmin, &r__1, &lbeta);
<a name="l00605"></a>00605 ieee = FALSE_;
<a name="l00606"></a>00606
<a name="l00607"></a>00607 <span class="keywordflow">if</span> (ngpmin == ngnmin && gpmin == gnmin) {
<a name="l00608"></a>00608 <span class="keywordflow">if</span> (ngpmin == gpmin) {
<a name="l00609"></a>00609 lemin = ngpmin;
<a name="l00610"></a>00610 <span class="comment">/* ( Non twos-complement machines, no gradual underflow; */</span>
<a name="l00611"></a>00611 <span class="comment">/* e.g., VAX ) */</span>
<a name="l00612"></a>00612 }
<a name="l00613"></a>00613 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (gpmin - ngpmin == 3) {
<a name="l00614"></a>00614 lemin = ngpmin - 1 + lt;
<a name="l00615"></a>00615 ieee = TRUE_;
<a name="l00616"></a>00616 <span class="comment">/* ( Non twos-complement machines, with gradual underflow; */</span>
<a name="l00617"></a>00617 <span class="comment">/* e.g., IEEE standard followers ) */</span>
<a name="l00618"></a>00618 }
<a name="l00619"></a>00619 <span class="keywordflow">else</span> {
<a name="l00620"></a>00620 lemin = min(ngpmin, gpmin);
<a name="l00621"></a>00621 <span class="comment">/* ( A guess; no known machine ) */</span>
<a name="l00622"></a>00622 iwarn = TRUE_;
<a name="l00623"></a>00623 }
<a name="l00624"></a>00624
<a name="l00625"></a>00625 }
<a name="l00626"></a>00626 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (ngpmin == gpmin && ngnmin == gnmin) {
<a name="l00627"></a>00627 <span class="keywordflow">if</span> ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1) {
<a name="l00628"></a>00628 lemin = max(ngpmin, ngnmin);
<a name="l00629"></a>00629 <span class="comment">/* ( Twos-complement machines, no gradual underflow; */</span>
<a name="l00630"></a>00630 <span class="comment">/* e.g., CYBER 205 ) */</span>
<a name="l00631"></a>00631 }
<a name="l00632"></a>00632 <span class="keywordflow">else</span> {
<a name="l00633"></a>00633 lemin = min(ngpmin, ngnmin);
<a name="l00634"></a>00634 <span class="comment">/* ( A guess; no known machine ) */</span>
<a name="l00635"></a>00635 iwarn = TRUE_;
<a name="l00636"></a>00636 }
<a name="l00637"></a>00637
<a name="l00638"></a>00638 }
<a name="l00639"></a>00639 <span class="keywordflow">else</span> <span class="keywordflow">if</span> ((i__1 = ngpmin - ngnmin, abs(i__1)) == 1
<a name="l00640"></a>00640 && gpmin == gnmin) {
<a name="l00641"></a>00641 <span class="keywordflow">if</span> (gpmin - min(ngpmin, ngnmin) == 3) {
<a name="l00642"></a>00642 lemin = max(ngpmin, ngnmin) - 1 + lt;
<a name="l00643"></a>00643 <span class="comment">/* ( Twos-complement machines with gradual underflow; */</span>
<a name="l00644"></a>00644 <span class="comment">/* no known machine ) */</span>
<a name="l00645"></a>00645 }
<a name="l00646"></a>00646 <span class="keywordflow">else</span> {
<a name="l00647"></a>00647 lemin = min(ngpmin, ngnmin);
<a name="l00648"></a>00648 <span class="comment">/* ( A guess; no known machine ) */</span>
<a name="l00649"></a>00649 iwarn = TRUE_;
<a name="l00650"></a>00650 }
<a name="l00651"></a>00651
<a name="l00652"></a>00652 }
<a name="l00653"></a>00653 <span class="keywordflow">else</span> {
<a name="l00654"></a>00654 <span class="comment">/* Computing MIN */</span>
<a name="l00655"></a>00655 i__1 = min(ngpmin, ngnmin), i__1 = min(i__1, gpmin);
<a name="l00656"></a>00656 lemin = min(i__1, gnmin);
<a name="l00657"></a>00657 <span class="comment">/* ( A guess; no known machine ) */</span>
<a name="l00658"></a>00658 iwarn = TRUE_;
<a name="l00659"></a>00659 }
<a name="l00660"></a>00660 <span class="comment">/* ** */</span>
<a name="l00661"></a>00661 <span class="comment">/* Comment out this if block if EMIN is ok */</span>
<a name="l00662"></a>00662 <span class="keywordflow">if</span> (iwarn) {
<a name="l00663"></a>00663 first = TRUE_;
<a name="l00664"></a>00664 s_wsfe(&io___58);
<a name="l00665"></a>00665 do_fio(&c__1, (<span class="keywordtype">char</span> *) &lemin, (ftnlen) <span class="keyword">sizeof</span>(integer));
<a name="l00666"></a>00666 e_wsfe();
<a name="l00667"></a>00667 }
<a name="l00668"></a>00668 <span class="comment">/* ** */</span>
<a name="l00669"></a>00669
<a name="l00670"></a>00670 <span class="comment">/* Assume IEEE arithmetic if we found denormalised numbers above, */</span>
<a name="l00671"></a>00671 <span class="comment">/* or if arithmetic seems to round in the IEEE style, determined */</span>
<a name="l00672"></a>00672 <span class="comment">/* in routine SLAMC1. A true IEEE machine should have both things */</span>
<a name="l00673"></a>00673 <span class="comment">/* true; however, faulty machines may have one or the other. */</span>
<a name="l00674"></a>00674
<a name="l00675"></a>00675 ieee = ieee || lieee1;
<a name="l00676"></a>00676
<a name="l00677"></a>00677 <span class="comment">/* Compute RMIN by successive division by BETA. We could compute */</span>
<a name="l00678"></a>00678 <span class="comment">/* RMIN as BASE**( EMIN - 1 ), but some machines underflow during */</span>
<a name="l00679"></a>00679 <span class="comment">/* this computation. */</span>
<a name="l00680"></a>00680
<a name="l00681"></a>00681 lrmin = 1.f;
<a name="l00682"></a>00682 i__1 = 1 - lemin;
<a name="l00683"></a>00683 <span class="keywordflow">for</span> (i__ = 1; i__ <= i__1; ++i__) {
<a name="l00684"></a>00684 r__1 = lrmin * rbase;
<a name="l00685"></a>00685 lrmin = slamc3_(&r__1, &zero);
<a name="l00686"></a>00686 <span class="comment">/* L30: */</span>
<a name="l00687"></a>00687 }
<a name="l00688"></a>00688
<a name="l00689"></a>00689 <span class="comment">/* Finally, call SLAMC5 to compute EMAX and RMAX. */</span>
<a name="l00690"></a>00690
<a name="l00691"></a>00691 slamc5_(&lbeta, &lt, &lemin, &ieee, &lemax, &lrmax);
<a name="l00692"></a>00692 }
<a name="l00693"></a>00693
<a name="l00694"></a>00694 *beta = lbeta;
<a name="l00695"></a>00695 *t = lt;
<a name="l00696"></a>00696 *rnd = lrnd;
<a name="l00697"></a>00697 *eps = leps;
<a name="l00698"></a>00698 *emin = lemin;
<a name="l00699"></a>00699 *rmin = lrmin;
<a name="l00700"></a>00700 *emax = lemax;
<a name="l00701"></a>00701 *rmax = lrmax;
<a name="l00702"></a>00702
<a name="l00703"></a>00703 <span class="keywordflow">return</span> 0;
<a name="l00704"></a>00704
<a name="l00705"></a>00705
<a name="l00706"></a>00706 <span class="comment">/* End of SLAMC2 */</span>
<a name="l00707"></a>00707
<a name="l00708"></a>00708 } <span class="comment">/* slamc2_ */</span>
<a name="l00709"></a>00709
<a name="l00710"></a>00710
<a name="l00711"></a>00711 <span class="comment">/* *********************************************************************** */</span>
<a name="l00712"></a>00712
<a name="l00713"></a>00713 doublereal
<a name="l00714"></a>00714 slamc3_(real * a, real * b)
<a name="l00715"></a>00715 {
<a name="l00716"></a>00716 <span class="comment">/* System generated locals */</span>
<a name="l00717"></a>00717 real ret_val;
<a name="l00718"></a>00718
<a name="l00719"></a>00719
<a name="l00720"></a>00720 <span class="comment">/* -- LAPACK auxiliary routine (version 3.0) -- */</span>
<a name="l00721"></a>00721 <span class="comment">/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */</span>
<a name="l00722"></a>00722 <span class="comment">/* Courant Institute, Argonne National Lab, and Rice University */</span>
<a name="l00723"></a>00723 <span class="comment">/* October 31, 1992 */</span>
<a name="l00724"></a>00724
<a name="l00725"></a>00725 <span class="comment">/* .. Scalar Arguments .. */</span>
<a name="l00726"></a>00726 <span class="comment">/* .. */</span>
<a name="l00727"></a>00727
<a name="l00728"></a>00728 <span class="comment">/* Purpose */</span>
<a name="l00729"></a>00729 <span class="comment">/* ======= */</span>
<a name="l00730"></a>00730
<a name="l00731"></a>00731 <span class="comment">/* SLAMC3 is intended to force A and B to be stored prior to doing */</span>
<a name="l00732"></a>00732 <span class="comment">/* the addition of A and B , for use in situations where optimizers */</span>
<a name="l00733"></a>00733 <span class="comment">/* might hold one of these in a register. */</span>
<a name="l00734"></a>00734
<a name="l00735"></a>00735 <span class="comment">/* Arguments */</span>
<a name="l00736"></a>00736 <span class="comment">/* ========= */</span>
<a name="l00737"></a>00737
<a name="l00738"></a>00738 <span class="comment">/* A, B (input) REAL */</span>
<a name="l00739"></a>00739 <span class="comment">/* The values A and B. */</span>
<a name="l00740"></a>00740
<a name="l00741"></a>00741 <span class="comment">/* ===================================================================== */</span>
<a name="l00742"></a>00742
<a name="l00743"></a>00743 <span class="comment">/* .. Executable Statements .. */</span>
<a name="l00744"></a>00744
<a name="l00745"></a>00745 ret_val = *a + *b;
<a name="l00746"></a>00746
<a name="l00747"></a>00747 <span class="keywordflow">return</span> ret_val;
<a name="l00748"></a>00748
<a name="l00749"></a>00749 <span class="comment">/* End of SLAMC3 */</span>
<a name="l00750"></a>00750
<a name="l00751"></a>00751 } <span class="comment">/* slamc3_ */</span>
<a name="l00752"></a>00752
<a name="l00753"></a>00753
<a name="l00754"></a>00754 <span class="comment">/* *********************************************************************** */</span>
<a name="l00755"></a>00755
<a name="l00756"></a>00756 <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span>
<a name="l00757"></a>00757 slamc4_(integer * emin, real * start, integer * base)
<a name="l00758"></a>00758 {
<a name="l00759"></a>00759 <span class="comment">/* System generated locals */</span>
<a name="l00760"></a>00760 integer i__1;
<a name="l00761"></a>00761 real r__1;
<a name="l00762"></a>00762
<a name="l00763"></a>00763 <span class="comment">/* Local variables */</span>
<a name="l00764"></a>00764 <span class="keyword">static</span> real a;
<a name="l00765"></a>00765 <span class="keyword">static</span> integer i__;
<a name="l00766"></a>00766 <span class="keyword">static</span> real b1, b2, c1, c2, d1, d2, one, zero, rbase;
<a name="l00767"></a>00767 <span class="keyword">extern</span> doublereal slamc3_(real *, real *);
<a name="l00768"></a>00768
<a name="l00769"></a>00769
<a name="l00770"></a>00770 <span class="comment">/* -- LAPACK auxiliary routine (version 3.0) -- */</span>
<a name="l00771"></a>00771 <span class="comment">/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */</span>
<a name="l00772"></a>00772 <span class="comment">/* Courant Institute, Argonne National Lab, and Rice University */</span>
<a name="l00773"></a>00773 <span class="comment">/* October 31, 1992 */</span>
<a name="l00774"></a>00774
<a name="l00775"></a>00775 <span class="comment">/* .. Scalar Arguments .. */</span>
<a name="l00776"></a>00776 <span class="comment">/* .. */</span>
<a name="l00777"></a>00777
<a name="l00778"></a>00778 <span class="comment">/* Purpose */</span>
<a name="l00779"></a>00779 <span class="comment">/* ======= */</span>
<a name="l00780"></a>00780
<a name="l00781"></a>00781 <span class="comment">/* SLAMC4 is a service routine for SLAMC2. */</span>
<a name="l00782"></a>00782
<a name="l00783"></a>00783 <span class="comment">/* Arguments */</span>
<a name="l00784"></a>00784 <span class="comment">/* ========= */</span>
<a name="l00785"></a>00785
<a name="l00786"></a>00786 <span class="comment">/* EMIN (output) EMIN */</span>
<a name="l00787"></a>00787 <span class="comment">/* The minimum exponent before (gradual) underflow, computed by */</span>
<a name="l00788"></a>00788 <span class="comment">/* setting A = START and dividing by BASE until the previous A */</span>
<a name="l00789"></a>00789 <span class="comment">/* can not be recovered. */</span>
<a name="l00790"></a>00790
<a name="l00791"></a>00791 <span class="comment">/* START (input) REAL */</span>
<a name="l00792"></a>00792 <span class="comment">/* The starting point for determining EMIN. */</span>
<a name="l00793"></a>00793
<a name="l00794"></a>00794 <span class="comment">/* BASE (input) INTEGER */</span>
<a name="l00795"></a>00795 <span class="comment">/* The base of the machine. */</span>
<a name="l00796"></a>00796
<a name="l00797"></a>00797 <span class="comment">/* ===================================================================== */</span>
<a name="l00798"></a>00798
<a name="l00799"></a>00799 <span class="comment">/* .. Local Scalars .. */</span>
<a name="l00800"></a>00800 <span class="comment">/* .. */</span>
<a name="l00801"></a>00801 <span class="comment">/* .. External Functions .. */</span>
<a name="l00802"></a>00802 <span class="comment">/* .. */</span>
<a name="l00803"></a>00803 <span class="comment">/* .. Executable Statements .. */</span>
<a name="l00804"></a>00804
<a name="l00805"></a>00805 a = *start;
<a name="l00806"></a>00806 one = 1.f;
<a name="l00807"></a>00807 rbase = one / *base;
<a name="l00808"></a>00808 zero = 0.f;
<a name="l00809"></a>00809 *emin = 1;
<a name="l00810"></a>00810 r__1 = a * rbase;
<a name="l00811"></a>00811 b1 = slamc3_(&r__1, &zero);
<a name="l00812"></a>00812 c1 = a;
<a name="l00813"></a>00813 c2 = a;
<a name="l00814"></a>00814 d1 = a;
<a name="l00815"></a>00815 d2 = a;
<a name="l00816"></a>00816 <span class="comment">/* + WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND. */</span>
<a name="l00817"></a>00817 <span class="comment">/* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP */</span>
<a name="l00818"></a>00818 L10:
<a name="l00819"></a>00819 <span class="keywordflow">if</span> (c1 == a && c2 == a && d1 == a && d2 == a) {
<a name="l00820"></a>00820 --(*emin);
<a name="l00821"></a>00821 a = b1;
<a name="l00822"></a>00822 r__1 = a / *base;
<a name="l00823"></a>00823 b1 = slamc3_(&r__1, &zero);
<a name="l00824"></a>00824 r__1 = b1 * *base;
<a name="l00825"></a>00825 c1 = slamc3_(&r__1, &zero);
<a name="l00826"></a>00826 d1 = zero;
<a name="l00827"></a>00827 i__1 = *base;
<a name="l00828"></a>00828 <span class="keywordflow">for</span> (i__ = 1; i__ <= i__1; ++i__) {
<a name="l00829"></a>00829 d1 += b1;
<a name="l00830"></a>00830 <span class="comment">/* L20: */</span>
<a name="l00831"></a>00831 }
<a name="l00832"></a>00832 r__1 = a * rbase;
<a name="l00833"></a>00833 b2 = slamc3_(&r__1, &zero);
<a name="l00834"></a>00834 r__1 = b2 / rbase;
<a name="l00835"></a>00835 c2 = slamc3_(&r__1, &zero);
<a name="l00836"></a>00836 d2 = zero;
<a name="l00837"></a>00837 i__1 = *base;
<a name="l00838"></a>00838 <span class="keywordflow">for</span> (i__ = 1; i__ <= i__1; ++i__) {
<a name="l00839"></a>00839 d2 += b2;
<a name="l00840"></a>00840 <span class="comment">/* L30: */</span>
<a name="l00841"></a>00841 }
<a name="l00842"></a>00842 <span class="keywordflow">goto</span> L10;
<a name="l00843"></a>00843 }
<a name="l00844"></a>00844 <span class="comment">/* + END WHILE */</span>
<a name="l00845"></a>00845
<a name="l00846"></a>00846 <span class="keywordflow">return</span> 0;
<a name="l00847"></a>00847
<a name="l00848"></a>00848 <span class="comment">/* End of SLAMC4 */</span>
<a name="l00849"></a>00849
<a name="l00850"></a>00850 } <span class="comment">/* slamc4_ */</span>
<a name="l00851"></a>00851
<a name="l00852"></a>00852
<a name="l00853"></a>00853 <span class="comment">/* *********************************************************************** */</span>
<a name="l00854"></a>00854
<a name="l00855"></a>00855 <span class="comment">/* Subroutine */</span> <span class="keywordtype">int</span>
<a name="l00856"></a>00856 slamc5_(integer * beta, integer * p, integer * emin,
<a name="l00857"></a>00857 logical * ieee, integer * emax, real * rmax)
<a name="l00858"></a>00858 {
<a name="l00859"></a>00859 <span class="comment">/* System generated locals */</span>
<a name="l00860"></a>00860 integer i__1;
<a name="l00861"></a>00861 real r__1;
<a name="l00862"></a>00862
<a name="l00863"></a>00863 <span class="comment">/* Local variables */</span>
<a name="l00864"></a>00864 <span class="keyword">static</span> integer i__;
<a name="l00865"></a>00865 <span class="keyword">static</span> real y, z__;
<a name="l00866"></a>00866 <span class="keyword">static</span> integer try__, lexp;
<a name="l00867"></a>00867 <span class="keyword">static</span> real oldy;
<a name="l00868"></a>00868 <span class="keyword">static</span> integer uexp, nbits;
<a name="l00869"></a>00869 <span class="keyword">extern</span> doublereal slamc3_(real *, real *);
<a name="l00870"></a>00870 <span class="keyword">static</span> real recbas;
<a name="l00871"></a>00871 <span class="keyword">static</span> integer exbits, expsum;
<a name="l00872"></a>00872
<a name="l00873"></a>00873
<a name="l00874"></a>00874 <span class="comment">/* -- LAPACK auxiliary routine (version 3.0) -- */</span>
<a name="l00875"></a>00875 <span class="comment">/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */</span>
<a name="l00876"></a>00876 <span class="comment">/* Courant Institute, Argonne National Lab, and Rice University */</span>
<a name="l00877"></a>00877 <span class="comment">/* October 31, 1992 */</span>
<a name="l00878"></a>00878
<a name="l00879"></a>00879 <span class="comment">/* .. Scalar Arguments .. */</span>
<a name="l00880"></a>00880 <span class="comment">/* .. */</span>
<a name="l00881"></a>00881
<a name="l00882"></a>00882 <span class="comment">/* Purpose */</span>
<a name="l00883"></a>00883 <span class="comment">/* ======= */</span>
<a name="l00884"></a>00884
<a name="l00885"></a>00885 <span class="comment">/* SLAMC5 attempts to compute RMAX, the largest machine floating-point */</span>
<a name="l00886"></a>00886 <span class="comment">/* number, without overflow. It assumes that EMAX + abs(EMIN) sum */</span>
<a name="l00887"></a>00887 <span class="comment">/* approximately to a power of 2. It will fail on machines where this */</span>
<a name="l00888"></a>00888 <span class="comment">/* assumption does not hold, for example, the Cyber 205 (EMIN = -28625, */</span>
<a name="l00889"></a>00889 <span class="comment">/* EMAX = 28718). It will also fail if the value supplied for EMIN is */</span>
<a name="l00890"></a>00890 <span class="comment">/* too large (i.e. too close to zero), probably with overflow. */</span>
<a name="l00891"></a>00891
<a name="l00892"></a>00892 <span class="comment">/* Arguments */</span>
<a name="l00893"></a>00893 <span class="comment">/* ========= */</span>
<a name="l00894"></a>00894
<a name="l00895"></a>00895 <span class="comment">/* BETA (input) INTEGER */</span>
<a name="l00896"></a>00896 <span class="comment">/* The base of floating-point arithmetic. */</span>
<a name="l00897"></a>00897
<a name="l00898"></a>00898 <span class="comment">/* P (input) INTEGER */</span>
<a name="l00899"></a>00899 <span class="comment">/* The number of base BETA digits in the mantissa of a */</span>
<a name="l00900"></a>00900 <span class="comment">/* floating-point value. */</span>
<a name="l00901"></a>00901
<a name="l00902"></a>00902 <span class="comment">/* EMIN (input) INTEGER */</span>
<a name="l00903"></a>00903 <span class="comment">/* The minimum exponent before (gradual) underflow. */</span>
<a name="l00904"></a>00904
<a name="l00905"></a>00905 <span class="comment">/* IEEE (input) LOGICAL */</span>
<a name="l00906"></a>00906 <span class="comment">/* A logical flag specifying whether or not the arithmetic */</span>
<a name="l00907"></a>00907 <span class="comment">/* system is thought to comply with the IEEE standard. */</span>
<a name="l00908"></a>00908
<a name="l00909"></a>00909 <span class="comment">/* EMAX (output) INTEGER */</span>
<a name="l00910"></a>00910 <span class="comment">/* The largest exponent before overflow */</span>
<a name="l00911"></a>00911
<a name="l00912"></a>00912 <span class="comment">/* RMAX (output) REAL */</span>
<a name="l00913"></a>00913 <span class="comment">/* The largest machine floating-point number. */</span>
<a name="l00914"></a>00914
<a name="l00915"></a>00915 <span class="comment">/* ===================================================================== */</span>
<a name="l00916"></a>00916
<a name="l00917"></a>00917 <span class="comment">/* .. Parameters .. */</span>
<a name="l00918"></a>00918 <span class="comment">/* .. */</span>
<a name="l00919"></a>00919 <span class="comment">/* .. Local Scalars .. */</span>
<a name="l00920"></a>00920 <span class="comment">/* .. */</span>
<a name="l00921"></a>00921 <span class="comment">/* .. External Functions .. */</span>
<a name="l00922"></a>00922 <span class="comment">/* .. */</span>
<a name="l00923"></a>00923 <span class="comment">/* .. Intrinsic Functions .. */</span>
<a name="l00924"></a>00924 <span class="comment">/* .. */</span>
<a name="l00925"></a>00925 <span class="comment">/* .. Executable Statements .. */</span>
<a name="l00926"></a>00926
<a name="l00927"></a>00927 <span class="comment">/* First compute LEXP and UEXP, two powers of 2 that bound */</span>
<a name="l00928"></a>00928 <span class="comment">/* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum */</span>
<a name="l00929"></a>00929 <span class="comment">/* approximately to the bound that is closest to abs(EMIN). */</span>
<a name="l00930"></a>00930 <span class="comment">/* (EMAX is the exponent of the required number RMAX). */</span>
<a name="l00931"></a>00931
<a name="l00932"></a>00932 lexp = 1;
<a name="l00933"></a>00933 exbits = 1;
<a name="l00934"></a>00934 L10:
<a name="l00935"></a>00935 try__ = lexp << 1;
<a name="l00936"></a>00936 <span class="keywordflow">if</span> (try__ <= -(*emin)) {
<a name="l00937"></a>00937 lexp = try__;
<a name="l00938"></a>00938 ++exbits;
<a name="l00939"></a>00939 <span class="keywordflow">goto</span> L10;
<a name="l00940"></a>00940 }
<a name="l00941"></a>00941 <span class="keywordflow">if</span> (lexp == -(*emin)) {
<a name="l00942"></a>00942 uexp = lexp;
<a name="l00943"></a>00943 }
<a name="l00944"></a>00944 <span class="keywordflow">else</span> {
<a name="l00945"></a>00945 uexp = try__;
<a name="l00946"></a>00946 ++exbits;
<a name="l00947"></a>00947 }
<a name="l00948"></a>00948
<a name="l00949"></a>00949 <span class="comment">/* Now -LEXP is less than or equal to EMIN, and -UEXP is greater */</span>
<a name="l00950"></a>00950 <span class="comment">/* than or equal to EMIN. EXBITS is the number of bits needed to */</span>
<a name="l00951"></a>00951 <span class="comment">/* store the exponent. */</span>
<a name="l00952"></a>00952
<a name="l00953"></a>00953 <span class="keywordflow">if</span> (uexp + *emin > -lexp - *emin) {
<a name="l00954"></a>00954 expsum = lexp << 1;
<a name="l00955"></a>00955 }
<a name="l00956"></a>00956 <span class="keywordflow">else</span> {
<a name="l00957"></a>00957 expsum = uexp << 1;
<a name="l00958"></a>00958 }
<a name="l00959"></a>00959
<a name="l00960"></a>00960 <span class="comment">/* EXPSUM is the exponent range, approximately equal to */</span>
<a name="l00961"></a>00961 <span class="comment">/* EMAX - EMIN + 1 . */</span>
<a name="l00962"></a>00962
<a name="l00963"></a>00963 *emax = expsum + *emin - 1;
<a name="l00964"></a>00964 nbits = exbits + 1 + *p;
<a name="l00965"></a>00965
<a name="l00966"></a>00966 <span class="comment">/* NBITS is the total number of bits needed to store a */</span>
<a name="l00967"></a>00967 <span class="comment">/* floating-point number. */</span>
<a name="l00968"></a>00968
<a name="l00969"></a>00969 <span class="keywordflow">if</span> (nbits % 2 == 1 && *beta == 2) {
<a name="l00970"></a>00970
<a name="l00971"></a>00971 <span class="comment">/* Either there are an odd number of bits used to store a */</span>
<a name="l00972"></a>00972 <span class="comment">/* floating-point number, which is unlikely, or some bits are */</span>
<a name="l00973"></a>00973 <span class="comment">/* not used in the representation of numbers, which is possible, */</span>
<a name="l00974"></a>00974 <span class="comment">/* (e.g. Cray machines) or the mantissa has an implicit bit, */</span>
<a name="l00975"></a>00975 <span class="comment">/* (e.g. IEEE machines, Dec Vax machines), which is perhaps the */</span>
<a name="l00976"></a>00976 <span class="comment">/* most likely. We have to assume the last alternative. */</span>
<a name="l00977"></a>00977 <span class="comment">/* If this is true, then we need to reduce EMAX by one because */</span>
<a name="l00978"></a>00978 <span class="comment">/* there must be some way of representing zero in an implicit-bit */</span>
<a name="l00979"></a>00979 <span class="comment">/* system. On machines like Cray, we are reducing EMAX by one */</span>
<a name="l00980"></a>00980 <span class="comment">/* unnecessarily. */</span>
<a name="l00981"></a>00981
<a name="l00982"></a>00982 --(*emax);
<a name="l00983"></a>00983 }
<a name="l00984"></a>00984
<a name="l00985"></a>00985 <span class="keywordflow">if</span> (*ieee) {
<a name="l00986"></a>00986
<a name="l00987"></a>00987 <span class="comment">/* Assume we are on an IEEE machine which reserves one exponent */</span>
<a name="l00988"></a>00988 <span class="comment">/* for infinity and NaN. */</span>
<a name="l00989"></a>00989
<a name="l00990"></a>00990 --(*emax);
<a name="l00991"></a>00991 }
<a name="l00992"></a>00992
<a name="l00993"></a>00993 <span class="comment">/* Now create RMAX, the largest machine number, which should */</span>
<a name="l00994"></a>00994 <span class="comment">/* be equal to (1.0 - BETA**(-P)) * BETA**EMAX . */</span>
<a name="l00995"></a>00995
<a name="l00996"></a>00996 <span class="comment">/* First compute 1.0 - BETA**(-P), being careful that the */</span>
<a name="l00997"></a>00997 <span class="comment">/* result is less than 1.0 . */</span>
<a name="l00998"></a>00998
<a name="l00999"></a>00999 recbas = 1.f / *beta;
<a name="l01000"></a>01000 z__ = *beta - 1.f;
<a name="l01001"></a>01001 y = 0.f;
<a name="l01002"></a>01002 i__1 = *p;
<a name="l01003"></a>01003 <span class="keywordflow">for</span> (i__ = 1; i__ <= i__1; ++i__) {
<a name="l01004"></a>01004 z__ *= recbas;
<a name="l01005"></a>01005 <span class="keywordflow">if</span> (y < 1.f) {
<a name="l01006"></a>01006 oldy = y;
<a name="l01007"></a>01007 }
<a name="l01008"></a>01008 y = slamc3_(&y, &z__);
<a name="l01009"></a>01009 <span class="comment">/* L20: */</span>
<a name="l01010"></a>01010 }
<a name="l01011"></a>01011 <span class="keywordflow">if</span> (y >= 1.f) {
<a name="l01012"></a>01012 y = oldy;
<a name="l01013"></a>01013 }
<a name="l01014"></a>01014
<a name="l01015"></a>01015 <span class="comment">/* Now multiply by BETA**EMAX to get RMAX. */</span>
<a name="l01016"></a>01016
<a name="l01017"></a>01017 i__1 = *emax;
<a name="l01018"></a>01018 <span class="keywordflow">for</span> (i__ = 1; i__ <= i__1; ++i__) {
<a name="l01019"></a>01019 r__1 = y * *beta;
<a name="l01020"></a>01020 y = slamc3_(&r__1, &c_b32);
<a name="l01021"></a>01021 <span class="comment">/* L30: */</span>
<a name="l01022"></a>01022 }
<a name="l01023"></a>01023
<a name="l01024"></a>01024 *rmax = y;
<a name="l01025"></a>01025 <span class="keywordflow">return</span> 0;
<a name="l01026"></a>01026
<a name="l01027"></a>01027 <span class="comment">/* End of SLAMC5 */</span>
<a name="l01028"></a>01028
<a name="l01029"></a>01029 } <span class="comment">/* slamc5_ */</span>
</pre></div></div>
</div>
<div id="nav-path" class="navpath">
<ul>
<li class="navelem"><b>slamch.c</b> </li>
<li class="footer">Generated on Tue Apr 19 2011 for SphinxBase by 
<a href="http://www.doxygen.org/index.html">
<img class="footer" src="doxygen.png" alt="doxygen"/></a> 1.7.3 </li>
</ul>
</div>
</body>
</html>
distrib
>
Fedora
>
14
>
x86_64
>
media
>
updates
>
by-pkgid
>
0b420d0fce195cf4115dc6a3be5c2da2
>
files
>
325
