townforge/multiprecision
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
cc
multiprecision/performance/linpack-benchmark.cpp

1303 lines
34 KiB
C++
Raw Permalink Blame History

///////////////////////////////////////////////////////////////////////////////
// Copyright 2011 John Maddock. Distributed under the Boost
// Software License, Version 1.0. (See accompanying file
// LICENSE_1_0.txt or copy at http://www.boost.org/LICENSE_1_0.txt)
/* 1000d.f -- translated by f2c (version 20050501).
You must link the resulting object file with libf2c:
on Microsoft Windows system, link with libf2c.lib;
on Linux or Unix systems, link with .../path/to/libf2c.a -lm
or, if you install libf2c.a in a standard place, with -lf2c -lm
-- in that order, at the end of the command line, as in
cc *.o -lf2c -lm
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
http://www.netlib.org/f2c/libf2c.zip
*/
#include <iostream>
#include <iomanip>
#include <cmath>
#if defined(TEST_GMPXX)
#include <gmpxx.h>
typedef mpf_class real_type;
#elif defined(TEST_MPFRXX)
#include <gmpfrxx.h>
typedef mpfr_class real_type;
#elif defined(TEST_CPP_DEC_FLOAT)
#include <boost/multiprecision/cpp_dec_float.hpp>
typedef boost::multiprecision::cpp_dec_float_50 real_type;
#elif defined(TEST_MPFR_50)
#include <boost/multiprecision/mpfr.hpp>
typedef boost::multiprecision::mpfr_float_50 real_type;
#elif defined(TEST_MPF_50)
#include <boost/multiprecision/gmp.hpp>
typedef boost::multiprecision::mpf_float_50 real_type;
#elif defined(NATIVE_FLOAT128)
#include <boost/multiprecision/float128.hpp>
typedef __float128 real_type;
std::ostream& operator<<(std::ostream& os, const __float128& f)
{
return os << boost::multiprecision::float128(f);
}
#include <boost/type_traits/has_left_shift.hpp>
namespace boost {
template <>
struct has_left_shift<std::basic_ostream<char>, __float128> : public mpl::true_
{};
template <>
double lexical_cast<double, __float128>(const __float128& f)
{
return f;
}
} // namespace boost
#elif defined(TEST_FLOAT128)
#include <boost/multiprecision/float128.hpp>
typedef boost::multiprecision::float128 real_type;
#elif defined(TEST_CPP_BIN_FLOAT_QUAD)
#include <boost/multiprecision/cpp_bin_float.hpp>
typedef boost::multiprecision::cpp_bin_float_quad real_type;
#elif defined(TEST_CPP_BIN_FLOAT_OCT)
#include <boost/multiprecision/cpp_bin_float.hpp>
typedef boost::multiprecision::cpp_bin_float_oct real_type;
#else
typedef double real_type;
#endif
#include <boost/lexical_cast.hpp>
#ifndef CAST_TO_RT
#define CAST_TO_RT(x) x
#endif
extern "C" {
#include "f2c.h"
integer s_wsfe(cilist*), e_wsfe(void), do_fio(integer*, char*, ftnlen),
s_wsle(cilist*), do_lio(integer*, integer*, char*, ftnlen),
e_wsle(void);
/* Subroutine */ int s_stop(char*, ftnlen);
#undef abs
#undef dabs
#define dabs abs
#undef dmin
#undef dmax
#define dmin min
#define dmax max
}
#include <time.h>
using std::max;
using std::min;
/* Table of constant values */
static integer c__0 = 0;
static real_type c_b7 = CAST_TO_RT(1);
static integer c__1 = 1;
static integer c__9 = 9;
inline double second_(void)
{
return ((double)(clock())) / CLOCKS_PER_SEC;
}
int dgefa_(real_type*, integer*, integer*, integer*, integer*), dgesl_(real_type*, integer*, integer*, integer*, real_type*, integer*);
int dmxpy_(integer*, real_type*, integer*, integer*, real_type*, real_type*);
int matgen_(real_type*, integer*, integer*, real_type*, real_type*);
real_type epslon_(real_type*);
real_type ran_(integer*);
int dscal_(integer*, real_type*, real_type*, integer*);
int daxpy_(integer*, real_type*, real_type*, integer*, real_type*, integer*);
integer idamax_(integer*, real_type*, integer*);
real_type ddot_(integer*, real_type*, integer*, real_type*, integer*);
int daxpy_(integer*, real_type*, real_type*, integer*, real_type*, integer*);
int dmxpy_(integer*, real_type*, integer*, integer*, real_type*, real_type*);
extern "C" int MAIN__()
{
#ifdef TEST_MPF_50
std::cout << "Testing number<mpf_float<50> >" << std::endl;
#elif defined(TEST_MPFR_50)
std::cout << "Testing number<mpf_float<50> >" << std::endl;
#elif defined(TEST_GMPXX)
std::cout << "Testing mpf_class at 50 decimal degits" << std::endl;
mpf_set_default_prec(((50 + 1) * 1000L) / 301L);
#elif defined(TEST_MPFRXX)
std::cout << "Testing mpfr_class at 50 decimal degits" << std::endl;
mpfr_set_default_prec(((50 + 1) * 1000L) / 301L);
#elif defined(TEST_CPP_DEC_FLOAT)
std::cout << "Testing number<cpp_dec_float<50> >" << std::endl;
#elif defined(NATIVE_FLOAT128)
std::cout << "Testing __float128" << std::endl;
#elif defined(TEST_FLOAT128)
std::cout << "Testing number<float128_backend, et_off>" << std::endl;
#else
std::cout << "Testing double" << std::endl;
#endif
/* Format strings */
static char fmt_1[] = "(\002 Please send the results of this run to:\002"
"//\002 Jack J. Dongarra\002/\002 Computer Science Department\002/"
"\002 University of Tennessee\002/\002 Knoxville, Tennessee 37996"
"-1300\002//\002 Fax: 615-974-8296\002//\002 Internet: dongarra@c"
"s.utk.edu\002/)";
static char fmt_40[] = "(\002 norm. resid resid mac"
"hep\002,\002 x(1) x(n)\002)";
static char fmt_50[] = "(1p5e16.8)";
static char fmt_60[] = "(//\002 times are reported for matrices of or"
"der \002,i5)";
static char fmt_70[] = "(6x,\002factor\002,5x,\002solve\002,6x,\002tota"
"l\002,5x,\002mflops\002,7x,\002unit\002,6x,\002ratio\002)";
static char fmt_80[] = "(\002 times for array with leading dimension o"
"f\002,i4)";
static char fmt_110[] = "(6(1pe11.3))";
/* System generated locals */
integer i__1;
real_type d__1, d__2, d__3;
/* Builtin functions */
/* Local variables */
static real_type a[1001000] /* was [1001][1000] */, b[1000];
static integer i__, n;
static real_type x[1000];
static double t1;
static integer lda;
static double ops;
static real_type eps;
static integer info;
static double time[6], cray, total;
static integer ipvt[1000];
static real_type resid, norma;
static real_type normx;
static real_type residn;
/* Fortran I/O blocks */
static cilist io___4 = {0, 6, 0, fmt_1, 0};
static cilist io___20 = {0, 6, 0, fmt_40, 0};
static cilist io___21 = {0, 6, 0, fmt_50, 0};
static cilist io___22 = {0, 6, 0, fmt_60, 0};
static cilist io___23 = {0, 6, 0, fmt_70, 0};
static cilist io___24 = {0, 6, 0, fmt_80, 0};
static cilist io___25 = {0, 6, 0, fmt_110, 0};
static cilist io___26 = {0, 6, 0, 0, 0};
lda = 1001;
/* this program was updated on 10/12/92 to correct a */
/* problem with the random number generator. The previous */
/* random number generator had a short period and produced */
/* singular matrices occasionally. */
n = 1000;
cray = .056f;
s_wsfe(&io___4);
e_wsfe();
/* Computing 3rd power */
d__1 = (real_type)n;
/* Computing 2nd power */
d__2 = (real_type)n;
ops = boost::lexical_cast<double>(real_type(d__1 * (d__1 * d__1) * 2. / 3. + d__2 * d__2 * 2.));
matgen_(a, &lda, &n, b, &norma);
/* ****************************************************************** */
/* ****************************************************************** */
/* you should replace the call to dgefa and dgesl */
/* by calls to your linear equation solver. */
/* ****************************************************************** */
/* ****************************************************************** */
t1 = second_();
dgefa_(a, &lda, &n, ipvt, &info);
time[0] = second_() - t1;
t1 = second_();
dgesl_(a, &lda, &n, ipvt, b, &c__0);
time[1] = second_() - t1;
total = time[0] + time[1];
/* ****************************************************************** */
/* ****************************************************************** */
/* compute a residual to verify results. */
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__)
{
x[i__ - 1] = b[i__ - 1];
/* L10: */
}
matgen_(a, &lda, &n, b, &norma);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__)
{
b[i__ - 1] = -b[i__ - 1];
/* L20: */
}
dmxpy_(&n, b, &n, &lda, x, a);
resid = CAST_TO_RT(0);
normx = CAST_TO_RT(0);
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__)
{
/* Computing MAX */
d__2 = resid, d__3 = (d__1 = b[i__ - 1], abs(d__1));
resid = (max)(d__2, d__3);
/* Computing MAX */
d__2 = normx, d__3 = (d__1 = x[i__ - 1], abs(d__1));
normx = (max)(d__2, d__3);
/* L30: */
}
eps = epslon_(&c_b7);
residn = resid / (n * norma * normx * eps);
s_wsfe(&io___20);
e_wsfe();
s_wsfe(&io___21);
/*
do_fio(&c__1, (char *)&residn, (ftnlen)sizeof(real_type));
do_fio(&c__1, (char *)&resid, (ftnlen)sizeof(real_type));
do_fio(&c__1, (char *)&eps, (ftnlen)sizeof(real_type));
do_fio(&c__1, (char *)&x[0], (ftnlen)sizeof(real_type));
do_fio(&c__1, (char *)&x[n - 1], (ftnlen)sizeof(real_type));
*/
std::cout << std::setw(12) << std::setprecision(5) << residn << " " << resid << " " << eps << " " << x[0] << " " << x[n - 1] << std::endl;
e_wsfe();
s_wsfe(&io___22);
do_fio(&c__1, (char*)&n, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___23);
e_wsfe();
time[2] = total;
time[3] = ops / (total * 1e6);
time[4] = 2. / time[3];
time[5] = total / cray;
s_wsfe(&io___24);
do_fio(&c__1, (char*)&lda, (ftnlen)sizeof(integer));
e_wsfe();
s_wsfe(&io___25);
for (i__ = 1; i__ <= 6; ++i__)
{
// do_fio(&c__1, (char *)&time[i__ - 1], (ftnlen)sizeof(real_type));
std::cout << std::setw(12) << std::setprecision(5) << time[i__ - 1];
}
e_wsfe();
s_wsle(&io___26);
do_lio(&c__9, &c__1, " end of tests -- this version dated 10/12/92", (ftnlen)44);
e_wsle();
s_stop("", (ftnlen)0);
return 0;
} /* MAIN__ */
/* Subroutine */ int matgen_(real_type* a, integer* lda, integer* n,
real_type* b, real_type* norma)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
real_type d__1, d__2;
/* Local variables */
static integer i__, j;
static integer init[4];
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--b;
/* Function Body */
init[0] = 1;
init[1] = 2;
init[2] = 3;
init[3] = 1325;
*norma = CAST_TO_RT(0);
i__1 = *n;
for (j = 1; j <= i__1; ++j)
{
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__)
{
a[i__ + j * a_dim1] = ran_(init) - .5f;
/* Computing MAX */
d__2 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
*norma = (max)(d__2, *norma);
/* L20: */
}
/* L30: */
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__)
{
b[i__] = CAST_TO_RT(0);
/* L35: */
}
i__1 = *n;
for (j = 1; j <= i__1; ++j)
{
i__2 = *n;
for (i__ = 1; i__ <= i__2; ++i__)
{
b[i__] += a[i__ + j * a_dim1];
/* L40: */
}
/* L50: */
}
return 0;
} /* matgen_ */
/* Subroutine */ int dgefa_(real_type* a, integer* lda, integer* n, integer* ipvt, integer* info)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
/* Local variables */
static integer j, k, l;
static real_type t;
static integer kp1, nm1;
/* dgefa factors a double precision matrix by gaussian elimination. */
/* dgefa is usually called by dgeco, but it can be called */
/* directly with a saving in time if rcond is not needed. */
/* (time for dgeco) = (1 + 9/n)*(time for dgefa) . */
/* on entry */
/* a double precision(lda, n) */
/* the matrix to be factored. */
/* lda integer */
/* the leading dimension of the array a . */
/* n integer */
/* the order of the matrix a . */
/* on return */
/* a an upper triangular matrix and the multipliers */
/* which were used to obtain it. */
/* the factorization can be written a = l*u where */
/* l is a product of permutation and unit lower */
/* triangular matrices and u is upper triangular. */
/* ipvt integer(n) */
/* an integer vector of pivot indices. */
/* info integer */
/* = 0 normal value. */
/* = k if u(k,k) .eq. 0.0 . this is not an error */
/* condition for this subroutine, but it does */
/* indicate that dgesl or dgedi will divide by zero */
/* if called. use rcond in dgeco for a reliable */
/* indication of singularity. */
/* linpack. this version dated 08/14/78 . */
/* cleve moler, university of new mexico, argonne national lab. */
/* subroutines and functions */
/* blas daxpy,dscal,idamax */
/* internal variables */
/* gaussian elimination with partial pivoting */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipvt;
/* Function Body */
*info = 0;
nm1 = *n - 1;
if (nm1 < 1)
{
goto L70;
}
i__1 = nm1;
for (k = 1; k <= i__1; ++k)
{
kp1 = k + 1;
/* find l = pivot index */
i__2 = *n - k + 1;
l = idamax_(&i__2, &a[k + k * a_dim1], &c__1) + k - 1;
ipvt[k] = l;
/* zero pivot implies this column already triangularized */
if (a[l + k * a_dim1] == 0.)
{
goto L40;
}
/* interchange if necessary */
if (l == k)
{
goto L10;
}
t = a[l + k * a_dim1];
a[l + k * a_dim1] = a[k + k * a_dim1];
a[k + k * a_dim1] = t;
L10:
/* compute multipliers */
t = -1. / a[k + k * a_dim1];
i__2 = *n - k;
dscal_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1);
/* row elimination with column indexing */
i__2 = *n;
for (j = kp1; j <= i__2; ++j)
{
t = a[l + j * a_dim1];
if (l == k)
{
goto L20;
}
a[l + j * a_dim1] = a[k + j * a_dim1];
a[k + j * a_dim1] = t;
L20:
i__3 = *n - k;
daxpy_(&i__3, &t, &a[k + 1 + k * a_dim1], &c__1, &a[k + 1 + j * a_dim1], &c__1);
/* L30: */
}
goto L50;
L40:
*info = k;
L50:
/* L60: */
;
}
L70:
ipvt[*n] = *n;
if (a[*n + *n * a_dim1] == 0.)
{
*info = *n;
}
return 0;
} /* dgefa_ */
/* Subroutine */ int dgesl_(real_type* a, integer* lda, integer* n, integer* ipvt, real_type* b, integer* job)
{
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2;
/* Local variables */
static integer k, l;
static real_type t;
static integer kb, nm1;
/* dgesl solves the double precision system */
/* a * x = b or trans(a) * x = b */
/* using the factors computed by dgeco or dgefa. */
/* on entry */
/* a double precision(lda, n) */
/* the output from dgeco or dgefa. */
/* lda integer */
/* the leading dimension of the array a . */
/* n integer */
/* the order of the matrix a . */
/* ipvt integer(n) */
/* the pivot vector from dgeco or dgefa. */
/* b double precision(n) */
/* the right hand side vector. */
/* job integer */
/* = 0 to solve a*x = b , */
/* = nonzero to solve trans(a)*x = b where */
/* trans(a) is the transpose. */
/* on return */
/* b the solution vector x . */
/* error condition */
/* a division by zero will occur if the input factor contains a */
/* zero on the diagonal. technically this indicates singularity */
/* but it is often caused by improper arguments or improper */
/* setting of lda . it will not occur if the subroutines are */
/* called correctly and if dgeco has set rcond .gt. 0.0 */
/* or dgefa has set info .eq. 0 . */
/* to compute inverse(a) * c where c is a matrix */
/* with p columns */
/* call dgeco(a,lda,n,ipvt,rcond,z) */
/* if (rcond is too small) go to ... */
/* do 10 j = 1, p */
/* call dgesl(a,lda,n,ipvt,c(1,j),0) */
/* 10 continue */
/* linpack. this version dated 08/14/78 . */
/* cleve moler, university of new mexico, argonne national lab. */
/* subroutines and functions */
/* blas daxpy,ddot */
/* internal variables */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
--ipvt;
--b;
/* Function Body */
nm1 = *n - 1;
if (*job != 0)
{
goto L50;
}
/* job = 0 , solve a * x = b */
/* first solve l*y = b */
if (nm1 < 1)
{
goto L30;
}
i__1 = nm1;
for (k = 1; k <= i__1; ++k)
{
l = ipvt[k];
t = b[l];
if (l == k)
{
goto L10;
}
b[l] = b[k];
b[k] = t;
L10:
i__2 = *n - k;
daxpy_(&i__2, &t, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1], &c__1);
/* L20: */
}
L30:
/* now solve u*x = y */
i__1 = *n;
for (kb = 1; kb <= i__1; ++kb)
{
k = *n + 1 - kb;
b[k] /= a[k + k * a_dim1];
t = -b[k];
i__2 = k - 1;
daxpy_(&i__2, &t, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1);
/* L40: */
}
goto L100;
L50:
/* job = nonzero, solve trans(a) * x = b */
/* first solve trans(u)*y = b */
i__1 = *n;
for (k = 1; k <= i__1; ++k)
{
i__2 = k - 1;
t = ddot_(&i__2, &a[k * a_dim1 + 1], &c__1, &b[1], &c__1);
b[k] = (b[k] - t) / a[k + k * a_dim1];
/* L60: */
}
/* now solve trans(l)*x = y */
if (nm1 < 1)
{
goto L90;
}
i__1 = nm1;
for (kb = 1; kb <= i__1; ++kb)
{
k = *n - kb;
i__2 = *n - k;
b[k] += ddot_(&i__2, &a[k + 1 + k * a_dim1], &c__1, &b[k + 1], &c__1);
l = ipvt[k];
if (l == k)
{
goto L70;
}
t = b[l];
b[l] = b[k];
b[k] = t;
L70:
/* L80: */
;
}
L90:
L100:
return 0;
} /* dgesl_ */
/* Subroutine */ int daxpy_(integer* n, real_type* da, real_type* dx,
integer* incx, real_type* dy, integer* incy)
{
/* System generated locals */
integer i__1;
/* Local variables */
static integer i__, m, ix, iy, mp1;
/* constant times a vector plus a vector. */
/* uses unrolled loops for increments equal to one. */
/* jack dongarra, linpack, 3/11/78. */
/* Parameter adjustments */
--dy;
--dx;
/* Function Body */
if (*n <= 0)
{
return 0;
}
if (*da == 0.)
{
return 0;
}
if (*incx == 1 && *incy == 1)
{
goto L20;
}
/* code for unequal increments or equal increments */
/* not equal to 1 */
ix = 1;
iy = 1;
if (*incx < 0)
{
ix = (-(*n) + 1) * *incx + 1;
}
if (*incy < 0)
{
iy = (-(*n) + 1) * *incy + 1;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__)
{
dy[iy] += *da * dx[ix];
ix += *incx;
iy += *incy;
/* L10: */
}
return 0;
/* code for both increments equal to 1 */
/* clean-up loop */
L20:
m = *n % 4;
if (m == 0)
{
goto L40;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__)
{
dy[i__] += *da * dx[i__];
/* L30: */
}
if (*n < 4)
{
return 0;
}
L40:
mp1 = m + 1;
i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 4)
{
dy[i__] += *da * dx[i__];
dy[i__ + 1] += *da * dx[i__ + 1];
dy[i__ + 2] += *da * dx[i__ + 2];
dy[i__ + 3] += *da * dx[i__ + 3];
/* L50: */
}
return 0;
} /* daxpy_ */
real_type ddot_(integer* n, real_type* dx, integer* incx, real_type* dy,
integer* incy)
{
/* System generated locals */
integer i__1;
real_type ret_val;
/* Local variables */
static integer i__, m, ix, iy, mp1;
static real_type dtemp;
/* forms the dot product of two vectors. */
/* uses unrolled loops for increments equal to one. */
/* jack dongarra, linpack, 3/11/78. */
/* Parameter adjustments */
--dy;
--dx;
/* Function Body */
ret_val = CAST_TO_RT(0);
dtemp = CAST_TO_RT(0);
if (*n <= 0)
{
return ret_val;
}
if (*incx == 1 && *incy == 1)
{
goto L20;
}
/* code for unequal increments or equal increments */
/* not equal to 1 */
ix = 1;
iy = 1;
if (*incx < 0)
{
ix = (-(*n) + 1) * *incx + 1;
}
if (*incy < 0)
{
iy = (-(*n) + 1) * *incy + 1;
}
i__1 = *n;
for (i__ = 1; i__ <= i__1; ++i__)
{
dtemp += dx[ix] * dy[iy];
ix += *incx;
iy += *incy;
/* L10: */
}
ret_val = dtemp;
return ret_val;
/* code for both increments equal to 1 */
/* clean-up loop */
L20:
m = *n % 5;
if (m == 0)
{
goto L40;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__)
{
dtemp += dx[i__] * dy[i__];
/* L30: */
}
if (*n < 5)
{
goto L60;
}
L40:
mp1 = m + 1;
i__1 = *n;
for (i__ = mp1; i__ <= i__1; i__ += 5)
{
dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + 4] * dy[i__ + 4];
/* L50: */
}
L60:
ret_val = dtemp;
return ret_val;
} /* ddot_ */
/* Subroutine */ int dscal_(integer* n, real_type* da, real_type* dx,
integer* incx)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
static integer i__, m, mp1, nincx;
/* scales a vector by a constant. */
/* uses unrolled loops for increment equal to one. */
/* jack dongarra, linpack, 3/11/78. */
/* Parameter adjustments */
--dx;
/* Function Body */
if (*n <= 0)
{
return 0;
}
if (*incx == 1)
{
goto L20;
}
/* code for increment not equal to 1 */
nincx = *n * *incx;
i__1 = nincx;
i__2 = *incx;
for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2)
{
dx[i__] = *da * dx[i__];
/* L10: */
}
return 0;
/* code for increment equal to 1 */
/* clean-up loop */
L20:
m = *n % 5;
if (m == 0)
{
goto L40;
}
i__2 = m;
for (i__ = 1; i__ <= i__2; ++i__)
{
dx[i__] = *da * dx[i__];
/* L30: */
}
if (*n < 5)
{
return 0;
}
L40:
mp1 = m + 1;
i__2 = *n;
for (i__ = mp1; i__ <= i__2; i__ += 5)
{
dx[i__] = *da * dx[i__];
dx[i__ + 1] = *da * dx[i__ + 1];
dx[i__ + 2] = *da * dx[i__ + 2];
dx[i__ + 3] = *da * dx[i__ + 3];
dx[i__ + 4] = *da * dx[i__ + 4];
/* L50: */
}
return 0;
} /* dscal_ */
integer idamax_(integer* n, real_type* dx, integer* incx)
{
/* System generated locals */
integer ret_val, i__1;
real_type d__1;
/* Local variables */
static integer i__, ix;
static real_type dmax__;
/* finds the index of element having max. dabsolute value. */
/* jack dongarra, linpack, 3/11/78. */
/* Parameter adjustments */
--dx;
/* Function Body */
ret_val = 0;
if (*n < 1)
{
return ret_val;
}
ret_val = 1;
if (*n == 1)
{
return ret_val;
}
if (*incx == 1)
{
goto L20;
}
/* code for increment not equal to 1 */
ix = 1;
dmax__ = abs(dx[1]);
ix += *incx;
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__)
{
if ((d__1 = dx[ix], abs(d__1)) <= dmax__)
{
goto L5;
}
ret_val = i__;
dmax__ = (d__1 = dx[ix], abs(d__1));
L5:
ix += *incx;
/* L10: */
}
return ret_val;
/* code for increment equal to 1 */
L20:
dmax__ = abs(dx[1]);
i__1 = *n;
for (i__ = 2; i__ <= i__1; ++i__)
{
if ((d__1 = dx[i__], abs(d__1)) <= dmax__)
{
goto L30;
}
ret_val = i__;
dmax__ = (d__1 = dx[i__], abs(d__1));
L30:;
}
return ret_val;
} /* idamax_ */
real_type epslon_(real_type* x)
{
#if defined(TEST_MPF_100) || defined(TEST_MPFR_100) || defined(TEST_GMPXX) || defined(TEST_MPFRXX)
return std::ldexp(1.0, 1 - ((100 + 1) * 1000L) / 301L);
#elif defined(TEST_CPP_DEC_FLOAT_BN)
return std::pow(10.0, 1 - std::numeric_limits<efx::cpp_dec_float_50>::digits10);
#elif defined(NATIVE_FLOAT128)
return FLT128_EPSILON;
#else
return CAST_TO_RT(std::numeric_limits<real_type>::epsilon());
#endif
} /* epslon_ */
/* Subroutine */ int mm_(real_type* a, integer* lda, integer* n1, integer* n3, real_type* b, integer* ldb, integer* n2, real_type* c__,
integer* ldc)
{
/* System generated locals */
integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2;
/* Local variables */
static integer i__, j;
/* purpose: */
/* multiply matrix b times matrix c and store the result in matrix a. */
/* parameters: */
/* a double precision(lda,n3), matrix of n1 rows and n3 columns */
/* lda integer, leading dimension of array a */
/* n1 integer, number of rows in matrices a and b */
/* n3 integer, number of columns in matrices a and c */
/* b double precision(ldb,n2), matrix of n1 rows and n2 columns */
/* ldb integer, leading dimension of array b */
/* n2 integer, number of columns in matrix b, and number of rows in */
/* matrix c */
/* c double precision(ldc,n3), matrix of n2 rows and n3 columns */
/* ldc integer, leading dimension of array c */
/* ---------------------------------------------------------------------- */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
b_dim1 = *ldb;
b_offset = 1 + b_dim1;
b -= b_offset;
c_dim1 = *ldc;
c_offset = 1 + c_dim1;
c__ -= c_offset;
/* Function Body */
i__1 = *n3;
for (j = 1; j <= i__1; ++j)
{
i__2 = *n1;
for (i__ = 1; i__ <= i__2; ++i__)
{
a[i__ + j * a_dim1] = CAST_TO_RT(0);
/* L10: */
}
dmxpy_(n2, &a[j * a_dim1 + 1], n1, ldb, &c__[j * c_dim1 + 1], &b[b_offset]);
/* L20: */
}
return 0;
} /* mm_ */
/* Subroutine */ int dmxpy_(integer* n1, real_type* y, integer* n2, integer* ldm, real_type* x, real_type* m)
{
/* System generated locals */
integer m_dim1, m_offset, i__1, i__2;
/* Local variables */
static integer i__, j, jmin;
/* purpose: */
/* multiply matrix m times vector x and add the result to vector y. */
/* parameters: */
/* n1 integer, number of elements in vector y, and number of rows in */
/* matrix m */
/* y double precision(n1), vector of length n1 to which is added */
/* the product m*x */
/* n2 integer, number of elements in vector x, and number of columns */
/* in matrix m */
/* ldm integer, leading dimension of array m */
/* x double precision(n2), vector of length n2 */
/* m double precision(ldm,n2), matrix of n1 rows and n2 columns */
/* ---------------------------------------------------------------------- */
/* cleanup odd vector */
/* Parameter adjustments */
--y;
m_dim1 = *ldm;
m_offset = 1 + m_dim1;
m -= m_offset;
--x;
/* Function Body */
j = *n2 % 2;
if (j >= 1)
{
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__)
{
y[i__] += x[j] * m[i__ + j * m_dim1];
/* L10: */
}
}
/* cleanup odd group of two vectors */
j = *n2 % 4;
if (j >= 2)
{
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__)
{
y[i__] = y[i__] + x[j - 1] * m[i__ + (j - 1) * m_dim1] + x[j] * m[i__ + j * m_dim1];
/* L20: */
}
}
/* cleanup odd group of four vectors */
j = *n2 % 8;
if (j >= 4)
{
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__)
{
y[i__] = y[i__] + x[j - 3] * m[i__ + (j - 3) * m_dim1] + x[j - 2] * m[i__ + (j - 2) * m_dim1] + x[j - 1] * m[i__ + (j - 1) * m_dim1] + x[j] * m[i__ + j * m_dim1];
/* L30: */
}
}
/* cleanup odd group of eight vectors */
j = *n2 % 16;
if (j >= 8)
{
i__1 = *n1;
for (i__ = 1; i__ <= i__1; ++i__)
{
y[i__] = y[i__] + x[j - 7] * m[i__ + (j - 7) * m_dim1] + x[j - 6] * m[i__ + (j - 6) * m_dim1] + x[j - 5] * m[i__ + (j - 5) * m_dim1] + x[j - 4] * m[i__ + (j - 4) * m_dim1] + x[j - 3] * m[i__ + (j - 3) * m_dim1] + x[j - 2] * m[i__ + (j - 2) * m_dim1] + x[j - 1] * m[i__ + (j - 1) * m_dim1] + x[j] * m[i__ + j * m_dim1];
/* L40: */
}
}
/* main loop - groups of sixteen vectors */
jmin = j + 16;
i__1 = *n2;
for (j = jmin; j <= i__1; j += 16)
{
i__2 = *n1;
for (i__ = 1; i__ <= i__2; ++i__)
{
y[i__] = y[i__] + x[j - 15] * m[i__ + (j - 15) * m_dim1] + x[j - 14] * m[i__ + (j - 14) * m_dim1] + x[j - 13] * m[i__ + (j - 13) * m_dim1] + x[j - 12] * m[i__ + (j - 12) * m_dim1] + x[j - 11] * m[i__ + (j - 11) * m_dim1] + x[j - 10] * m[i__ + (j - 10) * m_dim1] + x[j - 9] * m[i__ + (j - 9) * m_dim1] + x[j - 8] * m[i__ + (j - 8) * m_dim1] + x[j - 7] * m[i__ + (j - 7) * m_dim1] + x[j - 6] * m[i__ + (j - 6) * m_dim1] + x[j - 5] * m[i__ + (j - 5) * m_dim1] + x[j - 4] * m[i__ + (j - 4) * m_dim1] + x[j - 3] * m[i__ + (j - 3) * m_dim1] + x[j - 2] * m[i__ + (j - 2) * m_dim1] + x[j - 1] * m[i__ + (j - 1) * m_dim1] + x[j] * m[i__ + j * m_dim1];
/* L50: */
}
/* L60: */
}
return 0;
} /* dmxpy_ */
real_type ran_(integer* iseed)
{
/* System generated locals */
real_type ret_val;
/* Local variables */
static integer it1, it2, it3, it4;
/* modified from the LAPACK auxiliary routine 10/12/92 JD */
/* -- LAPACK auxiliary routine (version 1.0) -- */
/* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
/* Courant Institute, Argonne National Lab, and Rice University */
/* February 29, 1992 */
/* .. Array Arguments .. */
/* .. */
/* Purpose */
/* ======= */
/* DLARAN returns a random double number from a uniform (0,1) */
/* distribution. */
/* Arguments */
/* ========= */
/* ISEED (input/output) INTEGER array, dimension (4) */
/* On entry, the seed of the random number generator; the array */
/* elements must be between 0 and 4095, and ISEED(4) must be */
/* odd. */
/* On exit, the seed is updated. */
/* Further Details */
/* =============== */
/* This routine uses a multiplicative congruential method with modulus */
/* 2**48 and multiplier 33952834046453 (see G.S.Fishman, */
/* 'Multiplicative congruential random number generators with modulus */
/* 2**b: an exhaustive analysis for b = 32 and a partial analysis for */
/* b = 48', Math. Comp. 189, pp 331-344, 1990). */
/* 48-bit integers are stored in 4 integer array elements with 12 bits */
/* per element. Hence the routine is portable across machines with */
/* integers of 32 bits or more. */
/* .. Parameters .. */
/* .. */
/* .. Local Scalars .. */
/* .. */
/* .. Intrinsic Functions .. */
/* .. */
/* .. Executable Statements .. */
/* multiply the seed by the multiplier modulo 2**48 */
/* Parameter adjustments */
--iseed;
/* Function Body */
it4 = iseed[4] * 2549;
it3 = it4 / 4096;
it4 -= it3 << 12;
it3 = it3 + iseed[3] * 2549 + iseed[4] * 2508;
it2 = it3 / 4096;
it3 -= it2 << 12;
it2 = it2 + iseed[2] * 2549 + iseed[3] * 2508 + iseed[4] * 322;
it1 = it2 / 4096;
it2 -= it1 << 12;
it1 = it1 + iseed[1] * 2549 + iseed[2] * 2508 + iseed[3] * 322 + iseed[4] * 494;
it1 %= 4096;
/* return updated seed */
iseed[1] = it1;
iseed[2] = it2;
iseed[3] = it3;
iseed[4] = it4;
/* convert 48-bit integer to a double number in the interval (0,1) */
ret_val = ((real_type)it1 + ((real_type)it2 + ((real_type)it3 + (real_type)it4 * 2.44140625e-4) * 2.44140625e-4) * 2.44140625e-4) * 2.44140625e-4;
return ret_val;
/* End of RAN */
} /* ran_ */
/*
Double results:
~~~~~~~~~~~~~~
norm. resid resid machep x(1) x(n)
6.4915 7.207e-013 2.2204e-016 1 1
times are reported for matrices of order 1000
factor solve total mflops unit ratio
times for array with leading dimension of1001
1.443 0.003 1.446 462.43 0.004325 25.821
mpf_class results:
~~~~~~~~~~~~~~~~~~
norm. resid resid machep x(1) x(n)
3.6575e-05 5.2257e-103 2.8575e-101 1 1
times are reported for matrices of order 1000
factor solve total mflops unit ratio
times for array with leading dimension of1001
266.45 0.798 267.24 2.5021 0.79933 4772.2
number<gmp_float<100> >:
~~~~~~~~~~~~~~~~~~~~~~~~~~~
norm. resid resid machep x(1) x(n)
0.36575e-4 0.52257e-102 0.28575e-100 0.1e1 0.1e1
times are reported for matrices of order 1000
factor solve total mflops unit ratio
times for array with leading dimension of1001
279.96 0.84 280.8 2.3813 0.83988 5014.3
boost::multiprecision::ef::cpp_dec_float_50:
~~~~~~~~~~~~~~~~~~~~~~~~~
norm. resid resid machep x(1) x(n)
2.551330735e-16 1.275665107e-112 1e-99 1 1
times are reported for matrices of order 1000
factor solve total mflops unit ratio
times for array with leading dimension of1001
363.89 1.074 364.97 1.8321 1.0916 6517.3
*/
Reference in New Issue View Git Blame Copy Permalink