nmatrix 0.0.6 → 0.0.7

data/ext/nmatrix/extconf.rb

@@ -105,7 +105,7 @@ $srcs = [
          'ruby_constants.cpp',
 
          'data/data.cpp',
-         'util/math.cpp',
+         'math.cpp',
          'util/sl_list.cpp',
          'util/io.cpp',
          'storage/common.cpp',
@@ -148,6 +148,7 @@ have_header("clapack.h")
 have_header("cblas.h")
 
 have_func("clapack_dgetrf", "clapack.h")
+have_func("dgesvd_", "clapack.h")
 
 
 #find_library("cblas", "cblas_dgemm")
@@ -158,7 +159,7 @@ have_func("cblas_dgemm", "cblas.h")
 # Order matters here: ATLAS has to go after LAPACK: http://mail.scipy.org/pipermail/scipy-user/2007-January/010717.html
 $libs += " -llapack -lcblas -latlas "
 
-$objs = %w{nmatrix ruby_constants data/data util/io util/math util/sl_list storage/common storage/storage storage/dense storage/yale storage/list}.map { |i| i + ".o" }
+$objs = %w{nmatrix ruby_constants data/data util/io math util/sl_list storage/common storage/storage storage/dense storage/yale storage/list}.map { |i| i + ".o" }
 
 #CONFIG['CXX'] = 'clang++'
 CONFIG['CXX'] = 'g++'

data/ext/nmatrix/{util/math.cpp → math.cpp}

@@ -112,8 +112,33 @@
  * Project Includes
  */
 
-#include "math.h"
-#include "lapack.h"
+#include <algorithm>
+#include <limits>
+
+#include "data/data.h"
+#include "math/gesdd.h"
+#include "math/gesvd.h"
+#include "math/geev.h"
+#include "math/swap.h"
+#include "math/idamax.h"
+#include "math/scal.h"
+#include "math/ger.h"
+#include "math/getf2.h"
+#include "math/laswp.h"
+#include "math/trsm.h"
+#include "math/long_dtype.h" // for gemm.h
+#include "math/gemm.h"
+#include "math/gemv.h"
+#include "math/asum.h"
+#include "math/nrm2.h"
+#include "math/getrf.h"
+#include "math/getri.h"
+#include "math/getrs.h"
+#include "math/potrs.h"
+#include "math/rot.h"
+#include "math/rotg.h"
+#include "math/math.h"
+#include "storage/dense.h"
 
 #include "nmatrix.h"
 #include "ruby_constants.h"
@@ -155,6 +180,9 @@ extern "C" {
   static VALUE nm_clapack_scal(VALUE self, VALUE n, VALUE scale, VALUE vector, VALUE incx);
   static VALUE nm_clapack_lauum(VALUE self, VALUE order, VALUE uplo, VALUE n, VALUE a, VALUE lda);
 
+  static VALUE nm_lapack_gesvd(VALUE self, VALUE jobu, VALUE jobvt, VALUE m, VALUE n, VALUE a, VALUE lda, VALUE s, VALUE u, VALUE ldu, VALUE vt, VALUE ldvt, VALUE lworkspace_size);
+  static VALUE nm_lapack_gesdd(VALUE self, VALUE jobz, VALUE m, VALUE n, VALUE a, VALUE lda, VALUE s, VALUE u, VALUE ldu, VALUE vt, VALUE ldvt, VALUE lworkspace_size);
+  static VALUE nm_lapack_geev(VALUE self, VALUE compute_left, VALUE compute_right, VALUE n, VALUE a, VALUE lda, VALUE w, VALUE wi, VALUE vl, VALUE ldvl, VALUE vr, VALUE ldvr, VALUE lwork);
 } // end of extern "C" block
 
 ////////////////////
@@ -191,7 +219,21 @@ void det_exact(const int M, const void* A_elements, const int lda, void* result_
 }
 
 
+/*
+ * Function signature conversion for calling CBLAS' gesvd functions as directly as possible.
+ */
+template <typename DType, typename CType>
+inline static int lapack_gesvd(char jobu, char jobvt, int m, int n, void* a, int lda, void* s, void* u, int ldu, void* vt, int ldvt, void* work, int lwork, void* rwork) {
+  return gesvd<DType,CType>(jobu, jobvt, m, n, reinterpret_cast<DType*>(a), lda, reinterpret_cast<DType*>(s), reinterpret_cast<DType*>(u), ldu, reinterpret_cast<DType*>(vt), ldvt, reinterpret_cast<DType*>(work), lwork, reinterpret_cast<CType*>(rwork));
+}
 
+/*
+ * Function signature conversion for calling CBLAS' gesvd functions as directly as possible.
+ */
+template <typename DType, typename CType>
+inline static int lapack_gesdd(char jobz, int m, int n, void* a, int lda, void* s, void* u, int ldu, void* vt, int ldvt, void* work, int lwork, int* iwork, void* rwork) {
+  return gesdd<DType,CType>(jobz, m, n, reinterpret_cast<DType*>(a), lda, reinterpret_cast<DType*>(s), reinterpret_cast<DType*>(u), ldu, reinterpret_cast<DType*>(vt), ldvt, reinterpret_cast<DType*>(work), lwork, iwork, reinterpret_cast<CType*>(rwork));
+}
 
 /*
  * Function signature conversion for calling CBLAS' gemm functions as directly as possible.
@@ -297,6 +339,7 @@ extern "C" {
 void nm_math_init_blas() {
 	cNMatrix_LAPACK = rb_define_module_under(cNMatrix, "LAPACK");
 
+  /* ATLAS-CLAPACK Functions */
   rb_define_singleton_method(cNMatrix_LAPACK, "clapack_getrf", (METHOD)nm_clapack_getrf, 5);
   rb_define_singleton_method(cNMatrix_LAPACK, "clapack_potrf", (METHOD)nm_clapack_potrf, 5);
   rb_define_singleton_method(cNMatrix_LAPACK, "clapack_getrs", (METHOD)nm_clapack_getrs, 9);
@@ -307,6 +350,11 @@ void nm_math_init_blas() {
   rb_define_singleton_method(cNMatrix_LAPACK, "clapack_scal",  (METHOD)nm_clapack_scal,  4);
   rb_define_singleton_method(cNMatrix_LAPACK, "clapack_lauum", (METHOD)nm_clapack_lauum, 5);
 
+  /* Non-ATLAS regular LAPACK Functions called via Fortran interface */
+  rb_define_singleton_method(cNMatrix_LAPACK, "lapack_gesvd", (METHOD)nm_lapack_gesvd, 12);
+  rb_define_singleton_method(cNMatrix_LAPACK, "lapack_gesdd", (METHOD)nm_lapack_gesdd, 11);
+  rb_define_singleton_method(cNMatrix_LAPACK, "lapack_geev",  (METHOD)nm_lapack_geev,  12);
+
   cNMatrix_BLAS = rb_define_module_under(cNMatrix, "BLAS");
 
   rb_define_singleton_method(cNMatrix_BLAS, "cblas_nrm2", (METHOD)nm_cblas_nrm2, 3);
@@ -322,6 +370,31 @@ void nm_math_init_blas() {
 	rb_define_singleton_method(cNMatrix_BLAS, "cblas_herk", (METHOD)nm_cblas_herk, 11);
 }
 
+/*
+ * Interprets lapack jobu and jobvt arguments, for which LAPACK needs character values A, S, O, or N.
+ *
+ * Called by lapack_gesvd -- basically inline. svd stands for singular value decomposition.
+ */
+static inline char lapack_svd_job_sym(VALUE op) {
+  if (rb_to_id(op) == rb_intern("all") || rb_to_id(op) == rb_intern("a")) return 'A';
+  else if (rb_to_id(op) == rb_intern("return") || rb_to_id(op) == rb_intern("s")) return 'S';
+  else if (rb_to_id(op) == rb_intern("overwrite") || rb_to_id(op) == rb_intern("o")) return 'O';
+  else if (rb_to_id(op) == rb_intern("none") || rb_to_id(op) == rb_intern("n")) return 'N';
+  else rb_raise(rb_eArgError, "Expected :all, :return, :overwrite, :none (or :a, :s, :o, :n, respectively)");
+  return 'a';
+}
+
+
+/*
+ * Interprets lapack jobvl and jobvr arguments, for which LAPACK needs character values N or V.
+ *
+ * Called by lapack_geev -- basically inline. evd stands for eigenvalue decomposition.
+ */
+static inline char lapack_evd_job_sym(VALUE op) {
+  if (op == Qfalse || op == Qnil || rb_to_id(op) == rb_intern("n")) return 'N';
+  else return 'V';
+}
+
 
 /* Interprets cblas argument which could be any of false/:no_transpose, :transpose, or :complex_conjugate,
  * into an enum recognized by cblas.
@@ -337,6 +410,7 @@ static inline enum CBLAS_TRANSPOSE blas_transpose_sym(VALUE op) {
   return CblasNoTrans;
 }
 
+
 /*
  * Interprets cblas argument which could be :left or :right
  *
@@ -417,7 +491,7 @@ static VALUE nm_cblas_rotg(VALUE self, VALUE ab) {
       nm::math::cblas_rotg<nm::Complex64>,
       nm::math::cblas_rotg<nm::Complex128>,
       NULL, NULL, NULL, // no rationals
-      nm::math::cblas_rotg<nm::RubyObject>
+      NULL //nm::math::cblas_rotg<nm::RubyObject>
   };
 
   nm::dtype_t dtype = NM_DTYPE(ab);
@@ -438,8 +512,14 @@ static VALUE nm_cblas_rotg(VALUE self, VALUE ab) {
     ttable[dtype](pA, pB, pC, pS);
 
     VALUE result = rb_ary_new2(2);
-    rb_ary_store(result, 0, rubyobj_from_cval(pC, dtype).rval);
-    rb_ary_store(result, 1, rubyobj_from_cval(pS, dtype).rval);
+
+    if (dtype == nm::RUBYOBJ) {
+      rb_ary_store(result, 0, *reinterpret_cast<VALUE*>(pC));
+      rb_ary_store(result, 1, *reinterpret_cast<VALUE*>(pS));
+    } else {
+      rb_ary_store(result, 0, rubyobj_from_cval(pC, dtype).rval);
+      rb_ary_store(result, 1, rubyobj_from_cval(pS, dtype).rval);
+    }
 
     return result;
   }
@@ -852,9 +932,219 @@ static VALUE nm_cblas_herk(VALUE self,
     cblas_zherk(blas_order_sym(order), blas_uplo_sym(uplo), blas_transpose_sym(trans), FIX2INT(n), FIX2INT(k), NUM2DBL(alpha), NM_STORAGE_DENSE(a)->elements, FIX2INT(lda), NUM2DBL(beta), NM_STORAGE_DENSE(c)->elements, FIX2INT(ldc));
   } else
     rb_raise(rb_eNotImpError, "this matrix operation undefined for non-complex dtypes");
+  return Qtrue;
+}
 
 
-  return Qtrue;
+/*
+ * Function signature conversion for calling CBLAS' gesvd functions as directly as possible.
+ *
+ * xGESVD computes the singular value decomposition (SVD) of a real
+ * M-by-N matrix A, optionally computing the left and/or right singular
+ * vectors. The SVD is written
+ *
+ *      A = U * SIGMA * transpose(V)
+ *
+ * where SIGMA is an M-by-N matrix which is zero except for its
+ * min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+ * V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
+ * are the singular values of A; they are real and non-negative, and
+ * are returned in descending order.  The first min(m,n) columns of
+ * U and V are the left and right singular vectors of A.
+ *
+ * Note that the routine returns V**T, not V.
+ */
+static VALUE nm_lapack_gesvd(VALUE self, VALUE jobu, VALUE jobvt, VALUE m, VALUE n, VALUE a, VALUE lda, VALUE s, VALUE u, VALUE ldu, VALUE vt, VALUE ldvt, VALUE lwork) {
+  static int (*gesvd_table[nm::NUM_DTYPES])(char, char, int, int, void* a, int, void* s, void* u, int, void* vt, int, void* work, int, void* rwork) = {
+    NULL, NULL, NULL, NULL, NULL, // no integer ops
+    nm::math::lapack_gesvd<float,float>,
+    nm::math::lapack_gesvd<double,double>,
+    nm::math::lapack_gesvd<nm::Complex64,float>,
+    nm::math::lapack_gesvd<nm::Complex128,double>,
+    NULL, NULL, NULL, NULL // no rationals or Ruby objects
+  };
+
+  nm::dtype_t dtype = NM_DTYPE(a);
+
+
+  if (!gesvd_table[dtype]) {
+    rb_raise(rb_eNotImpError, "this operation not yet implemented for non-BLAS dtypes");
+    return Qfalse;
+  } else {
+    int M = FIX2INT(m),
+        N = FIX2INT(n);
+
+    int min_mn  = NM_MIN(M,N);
+    int max_mn  = NM_MAX(M,N);
+
+    char JOBU = lapack_svd_job_sym(jobu),
+         JOBVT = lapack_svd_job_sym(jobvt);
+
+    // only need rwork for complex matrices
+    int rwork_size  = (dtype == nm::COMPLEX64 || dtype == nm::COMPLEX128) ? 5 * min_mn : 0;
+    void* rwork     = rwork_size > 0 ? ALLOCA_N(char, DTYPE_SIZES[dtype] * rwork_size) : NULL;
+    int work_size   = FIX2INT(lwork);
+
+    // ignore user argument for lwork if it's too small.
+    work_size       = NM_MAX((dtype == nm::COMPLEX64 || dtype == nm::COMPLEX128 ? 2 * min_mn + max_mn : NM_MAX(3*min_mn + max_mn, 5*min_mn)), work_size);
+    void* work      = ALLOCA_N(char, DTYPE_SIZES[dtype] * work_size);
+
+    int info = gesvd_table[dtype](JOBU, JOBVT, M, N, NM_STORAGE_DENSE(a)->elements, FIX2INT(lda),
+      NM_STORAGE_DENSE(s)->elements, NM_STORAGE_DENSE(u)->elements, FIX2INT(ldu), NM_STORAGE_DENSE(vt)->elements, FIX2INT(ldvt),
+      work, work_size, rwork);
+    return INT2FIX(info);
+  }
+}
+
+/*
+ * Function signature conversion for calling CBLAS' gesdd functions as directly as possible.
+ *
+ * xGESDD uses a divide-and-conquer strategy to compute the singular value decomposition (SVD) of a real
+ * M-by-N matrix A, optionally computing the left and/or right singular
+ * vectors. The SVD is written
+ *
+ *      A = U * SIGMA * transpose(V)
+ *
+ * where SIGMA is an M-by-N matrix which is zero except for its
+ * min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+ * V is an N-by-N orthogonal matrix.  The diagonal elements of SIGMA
+ * are the singular values of A; they are real and non-negative, and
+ * are returned in descending order.  The first min(m,n) columns of
+ * U and V are the left and right singular vectors of A.
+ *
+ * Note that the routine returns V**T, not V.
+ */
+static VALUE nm_lapack_gesdd(VALUE self, VALUE jobz, VALUE m, VALUE n, VALUE a, VALUE lda, VALUE s, VALUE u, VALUE ldu, VALUE vt, VALUE ldvt, VALUE lwork) {
+  static int (*gesdd_table[nm::NUM_DTYPES])(char, int, int, void* a, int, void* s, void* u, int, void* vt, int, void* work, int, int* iwork, void* rwork) = {
+    NULL, NULL, NULL, NULL, NULL, // no integer ops
+    nm::math::lapack_gesdd<float,float>,
+    nm::math::lapack_gesdd<double,double>,
+    nm::math::lapack_gesdd<nm::Complex64,float>,
+    nm::math::lapack_gesdd<nm::Complex128,double>,
+    NULL, NULL, NULL, NULL // no rationals or Ruby objects
+  };
+
+  nm::dtype_t dtype = NM_DTYPE(a);
+
+  if (!gesdd_table[dtype]) {
+    rb_raise(rb_eNotImpError, "this operation not yet implemented for non-BLAS dtypes");
+    return Qfalse;
+  } else {
+    int M = FIX2INT(m),
+        N = FIX2INT(n);
+
+    int min_mn  = NM_MIN(M,N);
+    int max_mn  = NM_MAX(M,N);
+
+    char JOBZ = lapack_svd_job_sym(jobz);
+
+    // only need rwork for complex matrices
+    void* rwork = NULL;
+
+    int work_size = FIX2INT(lwork); // Make sure we allocate enough work, regardless of the user request.
+    if (dtype == nm::COMPLEX64 || dtype == nm::COMPLEX128) {
+      int rwork_size = min_mn * (JOBZ == 'N' ? 5 : NM_MAX(5*min_mn + 7, 2*max_mn + 2*min_mn + 1));
+      rwork = ALLOCA_N(char, DTYPE_SIZES[dtype] * rwork_size);
+
+      if (JOBZ == 'N')      work_size = NM_MAX(work_size, 3*min_mn + NM_MAX(max_mn, 6*min_mn));
+      else if (JOBZ == 'O') work_size = NM_MAX(work_size, 3*min_mn*min_mn + NM_MAX(max_mn, 5*min_mn*min_mn + 4*min_mn));
+      else                  work_size = NM_MAX(work_size, 3*min_mn*min_mn + NM_MAX(max_mn, 4*min_mn*min_mn + 4*min_mn));
+    } else {
+      if (JOBZ == 'N')      work_size = NM_MAX(work_size, 2*min_mn + max_mn);
+      else if (JOBZ == 'O') work_size = NM_MAX(work_size, 2*min_mn*min_mn + max_mn + 2*min_mn);
+      else                  work_size = NM_MAX(work_size, min_mn*min_mn + max_mn + 2*min_mn);
+    }
+    void* work  = ALLOCA_N(char, DTYPE_SIZES[dtype] * work_size);
+    int* iwork  = ALLOCA_N(int, 8*min_mn);
+
+    int info = gesdd_table[dtype](JOBZ, M, N, NM_STORAGE_DENSE(a)->elements, FIX2INT(lda),
+      NM_STORAGE_DENSE(s)->elements, NM_STORAGE_DENSE(u)->elements, FIX2INT(ldu), NM_STORAGE_DENSE(vt)->elements, FIX2INT(ldvt),
+      work, work_size, iwork, rwork);
+    return INT2FIX(info);
+  }
+}
+
+
+/*
+ * Function signature conversion for calling CBLAS' geev functions as directly as possible.
+ *
+ * GEEV computes for an N-by-N real nonsymmetric matrix A, the
+ * eigenvalues and, optionally, the left and/or right eigenvectors.
+ *
+ * The right eigenvector v(j) of A satisfies
+ *                    A * v(j) = lambda(j) * v(j)
+ * where lambda(j) is its eigenvalue.
+ *
+ * The left eigenvector u(j) of A satisfies
+ *                 u(j)**H * A = lambda(j) * u(j)**H
+ * where u(j)**H denotes the conjugate transpose of u(j).
+ *
+ * The computed eigenvectors are normalized to have Euclidean norm
+ * equal to 1 and largest component real.
+ */
+static VALUE nm_lapack_geev(VALUE self, VALUE compute_left, VALUE compute_right, VALUE n, VALUE a, VALUE lda, VALUE w, VALUE wi, VALUE vl, VALUE ldvl, VALUE vr, VALUE ldvr, VALUE lwork) {
+  static int (*geev_table[nm::NUM_DTYPES])(char, char, int, void* a, int, void* w, void* wi, void* vl, int, void* vr, int, void* work, int, void* rwork) = {
+    NULL, NULL, NULL, NULL, NULL, // no integer ops
+    nm::math::lapack_geev<float,float>,
+    nm::math::lapack_geev<double,double>,
+    nm::math::lapack_geev<nm::Complex64,float>,
+    nm::math::lapack_geev<nm::Complex128,double>,
+    NULL, NULL, NULL, NULL // no rationals or Ruby objects
+  };
+
+  nm::dtype_t dtype = NM_DTYPE(a);
+
+
+  if (!geev_table[dtype]) {
+    rb_raise(rb_eNotImpError, "this operation not yet implemented for non-BLAS dtypes");
+    return Qfalse;
+  } else {
+    int N = FIX2INT(n);
+
+    char JOBVL = lapack_evd_job_sym(compute_left),
+         JOBVR = lapack_evd_job_sym(compute_right);
+
+    void* A  = NM_STORAGE_DENSE(a)->elements;
+    void* WR = NM_STORAGE_DENSE(w)->elements;
+    void* WI = wi == Qnil ? NULL : NM_STORAGE_DENSE(wi)->elements;
+    void* VL = NM_STORAGE_DENSE(vl)->elements;
+    void* VR = NM_STORAGE_DENSE(vr)->elements;
+
+    // only need rwork for complex matrices (wi == Qnil for complex)
+    int rwork_size  = dtype == nm::COMPLEX64 || dtype == nm::COMPLEX128 ? N * DTYPE_SIZES[dtype] : 0; // 2*N*floattype for complex only, otherwise 0
+    void* rwork     = rwork_size > 0 ? ALLOCA_N(char, rwork_size) : NULL;
+    int work_size   = FIX2INT(lwork);
+    void* work;
+
+    int info;
+
+    // if work size is 0 or -1, query.
+    if (work_size <= 0) {
+      work_size = -1;
+      work = ALLOC_N(char, DTYPE_SIZES[dtype]); //2*N * DTYPE_SIZES[dtype]);
+      info = geev_table[dtype](JOBVL, JOBVR, N, A, FIX2INT(lda), WR, WI, VL, FIX2INT(ldvl), VR, FIX2INT(ldvr), work, work_size, rwork);
+      work_size = (int)(dtype == nm::COMPLEX64 || dtype == nm::FLOAT32 ? reinterpret_cast<float*>(work)[0] : reinterpret_cast<double*>(work)[0]);
+      // line above is basically: work_size = (int)(work[0]); // now have new work_size
+      xfree(work);
+      if (info == 0)
+        rb_warn("geev: calculated optimal lwork of %d; to eliminate this message, use a positive value for lwork (at least 2*shape[i])", work_size);
+      else return INT2FIX(info); // error of some kind on query!
+    }
+
+    // if work size is < 2*N, just set it to 2*N
+    if (work_size < 2*N) work_size = 2*N;
+    if (work_size < 3*N && (dtype == nm::FLOAT32 || dtype == nm::FLOAT64)) {
+      work_size = JOBVL == 'V' || JOBVR == 'V' ? 4*N : 3*N;
+    }
+
+    // Allocate work array for actual run
+    work = ALLOCA_N(char, work_size * DTYPE_SIZES[dtype]);
+
+    // Perform the actual calculation.
+    info = geev_table[dtype](JOBVL, JOBVR, N, A, FIX2INT(lda), WR, WI, VL, FIX2INT(ldvl), VR, FIX2INT(ldvr), work, work_size, rwork);
+
+    return INT2FIX(info);
+  }
 }
 
 

data/ext/nmatrix/math/asum.h

@@ -0,0 +1,143 @@
+/////////////////////////////////////////////////////////////////////
+// = NMatrix
+//
+// A linear algebra library for scientific computation in Ruby.
+// NMatrix is part of SciRuby.
+//
+// NMatrix was originally inspired by and derived from NArray, by
+// Masahiro Tanaka: http://narray.rubyforge.org
+//
+// == Copyright Information
+//
+// SciRuby is Copyright (c) 2010 - 2013, Ruby Science Foundation
+// NMatrix is Copyright (c) 2013, Ruby Science Foundation
+//
+// Please see LICENSE.txt for additional copyright notices.
+//
+// == Contributing
+//
+// By contributing source code to SciRuby, you agree to be bound by
+// our Contributor Agreement:
+//
+// * https://github.com/SciRuby/sciruby/wiki/Contributor-Agreement
+//
+// == asum.h
+//
+// CBLAS asum function
+//
+
+/*
+ *             Automatically Tuned Linear Algebra Software v3.8.4
+ *                    (C) Copyright 1999 R. Clint Whaley
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions
+ * are met:
+ *   1. Redistributions of source code must retain the above copyright
+ *      notice, this list of conditions and the following disclaimer.
+ *   2. Redistributions in binary form must reproduce the above copyright
+ *      notice, this list of conditions, and the following disclaimer in the
+ *      documentation and/or other materials provided with the distribution.
+ *   3. The name of the ATLAS group or the names of its contributers may
+ *      not be used to endorse or promote products derived from this
+ *      software without specific written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+ * ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
+ * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
+ * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE ATLAS GROUP OR ITS CONTRIBUTORS
+ * BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *
+ */
+
+#ifndef ASUM_H
+# define ASUM_H
+
+
+namespace nm { namespace math {
+
+/*
+ * Level 1 BLAS routine which sums the absolute values of a vector's contents. If the vector consists of complex values,
+ * the routine sums the absolute values of the real and imaginary components as well.
+ *
+ * So, based on input types, these are the valid return types:
+ *    int -> int
+ *    float -> float or double
+ *    double -> double
+ *    complex64 -> float or double
+ *    complex128 -> double
+ *    rational -> rational
+ */
+template <typename ReturnDType, typename DType>
+inline ReturnDType asum(const int N, const DType* X, const int incX) {
+  ReturnDType sum = 0;
+  if ((N > 0) && (incX > 0)) {
+    for (int i = 0; i < N; ++i) {
+      sum += std::abs(X[i*incX]);
+    }
+  }
+  return sum;
+}
+
+
+#ifdef HAVE_CBLAS_H
+template <>
+inline float asum(const int N, const float* X, const int incX) {
+  return cblas_sasum(N, X, incX);
+}
+
+template <>
+inline double asum(const int N, const double* X, const int incX) {
+  return cblas_dasum(N, X, incX);
+}
+
+template <>
+inline float asum(const int N, const Complex64* X, const int incX) {
+  return cblas_scasum(N, X, incX);
+}
+
+template <>
+inline double asum(const int N, const Complex128* X, const int incX) {
+  return cblas_dzasum(N, X, incX);
+}
+#else
+template <>
+inline float asum(const int N, const Complex64* X, const int incX) {
+  float sum = 0;
+  if ((N > 0) && (incX > 0)) {
+    for (int i = 0; i < N; ++i) {
+      sum += std::abs(X[i*incX].r) + std::abs(X[i*incX].i);
+    }
+  }
+  return sum;
+}
+
+template <>
+inline double asum(const int N, const Complex128* X, const int incX) {
+  double sum = 0;
+  if ((N > 0) && (incX > 0)) {
+    for (int i = 0; i < N; ++i) {
+      sum += std::abs(X[i*incX].r) + std::abs(X[i*incX].i);
+    }
+  }
+  return sum;
+}
+#endif
+
+
+template <typename ReturnDType, typename DType>
+inline void cblas_asum(const int N, const void* X, const int incX, void* sum) {
+  *reinterpret_cast<ReturnDType*>( sum ) = asum<ReturnDType, DType>( N, reinterpret_cast<const DType*>(X), incX );
+}
+
+
+
+}} // end of namespace nm::math
+
+#endif // NRM2_H