lsei/0000755000176200001440000000000013730616063011213 5ustar liggesuserslsei/NAMESPACE0000644000176200001440000000025213724342340012426 0ustar liggesusersuseDynLib(lsei, .registration = TRUE) export(hfti) export(indx) export(ldp) export(lsei) export(lsi) export(matMaxs) export(nnls) export(pnnls) export(pnnqp) export(qp) lsei/man/0000755000176200001440000000000013725043200011755 5ustar liggesuserslsei/man/indx.Rd0000644000176200001440000000164713724335274013234 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{indx} \alias{indx} \title{Index-finding in a Sorted Vector} \usage{ indx(x, v) } \arguments{ \item{x}{vector of numeric values, the indices of which are to be found.} \item{v}{vector of numeric values sorted in ascending order.} } \value{ Returns a vector of integers, that are indices of x-values in vector v. } \description{ For each of given values, \code{indx} finds the index of the value in a vector sorted in ascending order that the given value is barely greater than or equal to. } \details{ For each x[i], the function returns integer j such that \deqn{v_j \le x_i < v_{j+1}}{v[j] <= x[i] < v[j+1]} where \eqn{v_0 = - \infty \mathrm{ and } v_{n+1} = \infty}{v[0] = -Inf and v[n+1] = Inf}. } \examples{ indx(0:6,c(1:5,5)) indx(sort(rnorm(5)),-2:2) } \author{ Yong Wang } \keyword{algebra} \keyword{array} lsei/man/hfti.Rd0000644000176200001440000000245413725253275013222 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lsei.R \name{hfti} \alias{hfti} \title{Least Squares Solution using Householder Transformation} \usage{ hfti(a, b, tol = 1e-07) } \arguments{ \item{a}{Design matrix.} \item{b}{Response vector or matrix.} \item{tol}{Tolerance for determining the pseudorank.} } \value{ \item{b}{first \code{krank} elements contains the solution} \item{krank}{psuedo-rank} \item{rnorm}{Euclidean norm of the residual vector.} } \description{ Solves the least squares problem using Householder forward triangulation with column interchanges. It is an R interface to the HFTI function that is described in Lawson and Hanson (1974, 1995). Its Fortran implementation is public domain and is available at \url{http://www.netlib.org/lawson-hanson/}. } \details{ Given matrix \code{a} and vector \code{b}, \code{hfti} solves the least squares problem: \deqn{\mathrm{minimize\ \ } || a x - b ||.}{minimize || a x - b ||.} } \examples{ a = matrix(rnorm(10*4), nrow=10) b = a \%*\% c(0,1,-1,1) + rnorm(10) hfti(a, b) } \references{ Lawson and Hanson (1974, 1995). Solving least squares problems. Englewood Cliffs, N.J., Prentice-Hall. } \seealso{ \code{\link{lsei}}, \code{\link{nnls}}. } \author{ Yong Wang } \keyword{algebra} \keyword{array} lsei/man/lsei.Rd0000644000176200001440000001142713725253275013224 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lsei.R \name{lsei} \alias{lsei} \alias{lsi} \alias{ldp} \alias{qp} \title{Least Squares and Quadratic Programming under Equality and Inequality Constraints} \usage{ lsei(a, b, c=NULL, d=NULL, e=NULL, f=NULL, lower=-Inf, upper=Inf) lsi(a, b, e=NULL, f=NULL, lower=-Inf, upper=Inf) ldp(e, f) qp(q, p, c=NULL, d=NULL, e=NULL, f=NULL, lower=-Inf, upper=Inf, tol=1e-15) } \arguments{ \item{a}{Design matrix.} \item{b}{Response vector.} \item{c}{Matrix of numeric coefficients on the left-hand sides of equality constraints. If it is NULL, \code{c} and \code{d} are ignored.} \item{d}{Vector of numeric values on the right-hand sides of equality constraints.} \item{e}{Matrix of numeric coefficients on the left-hand sides of inequality constraints. If it is NULL, \code{e} and \code{f} are ignored.} \item{f}{Vector of numeric values on the right-hand sides of inequality constraints.} \item{lower, upper}{Bounds on the solutions, as a way to specify such simple inequality constraints.} \item{q}{Matrix of numeric values for the quadratic term of a quadratic programming problem.} \item{p}{Vector of numeric values for the linear term of a quadratic programming problem.} \item{tol}{Tolerance, for calculating pseudo-rank in \code{qp}.} } \value{ A vector of the solution values } \description{ These functions can be used for solving least squares or quadratic programming problems under general equality and/or inequality constraints. } \details{ The \code{lsei} function solves a least squares problem under both equality and inequality constraints. It is an implementation of the LSEI algorithm described in Lawson and Hanson (1974, 1995). The \code{lsi} function solves a least squares problem under inequality constraints. It is an implementation of the LSI algorithm described in Lawson and Hanson (1974, 1995). The \code{ldp} function solves a least distance programming problem under inequality constraints. It is an R wrapper of the LDP function which is in Fortran, as described in Lawson and Hanson (1974, 1995). The \code{qp} function solves a quadratic programming problem, by transforming the problem into a least squares one under the same equality and inequality constraints, which is then solved by function \code{lsei}. The NNLS and LDP Fortran implementations used internally is downloaded from \url{http://www.netlib.org/lawson-hanson/}. Given matrices \code{a}, \code{c} and \code{e}, and vectors \code{b}, \code{d} and \code{f}, function \code{lsei} solves the least squares problem under both equality and inequality constraints: \deqn{\mathrm{minimize\ \ } || a x - b ||,}{minimize || a x - b ||,} \deqn{\mathrm{subject\ to\ \ } c x = d, e x \ge f.}{subject to c x = d, e x >= f.} Function \code{lsi} solves the least squares problem under inequality constraints: \deqn{\mathrm{minimize\ \ } || a x - b ||,}{minimize || a x - b ||,} \deqn{\mathrm{\ \ \ subject\ to\ \ } e x \ge f.}{subject to e x >= f.} Function \code{ldp} solves the least distance programming problem under inequality constraints: \deqn{\mathrm{minimize\ \ } || x ||,}{minimize || x ||,} \deqn{\mathrm{\ \ \ subject\ to\ \ } e x \ge f.}{subject to e x >= f.} Function \code{qp} solves the quadratic programming problem: \deqn{\mathrm{minimize\ \ } \frac12 x^T q x + p^T x,}{minimize 0.5 x^T q x + p^T x,} \deqn{\mathrm{subject\ to\ \ } c x = d, e x \ge f.}{subject to c x = d, e x >= f.} } \examples{ beta = c(rnorm(2), 1) beta[beta<0] = 0 beta = beta / sum(beta) a = matrix(rnorm(18), ncol=3) b = a \%*\% beta + rnorm(3,sd=.1) c = t(rep(1, 3)) d = 1 e = diag(1,3) f = rep(0,3) lsei(a, b) # under no constraint lsei(a, b, c, d) # under eq. constraints lsei(a, b, e=e, f=f) # under ineq. constraints lsei(a, b, c, d, e, f) # under eq. and ineq. constraints lsei(a, b, rep(1,3), 1, lower=0) # same solution q = crossprod(a) p = -drop(crossprod(b, a)) qp(q, p, rep(1,3), 1, lower=0) # same solution ## Example from Lawson and Hanson (1974), p.140 a = cbind(c(.4302,.6246), c(.3516,.3384)) b = c(.6593, .9666) c = c(.4087, .1593) d = .1376 lsei(a, b, c, d) # Solution: -1.177499 3.884770 ## Example from Lawson and Hanson (1974), p.170 a = cbind(c(.25,.5,.5,.8),rep(1,4)) b = c(.5,.6,.7,1.2) e = cbind(c(1,0,-1),c(0,1,-1)) f = c(0,0,-1) lsi(a, b, e, f) # Solution: 0.6213152 0.3786848 ## Example from Lawson and Hanson (1974), p.171: e = cbind(c(-.207,-.392,.599), c(2.558, -1.351, -1.206)) f = c(-1.3,-.084,.384) ldp(e, f) # Solution: 0.1268538 -0.2554018 } \references{ Lawson and Hanson (1974, 1995). Solving least squares problems. Englewood Cliffs, N.J., Prentice-Hall. } \seealso{ \code{\link{nnls}},\code{\link{hfti}}. } \author{ Yong Wang } \keyword{algebra} \keyword{array} lsei/man/matMaxs.Rd0000644000176200001440000000146413724335274013701 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/utils.R \name{matMaxs} \alias{matMaxs} \title{Row or Column Maximum Values of a Matrix} \usage{ matMaxs(x, dim = 1) } \arguments{ \item{x}{numeric matrix.} \item{dim}{\code{=1}, for row maximum values; \code{=2}, for column maximum values.} } \value{ Returns a numeric vector with row or column maximum values. The function is very much the same as using \code{apply(x, 1, max)} or \code{apply(x, 2, max)}, but faster. } \description{ Finds either row or column maximum values of a matrix. } \details{ Matrix \code{x} may contain \code{Inf} or \code{-Inf}, but not \code{NA} or \code{NaN}. } \examples{ x = cbind(c(1:4,Inf), 5:1) matMaxs(x) matMaxs(x, 2) } \author{ Yong Wang } \keyword{algebra} \keyword{array} lsei/man/nnls.Rd0000644000176200001440000001164213725253275013241 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lsei.R \name{nnls} \alias{nnls} \alias{pnnls} \alias{pnnqp} \title{Least Squares and Quadratic Programming under Nonnegativity Constraints} \usage{ nnls(a, b) pnnls(a, b, k=0, sum=NULL) pnnqp(q, p, k=0, sum=NULL, tol=1e-20) } \arguments{ \item{a}{Design matrix.} \item{b}{Response vector.} \item{k}{Integer, meaning that the first \code{k} coefficients are not NN-restricted.} \item{sum}{= NULL, if NN-restricted coefficients are not further restricted to have a fixed sum; = a positive value, if NN-restricted coefficients are further restricted to have a fixed positive sum.} \item{q}{Positive semidefinite matrix of numeric values for the quadratic term of a quadratic programming problem.} \item{p}{Vector of numeric values for the linear term of a quadratic programming problem.} \item{tol}{Tolerance used for calculating pseudo-rank of \code{q}.} } \value{ \item{x}{Solution} \item{r}{The upper-triangular matrix \code{Q*a}, pivoted by variables in the order of \code{index}, when \code{sum=NULL}. If \code{sum > 0}, \code{r} is for the transformed \code{a}.} \item{b}{The vector \code{Q*b}, pivoted by variables in the order of \code{index}, when \code{sum=NULL}. If \code{sum > 0}, \code{b} is for the transformed \code{b}.} \item{index}{Indices of the columns of \code{r}; those unrestricted and in the positive set are first given, and then those in the zero set.} \item{rnorm}{Euclidean norm of the residual vector.} \item{mode}{= 1, successful computation; = 2, bad dimensions of the problem; = 3, iteration count exceeded (more than 3 times the number of variables iterations).} \item{k}{Number of the first few coefficients that are truly not NN-restricted.} } \description{ These functions are particularly useful for solving least squares or quadratic programming problems when some or all of the solution values are subject to nonnegativity constraint. One may further restrict the NN-restricted coefficients to have a fixed positive sum. } \details{ Function \code{nnls} solves the least squares problem under nonnegativity (NN) constraints. It is an R interface to the NNLS function that is described in Lawson and Hanson (1974, 1995). Its Fortran implementation is public domain and available at \url{http://www.netlib.org/lawson-hanson/} (with slight modifications by Yong Wang for compatibility with the lastest Fortran compiler.) Given matrix \code{a} and vector \code{b}, \code{nnls} solves the nonnegativity least squares problem: \deqn{\mathrm{minimize \ \ } || a x - b ||,}{minimize || a x - b ||,} \deqn{\mathrm{\ \ \ subject\ to\ \ } x \ge 0.}{ subject to x >= 0.} Function \code{pnnls} also solves the above nonnegativity least squares problem when \code{k=0}, but it may also leave the first \code{k} coefficients unrestricted. The output value of \code{k} can be smaller than the input one, if \code{a} has linearly dependent columns. If \code{sum} is a positive value, \code{pnnls} solves the problem by further restricting that the NN-restricted coefficients must sum to the given value. Function \code{pnnqp} solves the quadratic programming problem \deqn{\mathrm{minimize\ \ } \frac12 x^T q x + p^T x,}{minimize 0.5 x^T q x + p^T x,} when only some or all coefficients are restricted by nonnegativity. The quadratic programming problem is solved by transforming the problem into a least squares one under the same constraints, which is then solved by function \code{pnnls}. Arguments \code{k} and \code{sum} have the same meanings as for \code{pnnls}. Functions \code{nnls}, \code{pnnls} and \code{pnnqp} are able to return any zero-valued solution as 0 exactly. This differs from functions \code{lsei} and \code{qp}, which may produce very small values for exactly 0s, thanks to numerical errors. } \examples{ a = matrix(rnorm(40), nrow=10) b = drop(a \%*\% c(0,1,-1,1)) + rnorm(10) nnls(a, b)$x # constraint x >= 0 pnnls(a, b, k=0)$x # same as nnls(a, b) pnnls(a, b, k=2)$x # first two coeffs are not NN-constrained pnnls(a, b, k=2, sum=1)$x # NN-constrained coeffs must sum to 1 pnnls(a, b, k=2, sum=2)$x # NN-constrained coeffs must sum to 2 q = crossprod(a) p = -drop(crossprod(b, a)) pnnqp(q, p, k=2, sum=2)$x # same solution pnnls(a, b, sum=1)$x # zeros found exactly pnnqp(q, p, sum=1)$x # zeros found exactly lsei(a, b, rep(1,4), 1, lower=0) # zeros not so exact } \references{ Lawson and Hanson (1974, 1995). Solving Least Squares Problems. Englewood Cliffs, N.J., Prentice-Hall. Dax (1990). The smallest point of a polytope. Journal of Optimization Theory and Applications, 64, pp. 429-432. Wang (2010). Fisher scoring: An interpolation family and its Monte Carlo implementations. Computational Statistics and Data Analysis, 54, pp. 1744-1755. } \seealso{ \code{\link{lsei}}, \code{\link{hfti}}. } \author{ Yong Wang } \keyword{algebra} \keyword{array} lsei/DESCRIPTION0000644000176200001440000000225113730616063012721 0ustar liggesusersPackage: lsei Title: Solving Least Squares or Quadratic Programming Problems under Equality/Inequality Constraints Version: 1.3-0 Date: 2020-09-07 Authors@R: c( person("Yong", "Wang", email = "yongwang@auckland.ac.nz", role = c("aut","cre")), person("Charles L.", "Lawson", role = "aut"), person("Richard J.", "Hanson", role = "aut")) Description: It contains functions that solve least squares linear regression problems under linear equality/inequality constraints. Functions for solving quadratic programming problems are also available, which transform such problems into least squares ones first. It is developed based on the 'Fortran' program of Lawson and Hanson (1974, 1995), which is public domain and available at . Encoding: UTF-8 License: GPL (>= 2) URL: https://www.stat.auckland.ac.nz/~yongwang/ RoxygenNote: 7.1.1 NeedsCompilation: yes Packaged: 2020-09-06 21:47:31 UTC; yong Author: Yong Wang [aut, cre], Charles L. Lawson [aut], Richard J. Hanson [aut] Maintainer: Yong Wang Repository: CRAN Date/Publication: 2020-09-17 08:20:03 UTC lsei/src/0000755000176200001440000000000013725254363012007 5ustar liggesuserslsei/src/init.c0000644000176200001440000000321513173241154013106 0ustar liggesusers// RegisteringDynamic Symbols #include #include #include void R_init_lsei(DllInfo* info) { R_registerRoutines(info, NULL, NULL, NULL, NULL); R_useDynamicSymbols(info, TRUE); } // #include // #include // for NULL // #include // // /* FIXME: // Check these declarations against the C/Fortran source code. // */ // // /* .C calls */ // extern void indx(void *, void *, void *, void *, void *); // extern void matMaxs(void *, void *, void *, void *, void *); // // /* .Fortran calls */ // extern void F77_NAME(hfti)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); // extern void F77_NAME(nnls)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); // extern void F77_NAME(pnnls)(void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *, void *); // extern void F77_NAME(svdrs)(void *, void *, void *, void *, void *, void *, void *, void *, void *); // // static const R_CMethodDef CEntries[] = { // {"indx", (DL_FUNC) &indx, 5}, // {"matMaxs", (DL_FUNC) &matMaxs, 5}, // {NULL, NULL, 0} // }; // // static const R_FortranMethodDef FortranEntries[] = { // {"hfti", (DL_FUNC) &F77_NAME(hfti), 13}, // {"nnls", (DL_FUNC) &F77_NAME(nnls), 11}, // {"pnnls", (DL_FUNC) &F77_NAME(pnnls), 12}, // {"svdrs", (DL_FUNC) &F77_NAME(svdrs), 9}, // {NULL, NULL, 0} // }; // // void R_init_lsei(DllInfo *dll) // { // R_registerRoutines(dll, CEntries, NULL, FortranEntries, NULL); // R_useDynamicSymbols(dll, FALSE); // } lsei/src/utils.c0000644000176200001440000000251213724333652013311 0ustar liggesusers#include // #include // Find the index of each x[i] in a vector v sorted in ascending order, // i.e., for i = 1, ..., m, returns // // min {0 <= j <= n: x[i] <= v[j]} // // where v[0] = -Inf. void indx(double *x, int *m, double *v, int *n, int *ind) { int left, right, mid; int i; for(i = 0; i < *m; i++) { if(x[i] < v[0]) { ind[i] = 0; continue; } if(x[i] >= v[*n-1]) { ind[i] = *n; continue; } left = 0; right = *n - 1; // always x[i] < x[right] while(1) { if(left >= right - 1) { ind[i] = left + 1; break; } mid = rint((left + right) * 0.5); if(x[i] >= v[mid]) { // to find the rightmost tied value left = mid; } else { right = mid; } } } } // Returns either row or column maxima void matMaxs(double *x, int *n, int *m, double *v, int *dim) { int i, j; if(*dim == 1) { // rows for(i = 0; i < *n; i++) { v[i] = x[i]; if(*m > 0) { for(j = 1; j < *m; j++) { if(x[j*(*n)+i] > v[i]) { v[i] = x[j*(*n)+i]; } } } } } else { // columns for(j = 0; j < *m; j++) { v[j] = x[j*(*n)]; if(*n > 0) { for(i = 1; i < *n; i++) { if(x[j*(*n)+i] > v[j]) { v[j] = x[j*(*n)+i]; } } } } } } lsei/src/lsei.f0000644000176200001440000023122713725254300013110 0ustar liggesusersC ============================================================== C The following source code is obtained from C http://www.netlib.org/lawson-hanson/all C with units 15.-23. deleted (and nothing else changed). C (Note by Yong Wang, Department of Statistics, University of Auckland, C New Zealand. Email: yongwang@stat.auckland.ac.nz) C ============================================================== C This package of Fortran 77 and Fortran 90 code accompanies the C SIAM Publications printing of "Solving Least Squares C Problems," by C. Lawson and R. Hanson. The routines in the C package are filed as shown in the list below. The units C listed 1.-14. may be compiled and placed in a library. Routine C G2 is no longer used but is included for completeness. The C main program units 15.-18., 20.-21. require this library for C all external references. The item 19. is a data file read C by program unit PROG4.FOR. The main program 23., PROG7.F90, C requires the subprogram 22. or BVLS.F90. C 1. BNDACC.FOR C 2. BNDSOL.FOR C 3. DIFF.FOR C 4. G1.FOR C 5. G2.FOR C 6. GEN.FOR C 7. H12.FOR C 8. HFTI.FOR C 9. LDP.FOR C 10. MFEOUT.FOR C 11. NNLS.FOR C 12. QRBD.FOR C 13. SVA.FOR C 14. SVDRS.FOR C 15. PROG1.FOR C 16. PROG2.FOR C 17. PROG3.FOR C 18. PROG4.FOR C 19. DATA4.DAT C 20. PROG5.FOR C 21. PROG6.FOR C 22. BVLS.F90 C 23. PROG7.F90 SUBROUTINE BNDACC (G,MDG,NB,IP,IR,MT,JT) c C SEQUENTIAL ALGORITHM FOR BANDED LEAST SQUARES PROBLEM.. C ACCUMULATION PHASE. FOR SOLUTION PHASE USE BNDSOL. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C C THE CALLING PROGRAM MUST SET IR=1 AND IP=1 BEFORE THE FIRST CALL C TO BNDACC FOR A NEW CASE. C C THE SECOND SUBSCRIPT OF G( ) MUST BE DIMENSIONED AT LEAST C NB+1 IN THE CALLING PROGRAM. c ------------------------------------------------------------------ integer I, J, IE, IG, IG1, IG2, IP, IR, JG, JT, K, KH, L, LP1 integer MDG, MH, MT, MU, NB, NBP1 c double precision G(MDG,NB+1) double precision G(MDG,*) double precision RHO, ZERO parameter(ZERO = 0.0d0) c ------------------------------------------------------------------ C C ALG. STEPS 1-4 ARE PERFORMED EXTERNAL TO THIS SUBROUTINE. C NBP1=NB+1 IF (MT.LE.0) RETURN C ALG. STEP 5 IF (JT.EQ.IP) GO TO 70 C ALG. STEPS 6-7 IF (JT.LE.IR) GO TO 30 C ALG. STEPS 8-9 DO 15 I=1,MT IG1=JT+MT-I IG2=IR+MT-I DO 10 J=1,NBP1 G(IG1,J)=G(IG2,J) 10 END DO 15 END DO C ALG. STEP 10 IE=JT-IR DO 25 I=1,IE IG=IR+I-1 DO 20 J=1,NBP1 G(IG,J)=ZERO 20 END DO 25 END DO C ALG. STEP 11 IR=JT C ALG. STEP 12 30 MU=min(NB-1,IR-IP-1) IF (MU.EQ.0) GO TO 60 C ALG. STEP 13 DO 50 L=1,MU C ALG. STEP 14 K=min(L,JT-IP) C ALG. STEP 15 LP1=L+1 IG=IP+L DO 40 I=LP1,NB JG=I-K G(IG,JG)=G(IG,I) 40 END DO C ALG. STEP 16 DO 45 I=1,K JG=NBP1-I G(IG,JG)=ZERO 45 END DO 50 END DO C ALG. STEP 17 60 IP=JT C ALG. STEPS 18-19 70 MH=IR+MT-IP KH=min(NBP1,MH) C ALG. STEP 20 DO 80 I=1,KH CALL H12 (1,I,max(I+1,IR-IP+1),MH,G(IP,I),1,RHO, * G(IP,I+1),1,MDG,NBP1-I) 80 continue C ALG. STEP 21 IR=IP+KH C ALG. STEP 22 IF (KH.LT.NBP1) GO TO 100 C ALG. STEP 23 DO 90 I=1,NB G(IR-1,I)=ZERO 90 END DO C ALG. STEP 24 100 CONTINUE C ALG. STEP 25 RETURN END SUBROUTINE BNDSOL (MODE,G,MDG,NB,IP,IR,X,N,RNORM) c C SEQUENTIAL SOLUTION OF A BANDED LEAST SQUARES PROBLEM.. C SOLUTION PHASE. FOR THE ACCUMULATION PHASE USE BNDACC. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C C MODE = 1 SOLVE R*X=Y WHERE R AND Y ARE IN THE G( ) ARRAY C AND X WILL BE STORED IN THE X( ) ARRAY. C 2 SOLVE (R**T)*X=Y WHERE R IS IN G( ), C Y IS INITIALLY IN X( ), AND X REPLACES Y IN X( ), C 3 SOLVE R*X=Y WHERE R IS IN G( ). C Y IS INITIALLY IN X( ), AND X REPLACES Y IN X( ). C C THE SECOND SUBSCRIPT OF G( ) MUST BE DIMENSIONED AT LEAST C NB+1 IN THE CALLING PROGRAM. integer I, I1, I2, IE, II, IP, IR, IX, J, JG, L integer MDG, MODE, N, NB, NP1, IRM1 double precision G(MDG,*), RNORM, RSQ, S, X(N), ZERO parameter(ZERO = 0.0d0) C RNORM=ZERO c GO TO (10,90,50), MODE IF (MODE .EQ. 2) GOTO 90 IF (MODE .EQ. 3) GOTO 50 C ********************* MODE = 1 C ALG. STEP 26 DO 20 J=1,N X(J)=G(J,NB+1) 20 END DO RSQ=ZERO NP1=N+1 IRM1=IR-1 IF (NP1.GT.IRM1) GO TO 40 DO 30 J=NP1,IRM1 RSQ=RSQ+G(J,NB+1)**2 30 END DO RNORM=SQRT(RSQ) 40 CONTINUE C ********************* MODE = 3 C ALG. STEP 27 50 DO 80 II=1,N I=N+1-II C ALG. STEP 28 S=ZERO L=max(0,I-IP) C ALG. STEP 29 IF (I.EQ.N) GO TO 70 C ALG. STEP 30 IE=min(N+1-I,NB) DO 60 J=2,IE JG=J+L IX=I-1+J S=S+G(I,JG)*X(IX) 60 END DO C ALG. STEP 31 70 continue IF (G(I,L+1) .eq. ZERO) go to 130 X(I)=(X(I)-S)/G(I,L+1) 80 END DO C ALG. STEP 32 RETURN C ********************* MODE = 2 90 DO 120 J=1,N S=ZERO IF (J.EQ.1) GO TO 110 I1=max(1,J-NB+1) I2=J-1 DO 100 I=I1,I2 L=J-I+1+max(0,I-IP) S=S+X(I)*G(I,L) 100 END DO 110 L=max(0,J-IP) IF (G(J,L+1) .eq. ZERO) go to 130 X(J)=(X(J)-S)/G(J,L+1) 120 END DO RETURN C cc 130 write (*,'(/a/a,4i6)')' ZERO DIAGONAL TERM IN BNDSOL.', cc * ' MODE,I,J,L = ',MODE,I,J,L 130 Continue cc STOP RETURN END double precision FUNCTION DIFF(X,Y) c c Function used in tests that depend on machine precision. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 7, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C double precision X, Y DIFF=X-Y RETURN END SUBROUTINE G1 (A,B,CTERM,STERM,SIG) c C COMPUTE ORTHOGONAL ROTATION MATRIX.. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C C COMPUTE.. MATRIX (C, S) SO THAT (C, S)(A) = (SQRT(A**2+B**2)) C (-S,C) (-S,C)(B) ( 0 ) C COMPUTE SIG = SQRT(A**2+B**2) C SIG IS COMPUTED LAST TO ALLOW FOR THE POSSIBILITY THAT C SIG MAY BE IN THE SAME LOCATION AS A OR B . C ------------------------------------------------------------------ double precision A, B, CTERM, ONE, SIG, STERM, XR, YR, ZERO parameter(ONE = 1.0d0, ZERO = 0.0d0) C ------------------------------------------------------------------ if (abs(A) .gt. abs(B)) then XR=B/A YR=sqrt(ONE+XR**2) CTERM=sign(ONE/YR,A) STERM=CTERM*XR SIG=abs(A)*YR RETURN endif if (B .ne. ZERO) then XR=A/B YR=sqrt(ONE+XR**2) STERM=sign(ONE/YR,B) CTERM=STERM*XR SIG=abs(B)*YR RETURN endif SIG=ZERO CTERM=ZERO STERM=ONE RETURN END SUBROUTINE G2 (CTERM,STERM,X,Y) c C APPLY THE ROTATION COMPUTED BY G1 TO (X,Y). c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1972 DEC 15, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. c ------------------------------------------------------------------ double precision CTERM, STERM, X, XR, Y c ------------------------------------------------------------------ XR=CTERM*X+STERM*Y Y=-STERM*X+CTERM*Y X=XR RETURN END double precision FUNCTION GEN(ANOISE) c C GENERATE NUMBERS FOR CONSTRUCTION OF TEST CASES. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1972 DEC 15, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. c ------------------------------------------------------------------ integer I, J, MI, MJ double precision AI, AJ, ANOISE, ZERO parameter(ZERO = 0.0d0) SAVE c ------------------------------------------------------------------ C IF (ANOISE) 10,30,20 IF (ANOISE >= 0.0d0) GOTO 20 MI=891 MJ=457 I=5 J=7 AJ= ZERO GEN= ZERO RETURN C C THE SEQUENCE OF VALUES OF J IS BOUNDED BETWEEN 1 AND 996 C IF INITIAL J = 1,2,3,4,5,6,7,8, OR 9, THE PERIOD IS 332 20 IF (ANOISE > 0.0d0) GOTO 30 J=J*MJ J=J-997*(J/997) AJ=J-498 C THE SEQUENCE OF VALUES OF I IS BOUNDED BETWEEN 1 AND 999 C IF INITIAL I = 1,2,3,6,7, OR 9, THE PERIOD WILL BE 50 C IF INITIAL I = 4 OR 8 THE PERIOD WILL BE 25 C IF INITIAL I = 5 THE PERIOD WILL BE 10 30 I=I*MI I=I-1000*(I/1000) AI=I-500 GEN=AI+AJ*ANOISE RETURN END C SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) C C CONSTRUCTION AND/OR APPLICATION OF A SINGLE C HOUSEHOLDER TRANSFORMATION.. Q = I + U*(U**T)/B C c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ c Subroutine Arguments c C MODE = 1 OR 2 Selects Algorithm H1 to construct and apply a c Householder transformation, or Algorithm H2 to apply a c previously constructed transformation. C LPIVOT IS THE INDEX OF THE PIVOT ELEMENT. C L1,M IF L1 .LE. M THE TRANSFORMATION WILL BE CONSTRUCTED TO C ZERO ELEMENTS INDEXED FROM L1 THROUGH M. IF L1 GT. M C THE SUBROUTINE DOES AN IDENTITY TRANSFORMATION. C U(),IUE,UP On entry with MODE = 1, U() contains the pivot c vector. IUE is the storage increment between elements. c On exit when MODE = 1, U() and UP contain quantities c defining the vector U of the Householder transformation. c on entry with MODE = 2, U() and UP should contain c quantities previously computed with MODE = 1. These will c not be modified during the entry with MODE = 2. C C() ON ENTRY with MODE = 1 or 2, C() CONTAINS A MATRIX WHICH c WILL BE REGARDED AS A SET OF VECTORS TO WHICH THE c HOUSEHOLDER TRANSFORMATION IS TO BE APPLIED. c ON EXIT C() CONTAINS THE SET OF TRANSFORMED VECTORS. C ICE STORAGE INCREMENT BETWEEN ELEMENTS OF VECTORS IN C(). C ICV STORAGE INCREMENT BETWEEN VECTORS IN C(). C NCV NUMBER OF VECTORS IN C() TO BE TRANSFORMED. IF NCV .LE. 0 C NO OPERATIONS WILL BE DONE ON C(). C ------------------------------------------------------------------ SUBROUTINE H12 (MODE,LPIVOT,L1,M,U,IUE,UP,C,ICE,ICV,NCV) C ------------------------------------------------------------------ integer I, I2, I3, I4, ICE, ICV, INCR, IUE, J integer L1, LPIVOT, M, MODE, NCV double precision B, C(*), CL, CLINV, ONE, SM c double precision U(IUE,M) double precision U(IUE,*) double precision UP parameter(ONE = 1.0d0) C ------------------------------------------------------------------ IF (0.GE.LPIVOT.OR.LPIVOT.GE.L1.OR.L1.GT.M) RETURN CL=abs(U(1,LPIVOT)) IF (MODE.EQ.2) GO TO 60 C ****** CONSTRUCT THE TRANSFORMATION. ****** DO 10 J=L1,M CL=MAX(abs(U(1,J)),CL) 10 END DO IF (CL <= 0.0d0) GOTO 130 CLINV=ONE/CL SM=(U(1,LPIVOT)*CLINV)**2 DO 30 J=L1,M SM=SM+(U(1,J)*CLINV)**2 30 END DO CL=CL*SQRT(SM) IF (U(1,LPIVOT) <= 0.0d0) GOTO 50 CL=-CL 50 UP=U(1,LPIVOT)-CL U(1,LPIVOT)=CL GO TO 70 C ****** APPLY THE TRANSFORMATION I+U*(U**T)/B TO C. ****** C 60 IF (CL <= 0.0d0) GOTO 130 70 IF (NCV.LE.0) RETURN B= UP*U(1,LPIVOT) C B MUST BE NONPOSITIVE HERE. IF B = 0., RETURN. C IF (B >= 0.0d0) GOTO 130 B=ONE/B I2=1-ICV+ICE*(LPIVOT-1) INCR=ICE*(L1-LPIVOT) DO 120 J=1,NCV I2=I2+ICV I3=I2+INCR I4=I3 SM=C(I2)*UP DO 90 I=L1,M SM=SM+C(I3)*U(1,I) I3=I3+ICE 90 END DO IF (SM == 0.0d0) GOTO 120 SM=SM*B C(I2)=C(I2)+SM*UP DO 110 I=L1,M C(I4)=C(I4)+SM*U(1,I) I4=I4+ICE 110 END DO 120 CONTINUE 130 RETURN END SUBROUTINE HFTI (A,MDA,M,N,B,MDB,NB,TAU,KRANK,RNORM,H,G,IP) c C SOLVE LEAST SQUARES PROBLEM USING ALGORITHM, HFTI. c Householder Forward Triangulation with column Interchanges. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ integer I, II, IP1, J, JB, JJ, K, KP1, KRANK integer L, LDIAG, LMAX, M, MDA, MDB, N, NB c integer IP(N) c double precision A(MDA,N),B(MDB,NB),H(N),G(N),RNORM(NB) integer IP(*) double precision A(MDA,*),B(MDB, *),H(*),G(*),RNORM( *) double precision DIFF, FACTOR, HMAX, SM, TAU, TMP, ZERO parameter(FACTOR = 0.001d0, ZERO = 0.0d0) C ------------------------------------------------------------------ C K=0 LDIAG=min(M,N) IF (LDIAG.LE.0) GO TO 270 DO 80 J=1,LDIAG IF (J.EQ.1) GO TO 20 C C UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX C .. LMAX=J DO 10 L=J,N H(L)=H(L)-A(J-1,L)**2 IF (H(L).GT.H(LMAX)) LMAX=L 10 CONTINUE IF(DIFF(HMAX+FACTOR*H(LMAX),HMAX) > 0.0d0) GOTO 50 C C COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX C .. 20 LMAX=J DO 40 L=J,N H(L)=0. DO 30 I=J,M H(L)=H(L)+A(I,L)**2 30 END DO IF (H(L).GT.H(LMAX)) LMAX=L 40 CONTINUE HMAX=H(LMAX) C .. C LMAX HAS BEEN DETERMINED C C DO COLUMN INTERCHANGES IF NEEDED. C .. 50 CONTINUE IP(J)=LMAX IF (IP(J).EQ.J) GO TO 70 DO 60 I=1,M TMP=A(I,J) A(I,J)=A(I,LMAX) A(I,LMAX)=TMP 60 END DO H(LMAX)=H(J) C C COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B. C .. 70 CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J) CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB) 80 END DO C C DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU. C .. DO 90 J=1,LDIAG IF (ABS(A(J,J)).LE.TAU) GO TO 100 90 CONTINUE K=LDIAG GO TO 110 100 K=J-1 110 KP1=K+1 C C COMPUTE THE NORMS OF THE RESIDUAL VECTORS. C IF (NB.LE.0) GO TO 145 DO 140 JB=1,NB TMP=ZERO IF (KP1.GT.M) GO TO 130 DO 120 I=KP1,M TMP=TMP+B(I,JB)**2 120 END DO 130 RNORM(JB)=SQRT(TMP) 140 END DO 145 CONTINUE C SPECIAL FOR PSEUDORANK = 0 IF (K.GT.0) GO TO 160 IF (NB.LE.0) GO TO 270 DO 155 JB=1,NB DO 150 I=1,N B(I,JB)=ZERO 150 END DO 155 END DO GO TO 270 C C IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER C DECOMPOSITION OF FIRST K ROWS. C .. 160 IF (K.EQ.N) GO TO 180 DO 170 II=1,K I=KP1-II CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1) 170 END DO 180 CONTINUE C C IF (NB.LE.0) GO TO 270 DO 260 JB=1,NB C C SOLVE THE K BY K TRIANGULAR SYSTEM. C .. DO 210 L=1,K SM=ZERO I=KP1-L IF (I.EQ.K) GO TO 200 IP1=I+1 DO 190 J=IP1,K SM=SM+A(I,J)*B(J,JB) 190 END DO 200 continue B(I,JB)=(B(I,JB)-SM)/A(I,I) 210 END DO C C COMPLETE COMPUTATION OF SOLUTION VECTOR. C .. IF (K.EQ.N) GO TO 240 DO 220 J=KP1,N B(J,JB)=ZERO 220 END DO DO 230 I=1,K CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1) 230 END DO C C RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE C COLUMN INTERCHANGES. C .. 240 DO 250 JJ=1,LDIAG J=LDIAG+1-JJ IF (IP(J).EQ.J) GO TO 250 L=IP(J) TMP=B(L,JB) B(L,JB)=B(J,JB) B(J,JB)=TMP 250 CONTINUE 260 CONTINUE C .. C THE SOLUTION VECTORS, X, ARE NOW C IN THE FIRST N ROWS OF THE ARRAY B(,). C 270 KRANK=K RETURN END SUBROUTINE LDP (G,MDG,M,N,H,X,XNORM,W,INDEX,MODE) c C Algorithm LDP: LEAST DISTANCE PROGRAMMING c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1974 MAR 1, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ integer I, IW, IWDUAL, IY, IZ, J, JF, M, MDG, MODE, N, NP1 c integer INDEX(M) c double precision G(MDG,N), H(M), X(N), W(*) integer INDEX(*) double precision G(MDG,*), H(*), X(*), W(*) double precision DIFF, FAC, ONE, RNORM, XNORM, ZERO parameter(ONE = 1.0d0, ZERO = 0.0d0) C ------------------------------------------------------------------ IF (N.LE.0) GO TO 120 DO 10 J=1,N X(J)=ZERO 10 END DO XNORM=ZERO IF (M.LE.0) GO TO 110 C C THE DECLARED DIMENSION OF W() MUST BE AT LEAST (N+1)*(M+2)+2*M. C C FIRST (N+1)*M LOCS OF W() = MATRIX E FOR PROBLEM NNLS. C NEXT N+1 LOCS OF W() = VECTOR F FOR PROBLEM NNLS. C NEXT N+1 LOCS OF W() = VECTOR Z FOR PROBLEM NNLS. C NEXT M LOCS OF W() = VECTOR Y FOR PROBLEM NNLS. C NEXT M LOCS OF W() = VECTOR WDUAL FOR PROBLEM NNLS. C COPY G**T INTO FIRST N ROWS AND M COLUMNS OF E. C COPY H**T INTO ROW N+1 OF E. C IW=0 DO 30 J=1,M DO 20 I=1,N IW=IW+1 W(IW)=G(J,I) 20 END DO IW=IW+1 W(IW)=H(J) 30 END DO JF=IW+1 C STORE N ZEROS FOLLOWED BY A ONE INTO F. DO 40 I=1,N IW=IW+1 W(IW)=ZERO 40 END DO W(IW+1)=ONE C NP1=N+1 IZ=IW+2 IY=IZ+NP1 IWDUAL=IY+M C CALL NNLS (W,NP1,NP1,M,W(JF),W(IY),RNORM,W(IWDUAL),W(IZ),INDEX, * MODE) C USE THE FOLLOWING RETURN IF UNSUCCESSFUL IN NNLS. IF (MODE.NE.1) RETURN IF (RNORM < 0.0d0) GOTO 130 FAC=ONE IW=IY-1 DO 60 I=1,M IW=IW+1 C HERE WE ARE USING THE SOLUTION VECTOR Y. FAC=FAC-H(I)*W(IW) 60 END DO C IF (DIFF(ONE+FAC,ONE) < 0.0d0) GOTO 130 FAC=ONE/FAC DO 90 J=1,N IW=IY-1 DO 80 I=1,M IW=IW+1 C HERE WE ARE USING THE SOLUTION VECTOR Y. X(J)=X(J)+G(I,J)*W(IW) 80 END DO X(J)=X(J)*FAC 90 END DO DO 100 J=1,N XNORM=XNORM+X(J)**2 100 END DO XNORM=sqrt(XNORM) C SUCCESSFUL RETURN. 110 MODE=1 RETURN C ERROR RETURN. N .LE. 0. 120 MODE=2 RETURN C RETURNING WITH CONSTRAINTS NOT COMPATIBLE. 130 MODE=4 RETURN END c subroutine MFEOUT (A, MDA, M, N, NAMES, MODE, UNIT, WIDTH) subroutine MFEOUT (M, N, NAMES, MODE, UNIT, WIDTH) c C LABELED MATRIX OUTPUT FOR USE WITH SINGULAR VALUE ANALYSIS. C c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ c This 1995 version has additional arguments, UNIT and WIDTH, c to support user options regarding the output unit and the width of c print lines. Also allows user to choose length of names in NAMES(). c ------------------------------------------------------------------ c Subroutine Arguments C All are input arguments. None are modified by this subroutine. c C A(,) Array containing matrix to be output. Removed by Yong C MDA First dimension of the array, A(,). Removed by Yong C M, N No. of rows and columns, respectively in the matrix c contained in A(,). C NAMES() [character array] Array of names. c If NAMES(1) contains only blanks, the rest of the NAMES() c array will be ignored. C MODE =1 Write header for V matrix and use an F format. C =2 Write header for for candidate solutions and use c P format. c UNIT [integer] Selects output unit. If UNIT .ge. 0 then UNIT c is the output unit number. If UNIT = -1, output to c the '*' unit. c WIDTH [integer] Selects width of output lines. c Each output line from this subroutine will have at most c max(26,min(124,WIDTH)) characters plus one additional c leading character for Fortran "carriage control". The c carriage control character will always be a blank. c ------------------------------------------------------------------ integer I, J1, J2, KBLOCK, L, LENNAM integer M, MAXCOL, MODE, N, NAMSIZ, NBLOCK, UNIT, WIDTH c double precision A(MDA,N) character NAMES(M)*(*) character(len=4) HEAD (2) character(len=26) FMT1(2) character(len=26) FMT2(2) logical BLKNAM, STAR C data HEAD(1)/' COL'/ data HEAD(2)/'SOLN'/ data FMT1 / '(/7x,00x,8(5x,a4,i4,1x)/)', * '(/7x,00x,8(2x,a4,i4,4x)/)'/ data FMT2 / '(1x,i4,1x,a00,1x,4p8f14.0)', * '(1x,i4,1x,a00,1x,8g14.6 )'/ c ------------------------------------------------------------------ if (M .le. 0 .or. N .le. 0) return STAR = UNIT .lt. 0 C c The LEN function returns the char length of a single element of c the NAMES() array. c LENNAM = len(NAMES(1)) BLKNAM = NAMES(1) .eq. ' ' NAMSIZ = 1 if(.not. BLKNAM) then do 30 I = 1,M do 10 L = LENNAM, NAMSIZ+1, -1 if(NAMES(I)(L:L) .ne. ' ') then NAMSIZ = L go to 20 endif 10 continue 20 continue 30 continue endif c cc write(FMT1(MODE)(6:7),'(i2.2)') NAMSIZ cc write(FMT2(MODE)(12:13),'(i2.2)') NAMSIZ c 70 format(/' V-Matrix of the Singular Value Decomposition of A*D.'/ c * ' (Elements of V scaled up by a factor of 10**4)') c 80 format(/' Sequence of candidate solutions, X') if(STAR) then if (MODE .eq. 1) then cc write (*,70) Continue else cc write (*,80) Continue endif else if (MODE .eq. 1) then cc write (UNIT,70) Continue else cc write (UNIT,80) Continue endif endif c c With NAMSIZ characters allowed for the "name" and MAXCOL c columns of numbers, the total line width, exclusive of a c carriage control character, will be 6 + LENNAM + 14 * MAXCOL. c MAXCOL = max(1,min(8,(WIDTH - 6 - NAMSIZ)/14)) C NBLOCK = (N + MAXCOL -1) / MAXCOL J2 = 0 C do 50 KBLOCK = 1, NBLOCK J1 = J2 + 1 J2 = min(N, J2 + MAXCOL) if(STAR) then cc write (*,FMT1(MODE)) (HEAD(MODE),J,J=J1,J2) Continue else cc write (UNIT,FMT1(MODE)) (HEAD(MODE),J,J=J1,J2) Continue endif C do 40 I=1,M if(STAR) then if(BLKNAM) then cc write (*,FMT2(MODE)) I,' ',(A(I,J),J=J1,J2) Continue else cc write (*,FMT2(MODE)) I,NAMES(I),(A(I,J),J=J1,J2) Continue endif else if(BLKNAM) then cc write (UNIT,FMT2(MODE)) I,' ',(A(I,J),J=J1,J2) Continue else cc write (UNIT,FMT2(MODE)) I,NAMES(I),(A(I,J),J=J1,J2) Continue endif endif 40 continue 50 continue end C SUBROUTINE NNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE) C C Algorithm NNLS: NONNEGATIVE LEAST SQUARES C c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 15, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. c C GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B, COMPUTE AN C N-VECTOR, X, THAT SOLVES THE LEAST SQUARES PROBLEM C C A * X = B SUBJECT TO X .GE. 0 C ------------------------------------------------------------------ c Subroutine Arguments c C A(),MDA,M,N MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE C ARRAY, A(). ON ENTRY A() CONTAINS THE M BY N C MATRIX, A. ON EXIT A() CONTAINS C THE PRODUCT MATRIX, Q*A , WHERE Q IS AN C M BY M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY C THIS SUBROUTINE. C B() ON ENTRY B() CONTAINS THE M-VECTOR, B. ON EXIT B() CON- C TAINS Q*B. C X() ON ENTRY X() NEED NOT BE INITIALIZED. ON EXIT X() WILL C CONTAIN THE SOLUTION VECTOR. C RNORM ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE C RESIDUAL VECTOR. C W() AN N-ARRAY OF WORKING SPACE. ON EXIT W() WILL CONTAIN C THE DUAL SOLUTION VECTOR. W WILL SATISFY W(I) = 0. C FOR ALL I IN SET P AND W(I) .LE. 0. FOR ALL I IN SET Z C ZZ() AN M-ARRAY OF WORKING SPACE. C INDEX() AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N. C ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS C P AND Z AS FOLLOWS.. C C INDEX(1) THRU INDEX(NSETP) = SET P. C INDEX(IZ1) THRU INDEX(IZ2) = SET Z. C IZ1 = NSETP + 1 = NPP1 C IZ2 = N C MODE THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING C MEANINGS. C 1 THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY. C 2 THE DIMENSIONS OF THE PROBLEM ARE BAD. C EITHER M .LE. 0 OR N .LE. 0. C 3 ITERATION COUNT EXCEEDED. MORE THAN 3*N ITERATIONS. C C ------------------------------------------------------------------ SUBROUTINE NNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE) C ------------------------------------------------------------------ integer I, II, IP, ITER, ITMAX, IZ, IZ1, IZ2, IZMAX, J, JJ, JZ, L integer M, MDA, MODE,N, NPP1, NSETP, RTNKEY c integer INDEX(N) c double precision A(MDA,N), B(M), W(N), X(N), ZZ(M) integer INDEX(*) double precision A(MDA,*), B(*), W(*), X(*), ZZ(*) c double precision ALPHA, ASAVE, CC, DIFF, DUMMY, FACTOR, RNORM double precision ALPHA, ASAVE, CC, DIFF, DUMMY(1), FACTOR, RNORM double precision SM, SS, T, TEMP, TWO, UNORM, UP, WMAX double precision ZERO, ZTEST parameter(FACTOR = 0.01d0) parameter(TWO = 2.0d0, ZERO = 0.0d0) C ------------------------------------------------------------------ MODE=1 IF (M .le. 0 .or. N .le. 0) then MODE=2 RETURN endif ITER=0 ITMAX=3*N C C INITIALIZE THE ARRAYS INDEX() AND X(). C DO 20 I=1,N X(I)=ZERO INDEX(I)=I 20 END DO C IZ2=N IZ1=1 NSETP=0 NPP1=1 C ****** MAIN LOOP BEGINS HERE ****** 30 CONTINUE C QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION. C OR IF M COLS OF A HAVE BEEN TRIANGULARIZED. C IF (IZ1 .GT.IZ2.OR.NSETP.GE.M) GO TO 350 C C COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W(). C DO 50 IZ=IZ1,IZ2 J=INDEX(IZ) SM=ZERO DO 40 L=NPP1,M SM=SM+A(L,J)*B(L) 40 END DO W(J)=SM 50 continue C FIND LARGEST POSITIVE W(J). 60 continue WMAX=ZERO IZMAX=0 DO 70 IZ=IZ1,IZ2 J=INDEX(IZ) IF (W(J) .gt. WMAX) then WMAX=W(J) IZMAX=IZ endif 70 CONTINUE C C IF WMAX .LE. 0. GO TO TERMINATION. C THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS. C IF (WMAX .le. ZERO) go to 350 IZ=IZMAX J=INDEX(IZ) C C THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P. C BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID C NEAR LINEAR DEPENDENCE. C ASAVE=A(NPP1,J) CALL H12 (1,NPP1,NPP1+1,M,A(1,J),1,UP,DUMMY,1,1,0) UNORM=ZERO IF (NSETP .ne. 0) then DO 90 L=1,NSETP UNORM=UNORM+A(L,J)**2 90 END DO endif UNORM=sqrt(UNORM) IF (DIFF(UNORM+ABS(A(NPP1,J))*FACTOR,UNORM) .gt. ZERO) then C C COL J IS SUFFICIENTLY INDEPENDENT. COPY B INTO ZZ, UPDATE ZZ C AND SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ). C DO 120 L=1,M ZZ(L)=B(L) 120 END DO CALL H12 (2,NPP1,NPP1+1,M,A(1,J),1,UP,ZZ,1,1,1) ZTEST=ZZ(NPP1)/A(NPP1,J) C C SEE IF ZTEST IS POSITIVE C IF (ZTEST .gt. ZERO) go to 140 endif C C REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P. C RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL C COEFFS AGAIN. C A(NPP1,J)=ASAVE W(J)=ZERO GO TO 60 C C THE INDEX J=INDEX(IZ) HAS BEEN SELECTED TO BE MOVED FROM C SET Z TO SET P. UPDATE B, UPDATE INDICES, APPLY HOUSEHOLDER C TRANSFORMATIONS TO COLS IN NEW SET Z, ZERO SUBDIAGONAL ELTS IN C COL J, SET W(J)=0. C 140 continue DO 150 L=1,M B(L)=ZZ(L) 150 END DO C INDEX(IZ)=INDEX(IZ1) INDEX(IZ1)=J IZ1=IZ1+1 NSETP=NPP1 NPP1=NPP1+1 C IF (IZ1 .le. IZ2) then DO 160 JZ=IZ1,IZ2 JJ=INDEX(JZ) CALL H12 (2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1) 160 continue endif C IF (NSETP .ne. M) then DO 180 L=NPP1,M A(L,J)=ZERO 180 END DO endif C W(J)=ZERO C SOLVE THE TRIANGULAR SYSTEM. C STORE THE SOLUTION TEMPORARILY IN ZZ(). RTNKEY = 1 GO TO 400 200 CONTINUE C C ****** SECONDARY LOOP BEGINS HERE ****** C C ITERATION COUNTER. C 210 continue ITER=ITER+1 IF (ITER .gt. ITMAX) then MODE=3 CC write (*,'(/a)') ' NNLS quitting on iteration count.' Continue GO TO 350 endif C C SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE. C IF NOT COMPUTE ALPHA. C ALPHA=TWO DO 240 IP=1,NSETP L=INDEX(IP) IF (ZZ(IP) .le. ZERO) then T=-X(L)/(ZZ(IP)-X(L)) IF (ALPHA .gt. T) then ALPHA=T JJ=IP endif endif 240 CONTINUE C C IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL C STILL = 2. IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP. C IF (ALPHA.EQ.TWO) GO TO 330 C C OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO C INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ. C DO 250 IP=1,NSETP L=INDEX(IP) X(L)=X(L)+ALPHA*(ZZ(IP)-X(L)) 250 continue C C MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I C FROM SET P TO SET Z. C I=INDEX(JJ) 260 continue X(I)=ZERO C IF (JJ .ne. NSETP) then JJ=JJ+1 DO 280 J=JJ,NSETP II=INDEX(J) INDEX(J-1)=II CALL G1 (A(J-1,II),A(J,II),CC,SS,A(J-1,II)) A(J,II)=ZERO DO 270 L=1,N IF (L.NE.II) then c c Apply procedure G2 (CC,SS,A(J-1,L),A(J,L)) c TEMP = A(J-1,L) A(J-1,L) = CC*TEMP + SS*A(J,L) A(J,L) =-SS*TEMP + CC*A(J,L) endif 270 CONTINUE c c Apply procedure G2 (CC,SS,B(J-1),B(J)) c TEMP = B(J-1) B(J-1) = CC*TEMP + SS*B(J) B(J) =-SS*TEMP + CC*B(J) 280 continue endif c NPP1=NSETP NSETP=NSETP-1 IZ1=IZ1-1 INDEX(IZ1)=I C C SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE. THEY SHOULD C BE BECAUSE OF THE WAY ALPHA WAS DETERMINED. C IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR. ANY C THAT ARE NONPOSITIVE WILL BE SET TO ZERO C AND MOVED FROM SET P TO SET Z. C DO 300 JJ=1,NSETP I=INDEX(JJ) IF (X(I) .le. ZERO) go to 260 300 CONTINUE C C COPY B( ) INTO ZZ( ). THEN SOLVE AGAIN AND LOOP BACK. C DO 310 I=1,M ZZ(I)=B(I) 310 END DO RTNKEY = 2 GO TO 400 320 CONTINUE GO TO 210 C ****** END OF SECONDARY LOOP ****** C 330 continue DO 340 IP=1,NSETP I=INDEX(IP) X(I)=ZZ(IP) 340 END DO C ALL NEW COEFFS ARE POSITIVE. LOOP BACK TO BEGINNING. GO TO 30 C C ****** END OF MAIN LOOP ****** C C COME TO HERE FOR TERMINATION. C COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR. C 350 continue SM=ZERO IF (NPP1 .le. M) then DO 360 I=NPP1,M SM=SM+B(I)**2 360 END DO else DO 380 J=1,N W(J)=ZERO 380 END DO endif RNORM=sqrt(SM) RETURN C C THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL SUBROUTINE C TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ(). C 400 continue DO 430 L=1,NSETP IP=NSETP+1-L IF (L .ne. 1) then DO 410 II=1,IP ZZ(II)=ZZ(II)-A(II,JJ)*ZZ(IP+1) 410 continue endif JJ=INDEX(IP) ZZ(IP)=ZZ(IP)/A(IP,JJ) 430 continue c go to (200, 320), RTNKEY if (RTNKEY .eq. 1) goto 200 if (RTNKEY .eq. 2) goto 320 END C SUBROUTINE QRBD (IPASS,Q,E,NN,V,MDV,NRV,C,MDC,NCC) c C QR ALGORITHM FOR SINGULAR VALUES OF A BIDIAGONAL MATRIX. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ C THE BIDIAGONAL MATRIX C C (Q1,E2,0... ) C ( Q2,E3,0... ) C D= ( . ) C ( . 0) C ( .EN) C ( 0,QN) C C IS PRE AND POST MULTIPLIED BY C ELEMENTARY ROTATION MATRICES C RI AND PI SO THAT C C RK...R1*D*P1**(T)...PK**(T) = DIAG(S1,...,SN) C C TO WITHIN WORKING ACCURACY. C C 1. EI AND QI OCCUPY E(I) AND Q(I) AS INPUT. C C 2. RM...R1*C REPLACES 'C' IN STORAGE AS OUTPUT. C C 3. V*P1**(T)...PM**(T) REPLACES 'V' IN STORAGE AS OUTPUT. C C 4. SI OCCUPIES Q(I) AS OUTPUT. C C 5. THE SI'S ARE NONINCREASING AND NONNEGATIVE. C C THIS CODE IS BASED ON THE PAPER AND 'ALGOL' CODE.. C REF.. C 1. REINSCH,C.H. AND GOLUB,G.H. 'SINGULAR VALUE DECOMPOSITION C AND LEAST SQUARES SOLUTIONS' (NUMER. MATH.), VOL. 14,(1970). C C ------------------------------------------------------------------ SUBROUTINE QRBD (IPASS,Q,E,NN,V,MDV,NRV,C,MDC,NCC) C ------------------------------------------------------------------ integer MDC, MDV, NCC, NN, NRV c double precision C(MDC,NCC), E(NN), Q(NN),V(MDV,NN) double precision C(MDC,* ), E(* ), Q(* ),V(MDV,* ) integer I, II, IPASS, J, K, KK, L, LL, LP1, N, N10, NQRS double precision CS, DIFF, DNORM, F, G, H, SMALL double precision ONE, SN, T, TEMP, TWO, X, Y, Z, ZERO logical WNTV ,HAVERS,FAIL parameter(ONE = 1.0d0, TWO = 2.0d0, ZERO = 0.0d0) C ------------------------------------------------------------------ L=0 N=NN IPASS=1 IF (N.LE.0) RETURN N10=10*N WNTV=NRV.GT.0 HAVERS=NCC.GT.0 FAIL=.FALSE. NQRS=0 E(1)=ZERO DNORM=ZERO DO 10 J=1,N DNORM=max(abs(Q(J))+abs(E(J)),DNORM) 10 END DO DO 200 KK=1,N K=N+1-KK C C TEST FOR SPLITTING OR RANK DEFICIENCIES.. C FIRST MAKE TEST FOR LAST DIAGONAL TERM, Q(K), BEING SMALL. 20 IF(K.EQ.1) GO TO 50 IF(DIFF(DNORM+Q(K),DNORM) .ne. ZERO) go to 50 C C SINCE Q(K) IS SMALL WE WILL MAKE A SPECIAL PASS TO C TRANSFORM E(K) TO ZERO. C CS=ZERO SN=-ONE DO 40 II=2,K I=K+1-II F=-SN*E(I+1) E(I+1)=CS*E(I+1) CALL G1 (Q(I),F,CS,SN,Q(I)) C TRANSFORMATION CONSTRUCTED TO ZERO POSITION (I,K). C IF (.NOT.WNTV) GO TO 40 DO 30 J=1,NRV c c Apply procedure G2 (CS,SN,V(J,I),V(J,K)) c TEMP = V(J,I) V(J,I) = CS*TEMP + SN*V(J,K) V(J,K) =-SN*TEMP + CS*V(J,K) 30 continue C ACCUMULATE RT. TRANSFORMATIONS IN V. C 40 CONTINUE C C THE MATRIX IS NOW BIDIAGONAL, AND OF LOWER ORDER C SINCE E(K) .EQ. ZERO.. C 50 DO 60 LL=1,K L=K+1-LL IF(DIFF(DNORM+E(L),DNORM) .eq. ZERO) go to 100 IF(DIFF(DNORM+Q(L-1),DNORM) .eq. ZERO) go to 70 60 CONTINUE C THIS LOOP CAN'T COMPLETE SINCE E(1) = ZERO. C GO TO 100 C C CANCELLATION OF E(L), L.GT.1. 70 CS=ZERO SN=-ONE DO 90 I=L,K F=-SN*E(I) E(I)=CS*E(I) IF(DIFF(DNORM+F,DNORM) .eq. ZERO) go to 100 CALL G1 (Q(I),F,CS,SN,Q(I)) IF (HAVERS) then DO 80 J=1,NCC c c Apply procedure G2 ( CS, SN, C(I,J), C(L-1,J) c TEMP = C(I,J) C(I,J) = CS*TEMP + SN*C(L-1,J) C(L-1,J) =-SN*TEMP + CS*C(L-1,J) 80 continue endif 90 CONTINUE C C TEST FOR CONVERGENCE.. 100 Z=Q(K) IF (L.EQ.K) GO TO 170 C C SHIFT FROM BOTTOM 2 BY 2 MINOR OF B**(T)*B. X=Q(L) Y=Q(K-1) G=E(K-1) H=E(K) F=((Y-Z)*(Y+Z)+(G-H)*(G+H))/(TWO*H*Y) G=sqrt(ONE+F**2) IF (F .ge. ZERO) then T=F+G else T=F-G endif F=((X-Z)*(X+Z)+H*(Y/T-H))/X C C NEXT QR SWEEP.. CS=ONE SN=ONE LP1=L+1 DO 160 I=LP1,K G=E(I) Y=Q(I) H=SN*G G=CS*G CALL G1 (F,H,CS,SN,E(I-1)) F=X*CS+G*SN G=-X*SN+G*CS H=Y*SN Y=Y*CS IF (WNTV) then C C ACCUMULATE ROTATIONS (FROM THE RIGHT) IN 'V' c DO 130 J=1,NRV c c Apply procedure G2 (CS,SN,V(J,I-1),V(J,I)) c TEMP = V(J,I-1) V(J,I-1) = CS*TEMP + SN*V(J,I) V(J,I) =-SN*TEMP + CS*V(J,I) 130 continue endif CALL G1 (F,H,CS,SN,Q(I-1)) F=CS*G+SN*Y X=-SN*G+CS*Y IF (HAVERS) then DO 150 J=1,NCC c c Apply procedure G2 (CS,SN,C(I-1,J),C(I,J)) c TEMP = C(I-1,J) C(I-1,J) = CS*TEMP + SN*C(I,J) C(I,J) =-SN*TEMP + CS*C(I,J) 150 continue endif c C APPLY ROTATIONS FROM THE LEFT TO C RIGHT HAND SIDES IN 'C'.. C 160 CONTINUE E(L)=ZERO E(K)=F Q(K)=X NQRS=NQRS+1 IF (NQRS.LE.N10) GO TO 20 C RETURN TO 'TEST FOR SPLITTING'. C SMALL=ABS(E(K)) I=K C IF FAILURE TO CONVERGE SET SMALLEST MAGNITUDE C TERM IN OFF-DIAGONAL TO ZERO. CONTINUE ON. C .. DO 165 J=L,K TEMP=ABS(E(J)) IF(TEMP .EQ. ZERO) GO TO 165 IF(TEMP .LT. SMALL) THEN SMALL=TEMP I=J end if 165 CONTINUE E(I)=ZERO NQRS=0 FAIL=.TRUE. GO TO 20 C .. C CUTOFF FOR CONVERGENCE FAILURE. 'NQRS' WILL BE 2*N USUALLY. 170 IF (Z.GE.ZERO) GO TO 190 Q(K)=-Z IF (WNTV) then DO 180 J=1,NRV V(J,K)=-V(J,K) 180 END DO endif 190 CONTINUE C CONVERGENCE. Q(K) IS MADE NONNEGATIVE.. C 200 CONTINUE IF (N.EQ.1) RETURN DO 210 I=2,N IF (Q(I).GT.Q(I-1)) GO TO 220 210 CONTINUE IF (FAIL) IPASS=2 RETURN C .. C EVERY SINGULAR VALUE IS IN ORDER.. 220 DO 270 I=2,N T=Q(I-1) K=I-1 DO 230 J=I,N IF (T.GE.Q(J)) GO TO 230 T=Q(J) K=J 230 CONTINUE IF (K.EQ.I-1) GO TO 270 Q(K)=Q(I-1) Q(I-1)=T IF (HAVERS) then DO 240 J=1,NCC T=C(I-1,J) C(I-1,J)=C(K,J) C(K,J)=T 240 END DO endif IF (WNTV) then DO 260 J=1,NRV T=V(J,I-1) V(J,I-1)=V(J,K) V(J,K)=T 260 END DO endif 270 CONTINUE C END OF ORDERING ALGORITHM. C IF (FAIL) IPASS=2 RETURN END subroutine SVA(A,MDA,M,N,MDATA,B,SING,KPVEC,NAMES,ISCALE,D,WORK) c C SINGULAR VALUE ANALYSIS. COMPUTES THE SINGULAR VALUE C DECOMPOSITION OF THE MATRIX OF A LEAST SQUARES PROBLEM, AND C PRODUCES A PRINTED REPORT. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 12, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ c This 1995 version differs from the original 1973 version by the c addition of the arguments KPVEC() and WORK(), and by allowing user to c choose the length of names in NAMES(). c KPVEC() allows the user to exercise options regarding printing. c WORK() provides 2*N locations of work space. Originally SING() was c required to have 3*N elements, of which the last 2*N were used for c work space. Now SING() only needs N elements. c ------------------------------------------------------------------ c Subroutine Arguments c A(,) [inout] On entry, contains the M x N matrix of the least c squares problem to be analyzed. This could be a matrix c obtained by preliminary orthogonal transformations c applied to the actual problem matrix which may have had c more rows (See MDATA below.) c c MDA [in] First dimensioning parameter for A(,). Require c MDA .ge. max(M, N). c c M,N [in] No. of rows and columns, respectively, in the c matrix, A. Either M > N or M .le. N is permitted. c Require M > 0 and N > 0. c c MDATA [in] No. of rows in actual least squares problem. c Generally MDATA .ge. M. MDATA is used only in computing c statistics for the report and is not used as a loop c count or array dimension. c c B() [inout] On entry, contains the right-side vector, b, of the c least squares problem. This vector is of length, M. c On return, contains the vector, g = (U**t)*b, where U c comes from the singular value decomposition of A. The c vector , g, is also of length M. c c SING() [out] On return, contains the singular values of A, in c descending order, in locations indexed 1 thru min(M,N). c If M < N, locations indexed from M+1 through N will be c set to zero. c c KPVEC() [integer array, in] Array of integers to select print c options. KPVEC(1) determines whether the rest of c the array is to be used or ignored. c If KPVEC(1) = 1, the contents of (KPVEC(I), I=2,4) c will be used to set internal variables as follows: c PRBLK = KPVEC(2) c UNIT = KPVEC(3) c WIDTH = KPVEC(4) c If KPVEC(1) = 0 default settings will be used. The user c need not dimension KPVEC() greater than 1. The subr will c set PRBLK = 111111, UNIT = -1, and WIDTH = 69. c c The internal variables PRBLK, UNIT, and WIDTH are c interpreted as follows: c c PRBLK The decimal representation of PRBLK must be c representable as at most 6 digits, each being 0 or 1. c The decimal digits will be interpreted as independant c on/off flags for the 6 possible blocks of printed output. c Examples: 111111 selects all blocks, 0 suppresses all c printing, 101010 selects the 1st, 3rd, and 5th blocks, c etc. c The six blocks are: c 1. Header, with size and scaling option parameters. c 2. V-matrix. Amount of output depends on M and N. c 3. Singular values and related quantities. Amount of c output depends on N. c 4. Listing of YNORM and RNORM and their logarithms. c Amount of output depends on N. c 5. Levenberg-Marquart analysis. c 6. Candidate solutions. Amount of output depends on c M and N. c c UNIT Selects the output unit. If UNIT .ge. 0, c UNIT will be used as the output unit number. c If UNIT = -1, output will be written to the "*" output c unit, i.e., the standard system output unit. c The calling program unit is responsible for opening c and/or closing the selected output unit if the host c system requires these actions. c c WIDTH Default value is 79. Determines the width of c blocks 2, 3, and 6 of the output report. c Block 3 will use 95(+1) cols if WIDTH .ge. 95, and otherwise c 69(+1) cols. c Blocks 2 and 6 are printed by subroutine MFEOUT. These blocks c generally use at most WIDTH(+1) cols, but will use more if c the names are so long that more space is needed to print one c name and one numeric column. The (+1)'s above are reminders c that in all cases there is one extra initial column for Fortran c "carriage control". The carriage control character will always c be a blank. c Blocks 1, 4, and 5 have fixed widths of 63(+1), 66(+1) and c 66(+1), respectively. c c NAMES() [in] NAMES(j), for j = 1, ..., N, may contain a c name for the jth component of the solution c vector. The declared length of the elements of the c NAMES() array is not specifically limited, but a c greater length reduces the space available for columns c of the matris to be printed. c If NAMES(1) contains only blank characters, c it will be assumed that no names have been provided, c and this subr will not access the NAMES() array beyond c the first element. C C ISCALE [in] Set by the user to 1, 2, or 3 to select the column c scaling option. C 1 SUBR WILL USE IDENTITY SCALING AND IGNORE THE D() C ARRAY. C 2 SUBR WILL SCALE NONZERO COLS TO HAVE UNIT EUCLID- C EAN LENGTH AND WILL STORE RECIPROCAL LENGTHS OF C ORIGINAL NONZERO COLS IN D(). C 3 USER SUPPLIES COL SCALE FACTORS IN D(). SUBR C WILL MULT COL J BY D(J) AND REMOVE THE SCALING C FROM THE SOLN AT THE END. c c D() [ignored or out or in] Usage of D() depends on ISCALE as c described above. When used, its length must be c at least N. c c WORK() [scratch] Work space of length at least 2*N. Used c directly in this subr and also in _SVDRS. c ------------------------------------------------------------------ integer I, IE, IPASS, ISCALE, J, K, KPVEC(4), M, MDA, MDATA integer MINMN, MINMN1, MPASS, N, NSOL integer PRBLK, UNIT, WIDTH double precision A(MDA,N), A1, A2, A3, A4, ALAMB, ALN10, B(M) double precision D(N), DEL, EL, EL2 double precision ONE, PCOEF, RL, RNORM, RS double precision SB, SING(N), SL, TEN, THOU, TWENTY double precision WORK(2*N), YL, YNORM, YS, YSQ, ZERO character*(*) NAMES(N) logical BLK(6), NARROW, STAR parameter( ZERO = 0.0d0, ONE = 1.0d0) parameter( TEN = 10.0d0, TWENTY = 20.0d0, THOU = 1000.0d0) c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c 220 format (1X/' INDEX SING. VAL. P COEF ', c * ' RECIPROCAL G COEF G**2 ', c * ' CUMULATIVE SCALED SQRT'/ c * 31x,' SING. VAL.',26x, c * ' SUM of SQRS of CUM.S.S.') c 221 format (1X/' INDEX SING. VAL. P COEF ', c * ' RECIPROCAL G COEF SCALED SQRT'/ c * 31x,' SING. VAL.',13x,' of CUM.S.S.') c 222 format (1X/' INDEX SING. VAL. G COEF G**2 ', c * ' CUMULATIVE SCALED SQRT'/ c * 44x,' SUM of SQRS of CUM.S.S.') c 230 format (' ',4X,'0',64X,2g13.4) c 231 format (' ',4X,'0',51X, g13.4) c 232 format (' ',4X,'0',38X,2g13.4) c 240 format (' ',i5,g12.4,6g13.4) c 260 format (1X,' M = ',I6,', N =',I4,', MDATA =',I8) c 270 format (1X/' Singular Value Analysis of the least squares', c * ' problem, A*X = B,'/ c * ' scaled as (A*D)*Y = B.') c 280 format (1X/' Scaling option No.',I2,'. D is a diagonal', c * ' matrix with the following diagonal elements..'/(5X,10E12.4)) c 290 format (1X/' Scaling option No. 1. D is the identity matrix.'/ c * 1X) c 300 format (1X/' INDEX',12X,'YNORM RNORM',11X, c * ' LOG10 LOG10'/ c * 45X,' YNORM RNORM'/1X) c 310 format (' ',I5,6X,2E11.3,11X,2F11.3) c 320 format (1X/ c *' Norms of solution and residual vectors for a range of values'/ c *' of the Levenberg-Marquardt parameter, LAMBDA.'// c * ' LAMBDA YNORM RNORM', c * ' LOG10 LOG10 LOG10'/ c * 34X,' LAMBDA YNORM RNORM') c 330 format (1X, 3E11.3, 3F11.3) c ------------------------------------------------------------------ IF (M.LE.0 .OR. N.LE.0) RETURN MINMN = min(M,N) MINMN1 = MINMN + 1 if(KPVEC(1) .eq. 0) then PRBLK = 111111 UNIT = -1 WIDTH = 79 else PRBLK = KPVEC(2) UNIT = KPVEC(3) WIDTH = KPVEC(4) endif STAR = UNIT .lt. 0 c Build logical array BLK() by testing c decimal digits of PRBLK. do 20 I=6, 1, -1 J = PRBLK/10 BLK(I) = (PRBLK - 10*J) .gt. 0 PRBLK = J 20 continue c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Optionally print header and M, N, MDATA if(BLK(1)) then if(STAR) then CC write (*,270) CC write (*,260) M,N,MDATA Continue else cc write (UNIT,270) cc write (UNIT,260) M,N,MDATA Continue endif endif c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - c Handle scaling as selected by ISCALE. if( ISCALE .eq. 1) then if(BLK(1)) then if(STAR) then cc write (*,290) Continue else cc write (UNIT,290) Continue endif endif else C C Apply column scaling to A. C DO 52 J = 1,N A1 = D(J) if( ISCALE .le. 2) then SB = ZERO DO 30 I = 1,M SB = SB + A(I,J)**2 30 END DO A1 = sqrt(SB) IF (A1.EQ.ZERO) A1 = ONE A1 = ONE/A1 D(J) = A1 endif DO 50 I = 1,M A(I,J) = A(I,J)*A1 50 continue 52 continue if(BLK(1)) then if(STAR) then cc write (*,280) ISCALE,(D(J),J = 1,N) Continue else cc write (UNIT,280) ISCALE,(D(J),J = 1,N) Continue endif endif endif c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Compute the Singular Value Decomposition of the scaled matrix. C call SVDRS (A,MDA,M,N,B,M,1,SING,WORK) c c Determine NSOL. NSOL = MINMN do 60 J = 1,MINMN if(SING(J) .eq. ZERO) then NSOL = J-1 go to 65 endif 60 continue 65 continue C c The array B() contains the vector G. C Compute cumulative sums of squares of components of C G and store them in WORK(I), I = 1,...,MINMN+1 C SB = ZERO DO 70 I = MINMN1,M SB = SB + B(I)**2 70 CONTINUE WORK(MINMN+1) = SB DO 75 J = MINMN, 1, -1 SB = SB + B(J)**2 WORK(J) = SB 75 CONTINUE c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C PRINT THE V MATRIX. C c if(BLK(2)) CALL MFEOUT (A,MDA,N,N,NAMES,1, UNIT, WIDTH) if(BLK(2)) CALL MFEOUT (N,N,NAMES,1, UNIT, WIDTH) c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C REPLACE V BY D*V IN THE ARRAY A() if (ISCALE .gt.1) then do 82 I = 1,N do 80 J = 1,N A(I,J) = D(I)*A(I,J) 80 continue 82 continue endif c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if(BLK(3)) then c Print singular values and other summary results. c c Output will be done using one of two layouts. The narrow c layout uses 69 cols + 1 for carriage control, and makes two passes c through the computation. c The wide layout uses 95 cols + 1 for carriage control, and makes c only one pass through the computation. c C G NOW IN B() ARRAY. V NOW IN A(,) ARRAY. C NARROW = WIDTH .lt. 95 MPASS = 1 if(NARROW) MPASS = 2 do 170 IPASS = 1, MPASS if(STAR) then if(NARROW) then if(IPASS .eq. 1) then cc write(*,221) Continue else cc write(*,222) Continue endif else cc write (*,220) Continue endif else if(NARROW) then if(IPASS .eq. 1) then cc write(UNIT,221) Continue else cc write(UNIT,222) Continue endif else cc write (UNIT,220) Continue endif endif c The following stmt converts from c integer to floating-point. A3 = WORK(1) A4 = sqrt(A3/ max(1,MDATA)) if(STAR) then if(NARROW) then if(IPASS .eq. 1) then cc write(*,231) A4 Continue else cc write(*,232) A3, A4 Continue endif else cc write (*,230) A3,A4 Continue endif else if(NARROW) then if(IPASS .eq. 1) then cc write(UNIT,231) A4 Continue else cc write(UNIT,232) A3, A4 Continue endif else cc write (UNIT,230) A3,A4 Continue endif endif C DO 160 K = 1,MINMN if (SING(K).EQ.ZERO) then PCOEF = ZERO if(STAR) then cc write (*,240) K,SING(K) Continue else cc write (UNIT,240) K,SING(K) Continue endif else PCOEF = B(K) / SING(K) A1 = ONE / SING(K) A2 = B(K)**2 A3 = WORK(K+1) A4 = sqrt(A3/max(1,MDATA-K)) if(STAR) then if(NARROW) then if(IPASS .eq. 1) then cc write(*,240) K,SING(K),PCOEF,A1,B(K), A4 Continue else cc write(*,240) K,SING(K), B(K),A2,A3,A4 Continue endif else cc write (*,240) K,SING(K),PCOEF,A1,B(K),A2,A3,A4 Continue endif else if(NARROW) then if(IPASS .eq. 1) then cc write(UNIT,240) K,SING(K),PCOEF,A1,B(K), A4 Continue else cc write(UNIT,240) K,SING(K), B(K),A2,A3,A4 Continue endif else cc write (UNIT,240) K,SING(K),PCOEF,A1,B(K),A2,A3,A4 Continue endif endif endif 160 continue 170 continue endif c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if( BLK(4) ) then C C Compute and print values of YNORM, RNORM and their logarithms. C if(STAR) then cc write (*,300) Continue else cc write (UNIT,300) Continue endif YSQ = ZERO do 180 J = 0, NSOL if(J .ne. 0) YSQ = YSQ + (B(J) / SING(J))**2 YNORM = sqrt(YSQ) RNORM = sqrt(WORK(J+1)) YL = -THOU IF (YNORM .GT. ZERO) YL = log10(YNORM) RL = -THOU IF (RNORM .GT. ZERO) RL = log10(RNORM) if(STAR) then cc write (*,310) J,YNORM,RNORM,YL,RL Continue else cc write (UNIT,310) J,YNORM,RNORM,YL,RL Continue endif 180 continue endif c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if( BLK(5) .and. SING(1) .ne. ZERO ) then C C COMPUTE VALUES OF XNORM AND RNORM FOR A SEQUENCE OF VALUES OF C THE LEVENBERG-MARQUARDT PARAMETER. C EL = log10(SING(1)) + ONE EL2 = log10(SING(NSOL)) - ONE DEL = (EL2-EL) / TWENTY ALN10 = log(TEN) if(STAR) then cc write (*,320) Continue else cc write (UNIT,320) Continue endif DO 200 IE = 1,21 C COMPUTE ALAMB = 10.0**EL ALAMB = EXP(ALN10*EL) YS = ZERO RS = WORK(NSOL+1) DO 190 I = 1,MINMN SL = SING(I)**2 + ALAMB**2 YS = YS + (B(I)*SING(I)/SL)**2 RS = RS + (B(I)*(ALAMB**2)/SL)**2 190 CONTINUE YNORM = sqrt(YS) RNORM = sqrt(RS) RL = -THOU IF (RNORM.GT.ZERO) RL = log10(RNORM) YL = -THOU IF (YNORM.GT.ZERO) YL = log10(YNORM) if(STAR) then cc write (*,330) ALAMB,YNORM,RNORM,EL,YL,RL Continue else cc write (UNIT,330) ALAMB,YNORM,RNORM,EL,YL,RL Continue endif EL = EL + DEL 200 CONTINUE endif c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C Compute and optionally print candidate solutions. C do 215 K = 1,NSOL PCOEF = B(K) / SING(K) DO 210 I = 1,N A(I,K) = A(I,K) * PCOEF IF (K.GT.1) A(I,K) = A(I,K) + A(I,K-1) 210 END DO 215 continue if (BLK(6) .and. NSOL.GE.1) * CALL MFEOUT (N,NSOL,NAMES,2,UNIT,WIDTH) c * CALL MFEOUT (A,MDA,N,NSOL,NAMES,2,UNIT,WIDTH) return END C SUBROUTINE SVDRS (A, MDA, M1, N1, B, MDB, NB, S, WORK) c C SINGULAR VALUE DECOMPOSITION ALSO TREATING RIGHT SIDE VECTOR. c c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1974 SEP 25, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. C ------------------------------------------------------------------ c This 1995 version differs from the original 1974 version by adding c the argument WORK(). c WORK() provides 2*N1 locations of work space. Originally S() was c required to have 3*N1 elements, of which the last 2*N1 were used for c work space. Now S() only needs N1 elements. C ------------------------------------------------------------------ c This subroutine computes the singular value decomposition of the c given M1 x N1 matrix, A, and optionally applys the transformations c from the left to the NB column vectors of the M1 x NB matrix B. c Either M1 .ge. N1 or M1 .lt. N1 is permitted. c c The singular value decomposition of A is of the form c c A = U * S * V**t c c where U is M1 x M1 orthogonal, S is M1 x N1 diagonal with the c diagonal terms nonnegative and ordered from large to small, and c V is N1 x N1 orthogonal. Note that these matrices also satisfy c c S = (U**t) * A * V c c The matrix V is returned in the leading N1 rows and c columns of the array A(,). c c The singular values, i.e. the diagonal terms of the matrix S, c are returned in the array S(). If M1 .lt. N1, positions M1+1 c through N1 of S() will be set to zero. c c The product matrix G = U**t * B replaces the given matrix B c in the array B(,). c c If the user wishes to obtain a minimum length least squares c solution of the linear system c c A * X ~=~ B c c the solution X can be constructed, following use of this subroutine, c by computing the sum for i = 1, ..., R of the outer products c c (Col i of V) * (1/S(i)) * (Row i of G) c c Here R denotes the pseudorank of A which the user may choose c in the range 0 through Min(M1, N1) based on the sizes of the c singular values. C ------------------------------------------------------------------ C Subroutine Arguments c c A(,) (In/Out) On input contains the M1 x N1 matrix A. c On output contains the N1 x N1 matrix V. c c LDA (In) First dimensioning parameter for A(,). c Require LDA .ge. Max(M1, N1). c c M1 (In) No. of rows of matrices A, B, and G. c Require M1 > 0. c c N1 (In) No. of cols of matrix A, No. of rows and cols of c matrix V. Permit M1 .ge. N1 or M1 .lt. N1. c Require N1 > 0. c c B(,) (In/Out) If NB .gt. 0 this array must contain an c M1 x NB matrix on input and will contain the c M1 x NB product matrix, G = (U**t) * B on output. c c LDB (In) First dimensioning parameter for B(,). c Require LDB .ge. M1. c c NB (In) No. of cols in the matrices B and G. c Require NB .ge. 0. c c S() (Out) Must be dimensioned at least N1. On return will c contain the singular values of A, with the ordering c S(1) .ge. S(2) .ge. ... .ge. S(N1) .ge. 0. c If M1 .lt. N1 the singular values indexed from M1+1 c through N1 will be zero. c If the given integer arguments are not consistent, this c subroutine will return immediately, setting S(1) = -1.0. c c WORK() (Scratch) Work space of total size at least 2*N1. c Locations 1 thru N1 will hold the off-diagonal terms of c the bidiagonal matrix for subroutine QRBD. Locations N1+1 c thru 2*N1 will save info from one call to the next of c H12. c ------------------------------------------------------------------ C This code gives special treatment to rows and columns that are c entirely zero. This causes certain zero sing. vals. to appear as c exact zeros rather than as about MACHEPS times the largest sing. val. c It similarly cleans up the associated columns of U and V. c c METHOD.. c 1. EXCHANGE COLS OF A TO PACK NONZERO COLS TO THE LEFT. c SET N = NO. OF NONZERO COLS. c USE LOCATIONS A(1,N1),A(1,N1-1),...,A(1,N+1) TO RECORD THE c COL PERMUTATIONS. c 2. EXCHANGE ROWS OF A TO PACK NONZERO ROWS TO THE TOP. c QUIT PACKING IF FIND N NONZERO ROWS. MAKE SAME ROW EXCHANGES c IN B. SET M SO THAT ALL NONZERO ROWS OF THE PERMUTED A c ARE IN FIRST M ROWS. IF M .LE. N THEN ALL M ROWS ARE c NONZERO. IF M .GT. N THEN THE FIRST N ROWS ARE KNOWN c TO BE NONZERO,AND ROWS N+1 THRU M MAY BE ZERO OR NONZERO. c 3. APPLY ORIGINAL ALGORITHM TO THE M BY N PROBLEM. c 4. MOVE PERMUTATION RECORD FROM A(,) TO S(I),I=N+1,...,N1. c 5. BUILD V UP FROM N BY N TO N1 BY N1 BY PLACING ONES ON c THE DIAGONAL AND ZEROS ELSEWHERE. THIS IS ONLY PARTLY DONE c EXPLICITLY. IT IS COMPLETED DURING STEP 6. c 6. EXCHANGE ROWS OF V TO COMPENSATE FOR COL EXCHANGES OF STEP 2. c 7. PLACE ZEROS IN S(I),I=N+1,N1 TO REPRESENT ZERO SING VALS. c ------------------------------------------------------------------ subroutine SVDRS (A, MDA, M1, N1, B, MDB, NB, S, WORK) integer I, IPASS, J, K, L, M, MDA, MDB, M1 integer N, NB, N1, NP1, NS, NSP1 c double precision A(MDA,N1),B(MDB,NB), S(N1) double precision A(MDA, *),B(MDB, *), S( *) double precision ONE, T, WORK(N1,2), ZERO parameter(ONE = 1.0d0, ZERO = 0.0d0) c -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - C BEGIN.. SPECIAL FOR ZERO ROWS AND COLS. C C PACK THE NONZERO COLS TO THE LEFT C N=N1 IF (N.LE.0.OR.M1.LE.0) RETURN J=N 10 CONTINUE DO 20 I=1,M1 IF (A(I,J) .ne. ZERO) go to 50 20 CONTINUE C C COL J IS ZERO. EXCHANGE IT WITH COL N. C IF (J .ne. N) then DO 30 I=1,M1 A(I,J)=A(I,N) 30 END DO endif A(1,N)=J N=N-1 50 CONTINUE J=J-1 IF (J.GE.1) GO TO 10 C IF N=0 THEN A IS ENTIRELY ZERO AND SVD C COMPUTATION CAN BE SKIPPED NS=0 IF (N.EQ.0) GO TO 240 C PACK NONZERO ROWS TO THE TOP C QUIT PACKING IF FIND N NONZERO ROWS I=1 M=M1 60 IF (I.GT.N.OR.I.GE.M) GO TO 150 IF (A(I,I) .NE. 0.0d0) GOTO 90 DO 80 J=1,N IF (A(I,J) .NE. 0.0d0) GOTO 90 80 CONTINUE GO TO 100 90 I=I+1 GO TO 60 C ROW I IS ZERO C EXCHANGE ROWS I AND M 100 IF(NB.LE.0) GO TO 115 DO 110 J=1,NB T=B(I,J) B(I,J)=B(M,J) B(M,J)=T 110 END DO 115 DO 120 J=1,N A(I,J)=A(M,J) 120 END DO IF (M.GT.N) GO TO 140 DO 130 J=1,N A(M,J)=ZERO 130 END DO 140 CONTINUE C EXCHANGE IS FINISHED M=M-1 GO TO 60 C 150 CONTINUE C END.. SPECIAL FOR ZERO ROWS AND COLUMNS C BEGIN.. SVD ALGORITHM C METHOD.. C (1) REDUCE THE MATRIX TO UPPER BIDIAGONAL FORM WITH C HOUSEHOLDER TRANSFORMATIONS. C H(N)...H(1)AQ(1)...Q(N-2) = (D**T,0)**T C WHERE D IS UPPER BIDIAGONAL. C C (2) APPLY H(N)...H(1) TO B. HERE H(N)...H(1)*B REPLACES B C IN STORAGE. C C (3) THE MATRIX PRODUCT W= Q(1)...Q(N-2) OVERWRITES THE FIRST C N ROWS OF A IN STORAGE. C C (4) AN SVD FOR D IS COMPUTED. HERE K ROTATIONS RI AND PI ARE C COMPUTED SO THAT C RK...R1*D*P1**(T)...PK**(T) = DIAG(S1,...,SM) C TO WORKING ACCURACY. THE SI ARE NONNEGATIVE AND NONINCREASING. C HERE RK...R1*B OVERWRITES B IN STORAGE WHILE C A*P1**(T)...PK**(T) OVERWRITES A IN STORAGE. C C (5) IT FOLLOWS THAT,WITH THE PROPER DEFINITIONS, C U**(T)*B OVERWRITES B, WHILE V OVERWRITES THE FIRST N ROW AND C COLUMNS OF A. C L=min(M,N) C THE FOLLOWING LOOP REDUCES A TO UPPER BIDIAGONAL AND C ALSO APPLIES THE PREMULTIPLYING TRANSFORMATIONS TO B. C DO 170 J=1,L IF (J.GE.M) GO TO 160 CALL H12 (1,J,J+1,M,A(1,J),1,T,A(1,J+1),1,MDA,N-J) CALL H12 (2,J,J+1,M,A(1,J),1,T,B,1,MDB,NB) 160 IF (J.GE.N-1) GO TO 170 CALL H12 (1,J+1,J+2,N,A(J,1),MDA,work(J,2),A(J+1,1),MDA,1,M-J) 170 CONTINUE C C COPY THE BIDIAGONAL MATRIX INTO S() and WORK() FOR QRBD. C 1986 Jan 8. C. L. Lawson. Changed N to L in following 2 statements. IF (L.EQ.1) GO TO 190 DO 180 J=2,L S(J)=A(J,J) WORK(J,1)=A(J-1,J) 180 END DO 190 S(1)=A(1,1) C NS=N IF (M.GE.N) GO TO 200 NS=M+1 S(NS)=ZERO WORK(NS,1)=A(M,M+1) 200 CONTINUE C C CONSTRUCT THE EXPLICIT N BY N PRODUCT MATRIX, W=Q1*Q2*...*QL*I C IN THE ARRAY A(). C DO 230 K=1,N I=N+1-K IF (I .GT. min(M,N-2)) GO TO 210 CALL H12 (2,I+1,I+2,N,A(I,1),MDA,WORK(I,2),A(1,I+1),1,MDA,N-I) 210 DO 220 J=1,N A(I,J)=ZERO 220 END DO A(I,I)=ONE 230 END DO C C COMPUTE THE SVD OF THE BIDIAGONAL MATRIX C CALL QRBD (IPASS,S(1),WORK(1,1),NS,A,MDA,N,B,MDB,NB) C if(IPASS .eq. 2) then cc write (*,'(/a)') cc * ' FULL ACCURACY NOT ATTAINED IN BIDIAGONAL SVD' Continue endif 240 CONTINUE IF (NS.GE.N) GO TO 260 NSP1=NS+1 DO 250 J=NSP1,N S(J)=ZERO 250 END DO 260 CONTINUE IF (N.EQ.N1) RETURN NP1=N+1 C MOVE RECORD OF PERMUTATIONS C AND STORE ZEROS DO 280 J=NP1,N1 S(J)=A(1,J) DO 270 I=1,N A(I,J)=ZERO 270 END DO 280 CONTINUE C PERMUTE ROWS AND SET ZERO SINGULAR VALUES. DO 300 K=NP1,N1 I=NINT(S(K)) S(K)=ZERO DO 290 J=1,N1 A(K,J)=A(I,J) A(I,J)=ZERO 290 END DO A(I,K)=ONE 300 CONTINUE C END.. SPECIAL FOR ZERO ROWS AND COLUMNS RETURN END lsei/src/pnnls.f0000644000176200001440000003211513725034275013310 0ustar liggesusersC ================================================================== C Subroutine for solving the partial NNLS problem, modified from the C NNLS subroutine downloaded from C http://www.netlib.org/lawson-hanson/all. (Yong Wang, Department C of Statistics, University of Auckland, New Zealand. Email: C yongwang@auckland.ac.nz) C ================================================================== C SUBROUTINE PNNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE,K) C C Algorithm NNLS: NONNEGATIVE LEAST SQUARES C c The original version of this code was developed by c Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory c 1973 JUN 15, and published in the book c "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974. c Revised FEB 1995 to accompany reprinting of the book by SIAM. c C GIVEN AN M BY N MATRIX, A, AND AN M-VECTOR, B, COMPUTE AN C N-VECTOR, X, THAT SOLVES THE LEAST SQUARES PROBLEM C C A * X = B SUBJECT TO X .GE. 0 C ------------------------------------------------------------------ c Subroutine Arguments c C A(),MDA,M,N MDA IS THE FIRST DIMENSIONING PARAMETER FOR THE C ARRAY, A(). ON ENTRY A() CONTAINS THE M BY N C MATRIX, A. ON EXIT A() CONTAINS C THE PRODUCT MATRIX, Q*A , WHERE Q IS AN C M BY M ORTHOGONAL MATRIX GENERATED IMPLICITLY BY C THIS SUBROUTINE. C B() ON ENTRY B() CONTAINS THE M-VECTOR, B. ON EXIT B() CON- C TAINS Q*B. C X() ON ENTRY X() NEED NOT BE INITIALIZED. ON EXIT X() WILL C CONTAIN THE SOLUTION VECTOR. C RNORM ON EXIT RNORM CONTAINS THE EUCLIDEAN NORM OF THE C RESIDUAL VECTOR. C W() AN N-ARRAY OF WORKING SPACE. ON EXIT W() WILL CONTAIN C THE DUAL SOLUTION VECTOR. W WILL SATISFY W(I) = 0. C FOR ALL I IN SET P AND W(I) .LE. 0. FOR ALL I IN SET Z C ZZ() AN M-ARRAY OF WORKING SPACE. C INDEX() AN INTEGER WORKING ARRAY OF LENGTH AT LEAST N. C ON EXIT THE CONTENTS OF THIS ARRAY DEFINE THE SETS C P AND Z AS FOLLOWS.. C C INDEX(1) THRU INDEX(NSETP) = SET P. C INDEX(IZ1) THRU INDEX(IZ2) = SET Z. C IZ1 = NSETP + 1 = NPP1 C IZ2 = N C MODE THIS IS A SUCCESS-FAILURE FLAG WITH THE FOLLOWING C MEANINGS. C 1 THE SOLUTION HAS BEEN COMPUTED SUCCESSFULLY. C 2 THE DIMENSIONS OF THE PROBLEM ARE BAD. C EITHER M .LE. 0 OR N .LE. 0. C 3 ITERATION COUNT EXCEEDED. MORE THAN 3*N ITERATIONS. C C C K The first K variables are not NN-restricted, but they are C subject to the examination of linear dependence and some C of them may be excluded C C ------------------------------------------------------------------ SUBROUTINE PNNLS (A,MDA,M,N,B,X,RNORM,W,ZZ,INDEX,MODE,K) C ------------------------------------------------------------------ integer I, II, IP, ITER, ITMAX, IZ, IZ1, IZ2, IZMAX, J, JJ, JZ, L integer M, MDA, MODE,N, NPP1, NSETP, RTNKEY, K, NK c integer INDEX(N) c double precision A(MDA,N), B(M), W(N), X(N), ZZ(M) integer INDEX(*) double precision A(MDA,*), B(*), W(*), X(*), ZZ(*) double precision ALPHA, ASAVE, CC, DIFF, DUMMY(MDA), FACTOR, RNORM double precision SM, SS, T, TEMP, TWO, UNORM, UP, WMAX double precision ZERO, ZTEST parameter(FACTOR = 0.01d0) parameter(TWO = 2.0d0, ZERO = 0.0d0) C ------------------------------------------------------------------ JJ=0 MODE=1 IF (M .le. 0 .or. N .le. 0) then MODE=2 RETURN endif ITER=0 ITMAX=3*N C C INITIALIZE THE ARRAYS INDEX() AND X(). C DO 20 I=1,N X(I)=ZERO INDEX(I)=I 20 enddo C IZ2=N C --- Yong's code starts here --- IZ1=K+1 NK=0 C Householder transformation for the frist K variables if (K .gt. 0) go to 500 K=NK NSETP=K NPP1=NSETP+1 go to 30 500 do 560 JK=1, K J = INDEX(NK+1) ASAVE=A(NK+1,J) CALL H12 (1,NK+1,NK+2,M,A(1,J),1,UP,DUMMY,1,1,0) UNORM=ZERO IF (NK .ne. 0) then DO 510 L=1,NK UNORM=UNORM+A(L,J)**2 510 enddo endif UNORM=sqrt(UNORM) IF (DIFF(UNORM+ABS(A(NK+1,J))*FACTOR,UNORM) .gt. ZERO) then CALL H12 (2,NK+1,NK+2,M,A(1,J),1,UP,B,1,1,1) NK=NK+1 DO 520 JZ=NK+1,IZ2 JJ=INDEX(JZ) CALL H12 (2,NK,NK+1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1) 520 continue IF (NK .ne. M) then DO 530 L=NK+1,M A(L,J)=ZERO 530 enddo endif else A(NK+1,J)=ASAVE if (NK+1 .le. IZ1-2) then do 540 IK=NK+1,IZ1-2 INDEX(IK) = INDEX(IK+1) 540 enddo endif if (IZ1 .le. IZ2) then do 550 IK=IZ1,IZ2 INDEX(IK-1) = INDEX(IK) 550 enddo endif INDEX(IZ2) = J IZ1=IZ1-1 endif 560 continue K=NK NSETP=K NPP1=NSETP+1 RTNKEY=3 JJ=NSETP do 570 IP=1,NK ZZ(IP)=B(IP) 570 enddo go to 400 580 continue do 590 IP=1,NK L = INDEX(IP) X(L)=ZZ(IP) 590 end do C Up to this point, the vector INDEX has two parts: the first K elements C store the indexes of free variables, and the remaining ones for those C initially allocated to set Z (zero). C --- Yong's code ends here --- C ****** MAIN LOOP BEGINS HERE ****** 30 CONTINUE C QUIT IF ALL COEFFICIENTS ARE ALREADY IN THE SOLUTION. C OR IF M COLS OF A HAVE BEEN TRIANGULARIZED. C IF (IZ1 .GT.IZ2.OR.NSETP.GE.M) GO TO 350 C C COMPUTE COMPONENTS OF THE DUAL (NEGATIVE GRADIENT) VECTOR W(). C DO 50 IZ=IZ1,IZ2 J=INDEX(IZ) SM=ZERO DO 40 L=NPP1,M SM=SM+A(L,J)*B(L) 40 enddo W(J)=SM 50 continue C FIND LARGEST POSITIVE W(J). 60 continue WMAX=ZERO IZMAX=0 DO 70 IZ=IZ1,IZ2 J=INDEX(IZ) IF (W(J) .gt. WMAX) then WMAX=W(J) IZMAX=IZ endif 70 CONTINUE C C IF WMAX .LE. 0. GO TO TERMINATION. C THIS INDICATES SATISFACTION OF THE KUHN-TUCKER CONDITIONS. C IF (WMAX .le. ZERO) go to 350 IZ=IZMAX J=INDEX(IZ) C C THE SIGN OF W(J) IS OK FOR J TO BE MOVED TO SET P. C BEGIN THE TRANSFORMATION AND CHECK NEW DIAGONAL ELEMENT TO AVOID C NEAR LINEAR DEPENDENCE. C ASAVE=A(NPP1,J) CALL H12 (1,NPP1,NPP1+1,M,A(1,J),1,UP,DUMMY,1,1,0) UNORM=ZERO IF (NSETP .ne. 0) then DO 90 L=1,NSETP UNORM=UNORM+A(L,J)**2 90 enddo endif UNORM=sqrt(UNORM) IF (DIFF(UNORM+ABS(A(NPP1,J))*FACTOR,UNORM) .gt. ZERO) then C C COL J IS SUFFICIENTLY INDEPENDENT. COPY B INTO ZZ, UPDATE ZZ C AND SOLVE FOR ZTEST ( = PROPOSED NEW VALUE FOR X(J) ). C DO 120 L=1,M ZZ(L)=B(L) 120 enddo CALL H12 (2,NPP1,NPP1+1,M,A(1,J),1,UP,ZZ,1,1,1) ZTEST=ZZ(NPP1)/A(NPP1,J) C C SEE IF ZTEST IS POSITIVE C IF (ZTEST .gt. ZERO) go to 140 endif C C REJECT J AS A CANDIDATE TO BE MOVED FROM SET Z TO SET P. C RESTORE A(NPP1,J), SET W(J)=0., AND LOOP BACK TO TEST DUAL C COEFFS AGAIN. C A(NPP1,J)=ASAVE W(J)=ZERO GO TO 60 C C THE INDEX J=INDEX(IZ) HAS BEEN SELECTED TO BE MOVED FROM C SET Z TO SET P. UPDATE B, UPDATE INDICES, APPLY HOUSEHOLDER C TRANSFORMATIONS TO COLS IN NEW SET Z, ZERO SUBDIAGONAL ELTS IN C COL J, SET W(J)=0. C 140 continue DO 150 L=1,M B(L)=ZZ(L) 150 enddo C INDEX(IZ)=INDEX(IZ1) INDEX(IZ1)=J IZ1=IZ1+1 NSETP=NPP1 NPP1=NPP1+1 C IF (IZ1 .le. IZ2) then DO 160 JZ=IZ1,IZ2 JJ=INDEX(JZ) CALL H12 (2,NSETP,NPP1,M,A(1,J),1,UP,A(1,JJ),1,MDA,1) 160 continue endif C IF (NSETP .ne. M) then DO 180 L=NPP1,M A(L,J)=ZERO 180 enddo endif C W(J)=ZERO C SOLVE THE TRIANGULAR SYSTEM. C STORE THE SOLUTION TEMPORARILY IN ZZ(). RTNKEY = 1 GO TO 400 200 CONTINUE C C ****** SECONDARY LOOP BEGINS HERE ****** C C ITERATION COUNTER. C 210 continue ITER=ITER+1 IF (ITER .gt. ITMAX) then MODE=3 cc write (*,'(/a)') ' NNLS quitting on iteration count.' Continue GO TO 350 endif C C SEE IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE. C IF NOT COMPUTE ALPHA. C ALPHA=TWO DO 240 IP=K+1,NSETP L=INDEX(IP) IF (ZZ(IP) .le. ZERO) then T=-X(L)/(ZZ(IP)-X(L)) IF (ALPHA .gt. T) then ALPHA=T JJ=IP endif endif 240 CONTINUE C C IF ALL NEW CONSTRAINED COEFFS ARE FEASIBLE THEN ALPHA WILL C STILL = 2. IF SO EXIT FROM SECONDARY LOOP TO MAIN LOOP. C IF (ALPHA.EQ.TWO) GO TO 330 C C OTHERWISE USE ALPHA WHICH WILL BE BETWEEN 0. AND 1. TO C INTERPOLATE BETWEEN THE OLD X AND THE NEW ZZ. C DO 250 IP=K+1,NSETP L=INDEX(IP) X(L)=X(L)+ALPHA*(ZZ(IP)-X(L)) 250 continue C C MODIFY A AND B AND THE INDEX ARRAYS TO MOVE COEFFICIENT I C FROM SET P TO SET Z. C I=INDEX(JJ) 260 continue X(I)=ZERO C IF (JJ .ne. NSETP) then JJ=JJ+1 DO 280 J=JJ,NSETP II=INDEX(J) INDEX(J-1)=II CALL G1 (A(J-1,II),A(J,II),CC,SS,A(J-1,II)) A(J,II)=ZERO DO 270 L=1,N IF (L.NE.II) then c c Apply procedure G2 (CC,SS,A(J-1,L),A(J,L)) c TEMP = A(J-1,L) A(J-1,L) = CC*TEMP + SS*A(J,L) A(J,L) =-SS*TEMP + CC*A(J,L) endif 270 CONTINUE c c Apply procedure G2 (CC,SS,B(J-1),B(J)) c TEMP = B(J-1) B(J-1) = CC*TEMP + SS*B(J) B(J) =-SS*TEMP + CC*B(J) 280 continue endif c NPP1=NSETP NSETP=NSETP-1 IZ1=IZ1-1 INDEX(IZ1)=I C C SEE IF THE REMAINING COEFFS IN SET P ARE FEASIBLE. THEY SHOULD C BE BECAUSE OF THE WAY ALPHA WAS DETERMINED. C IF ANY ARE INFEASIBLE IT IS DUE TO ROUND-OFF ERROR. ANY C THAT ARE NONPOSITIVE WILL BE SET TO ZERO C AND MOVED FROM SET P TO SET Z. C DO 300 JJ=K+1,NSETP I=INDEX(JJ) IF (X(I) .le. ZERO) go to 260 300 CONTINUE C C COPY B( ) INTO ZZ( ). THEN SOLVE AGAIN AND LOOP BACK. C DO 310 I=1,M ZZ(I)=B(I) 310 enddo RTNKEY = 2 GO TO 400 320 CONTINUE GO TO 210 C ****** END OF SECONDARY LOOP ****** C 330 continue DO 340 IP=1,NSETP I=INDEX(IP) X(I)=ZZ(IP) 340 enddo C ALL NEW COEFFS ARE POSITIVE. LOOP BACK TO BEGINNING. GO TO 30 C C ****** END OF MAIN LOOP ****** C C COME TO HERE FOR TERMINATION. C COMPUTE THE NORM OF THE FINAL RESIDUAL VECTOR. C 350 continue SM=ZERO IF (NPP1 .le. M) then DO 360 I=NPP1,M SM=SM+B(I)**2 360 enddo else DO 380 J=K+1,N W(J)=ZERO 380 enddo endif RNORM=sqrt(SM) RETURN C C THE FOLLOWING BLOCK OF CODE IS USED AS AN INTERNAL SUBROUTINE C TO SOLVE THE TRIANGULAR SYSTEM, PUTTING THE SOLUTION IN ZZ(). C 400 continue DO 430 L=1,NSETP IP=NSETP+1-L IF (L .ne. 1) then DO 410 II=1,IP ZZ(II)=ZZ(II)-A(II,JJ)*ZZ(IP+1) 410 continue endif JJ=INDEX(IP) ZZ(IP)=ZZ(IP)/A(IP,JJ) 430 continue c go to (200, 320, 580), RTNKEY if (RTNKEY .eq. 1) goto 200 if (RTNKEY .eq. 2) goto 320 if (RTNKEY .eq. 3) goto 580 END lsei/R/0000755000176200001440000000000013725253302011411 5ustar liggesuserslsei/R/utils.R0000644000176200001440000000466613724331746012720 0ustar liggesusers##'Index-finding in a Sorted Vector ##' ##' ##'For each of given values, \code{indx} finds the index of the value in a ##'vector sorted in ascending order that the given value is barely greater than ##'or equal to. ##' ##'For each x[i], the function returns integer j such that \deqn{v_j \le x_i < ##'v_{j+1}}{v[j] <= x[i] < v[j+1]} where \eqn{v_0 = - \infty \mathrm{ and } ##'v_{n+1} = \infty}{v[0] = -Inf and v[n+1] = Inf}. ##' ##'@param x vector of numeric values, the indices of which are to be found. ##'@param v vector of numeric values sorted in ascending order. ##'@return Returns a vector of integers, that are indices of x-values in vector ##'v. ##'@author Yong Wang ##'@keywords array algebra ##'@examples ##' ##'indx(0:6,c(1:5,5)) ##'indx(sort(rnorm(5)),-2:2) ##' ##'@export indx indx = function(x, v) { m = length(x) n = length(v) x = pmax(v[1] - 1e300, pmin(v[n] + 1e300, x)) # x may contain -Inf or Inf storage.mode(x) = storage.mode(v) = "double" ind = integer(m) .C("indx", x, m, v, n, ind=ind, PACKAGE="lsei")["ind"]$ind } ## # Much slower than indx(). ## ## indx2 = function(x, v) { ## ox = order(x) ## vx = c(v,x) ## o = order(vx) ## indo = c(rep(1, length(v)), rep(0, length(x)))[o] ## indx = double(length(x)) ## indx[ox] = cumsum(indo)[indo == 0] ## indx ## } ##'Row or Column Maximum Values of a Matrix ##' ##' ##'Finds either row or column maximum values of a matrix. ##' ##'Matrix \code{x} may contain \code{Inf} or \code{-Inf}, but not \code{NA} or ##'\code{NaN}. ##' ##'@param x numeric matrix. ##'@param dim \code{=1}, for row maximum values; \code{=2}, for column maximum ##'values. ##'@return Returns a numeric vector with row or column maximum values. ##' ##'The function is very much the same as using \code{apply(x, 1, max)} or ##'\code{apply(x, 2, max)}, but faster. ##'@author Yong Wang ##'@keywords array algebra ##'@examples ##' ##'x = cbind(c(1:4,Inf), 5:1) ##'matMaxs(x) ##'matMaxs(x, 2) ##' ##'@export matMaxs matMaxs = function(x, dim=1) { if(length(x) == 0) return(NULL) x.mode = storage.mode(x) n = nrow(x) m = ncol(x) v = if(dim == 1) double(n) else double(m) storage.mode(dim) = storage.mode(n) = storage.mode(m) = "integer" x[x == Inf] = 1e308 x[x == -Inf] = -1e308 storage.mode(x) = "double" v = .C("matMaxs", x, n, m, v=v, dim, PACKAGE="lsei")["v"]$v v[v > 9e307] = Inf v[v < -9e307] = -Inf storage.mode(v) = x.mode v } lsei/R/lsei.R0000644000176200001440000005345713725253251012511 0ustar liggesusers##' Least Squares and Quadratic Programming under Nonnegativity ##' Constraints ##' ##' ##' These functions are particularly useful for solving least squares ##' or quadratic programming problems when some or all of the solution ##' values are subject to nonnegativity constraint. One may further ##' restrict the NN-restricted coefficients to have a fixed positive ##' sum. ##' ##' Function \code{nnls} solves the least squares problem under ##' nonnegativity (NN) constraints. It is an R interface to the NNLS ##' function that is described in Lawson and Hanson (1974, 1995). Its ##' Fortran implementation is public domain and available at ##' \url{http://www.netlib.org/lawson-hanson/} (with slight ##' modifications by Yong Wang for compatibility with the lastest ##' Fortran compiler.) ##' ##' Given matrix \code{a} and vector \code{b}, \code{nnls} solves the ##' nonnegativity least squares problem: ##' ##' \deqn{\mathrm{minimize \ \ } || a x - b ||,}{minimize || a x - b ||,} ##' \deqn{\mathrm{\ \ \ subject\ to\ \ } x \ge 0.}{ subject to x >= 0.} ##' ##' Function \code{pnnls} also solves the above nonnegativity least ##' squares problem when \code{k=0}, but it may also leave the first ##' \code{k} coefficients unrestricted. The output value of \code{k} ##' can be smaller than the input one, if \code{a} has linearly ##' dependent columns. If \code{sum} is a positive value, \code{pnnls} ##' solves the problem by further restricting that the NN-restricted ##' coefficients must sum to the given value. ##' ##' Function \code{pnnqp} solves the quadratic programming problem ##' ##' \deqn{\mathrm{minimize\ \ } \frac12 x^T q x + p^T x,}{minimize 0.5 x^T q x + ##' p^T x,} ##' ##' when only some or all coefficients are restricted by ##' nonnegativity. The quadratic programming problem is solved by ##' transforming the problem into a least squares one under the same ##' constraints, which is then solved by function ##' \code{pnnls}. Arguments \code{k} and \code{sum} have the same ##' meanings as for \code{pnnls}. ##' ##' Functions \code{nnls}, \code{pnnls} and \code{pnnqp} are able to ##' return any zero-valued solution as 0 exactly. This differs from ##' functions \code{lsei} and \code{qp}, which may produce very small ##' values for exactly 0s, thanks to numerical errors. ##' ##'@aliases nnls pnnls pnnqp ##'@param a Design matrix. ##'@param b Response vector. ##'@param k Integer, meaning that the first \code{k} coefficients are not ##'NN-restricted. ##'@param sum = NULL, if NN-restricted coefficients are not further restricted ##'to have a fixed sum; ##' ##'= a positive value, if NN-restricted coefficients are further restricted to ##'have a fixed positive sum. ##'@param q Positive semidefinite matrix of numeric values for the quadratic ##'term of a quadratic programming problem. ##'@param p Vector of numeric values for the linear term of a quadratic ##'programming problem. ##'@param tol Tolerance used for calculating pseudo-rank of \code{q}. ##'@return ##' ##'\item{x}{Solution} ##' ##'\item{r}{The upper-triangular matrix \code{Q*a}, pivoted by variables in the ##'order of \code{index}, when \code{sum=NULL}. If \code{sum > 0}, \code{r} is ##'for the transformed \code{a}.} ##' ##'\item{b}{The vector \code{Q*b}, pivoted by variables in the order of ##'\code{index}, when \code{sum=NULL}. If \code{sum > 0}, \code{b} is for the ##'transformed \code{b}.} ##' ##'\item{index}{Indices of the columns of \code{r}; those unrestricted and in ##'the positive set are first given, and then those in the zero set.} ##' ##'\item{rnorm}{Euclidean norm of the residual vector.} ##' ##'\item{mode}{= 1, successful computation; ##' ##'= 2, bad dimensions of the problem; ##' ##'= 3, iteration count exceeded (more than 3 times the number of variables ##'iterations).} ##' ##'\item{k}{Number of the first few coefficients that are truly not ##'NN-restricted.} ##' ##'@author Yong Wang ##'@seealso \code{\link{lsei}}, \code{\link{hfti}}. ##'@references ##' ##'Lawson and Hanson (1974, 1995). Solving Least Squares Problems. Englewood ##'Cliffs, N.J., Prentice-Hall. ##' ##'Dax (1990). The smallest point of a polytope. Journal of Optimization Theory ##'and Applications, 64, pp. 429-432. ##' ##'Wang (2010). Fisher scoring: An interpolation family and its Monte Carlo ##'implementations. Computational Statistics and Data Analysis, 54, pp. ##'1744-1755. ##' ##'@keywords array algebra ##'@examples ##' ##'a = matrix(rnorm(40), nrow=10) ##'b = drop(a %*% c(0,1,-1,1)) + rnorm(10) ##'nnls(a, b)$x # constraint x >= 0 ##'pnnls(a, b, k=0)$x # same as nnls(a, b) ##'pnnls(a, b, k=2)$x # first two coeffs are not NN-constrained ##'pnnls(a, b, k=2, sum=1)$x # NN-constrained coeffs must sum to 1 ##'pnnls(a, b, k=2, sum=2)$x # NN-constrained coeffs must sum to 2 ##'q = crossprod(a) ##'p = -drop(crossprod(b, a)) ##'pnnqp(q, p, k=2, sum=2)$x # same solution ##' ##'pnnls(a, b, sum=1)$x # zeros found exactly ##'pnnqp(q, p, sum=1)$x # zeros found exactly ##'lsei(a, b, rep(1,4), 1, lower=0) # zeros not so exact ##' ##'@usage ##'nnls(a, b) ##'pnnls(a, b, k=0, sum=NULL) ##'pnnqp(q, p, k=0, sum=NULL, tol=1e-20) ##' ##'@export nnls ##'@export pnnls ##'@export pnnqp nnls = function(a, b) { if(!is.vector(b)) b = drop(b) if(!is.matrix(a)) stop("a not matrix") m = nrow(a) n = ncol(a) if(length(b) != m) stop("length(b) != ncol(a)") storage.mode(a) = "double" storage.mode(b) = "double" x = double(n) # only for output rnorm = double(1) # only for output w = x # n-vector of working space zz = b # m-vector of working space index = integer(n) # n-vector index, only for output mode = integer(1) # success-failure flag; = 1, success .Fortran("nnls",r=a,m,m,n,b=b,x=x,rnorm=rnorm,w,zz,index=index, mode=mode,PACKAGE="lsei")[c("x","r","b","index","rnorm","mode")] } pnnls = function(a, b, k=0, sum=NULL) { if(!is.vector(b)) b = drop(b) if(!is.matrix(a)) stop("a not matrix") m = nrow(a) n = ncol(a) if(!is.null(sum)) { if(sum <= 0) stop("Argument 'sum' must be positive or NULL") if(k= ncol(a) (null simplex)") a = rbind(a, c(double(k), rep(1, n-k))) b = c(double(m), 1) m = as.integer(m+1) } if(length(b) != m) stop("length(b) != ncol(a)") storage.mode(a) = "double" storage.mode(b) = "double" x = double(n) # only for output rnorm = double(1) # only for output w = x # n-vector of working space zz = b # m-vector of working space index = integer(n) # n-vector index, only for output mode = integer(1) # success-failure flag; = 1, success k = as.integer(k) r = .Fortran("pnnls",r=a,m,m,n,b=b,x=x,rnorm=rnorm,w,zz,index=index, mode=mode,k=k,PACKAGE="lsei") r$r = r$r[1:min(m,n),] if(!is.null(sum)) { t = sum(r$x[(r$k+1):n]) r$x = r$x / t r$x[(r$k+1):n] = r$x[(r$k+1):n] * sum r$rnorm = sqrt( pmax((r$rnorm/t)^2 - (1 - 1/t)^2, 0) ) } r[c("x","r","b","index","rnorm","mode","k")] } # --------------------------------- # # Least distance programming (LDP): # # # # Minimize ||x|| # # Suject to e x >= f # # --------------------------------- # ## Special treatment: Relax boundaries slightly to ignore negligible ## incompatibility that may be produced numerically. ## Remove constraints with effectively zero coefficients??? ldp = function(e, f) { if(!is.vector(f)) f = drop(f) if(is.vector(e)) dim(e) = c(1, length(e)) f = f - max(abs(f)) * 5e-15 # relax boundaries slightly m = nrow(e) n = ncol(e) # number of variables storage.mode(e) = "double" storage.mode(f) = "double" x = double(n) # only for output xnorm = double(1) # only for output w = double((n+1)*(m+2) + 2*m) # working space index = integer(m) # only for output mode = integer(1) # success-failure flag; = 1, success r = .Fortran("ldp",e,m,m,n,f,x=x,xnorm,w,index,mode=mode, PACKAGE="lsei")[c("x","mode")] if(r$mode != 1) stop("Incompatible constraints in ldp()") r$x } ldp2 = function(e, f, tol=1e-15) { if(!is.vector(f)) f = drop(f) if(is.vector(e)) dim(e) = c(1, length(e)) f = f - max(abs(f)) * 5e-15 # relax boundaries slightly k = ncol(e) # number of variables E = rbind(t(e), t(f)) h = c(double(k), 1) r = E %*% nnls(E, h)$x - h # residuals if(sqrt(sum(r^2)) <= tol) stop("Incompatible inequalities in ldp()") as.vector(-r[1:k] / r[k+1]) } # # Example from Lawson and Hanson. (1974), p.171: # e = cbind(c(-.207,-.392,.599), c(2.558, -1.351, -1.206)) # f = c(-1.3,-.084,.384) # ldp(e, f) # Solution: 0.1268538 -0.2554018 # G = matrix(rnorm(12), nrow=4); h = rnorm(4); x = ldp(G, h); print(x); G %*% x - h # --------------------------------------------------------------- # # Least squares problem with linear inequality constraints (LSI): # # # # Minimize || a x - b || # # Subject to e x >= f # # --------------------------------------------------------------- # lsi = function(a, b, e=NULL, f=NULL, lower=-Inf, upper=Inf) { if(is.vector(e)) dim(e) = c(1, length(e)) if(any(lower != -Inf, upper != Inf)) { k0 = ncol(a) lower = rep(lower, len=k0) upper = rep(upper, len=k0) jl = lower != -Inf ju = upper != Inf e = rbind(e, diag(1, k0)[jl,], diag(-1, k0)[ju,]) f = c(f, lower[jl], -upper[ju]) } if(is.null(e)) return(pnnls(a, b, k=ncol(a))$x) a.svd = svdrs(a, b) k = sum(a.svd$d > max(a.svd$d) * 1e-14) # pseudo-rank P1b = a.svd$uTb[1:k,,drop=FALSE] Q1 = a.svd$v[,1:k,drop=FALSE] et = e %*% sweep(Q1, 2, a.svd$d[1:k], "/") ft = f - et %*% P1b z = ldp2(et, ft) drop(Q1 %*% ((z + P1b) / a.svd$d[1:k])) } # # Example from Lawson and Hanson. (1974), p.170: # a = cbind(c(.25,.5,.5,.8),rep(1,4)); b = c(.5,.6,.7,1.2); e = cbind(c(1,0,-1),c(0,1,-1)); f = c(0,0,-1); lsi(a, b, e, f) # Solution: 0.6213152 0.3786848 # E = matrix(rnorm(24), nrow=8); f = rnorm(8); G = matrix(rnorm(12), nrow=4); h = rnorm(4); x = lsi(E, f, G, h); G %*% x - h # -------------------------------------------------------------------------- # # Least squares problem with both linear equalities and inequalities (LSEI): # # # # Minimize || a x - b || # # Subject to c x = d, e x >= f # # -------------------------------------------------------------------------- # ##'Least Squares and Quadratic Programming under Equality and Inequality Constraints ##' ##' These functions can be used for solving least squares or quadratic ##' programming problems under general equality and/or inequality ##' constraints. ##' ##'The \code{lsei} function solves a least squares problem under both equality ##'and inequality constraints. It is an implementation of the LSEI algorithm ##'described in Lawson and Hanson (1974, 1995). ##' ##'The \code{lsi} function solves a least squares problem under inequality ##'constraints. It is an implementation of the LSI algorithm described in ##'Lawson and Hanson (1974, 1995). ##' ##'The \code{ldp} function solves a least distance programming problem under ##'inequality constraints. It is an R wrapper of the LDP function which is in ##'Fortran, as described in Lawson and Hanson (1974, 1995). ##' ##'The \code{qp} function solves a quadratic programming problem, by ##'transforming the problem into a least squares one under the same equality ##'and inequality constraints, which is then solved by function \code{lsei}. ##' ##'The NNLS and LDP Fortran implementations used internally is downloaded from ##'\url{http://www.netlib.org/lawson-hanson/}. ##' ##' ##'Given matrices \code{a}, \code{c} and \code{e}, and vectors \code{b}, ##'\code{d} and \code{f}, function \code{lsei} solves the least squares problem ##'under both equality and inequality constraints: ##' ##'\deqn{\mathrm{minimize\ \ } || a x - b ||,}{minimize || a x - b ||,} ##'\deqn{\mathrm{subject\ to\ \ } c x = d, e x \ge f.}{subject to c x = d, e x ##'>= f.} ##' ##'Function \code{lsi} solves the least squares problem under inequality ##'constraints: ##' ##'\deqn{\mathrm{minimize\ \ } || a x - b ||,}{minimize || a x - b ||,} ##'\deqn{\mathrm{\ \ \ subject\ to\ \ } e x \ge f.}{subject to e x >= f.} ##' ##'Function \code{ldp} solves the least distance programming problem under ##'inequality constraints: ##' ##'\deqn{\mathrm{minimize\ \ } || x ||,}{minimize || x ||,} \deqn{\mathrm{\ \ \ ##'subject\ to\ \ } e x \ge f.}{subject to e x >= f.} ##' ##'Function \code{qp} solves the quadratic programming problem: ##' ##'\deqn{\mathrm{minimize\ \ } \frac12 x^T q x + p^T x,}{minimize 0.5 x^T q x + ##'p^T x,} \deqn{\mathrm{subject\ to\ \ } c x = d, e x \ge f.}{subject to c x = ##'d, e x >= f.} ##' ##'@aliases lsei lsi ldp qp ##'@param a Design matrix. ##'@param b Response vector. ##'@param c Matrix of numeric coefficients on the left-hand sides of equality ##'constraints. If it is NULL, \code{c} and \code{d} are ignored. ##'@param d Vector of numeric values on the right-hand sides of equality ##'constraints. ##'@param e Matrix of numeric coefficients on the left-hand sides of inequality ##'constraints. If it is NULL, \code{e} and \code{f} are ignored. ##'@param f Vector of numeric values on the right-hand sides of inequality ##'constraints. ##'@param q Matrix of numeric values for the quadratic term of a quadratic ##'programming problem. ##'@param p Vector of numeric values for the linear term of a quadratic ##'programming problem. ##'@param lower,upper Bounds on the solutions, as a way to specify such simple ##'inequality constraints. ##'@param tol Tolerance, for calculating pseudo-rank in \code{qp}. ##'@return A vector of the solution values ##'@author Yong Wang ##'@seealso \code{\link{nnls}},\code{\link{hfti}}. ##'@references Lawson and Hanson (1974, 1995). Solving least squares problems. ##'Englewood Cliffs, N.J., Prentice-Hall. ##'@keywords array algebra ##'@examples ##' ##'beta = c(rnorm(2), 1) ##'beta[beta<0] = 0 ##'beta = beta / sum(beta) ##'a = matrix(rnorm(18), ncol=3) ##'b = a %*% beta + rnorm(3,sd=.1) ##'c = t(rep(1, 3)) ##'d = 1 ##'e = diag(1,3) ##'f = rep(0,3) ##'lsei(a, b) # under no constraint ##'lsei(a, b, c, d) # under eq. constraints ##'lsei(a, b, e=e, f=f) # under ineq. constraints ##'lsei(a, b, c, d, e, f) # under eq. and ineq. constraints ##'lsei(a, b, rep(1,3), 1, lower=0) # same solution ##'q = crossprod(a) ##'p = -drop(crossprod(b, a)) ##'qp(q, p, rep(1,3), 1, lower=0) # same solution ##' ##'## Example from Lawson and Hanson (1974), p.140 ##'a = cbind(c(.4302,.6246), c(.3516,.3384)) ##'b = c(.6593, .9666) ##'c = c(.4087, .1593) ##'d = .1376 ##'lsei(a, b, c, d) # Solution: -1.177499 3.884770 ##' ##'## Example from Lawson and Hanson (1974), p.170 ##'a = cbind(c(.25,.5,.5,.8),rep(1,4)) ##'b = c(.5,.6,.7,1.2) ##'e = cbind(c(1,0,-1),c(0,1,-1)) ##'f = c(0,0,-1) ##'lsi(a, b, e, f) # Solution: 0.6213152 0.3786848 ##' ##'## Example from Lawson and Hanson (1974), p.171: ##'e = cbind(c(-.207,-.392,.599), c(2.558, -1.351, -1.206)) ##'f = c(-1.3,-.084,.384) ##'ldp(e, f) # Solution: 0.1268538 -0.2554018 ##' ##'@usage ##'lsei(a, b, c=NULL, d=NULL, e=NULL, f=NULL, lower=-Inf, upper=Inf) ##'lsi(a, b, e=NULL, f=NULL, lower=-Inf, upper=Inf) ##'ldp(e, f) ##'qp(q, p, c=NULL, d=NULL, e=NULL, f=NULL, lower=-Inf, upper=Inf, tol=1e-15) ##' ##'@export lsei ##'@export lsi ##'@export ldp ##'@export qp lsei = function(a, b, c=NULL, d=NULL, e=NULL, f=NULL, lower=-Inf, upper=Inf) { if(is.null(c) | length(c) == 0) return(lsi(a, b, e, f)) if(is.vector(c)) dim(c) = c(1, length(c)) c.qr = qr(t(c)) L = t(qr.R(c.qr)) k = c.qr$rank # number of effective equality constraints pvt = c.qr$pivot # pivoting for equality constraints k1 = 1:k if(nrow(c) <= ncol(c) && k == nrow(c)) { y1 = forwardsolve(L, d) at = t(qr.qty(c.qr, t(a))) } else { L1 = L[k1,k1,drop=FALSE] L2 = L[-k1,k1,drop=FALSE] pk1 = pvt[k1] d1 = d[pk1] # effective equality constraints d2 = d[-pk1] # redundant equality constraints (consistent?) y1 = forwardsolve(L1, d1) if(max(abs(L2 %*% y1 - d2)) > max(abs(diag(L1))) * 1e-14) stop("Inconsistent equality constraints in lsei()") at = t(qr.qty(c.qr, t(a))) } if(any(lower != -Inf, upper != Inf)) { k0 = ncol(a) lower = rep(lower, len=k0) upper = rep(upper, len=k0) jl = lower != -Inf ju = upper != Inf e = rbind(e, diag(1, k0)[jl,], diag(-1, k0)[ju,]) f = c(f, lower[jl], -upper[ju]) } if(is.null(e)) y2 = pnnls(at[,-k1,drop=FALSE], b - at[,k1,drop=FALSE] %*% y1, ncol(at)-k)$x else { if(is.vector(e)) dim(e) = c(1, length(e)) et = t(qr.qty(c.qr, t(e))) y2 = lsi(at[,-k1,drop=FALSE], b - at[,k1,drop=FALSE] %*% y1, et[,-k1,drop=FALSE], f - et[,k1,drop=FALSE] %*% y1) } qr.qy(c.qr, c(y1, y2)) } # beta = c(rnorm(2), 1); beta[beta<0] = 0; beta = beta/sum(beta) # a = matrix(rnorm(18), ncol=3); b = a %*% beta + rnorm(3,sd=.1); c = matrix(rep(1, 3), nrow=1); d = 1; e = diag(rep(1,3)); f = rep(0,3); lsei(a, b, c, d, e, f) # # c = matrix(rnorm(6), ncol=3); d = rnorm(2); a = matrix(rnorm(24), nrow=8); b = rnorm(8); e = matrix(rnorm(12), nrow=4); f = rnorm(4); x = lsei(a, b, c, d, e, f); print(x); print(c %*% x - d); e %*% x - f # ------------------------------------------------------- # # Least squares solution using Householder transformation # # ------------------------------------------------------- # ##'Least Squares Solution using Householder Transformation ##' ##'Solves the least squares problem using Householder forward triangulation ##'with column interchanges. It is an R interface to the HFTI function that is ##'described in Lawson and Hanson (1974, 1995). Its Fortran implementation is ##'public domain and is available at \url{http://www.netlib.org/lawson-hanson/}. ##' ##'Given matrix \code{a} and vector \code{b}, \code{hfti} solves the least ##'squares problem: ##' ##'\deqn{\mathrm{minimize\ \ } || a x - b ||.}{minimize || a x - b ||.} ##' ##'@param a Design matrix. ##'@param b Response vector or matrix. ##'@param tol Tolerance for determining the pseudorank. ##'@return \item{b}{first \code{krank} elements contains the solution} ##'\item{krank}{psuedo-rank} \item{rnorm}{Euclidean norm of the residual ##'vector.} ##'@author Yong Wang ##'@seealso \code{\link{lsei}}, \code{\link{nnls}}. ##'@references Lawson and Hanson (1974, 1995). Solving least squares problems. ##'Englewood Cliffs, N.J., Prentice-Hall. ##'@keywords array algebra ##'@examples ##' ##'a = matrix(rnorm(10*4), nrow=10) ##'b = a %*% c(0,1,-1,1) + rnorm(10) ##'hfti(a, b) ##' ##'@export hfti hfti = function(a, b, tol = 1e-7) { if(is.vector(b)) b = as.matrix(b) if(!(is.matrix(a) & is.matrix(b))) stop("a or b not a matrix") m = as.integer(dim(a)[1]) n = as.integer(dim(a)[2]) if(m != dim(b)[1]) stop("dim(a)[1] != dim(b)[1]") nb = as.integer(dim(b)[2]) storage.mode(a) = "double" storage.mode(b) = "double" krank = as.integer(0) rnorm = double(nb) # only for output h = g = double(n) # n-vector of working space ip = rep.int(0,n) # m-vector of working space .Fortran("hfti",a=a,m,m,n,b=b,m,nb,tol,krank=krank,rnorm=rnorm,h,g, ip=ip,PACKAGE="lsei")[c("b","krank","rnorm")] } # ---------------------------------------------------------- # # svdrs: singular value decomposition with right side vector # # # # For the least squares problem # # # # ||a x - b|| # # ---------------------------------------------------------- # svdrs = function(a, b) { m1 = nrow(a) n1 = ncol(a) if(m1 < n1) a = rbind(a, matrix(0, nrow=n1-m1, ncol=n1)) mda = nrow(a) k = min(m1, n1) missing.b = FALSE if( missing(b) ) {b = diag( rep(1.0, mda), nrow=mda ); missing.b = TRUE} if( is.vector(b) ) b = as.matrix(b) nb = ncol(b) if( nrow(b) < mda ) b = rbind(b, matrix(0, nrow=mda-nrow(b), ncol=ncol(b))) s = double(n1) work = double(2*n1) storage.mode(a) = "double" storage.mode(b) = "double" r = .Fortran("svdrs",a=a,mda,m1,n1,b=b,nrow(b),nb,s=s, work,PACKAGE="lsei")[c("s","a","b")] if( missing.b ) list(d=r$s[1:k], u=t(r$b[1:min(k,nrow(b)), 1:min(m1,nb),drop=FALSE]), v=r$a[1:n1,1:k,drop=FALSE]) else list(d=r$s[1:k], uTb=r$b[1:min(k,nrow(b)), 1:min(m1,nb),drop=FALSE], v=r$a[1:n1,1:k,drop=FALSE]) } # x = matrix(rnorm(6), nrow=3) # r = svdrs(x) # r$u %*% diag(r$d) %*% t(r$v) - x # svdrs(x, 1:3) # Quadratic programming: x^T q x / 2 + p^T x qp = function(q, p, c=NULL, d=NULL, e=NULL, f=NULL, lower=-Inf, upper=Inf, tol=1e-15) { eq = eigen(q) v2 = sqrt(eq$values[eq$values >= eq$values[1] * tol]) kr = length(v2) a = t(eq$vectors[,1:kr,drop=FALSE]) * v2 b = - colSums(eq$vectors[,1:kr,drop=FALSE] * p / rep(v2, each=length(p))) lsei(a, b, c, d, e, f, lower, upper) } # partial nonnegativity quadratic programming pnnqp = function(q, p, k=0, sum=NULL, tol=1e-20) { eq = eigen(q) v2 = sqrt(eq$values[eq$values >= eq$values[1] * tol]) kr = length(v2) a = t(eq$vectors[,1:kr,drop=FALSE]) * v2 b = - crossprod(p, eq$vectors[,1:kr,drop=FALSE])[1,] / v2 pnnls(a, b, k, sum) } lsei/MD50000644000176200001440000000112013730616063011515 0ustar liggesusersccfb91e4a01b58c1fb2b1deb307c726e *DESCRIPTION c0e6576b8aab4e8dab97a269741ec0aa *NAMESPACE cd864765c892737ca0e52c91dd44a508 *R/lsei.R 978afea699ea14294c64b54d09ce9ad8 *R/utils.R e61f5b877d010d7fe349c82acc341276 *man/hfti.Rd 4f16062de246ab50b4246ecf03ecab4d *man/indx.Rd 4dcdca6d5f094c517c4cb44f45e980d8 *man/lsei.Rd 7172177e494d1939305324a8135daf29 *man/matMaxs.Rd af19532a0c31259bcb93f5c407b224ef *man/nnls.Rd 626dfb29e59b4d1da10b29bd1fe515e4 *src/init.c 69b290bff80b74e0be0fa1fe262dc5ca *src/lsei.f 4d2f1ffad947b47fdad0496a8df44f9b *src/pnnls.f 35415e1f7f959a1c9943490a80995c56 *src/utils.c