├── VERSION ├── .gitignore ├── ext └── nnls │ ├── extconf.rb │ ├── test.rb │ ├── nnls.c │ └── impl.c ├── test ├── test_helper.rb └── nnls_test.rb ├── lib └── nnls.rb ├── README.md ├── Rakefile ├── LICENSE └── nnls.gemspec /VERSION: -------------------------------------------------------------------------------- 1 | 0.0.1 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | pkg/* 2 | ext/nnls/*.so 3 | ext/nnls/Makefile 4 | ext/nnls/*.o 5 | -------------------------------------------------------------------------------- /ext/nnls/extconf.rb: -------------------------------------------------------------------------------- 1 | require 'mkmf' 2 | extension_name = 'nnls' 3 | dir_config(extension_name) 4 | 5 | # $CFLAGS << ' -g' 6 | 7 | create_makefile(extension_name) 8 | -------------------------------------------------------------------------------- /test/test_helper.rb: -------------------------------------------------------------------------------- 1 | $LOAD_PATH << File.dirname(__FILE__) + "/../lib" 2 | $LOAD_PATH << File.dirname(__FILE__) + "/../ext" 3 | 4 | require 'test/unit' 5 | require "nnls" 6 | -------------------------------------------------------------------------------- /ext/nnls/test.rb: -------------------------------------------------------------------------------- 1 | require File.dirname(__FILE__) + "/nnls.so" 2 | 3 | A = [0.5, 0.3, 0.2, 4 | 0.2, 0.7, 0.8] 5 | 6 | B = [0.1, 0.1, 0.7] 7 | 8 | puts NNLS._nnls(A, B, 3, 2).inspect 9 | -------------------------------------------------------------------------------- /lib/nnls.rb: -------------------------------------------------------------------------------- 1 | require 'nnls.so' 2 | 3 | module NNLS 4 | def self.nnls(a, b, m, n) 5 | x, rnorm, status = self._nnls(a, b, m, n) 6 | 7 | case status 8 | when 2 9 | raise "The dimensions of the problem are bad (m = 0 or n = 0)" 10 | when 3 11 | raise "Iteration count exceeded (more than 3*n iterations)" 12 | end 13 | 14 | [x, rnorm] 15 | end 16 | end 17 | -------------------------------------------------------------------------------- /test/nnls_test.rb: -------------------------------------------------------------------------------- 1 | require File.dirname(__FILE__) + "/test_helper" 2 | 3 | class NnlsTest < Test::Unit::TestCase 4 | def test_nnls 5 | a = [0.5, 0.3, 0.2, 6 | 0.2, 0.7, 0.8] 7 | 8 | b = [0.1, 0.1, 0.7] 9 | 10 | result = nil 11 | assert_nothing_raised do 12 | result = NNLS.nnls(a, b, 2, 3) 13 | end 14 | 15 | assert_equal Array, result[0].class 16 | assert_equal 3, result[0].size 17 | 18 | assert_equal Float, result[1].class 19 | end 20 | end 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Non-negative Least Square Algorithm 2 | =================== 3 | 4 | It's a C. Lawson and R. Hanson Fortran 77 code published in 5 | ["Solving Least Squares Problems"](http://books.google.com/books?id=ROw4hU85nz8C&lpg=PA261&ots=mj7CFK4GNo&dq=mda%20is%20the%20first%20dimensioning%20parameter&pg=PP1#v=onepage&q&f=false) translated to C code and binded to Ruby. 6 | 7 | Usage 8 | ---------- 9 | 10 | $ gem install nnls 11 | 12 | a = [0.5, 0.3, 0.2, 13 | 0.2, 0.7, 0.8] 14 | 15 | b = [0.1, 0.1, 0.7] 16 | 17 | result = NNLS.nnls(a, b, 2, 3) 18 | => [[0.05263157894736844, 0.0, 0.10526315789473684], 0.0] 19 | 20 | License 21 | ---------- 22 | 23 | This gem is distributed under MIT license. -------------------------------------------------------------------------------- /Rakefile: -------------------------------------------------------------------------------- 1 | require 'rake/testtask' 2 | 3 | begin 4 | require 'jeweler' 5 | 6 | Jeweler::Tasks.new do |gemspec| 7 | gemspec.name = "nnls" 8 | gemspec.summary = "Non-negative Least Square Algorithm" 9 | gemspec.description = "Ruby bindings for C. Lawson and R. Hanson 'Non-negative Least Square' algorithm implementation." 10 | gemspec.email = "sotakone@sotakone.com" 11 | gemspec.homepage = "http://github.com/sotakone/nnls/" 12 | gemspec.authors = ["Mikhail Lapshin"] 13 | gemspec.files.include 'lib/nnls.rb' 14 | gemspec.files.include 'ext/nnls/*.c' 15 | gemspec.files.include 'ext/nnls/extconf.rb' 16 | end 17 | 18 | Jeweler::GemcutterTasks.new 19 | rescue LoadError 20 | puts "Jeweler not available. Install it with: gem install jeweler" 21 | end 22 | 23 | Rake::TestTask.new(:test) do |t| 24 | t.test_files = FileList['test/*_test.rb'] 25 | end 26 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2013 Mike Lapshin 2 | 3 | MIT License 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining 6 | a copy of this software and associated documentation files (the 7 | "Software"), to deal in the Software without restriction, including 8 | without limitation the rights to use, copy, modify, merge, publish, 9 | distribute, sublicense, and/or sell copies of the Software, and to 10 | permit persons to whom the Software is furnished to do so, subject to 11 | the following conditions: 12 | 13 | The above copyright notice and this permission notice shall be 14 | included in all copies or substantial portions of the Software. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 17 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 18 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 19 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 20 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 21 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 22 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -------------------------------------------------------------------------------- /nnls.gemspec: -------------------------------------------------------------------------------- 1 | # Generated by jeweler 2 | # DO NOT EDIT THIS FILE DIRECTLY 3 | # Instead, edit Jeweler::Tasks in Rakefile, and run 'rake gemspec' 4 | # -*- encoding: utf-8 -*- 5 | 6 | Gem::Specification.new do |s| 7 | s.name = "nnls" 8 | s.version = "0.0.1" 9 | 10 | s.required_rubygems_version = Gem::Requirement.new(">= 0") if s.respond_to? :required_rubygems_version= 11 | s.authors = ["Mikhail Lapshin"] 12 | s.date = "2011-12-08" 13 | s.description = "Ruby bindings for C. Lawson and R. Hanson 'Non-negative Less Square' algorithm implementation." 14 | s.email = "sotakone@sotakone.com" 15 | s.extensions = ["ext/nnls/extconf.rb"] 16 | s.extra_rdoc_files = [ 17 | "README.md" 18 | ] 19 | s.files = [ 20 | "README.md", 21 | "Rakefile", 22 | "VERSION", 23 | "ext/nnls/extconf.rb", 24 | "ext/nnls/impl.c", 25 | "ext/nnls/nnls.c", 26 | "ext/nnls/test.rb", 27 | "lib/nnls.rb", 28 | "nnls.gemspec", 29 | "test/nnls_test.rb", 30 | "test/test_helper.rb" 31 | ] 32 | s.homepage = "http://github.com/sotakone/nnls/" 33 | s.require_paths = ["lib"] 34 | s.rubygems_version = "1.8.11" 35 | s.summary = "Non-negative Less Square Algorithm" 36 | s.license = ['MIT'] 37 | 38 | if s.respond_to? :specification_version then 39 | s.specification_version = 3 40 | 41 | if Gem::Version.new(Gem::VERSION) >= Gem::Version.new('1.2.0') then 42 | else 43 | end 44 | else 45 | end 46 | end 47 | 48 | -------------------------------------------------------------------------------- /ext/nnls/nnls.c: -------------------------------------------------------------------------------- 1 | #include "ruby.h" 2 | 3 | int nnls_(a, mda, m, n, b, x, rnorm, w, zz, index, mode); 4 | 5 | VALUE nnls_module = Qnil; 6 | 7 | void Init_nnls(); 8 | 9 | static VALUE nnls_method(VALUE self, VALUE A, VALUE b, VALUE Aw, VALUE Ah); 10 | 11 | /* The initialization method for this module */ 12 | void Init_nnls() { 13 | nnls_module = rb_define_module("NNLS"); 14 | rb_define_singleton_method(nnls_module, "_nnls", nnls_method, 4); 15 | } 16 | 17 | static VALUE nnls_method(VALUE self, VALUE A, VALUE B, VALUE Aw, VALUE Ah) { 18 | long A_len = RARRAY_LEN(A); 19 | long B_len = RARRAY_LEN(B); 20 | long m = NUM2INT(Aw); 21 | long n = NUM2INT(Ah); 22 | 23 | double *A_copy = 0; 24 | double *B_copy = 0; 25 | 26 | double *X = 0; 27 | double Rnorm = 0; 28 | double *W = 0; 29 | double *ZZ = 0; 30 | int *index = 0; 31 | 32 | int i = 0; 33 | int mode = 0; 34 | int mda = 0; 35 | 36 | VALUE ret; 37 | VALUE ret_x; 38 | 39 | A_copy = malloc(sizeof(double) * m * n); 40 | B_copy = malloc(sizeof(double) * m); 41 | X = malloc(sizeof(double) * n); 42 | 43 | W = malloc(sizeof(double) * n); 44 | ZZ = malloc(sizeof(double) * m); 45 | index = malloc(sizeof(int) * n); 46 | 47 | mda = m; 48 | 49 | for (i = 0; i < m * n; i++) { 50 | A_copy[i] = NUM2DBL(rb_ary_entry(A, i)); 51 | } 52 | 53 | for (i = 0; i < m; i++) { 54 | B_copy[i] = NUM2DBL(rb_ary_entry(B, i)); 55 | } 56 | 57 | nnls_(A_copy, &mda, &m, &n, B_copy, X, &Rnorm, W, ZZ, index, &mode); 58 | 59 | /* 60 | Now we have solution in array X, 61 | let's copy it to ruby object 62 | */ 63 | ret_x = rb_ary_new2(n); 64 | for (i = 0; i < n; i++) { 65 | rb_ary_push(ret_x, DBL2NUM(X[i])); 66 | } 67 | 68 | ret = rb_ary_new2(3); 69 | rb_ary_push(ret, ret_x); 70 | rb_ary_push(ret, DBL2NUM(Rnorm)); 71 | rb_ary_push(ret, INT2FIX(mode)); 72 | 73 | free(A_copy); 74 | free(B_copy); 75 | free(W); 76 | free(ZZ); 77 | free(X); 78 | 79 | return ret; 80 | } 81 | -------------------------------------------------------------------------------- /ext/nnls/impl.c: -------------------------------------------------------------------------------- 1 | /* $Id: nnls.c,v 1.7 2000/11/07 16:29:30 tgkolda Exp $ */ 2 | /* $Source: /usr/local/cvsroot/appspack/apps/src/nnls.c,v $ */ 3 | 4 | /* Distributed with ASYNCHRONOUS PARALLEL PATTERN SEARCH (APPS) */ 5 | 6 | /* The routines in this file have been translated from Fortran to C by 7 | f2c. Additional modifications have been made to remove the 8 | dependencies on the f2c header file and library. The original 9 | Fortran 77 code accompanies the SIAM Publications printing of 10 | "Solving Least Squares Problems," by C. Lawson and R. Hanson and is 11 | freely available at www.netlib.org/lawson-hanson/all. */ 12 | 13 | /* nnls.F -- translated by f2c (version 19970805). 14 | You must link the resulting object file with the libraries: 15 | -lf2c -lm (in that order) 16 | */ 17 | 18 | /* The next line was removed after the f2c translation */ 19 | /* #include "f2c.h" */ 20 | 21 | /* The next lines were added after the f2c translation. Also swapped 22 | abs for nnls_abs and max for nnls_max to avoid confusion with some 23 | compilers. */ 24 | #include 25 | #include 26 | #define nnls_max(a,b) ((a) >= (b) ? (a) : (b)) 27 | #define nnls_abs(x) ((x) >= 0 ? (x) : -(x)) 28 | typedef int integer; 29 | typedef double doublereal; 30 | 31 | /* The following subroutine was added after the f2c translation */ 32 | double d_sign(double *a, double *b) 33 | { 34 | double x; 35 | x = (*a >= 0 ? *a : - *a); 36 | return( *b >= 0 ? x : -x); 37 | } 38 | 39 | /* Table of constant values */ 40 | 41 | static integer c__1 = 1; 42 | static integer c__0 = 0; 43 | static integer c__2 = 2; 44 | 45 | /* SUBROUTINE NNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE) */ 46 | 47 | /* Algorithm NNLS: NONNEGATIVE LEAST SQUARES */ 48 | 49 | /* The original version of this code was developed by */ 50 | /* Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory */ 51 | /* 1973 JUN 15, and published in the book */ 52 | /* "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. */ 53 | /* Revised FEB 1995 to accompany reprinting of the book by SIAM. */ 54 | 55 | /* GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B, COMPUTE AN */ 56 | /* N-VECTOR, X, THAT SOLVES THE LEAST SQUARES PROBLEM */ 57 | 58 | /* A * X = B SUBJECT TO X .GE. 0 */ 59 | /* ------------------------------------------------------------------ */ 60 | /* Subroutine Arguments */ 61 | 62 | /* A(),MDA,M,N MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE */ 63 | /* ARRAY, A(). ON ENTRY A() CONTAINS THE M BY N */ 64 | /* MATRIX, A. ON EXIT A() CONTAINS */ 65 | /* THE PRODUCT MATRIX, Q*A , WHERE Q IS AN */ 66 | /* M BY M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY */ 67 | /* THIS SUBROUTINE. */ 68 | /* B() ON ENTRY B() CONTAINS THE M-VECTOR, B. ON EXIT B() CON- */ 69 | /* TAINS Q*B. */ 70 | /* X() ON ENTRY X() NEED NOT BE INITIALIZED. ON EXIT X() WILL */ 71 | /* CONTAIN THE SOLUTION VECTOR. */ 72 | /* RNORM ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE */ 73 | /* RESIDUAL VECTOR. */ 74 | /* W() AN N-ARRAY OF WORKING SPACE. ON EXIT W() WILL CONTAIN */ 75 | /* THE DUAL SOLUTION VECTOR. W WILL SATISFY W(I) = 0. */ 76 | /* FOR ALL I IN SET P AND W(I) .LE. 0. FOR ALL I IN SET Z */ 77 | /* ZZ() AN M-ARRAY OF WORKING SPACE. */ 78 | /* INDEX() AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N. */ 79 | /* ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS */ 80 | /* P AND Z AS FOLLOWS.. */ 81 | 82 | /* INDEX(1) THRU INDEX(NSETP) = SET P. */ 83 | /* INDEX(IZ1) THRU INDEX(IZ2) = SET Z. */ 84 | /* IZ1 = NSETP + 1 = NPP1 */ 85 | /* IZ2 = N */ 86 | /* MODE THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING */ 87 | /* MEANINGS. */ 88 | /* 1 THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY. */ 89 | /* 2 THE DIMENSIONS OF THE PROBLEM ARE BAD. */ 90 | /* EITHER M .LE. 0 OR N .LE. 0. */ 91 | /* 3 ITERATION COUNT EXCEEDED. MORE THAN 3*N ITERATIONS. */ 92 | 93 | /* ------------------------------------------------------------------ */ 94 | /* Subroutine */ int nnls_(a, mda, m, n, b, x, rnorm, w, zz, index, mode) 95 | doublereal *a; 96 | integer *mda, *m, *n; 97 | doublereal *b, *x, *rnorm, *w, *zz; 98 | integer *index, *mode; 99 | { 100 | /* System generated locals */ 101 | integer a_dim1, a_offset, i__1, i__2; 102 | doublereal d__1, d__2; 103 | 104 | /* Builtin functions */ 105 | /* The following lines were commented out after the f2c translation */ 106 | /* double sqrt(); */ 107 | /* integer s_wsfe(), do_fio(), e_wsfe(); */ 108 | 109 | /* Local variables */ 110 | extern doublereal diff_(); 111 | static integer iter; 112 | static doublereal temp, wmax; 113 | static integer i__, j, l; 114 | static doublereal t, alpha, asave; 115 | static integer itmax, izmax, nsetp; 116 | extern /* Subroutine */ int g1_(); 117 | static doublereal dummy, unorm, ztest, cc; 118 | extern /* Subroutine */ int h12_(); 119 | static integer ii, jj, ip; 120 | static doublereal sm; 121 | static integer iz, jz; 122 | static doublereal up, ss; 123 | static integer rtnkey, iz1, iz2, npp1; 124 | 125 | /* Fortran I/O blocks */ 126 | /* The following line was commented out after the f2c translation */ 127 | /* static cilist io___22 = { 0, 6, 0, "(/a)", 0 }; */ 128 | 129 | 130 | /* ------------------------------------------------------------------ 131 | */ 132 | /* integer INDEX(N) */ 133 | /* double precision A(MDA,N), B(M), W(N), X(N), ZZ(M) */ 134 | /* ------------------------------------------------------------------ 135 | */ 136 | /* Parameter adjustments */ 137 | a_dim1 = *mda; 138 | a_offset = a_dim1 + 1; 139 | a -= a_offset; 140 | --b; 141 | --x; 142 | --w; 143 | --zz; 144 | --index; 145 | 146 | /* Function Body */ 147 | *mode = 1; 148 | if (*m <= 0 || *n <= 0) { 149 | *mode = 2; 150 | return 0; 151 | } 152 | iter = 0; 153 | itmax = *n * 3; 154 | 155 | /* INITIALIZE THE ARRAYS INDEX() AND X(). */ 156 | 157 | i__1 = *n; 158 | for (i__ = 1; i__ <= i__1; ++i__) { 159 | x[i__] = 0.; 160 | /* L20: */ 161 | index[i__] = i__; 162 | } 163 | 164 | iz2 = *n; 165 | iz1 = 1; 166 | nsetp = 0; 167 | npp1 = 1; 168 | /* ****** MAIN LOOP BEGINS HERE ****** */ 169 | L30: 170 | /* QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION. 171 | */ 172 | /* OR IF M COLS OF A HAVE BEEN TRIANGULARIZED. */ 173 | 174 | if (iz1 > iz2 || nsetp >= *m) { 175 | goto L350; 176 | } 177 | 178 | /* COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W(). 179 | */ 180 | 181 | i__1 = iz2; 182 | for (iz = iz1; iz <= i__1; ++iz) { 183 | j = index[iz]; 184 | sm = 0.; 185 | i__2 = *m; 186 | for (l = npp1; l <= i__2; ++l) { 187 | /* L40: */ 188 | sm += a[l + j * a_dim1] * b[l]; 189 | } 190 | w[j] = sm; 191 | /* L50: */ 192 | } 193 | /* FIND LARGEST POSITIVE W(J). */ 194 | L60: 195 | wmax = 0.; 196 | i__1 = iz2; 197 | for (iz = iz1; iz <= i__1; ++iz) { 198 | j = index[iz]; 199 | if (w[j] > wmax) { 200 | wmax = w[j]; 201 | izmax = iz; 202 | } 203 | /* L70: */ 204 | } 205 | 206 | /* IF WMAX .LE. 0. GO TO TERMINATION. */ 207 | /* THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS. 208 | */ 209 | 210 | if (wmax <= 0.) { 211 | goto L350; 212 | } 213 | iz = izmax; 214 | j = index[iz]; 215 | 216 | /* THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P. */ 217 | /* BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID */ 218 | /* NEAR LINEAR DEPENDENCE. */ 219 | 220 | asave = a[npp1 + j * a_dim1]; 221 | i__1 = npp1 + 1; 222 | h12_(&c__1, &npp1, &i__1, m, &a[j * a_dim1 + 1], &c__1, &up, &dummy, & 223 | c__1, &c__1, &c__0); 224 | unorm = 0.; 225 | if (nsetp != 0) { 226 | i__1 = nsetp; 227 | for (l = 1; l <= i__1; ++l) { 228 | /* L90: */ 229 | /* Computing 2nd power */ 230 | d__1 = a[l + j * a_dim1]; 231 | unorm += d__1 * d__1; 232 | } 233 | } 234 | unorm = sqrt(unorm); 235 | d__2 = unorm + (d__1 = a[npp1 + j * a_dim1], nnls_abs(d__1)) * .01; 236 | if (diff_(&d__2, &unorm) > 0.) { 237 | 238 | /* COL J IS SUFFICIENTLY INDEPENDENT. COPY B INTO ZZ, UPDATE Z 239 | Z */ 240 | /* AND SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ). */ 241 | 242 | i__1 = *m; 243 | for (l = 1; l <= i__1; ++l) { 244 | /* L120: */ 245 | zz[l] = b[l]; 246 | } 247 | i__1 = npp1 + 1; 248 | h12_(&c__2, &npp1, &i__1, m, &a[j * a_dim1 + 1], &c__1, &up, &zz[1], & 249 | c__1, &c__1, &c__1); 250 | ztest = zz[npp1] / a[npp1 + j * a_dim1]; 251 | 252 | /* SEE IF ZTEST IS POSITIVE */ 253 | 254 | if (ztest > 0.) { 255 | goto L140; 256 | } 257 | } 258 | 259 | /* REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P. */ 260 | /* RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL */ 261 | /* COEFFS AGAIN. */ 262 | 263 | a[npp1 + j * a_dim1] = asave; 264 | w[j] = 0.; 265 | goto L60; 266 | 267 | /* THE INDEX J=INDEX(IZ) HAS BEEN SELECTED TO BE MOVED FROM */ 268 | /* SET Z TO SET P. UPDATE B, UPDATE INDICES, APPLY HOUSEHOLDER */ 269 | /* TRANSFORMATIONS TO COLS IN NEW SET Z, ZERO SUBDIAGONAL ELTS IN */ 270 | /* COL J, SET W(J)=0. */ 271 | 272 | L140: 273 | i__1 = *m; 274 | for (l = 1; l <= i__1; ++l) { 275 | /* L150: */ 276 | b[l] = zz[l]; 277 | } 278 | 279 | index[iz] = index[iz1]; 280 | index[iz1] = j; 281 | ++iz1; 282 | nsetp = npp1; 283 | ++npp1; 284 | 285 | if (iz1 <= iz2) { 286 | i__1 = iz2; 287 | for (jz = iz1; jz <= i__1; ++jz) { 288 | jj = index[jz]; 289 | h12_(&c__2, &nsetp, &npp1, m, &a[j * a_dim1 + 1], &c__1, &up, &a[ 290 | jj * a_dim1 + 1], &c__1, mda, &c__1); 291 | /* L160: */ 292 | } 293 | } 294 | 295 | if (nsetp != *m) { 296 | i__1 = *m; 297 | for (l = npp1; l <= i__1; ++l) { 298 | /* L180: */ 299 | a[l + j * a_dim1] = 0.; 300 | } 301 | } 302 | 303 | w[j] = 0.; 304 | /* SOLVE THE TRIANGULAR SYSTEM. */ 305 | /* STORE THE SOLUTION TEMPORARILY IN ZZ(). 306 | */ 307 | rtnkey = 1; 308 | goto L400; 309 | L200: 310 | 311 | /* ****** SECONDARY LOOP BEGINS HERE ****** */ 312 | 313 | /* ITERATION COUNTER. */ 314 | 315 | L210: 316 | ++iter; 317 | if (iter > itmax) { 318 | *mode = 3; 319 | /* The following lines were replaced after the f2c translation */ 320 | /* s_wsfe(&io___22); */ 321 | /* do_fio(&c__1, " NNLS quitting on iteration count.", 34L); */ 322 | /* e_wsfe(); */ 323 | fprintf(stdout, "\n NNLS quitting on iteration count.\n"); 324 | fflush(stdout); 325 | goto L350; 326 | } 327 | 328 | /* SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE. */ 329 | /* IF NOT COMPUTE ALPHA. */ 330 | 331 | alpha = 2.; 332 | i__1 = nsetp; 333 | for (ip = 1; ip <= i__1; ++ip) { 334 | l = index[ip]; 335 | if (zz[ip] <= 0.) { 336 | t = -x[l] / (zz[ip] - x[l]); 337 | if (alpha > t) { 338 | alpha = t; 339 | jj = ip; 340 | } 341 | } 342 | /* L240: */ 343 | } 344 | 345 | /* IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL */ 346 | /* STILL = 2. IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP. */ 347 | 348 | if (alpha == 2.) { 349 | goto L330; 350 | } 351 | 352 | /* OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO */ 353 | /* INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ. */ 354 | 355 | i__1 = nsetp; 356 | for (ip = 1; ip <= i__1; ++ip) { 357 | l = index[ip]; 358 | x[l] += alpha * (zz[ip] - x[l]); 359 | /* L250: */ 360 | } 361 | 362 | /* MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I */ 363 | /* FROM SET P TO SET Z. */ 364 | 365 | i__ = index[jj]; 366 | L260: 367 | x[i__] = 0.; 368 | 369 | if (jj != nsetp) { 370 | ++jj; 371 | i__1 = nsetp; 372 | for (j = jj; j <= i__1; ++j) { 373 | ii = index[j]; 374 | index[j - 1] = ii; 375 | g1_(&a[j - 1 + ii * a_dim1], &a[j + ii * a_dim1], &cc, &ss, &a[j 376 | - 1 + ii * a_dim1]); 377 | a[j + ii * a_dim1] = 0.; 378 | i__2 = *n; 379 | for (l = 1; l <= i__2; ++l) { 380 | if (l != ii) { 381 | 382 | /* Apply procedure G2 (CC,SS,A(J-1,L),A(J, 383 | L)) */ 384 | 385 | temp = a[j - 1 + l * a_dim1]; 386 | a[j - 1 + l * a_dim1] = cc * temp + ss * a[j + l * a_dim1] 387 | ; 388 | a[j + l * a_dim1] = -ss * temp + cc * a[j + l * a_dim1]; 389 | } 390 | /* L270: */ 391 | } 392 | 393 | /* Apply procedure G2 (CC,SS,B(J-1),B(J)) */ 394 | 395 | temp = b[j - 1]; 396 | b[j - 1] = cc * temp + ss * b[j]; 397 | b[j] = -ss * temp + cc * b[j]; 398 | /* L280: */ 399 | } 400 | } 401 | 402 | npp1 = nsetp; 403 | --nsetp; 404 | --iz1; 405 | index[iz1] = i__; 406 | 407 | /* SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE. THEY SHOULD 408 | */ 409 | /* BE BECAUSE OF THE WAY ALPHA WAS DETERMINED. */ 410 | /* IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR. ANY */ 411 | /* THAT ARE NONPOSITIVE WILL BE SET TO ZERO */ 412 | /* AND MOVED FROM SET P TO SET Z. */ 413 | 414 | i__1 = nsetp; 415 | for (jj = 1; jj <= i__1; ++jj) { 416 | i__ = index[jj]; 417 | if (x[i__] <= 0.) { 418 | goto L260; 419 | } 420 | /* L300: */ 421 | } 422 | 423 | /* COPY B( ) INTO ZZ( ). THEN SOLVE AGAIN AND LOOP BACK. */ 424 | 425 | i__1 = *m; 426 | for (i__ = 1; i__ <= i__1; ++i__) { 427 | /* L310: */ 428 | zz[i__] = b[i__]; 429 | } 430 | rtnkey = 2; 431 | goto L400; 432 | L320: 433 | goto L210; 434 | /* ****** END OF SECONDARY LOOP ****** */ 435 | 436 | L330: 437 | i__1 = nsetp; 438 | for (ip = 1; ip <= i__1; ++ip) { 439 | i__ = index[ip]; 440 | /* L340: */ 441 | x[i__] = zz[ip]; 442 | } 443 | /* ALL NEW COEFFS ARE POSITIVE. LOOP BACK TO BEGINNING. */ 444 | goto L30; 445 | 446 | /* ****** END OF MAIN LOOP ****** */ 447 | 448 | /* COME TO HERE FOR TERMINATION. */ 449 | /* COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR. */ 450 | 451 | L350: 452 | sm = 0.; 453 | if (npp1 <= *m) { 454 | i__1 = *m; 455 | for (i__ = npp1; i__ <= i__1; ++i__) { 456 | /* L360: */ 457 | /* Computing 2nd power */ 458 | d__1 = b[i__]; 459 | sm += d__1 * d__1; 460 | } 461 | } else { 462 | i__1 = *n; 463 | for (j = 1; j <= i__1; ++j) { 464 | /* L380: */ 465 | w[j] = 0.; 466 | } 467 | } 468 | *rnorm = sqrt(sm); 469 | return 0; 470 | 471 | /* THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL SUBROUTINE */ 472 | /* TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ(). */ 473 | 474 | L400: 475 | i__1 = nsetp; 476 | for (l = 1; l <= i__1; ++l) { 477 | ip = nsetp + 1 - l; 478 | if (l != 1) { 479 | i__2 = ip; 480 | for (ii = 1; ii <= i__2; ++ii) { 481 | zz[ii] -= a[ii + jj * a_dim1] * zz[ip + 1]; 482 | /* L410: */ 483 | } 484 | } 485 | jj = index[ip]; 486 | zz[ip] /= a[ip + jj * a_dim1]; 487 | /* L430: */ 488 | } 489 | switch ((int)rtnkey) { 490 | case 1: goto L200; 491 | case 2: goto L320; 492 | } 493 | 494 | /* The next line was added after the f2c translation to keep 495 | compilers from complaining about a void return from a non-void 496 | function. */ 497 | return 0; 498 | 499 | } /* nnls_ */ 500 | 501 | /* Subroutine */ int g1_(a, b, cterm, sterm, sig) 502 | doublereal *a, *b, *cterm, *sterm, *sig; 503 | { 504 | /* System generated locals */ 505 | doublereal d__1; 506 | 507 | /* Builtin functions */ 508 | /* The following line was commented out after the f2c translation */ 509 | /* double sqrt(), d_sign(); */ 510 | 511 | /* Local variables */ 512 | static doublereal xr, yr; 513 | 514 | 515 | /* COMPUTE ORTHOGONAL ROTATION MATRIX.. */ 516 | 517 | /* The original version of this code was developed by */ 518 | /* Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory 519 | */ 520 | /* 1973 JUN 12, and published in the book */ 521 | /* "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. */ 522 | /* Revised FEB 1995 to accompany reprinting of the book by SIAM. */ 523 | 524 | /* COMPUTE.. MATRIX (C, S) SO THAT (C, S)(A) = (SQRT(A**2+B**2)) */ 525 | /* (-S,C) (-S,C)(B) ( 0 ) */ 526 | /* COMPUTE SIG = SQRT(A**2+B**2) */ 527 | /* SIG IS COMPUTED LAST TO ALLOW FOR THE POSSIBILITY THAT */ 528 | /* SIG MAY BE IN THE SAME LOCATION AS A OR B . */ 529 | /* ------------------------------------------------------------------ 530 | */ 531 | /* ------------------------------------------------------------------ 532 | */ 533 | if (nnls_abs(*a) > nnls_abs(*b)) { 534 | xr = *b / *a; 535 | /* Computing 2nd power */ 536 | d__1 = xr; 537 | yr = sqrt(d__1 * d__1 + 1.); 538 | d__1 = 1. / yr; 539 | *cterm = d_sign(&d__1, a); 540 | *sterm = *cterm * xr; 541 | *sig = nnls_abs(*a) * yr; 542 | return 0; 543 | } 544 | if (*b != 0.) { 545 | xr = *a / *b; 546 | /* Computing 2nd power */ 547 | d__1 = xr; 548 | yr = sqrt(d__1 * d__1 + 1.); 549 | d__1 = 1. / yr; 550 | *sterm = d_sign(&d__1, b); 551 | *cterm = *sterm * xr; 552 | *sig = nnls_abs(*b) * yr; 553 | return 0; 554 | } 555 | *sig = 0.; 556 | *cterm = 0.; 557 | *sterm = 1.; 558 | return 0; 559 | } /* g1_ */ 560 | 561 | /* SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) */ 562 | 563 | /* CONSTRUCTION AND/OR APPLICATION OF A SINGLE */ 564 | /* HOUSEHOLDER TRANSFORMATION.. Q = I + U*(U**T)/B */ 565 | 566 | /* The original version of this code was developed by */ 567 | /* Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory */ 568 | /* 1973 JUN 12, and published in the book */ 569 | /* "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. */ 570 | /* Revised FEB 1995 to accompany reprinting of the book by SIAM. */ 571 | /* ------------------------------------------------------------------ */ 572 | /* Subroutine Arguments */ 573 | 574 | /* MODE = 1 OR 2 Selects Algorithm H1 to construct and apply a */ 575 | /* Householder transformation, or Algorithm H2 to apply a */ 576 | /* previously constructed transformation. */ 577 | /* LPIVOT IS THE INDEX OF THE PIVOT ELEMENT. */ 578 | /* L1,M IF L1 .LE. M THE TRANSFORMATION WILL BE CONSTRUCTED TO */ 579 | /* ZERO ELEMENTS INDEXED FROM L1 THROUGH M. IF L1 GT. M */ 580 | /* THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. */ 581 | /* U(),IUE,UP On entry with MODE = 1, U() contains the pivot */ 582 | /* vector. IUE is the storage increment between elements. */ 583 | /* On exit when MODE = 1, U() and UP contain quantities */ 584 | /* defining the vector U of the Householder transformation. */ 585 | /* on entry with MODE = 2, U() and UP should contain */ 586 | /* quantities previously computed with MODE = 1. These will */ 587 | /* not be modified during the entry with MODE = 2. */ 588 | /* C() ON ENTRY with MODE = 1 or 2, C() CONTAINS A MATRIX WHICH */ 589 | /* WILL BE REGARDED AS A SET OF VECTORS TO WHICH THE */ 590 | /* HOUSEHOLDER TRANSFORMATION IS TO BE APPLIED. */ 591 | /* ON EXIT C() CONTAINS THE SET OF TRANSFORMED VECTORS. */ 592 | /* ICE STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C(). */ 593 | /* ICV STORAGE INCREMENT BETWEEN VECTORS IN C(). */ 594 | /* NCV NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0 */ 595 | /* NO OPERATIONS WILL BE DONE ON C(). */ 596 | /* ------------------------------------------------------------------ */ 597 | /* Subroutine */ int h12_(mode, lpivot, l1, m, u, iue, up, c__, ice, icv, ncv) 598 | integer *mode, *lpivot, *l1, *m; 599 | doublereal *u; 600 | integer *iue; 601 | doublereal *up, *c__; 602 | integer *ice, *icv, *ncv; 603 | { 604 | /* System generated locals */ 605 | integer u_dim1, u_offset, i__1, i__2; 606 | doublereal d__1, d__2; 607 | 608 | /* Builtin functions */ 609 | /* The following line was commented out after the f2c translation */ 610 | /* double sqrt(); */ 611 | 612 | /* Local variables */ 613 | static integer incr; 614 | static doublereal b; 615 | static integer i__, j; 616 | static doublereal clinv; 617 | static integer i2, i3, i4; 618 | static doublereal cl, sm; 619 | 620 | /* ------------------------------------------------------------------ 621 | */ 622 | /* double precision U(IUE,M) */ 623 | /* ------------------------------------------------------------------ 624 | */ 625 | /* Parameter adjustments */ 626 | u_dim1 = *iue; 627 | u_offset = u_dim1 + 1; 628 | u -= u_offset; 629 | --c__; 630 | 631 | /* Function Body */ 632 | if (0 >= *lpivot || *lpivot >= *l1 || *l1 > *m) { 633 | return 0; 634 | } 635 | cl = (d__1 = u[*lpivot * u_dim1 + 1], nnls_abs(d__1)); 636 | if (*mode == 2) { 637 | goto L60; 638 | } 639 | /* ****** CONSTRUCT THE TRANSFORMATION. ****** 640 | */ 641 | i__1 = *m; 642 | for (j = *l1; j <= i__1; ++j) { 643 | /* L10: */ 644 | /* Computing MAX */ 645 | d__2 = (d__1 = u[j * u_dim1 + 1], nnls_abs(d__1)); 646 | cl = nnls_max(d__2,cl); 647 | } 648 | if (cl <= 0.) { 649 | goto L130; 650 | } else { 651 | goto L20; 652 | } 653 | L20: 654 | clinv = 1. / cl; 655 | /* Computing 2nd power */ 656 | d__1 = u[*lpivot * u_dim1 + 1] * clinv; 657 | sm = d__1 * d__1; 658 | i__1 = *m; 659 | for (j = *l1; j <= i__1; ++j) { 660 | /* L30: */ 661 | /* Computing 2nd power */ 662 | d__1 = u[j * u_dim1 + 1] * clinv; 663 | sm += d__1 * d__1; 664 | } 665 | cl *= sqrt(sm); 666 | if (u[*lpivot * u_dim1 + 1] <= 0.) { 667 | goto L50; 668 | } else { 669 | goto L40; 670 | } 671 | L40: 672 | cl = -cl; 673 | L50: 674 | *up = u[*lpivot * u_dim1 + 1] - cl; 675 | u[*lpivot * u_dim1 + 1] = cl; 676 | goto L70; 677 | /* ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** 678 | */ 679 | 680 | L60: 681 | if (cl <= 0.) { 682 | goto L130; 683 | } else { 684 | goto L70; 685 | } 686 | L70: 687 | if (*ncv <= 0) { 688 | return 0; 689 | } 690 | b = *up * u[*lpivot * u_dim1 + 1]; 691 | /* B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. 692 | */ 693 | 694 | if (b >= 0.) { 695 | goto L130; 696 | } else { 697 | goto L80; 698 | } 699 | L80: 700 | b = 1. / b; 701 | i2 = 1 - *icv + *ice * (*lpivot - 1); 702 | incr = *ice * (*l1 - *lpivot); 703 | i__1 = *ncv; 704 | for (j = 1; j <= i__1; ++j) { 705 | i2 += *icv; 706 | i3 = i2 + incr; 707 | i4 = i3; 708 | sm = c__[i2] * *up; 709 | i__2 = *m; 710 | for (i__ = *l1; i__ <= i__2; ++i__) { 711 | sm += c__[i3] * u[i__ * u_dim1 + 1]; 712 | /* L90: */ 713 | i3 += *ice; 714 | } 715 | if (sm != 0.) { 716 | goto L100; 717 | } else { 718 | goto L120; 719 | } 720 | L100: 721 | sm *= b; 722 | c__[i2] += sm * *up; 723 | i__2 = *m; 724 | for (i__ = *l1; i__ <= i__2; ++i__) { 725 | c__[i4] += sm * u[i__ * u_dim1 + 1]; 726 | /* L110: */ 727 | i4 += *ice; 728 | } 729 | L120: 730 | ; 731 | } 732 | L130: 733 | return 0; 734 | } /* h12_ */ 735 | 736 | doublereal diff_(x, y) 737 | doublereal *x, *y; 738 | { 739 | /* System generated locals */ 740 | doublereal ret_val; 741 | 742 | 743 | /* Function used in tests that depend on machine precision. */ 744 | 745 | /* The original version of this code was developed by */ 746 | /* Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory 747 | */ 748 | /* 1973 JUN 7, and published in the book */ 749 | /* "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. */ 750 | /* Revised FEB 1995 to accompany reprinting of the book by SIAM. */ 751 | 752 | ret_val = *x - *y; 753 | return ret_val; 754 | } /* diff_ */ 755 | 756 | 757 | /* The following subroutine was added after the f2c translation */ 758 | int nnls_c(double* a, const int* mda, const int* m, const int* n, double* b, 759 | double* x, double* rnorm, double* w, double* zz, int* index, 760 | int* mode) 761 | { 762 | return (nnls_(a, mda, m, n, b, x, rnorm, w, zz, index, mode)); 763 | } 764 | 765 | --------------------------------------------------------------------------------