Merged from branch 'branches/multiple_regression'

Makefile.am

@@ -19,7 +19,14 @@
 ACLOCAL_AMFLAGS=-I m4
 CLEANFILES = *.gcno *.gcda *.linkinfo
 
-SUBDIRS = src
+SUBDIRS = 
+
+if STARPU_USE_MIN_DGELS
+SUBDIRS += min-dgels
+endif
+
+SUBDIRS += src
+
 SUBDIRS += tools
 
 if BUILD_TESTS

configure.ac

@@ -1134,6 +1134,45 @@ fi
 
 ###############################################################################
 #                                                                             #
+#			 Multiple linear regression			      #
+#                                                                             #
+###############################################################################
+AC_ARG_ENABLE(mlr, [AS_HELP_STRING([--disable-mlr],
+			[Disable multiple linear regression models])],
+			enable_mlr=$enableval, enable_mlr=yes)
+
+AC_MSG_CHECKING(whether multiple linear regression models are disabled)
+if test x$enable_mlr = xyes -a "$starpu_windows" != "yes" ; then
+   	AC_MSG_RESULT(no)
+	install_min_dgels=no
+   	STARPU_SEARCH_LIBS(LAPACK,[dgels_],[lapack],use_system_lapack=yes,,)
+	if test x$use_system_lapack = xyes; then
+	        AC_DEFINE(STARPU_MLR_MODEL, [1], [use reflapack library])
+		LDFLAGS="-llapack $LDFLAGS"
+	else
+		AC_MSG_CHECKING(whether min-dgels is linked)
+		if test x"$DGELS_LIBS" != x; then
+		   	AC_MSG_RESULT(yes)
+        		AC_DEFINE(STARPU_MLR_MODEL, [1], [use user defined library])
+			AC_ARG_VAR([DGELS_LIBS], [linker flags for lapack dgels])
+		else
+			AC_MSG_RESULT(no)
+			AC_MSG_CHECKING(min-dgels source)
+			cp -r $srcdir/min-dgels $PWD/
+			AC_MSG_RESULT(yes)
+			DGELS_LIBS="-Wl,--start-group $STARPU_BUILD_DIR/min-dgels/build/*.a -Wl,--end-group"
+			AC_DEFINE(STARPU_MLR_MODEL, [1], [use user defined library])
+			AC_ARG_VAR([DGELS_LIBS], [linker flags for lapack dgels])
+			install_min_dgels=yes
+		fi
+	fi
+else
+ 	AC_MSG_RESULT(yes)
+fi
+AM_CONDITIONAL(STARPU_USE_MIN_DGELS, test x$install_min_dgels = xyes)
+
+###############################################################################
+#                                                                             #
 #                                 MIC settings                                #
 #                                                                             #
 ###############################################################################
@@ -2915,7 +2954,7 @@ AM_CONDITIONAL(BUILD_DOC, [test x$enable_build_doc != xno])
 ###############################################################################
 
 # these are the flags needed for linking libstarpu (and thus also for static linking)
-LIBSTARPU_LDFLAGS="$HWLOC_LIBS $FXT_LIBS $STARPU_COI_LDFLAGS $STARPU_SCIF_LDFLAGS $STARPU_RCCE_LDFLAGS $STARPU_LEVELDB_LDFLAGS $STARPU_GLPK_LDFLAGS $STARPU_LEVELDB_LDFLAGS $SIMGRID_LIBS $STARPU_BLAS_LDFLAGS $STARPU_OMP_LDFLAGS"
+LIBSTARPU_LDFLAGS="$HWLOC_LIBS $FXT_LIBS $STARPU_COI_LDFLAGS $STARPU_SCIF_LDFLAGS $STARPU_RCCE_LDFLAGS $STARPU_LEVELDB_LDFLAGS $STARPU_GLPK_LDFLAGS $STARPU_LEVELDB_LDFLAGS $SIMGRID_LIBS $STARPU_BLAS_LDFLAGS $STARPU_OMP_LDFLAGS $DGELS_LIBS"
 AC_SUBST([LIBSTARPU_LDFLAGS])
 
 LIBSTARPU_LINK=libstarpu-$STARPU_EFFECTIVE_VERSION.la
@@ -2945,6 +2984,7 @@ AC_CONFIG_COMMANDS([executable-scripts], [
   chmod +x tools/starpu_paje_draw_histogram
   chmod +x tools/starpu_paje_state_stats
   chmod +x tools/starpu_paje_summary
+  chmod +x tools/starpu_mlr_analysis
   chmod +x tools/starpu_paje_sort
   chmod +x tools/starpu_smpirun
   chmod +x doc/doxygen/doxygen_filter.sh
@@ -3002,6 +3042,7 @@ AC_OUTPUT([
 	tools/starpu_paje_draw_histogram
 	tools/starpu_paje_state_stats
 	tools/starpu_paje_summary
+	tools/starpu_mlr_analysis
 	tools/starpu_paje_sort
 	tools/starpu_smpirun
 	socl/Makefile
@@ -3053,6 +3094,7 @@ AC_OUTPUT([
 	doc/doxygen/doxygen-config.cfg
 	doc/doxygen/doxygen_filter.sh
 	tools/msvc/starpu_var.bat
+	min-dgels/Makefile
 ])
 
 AC_MSG_NOTICE([

doc/doxygen/chapters/370_online_performance_tools.doxy

@@ -397,6 +397,48 @@ performance model to perform scheduling, without using regression.
 </li>
 
 <li>
+
+Another type of model is ::STARPU_MULTIPLE_REGRESSION_BASED, which
+is based on multiple linear regression. In this model, the user
+defines both the relevant parameters and the equation for computing the
+task duration.
+
+
+\f[
+T_{kernel} = a + b(M^{\alpha_1} * N^{\beta_1} * K^{\gamma_1}) + c(M^{\alpha_2} * N^{\beta_2} * K^{\gamma_2}) + ...
+\f]
+
+
+\f$M, N, K\f$ are the parameters of the task, added at the task
+creation. These need to be extracted by the <c>cl_perf_func</c>
+function, which should be defined by the user. \f$\alpha, \beta,
+\gamma\f$ are the exponents defined by the user in
+<c>model->combinations</c> table. Finally, coefficients \f$a, b, c\f$
+are computed automatically by the StarPU at the end of the execution, using least
+squares method of the <c>dgels_</c> LAPACK function.
+
+<c>examples/mlr/mlr.c</c> example provides more details on
+the usage of ::STARPU_MULTIPLE_REGRESSION_BASED models.
+
+Coefficients computation is done at the end of the execution, and the
+results are stored in standard codelet perfmodel files. Additional
+files containing the duration of task together with the value of each
+parameter are stored in <c>.starpu/sampling/codelets/tmp/</c>
+directory. These files are reused when \ref STARPU_CALIBRATE
+environment variable is set to <c>1</c>, to recompute coefficients
+based on the current, but also on the previous
+executions. Additionally, when multiple linear regression models are
+disabled (using "--disable-mlr" configuration option) or when the
+<c>model->combinations</c> are not defined, StarPU will still write
+output files into <c>.starpu/sampling/codelets/tmp/</c> to allow
+performing an analysis. This analysis typically aims at finding the
+most appropriate equation for the codelet and
+<c>tools/starpu_mlr_analysis</c> script provides an example of how to
+perform such study.
+
+</li>
+
+<li>
 Provided as an estimation from the application itself (model type
 ::STARPU_COMMON and field starpu_perfmodel::cost_function),
 see for instance

doc/doxygen/chapters/api/performance_model.doxy

@@ -26,6 +26,9 @@ Automatic linear regression-based cost model  (alpha * size ^ beta)
 \var starpu_perfmodel_type::STARPU_NL_REGRESSION_BASED
 \ingroup API_Performance_Model
 Automatic non-linear regression-based cost model (a * size ^ b + c)
+\var starpu_perfmodel_type::STARPU_MULTIPLE_REGRESSION_BASED
+\ingroup API_Performance_Model
+Automatic multiple linear regression-based cost model. Application provides parameters, their combinations and exponents
 
 \struct starpu_perfmodel_device
 todo
@@ -60,6 +63,8 @@ is the type of performance model
 ::STARPU_NL_REGRESSION_BASED: No other fields needs to be provided,
 this is purely history-based.
 </li>
+<li> ::STARPU_MULTIPLE_REGRESSION_BASED: Need to provide fields starpu_perfmodel::nparameters (number of different parameters),  starpu_perfmodel::ncombinations (number of parameters combinations-tuples) and table starpu_perfmodel::combinations which defines exponents of the equation. Function cl_perf_func also needs to define how to extract parameters from the task.
+</li>
 <li> ::STARPU_PER_ARCH: either field starpu_perfmodel::arch_cost_function has to be
 filled with a function that returns the cost in micro-seconds on the arch given
 as parameter, or field starpu_perfmodel::per_arch has to be
@@ -99,6 +104,18 @@ Whether the performance model is already loaded from the disk.
 todo
 \var starpu_perfmodel_state_t starpu_perfmodel::state
 \private
+\var const char ** starpu_perfmodel::parameters_names
+\private
+Names of parameters used for multiple linear regression models (M, N, K)
+\var unsigned starpu_perfmodel::nparameters
+\private
+Number of parameters used for multiple linear regression models
+\var unsigned ** starpu_perfmodel::combinations
+\private
+Table of combinations of parameters (and the exponents) used for multiple linear regression models
+\var unsigned starpu_perfmodel::ncombinations
+\private
+Number of combination of parameters used for multiple linear regression models
 
 
 \struct starpu_perfmodel_regression_model
@@ -132,6 +149,12 @@ estimated = a size ^b + c
 whether the non-linear regression model is valid (i.e. enough measures)
 \var unsigned starpu_perfmodel_regression_model::nsample
 number of sample values for non-linear regression
+\var double starpu_perfmodel_regression_model::coeff[]
+list of computed coefficients for multiple linear regression model
+\var double starpu_perfmodel_regression_model::ncoeff
+number of coefficients for multiple linear regression model
+\var double starpu_perfmodel_regression_model::multi_valid
+whether the multiple linear regression model is valid
 
 \struct starpu_perfmodel_per_arch
 contains information about the performance model of a given
@@ -150,12 +173,12 @@ depends on the architecture-specific implementation.
 The history of performance measurements.
 \var struct starpu_perfmodel_history_list *starpu_perfmodel_per_arch::list
 \private
-Used by ::STARPU_HISTORY_BASED and ::STARPU_NL_REGRESSION_BASED,
+Used by ::STARPU_HISTORY_BASED, ::STARPU_NL_REGRESSION_BASED and ::STARPU_MULTIPLE_REGRESSION_BASED,
 records all execution history measures.
 \var struct starpu_perfmodel_regression_model starpu_perfmodel_per_arch::regression
 \private
-Used by ::STARPU_REGRESSION_BASED and
-::STARPU_NL_REGRESSION_BASED, contains the estimated factors of the
+Used by ::STARPU_REGRESSION_BASED, 
+::STARPU_NL_REGRESSION_BASED and ::STARPU_MULTIPLE_REGRESSION_BASED, contains the estimated factors of the
 regression.
 
 \struct starpu_perfmodel_history_list

examples/Makefile.am

@@ -199,6 +199,7 @@ STARPU_EXAMPLES +=				\
 	basic_examples/variable			\
 	basic_examples/multiformat              \
 	basic_examples/dynamic_handles          \
+	mlr/mlr					\
 	cpp/incrementer_cpp			\
 	filters/fvector				\
 	filters/fblock				\

examples/mlr/mlr.c

@@ -0,0 +1,173 @@
+/* StarPU --- Runtime system for heterogeneous multicore architectures.
+ *
+ * Copyright (C) 2010, 2015-2016  Université de Bordeaux
+ * Copyright (C) 2010, 2011, 2012, 2013  CNRS
+ *
+ * StarPU is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation; either version 2.1 of the License, or (at
+ * your option) any later version.
+ *
+ * StarPU is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+ *
+ * See the GNU Lesser General Public License in COPYING.LGPL for more details.
+ */
+
+/*
+ * This examples demonstrates how to use multiple linear regression
+   models.
+
+   First, there is mlr_codelet__init codelet for which we know the
+   parameters, but not the their exponents and relations. This tasks
+   should be benchmarked and analyzed to find the model, using
+   "tools/starpu_mlr_analysis" script as a template.
+
+   For the second (codelet cl_model_final), it is assumed that the
+   analysis has already been performed and that the duration of the
+   codelet mlr_codelet_final will be computed using the following
+   equation:
+
+   T = a + b * (M^2*N) + c * (N^3*K)
+
+   where M, N, K are the parameters of the task, exponents are coming
+   from model->combinations[..][..]  and finally a, b, c are
+   coefficients which mostly depend on the machine speed.
+   
+   These coefficients are going to be automatically computed using
+   least square method.
+
+ */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <stdint.h>
+#include <starpu.h>
+
+static long sum;
+
+/* Performance function of the task, which is in this case very simple, as the parameter values just need to be written in the array "parameters" */
+static void cl_params(struct starpu_task *task, double *parameters)
+{
+	int m, n, k;
+	starpu_codelet_unpack_args(task->cl_arg, &m, &n, &k);
+	parameters[0] = m;
+	parameters[1] = n;
+	parameters[2] = k;
+}
+
+/* Function of the task that will be executed. In this case running dummy cycles, just to make sure task duration is significant */
+void cpu_func(void *buffers[], void *cl_arg)
+{
+	long i;
+	int m,n,k;
+	starpu_codelet_unpack_args(cl_arg,
+			     	  &m,
+     			     	  &n,
+     			     	  &k);
+	
+	for(i=0; i < (long) (m*m*n); i++)
+		sum+=i;
+
+	for(i=0; i < (long) (n*n*n*k); i++)
+		sum+=i;
+}
+
+/* ############################################ */
+/* Start of the part specific to multiple linear regression perfmodels */
+
+/* Defining perfmodel, number of parameters and their names Initially
+   application developer only knows these parameters. The execution of
+   this codelet will generate traces that can be analyzed using
+   "tools/starpu_mlr_analysis" as a template to obtain the parameters
+   combinations and exponents.
+ */
+
+static const char * parameters_names[]	= {	"M",	"N",	"K", };
+
+static struct starpu_perfmodel cl_model_init = {
+	.type = STARPU_MULTIPLE_REGRESSION_BASED,
+	.symbol = "mlr_init",
+	.parameters = cl_params,
+	.nparameters = 3,
+	.parameters_names = parameters_names,
+};
+
+/* Defining the equation for modeling duration of the task. The
+   parameters combinations and exponents are computed externally
+   offline, for example using "tools/starpu_mlr_analysis" tool as a
+   template.
+ */
+
+static unsigned combi1 [3]		= {	2,	1,	0 };
+static unsigned combi2 [3]		= {	0,	3,	1 };
+
+static unsigned *combinations[] = { combi1, combi2 };
+
+static struct starpu_perfmodel cl_model_final = {
+	.type = STARPU_MULTIPLE_REGRESSION_BASED,
+	.symbol = "mlr_final",
+	.parameters = cl_params,
+	.nparameters = 3,
+	.parameters_names = parameters_names,
+	.ncombinations = 2,
+	.combinations = combinations,
+};
+
+/* End of the part specific to multiple linear regression perfmodels */
+/* ############################################ */
+
+static struct starpu_codelet cl_init = {
+	.cpu_funcs = { cpu_func },
+	.cpu_funcs_name = { "mlr_codelet_init" },
+	.nbuffers = 0,
+	.model = &cl_model_init,
+};
+
+static struct starpu_codelet cl_final = {
+	.cpu_funcs = { cpu_func },
+	.cpu_funcs_name = { "mlr_codelet_final" },
+	.nbuffers = 0,
+	.model = &cl_model_final,
+};
+
+
+int main(int argc, char **argv)
+{
+	/* Initialization */
+	unsigned i,j;
+	int ret;
+	ret = starpu_init(NULL);
+	if (ret == -ENODEV)
+		return 77;
+	
+	sum=0;
+	int m,n,k;
+
+        /* Giving pseudo-random values to the M,N,K parameters and inserting tasks */
+	for(i=0; i < 42; i++)
+	{
+		m = (int) ((rand() % 10)+1);
+		n = (int) ((rand() % 10)+1);
+		k = (int) ((rand() % 10)+1);
+		
+		for(j=0; j < 42; j++)
+		{
+			starpu_insert_task(&cl_init,
+				   STARPU_VALUE, &m, sizeof(int),
+				   STARPU_VALUE, &n, sizeof(int),
+				   STARPU_VALUE, &k, sizeof(int),
+				   0);
+			starpu_insert_task(&cl_final,
+				   STARPU_VALUE, &m, sizeof(int),
+				   STARPU_VALUE, &n, sizeof(int),
+				   STARPU_VALUE, &k, sizeof(int),
+				   0);
+		}
+	}
+			  
+	starpu_shutdown();
+
+	return 0;
+}

include/starpu_perfmodel.h

@@ -60,6 +60,10 @@ struct starpu_perfmodel_history_entry
 	uint32_t footprint;
 	size_t size;
 	double flops;
+
+	double duration;
+	starpu_tag_t tag;
+	double *parameters;
 };
 
 struct starpu_perfmodel_history_list
@@ -88,6 +92,10 @@ struct starpu_perfmodel_regression_model
 	unsigned nl_valid;
 
 	unsigned nsample;
+
+	double *coeff;
+	unsigned ncoeff;
+	unsigned multi_valid;
 };
 
 struct starpu_perfmodel_history_table;
@@ -116,7 +124,8 @@ enum starpu_perfmodel_type
 	STARPU_COMMON,
 	STARPU_HISTORY_BASED,
 	STARPU_REGRESSION_BASED,
-	STARPU_NL_REGRESSION_BASED
+	STARPU_NL_REGRESSION_BASED,
+	STARPU_MULTIPLE_REGRESSION_BASED
 };
 
 struct _starpu_perfmodel_state;
@@ -138,6 +147,12 @@ struct starpu_perfmodel
 	unsigned benchmarking;
 	unsigned is_init;
 
+	void (*parameters)(struct starpu_task * task, double *parameters);
+	const char **parameters_names;
+	unsigned nparameters;
+	unsigned **combinations;
+	unsigned ncombinations;
+
 	starpu_perfmodel_state_t state;
 };
 

min-dgels/Makefile.in

@@ -0,0 +1,30 @@
+CLAPACK=base
+ADDITIONAL=additional
+
+all:
+	mkdir -p build
+	cd $(CLAPACK) && $(MAKE) blaslib
+	cd $(CLAPACK) && $(MAKE) f2clib
+	cd $(ADDITIONAL) && gcc -c -fPIC *.c && ar cr ../build/minlibdgels.a *.o && ranlib ../build/minlibdgels.a
+
+install:
+
+clean:
+	cd $(CLAPACK) && $(MAKE) clean && rm -rf *~
+	cd $(ADDITIONAL) && rm -rf *.o *~
+	rm -rf build *~
+
+distclean: clean
+
+# This part is needed by StarPU
+
+STARPU_SRCDIR = @srcdir@
+
+distdir:
+	cp -fRp $(STARPU_SRCDIR)/* $(distdir)
+	cd $(distdir) && make -f Makefile.in clean
+
+check:
+	echo "No checks are implemented for min-dgels"
+
+showcheck: check

min-dgels/additional/blaswrap.h

@@ -0,0 +1,160 @@
+/* CLAPACK 3.0 BLAS wrapper macros
+ * Feb 5, 2000
+ */
+
+#ifndef __BLASWRAP_H
+#define __BLASWRAP_H
+
+#ifndef NO_BLAS_WRAP
+ 
+/* BLAS1 routines */
+#define srotg_ f2c_srotg
+#define crotg_ f2c_crotg
+#define drotg_ f2c_drotg
+#define zrotg_ f2c_zrotg
+#define srotmg_ f2c_srotmg
+#define drotmg_ f2c_drotmg
+#define srot_ f2c_srot
+#define drot_ f2c_drot
+#define srotm_ f2c_srotm
+#define drotm_ f2c_drotm
+#define sswap_ f2c_sswap
+#define dswap_ f2c_dswap
+#define cswap_ f2c_cswap
+#define zswap_ f2c_zswap
+#define sscal_ f2c_sscal
+#define dscal_ f2c_dscal
+#define cscal_ f2c_cscal
+#define zscal_ f2c_zscal
+#define csscal_ f2c_csscal
+#define zdscal_ f2c_zdscal
+#define scopy_ f2c_scopy
+#define dcopy_ f2c_dcopy
+#define ccopy_ f2c_ccopy
+#define zcopy_ f2c_zcopy
+#define saxpy_ f2c_saxpy
+#define daxpy_ f2c_daxpy
+#define caxpy_ f2c_caxpy
+#define zaxpy_ f2c_zaxpy
+#define sdot_ f2c_sdot
+#define ddot_ f2c_ddot
+#define cdotu_ f2c_cdotu
+#define zdotu_ f2c_zdotu
+#define cdotc_ f2c_cdotc
+#define zdotc_ f2c_zdotc
+#define snrm2_ f2c_snrm2
+#define dnrm2_ f2c_dnrm2
+#define scnrm2_ f2c_scnrm2
+#define dznrm2_ f2c_dznrm2
+#define sasum_ f2c_sasum
+#define dasum_ f2c_dasum
+#define scasum_ f2c_scasum
+#define dzasum_ f2c_dzasum
+#define isamax_ f2c_isamax
+#define idamax_ f2c_idamax
+#define icamax_ f2c_icamax
+#define izamax_ f2c_izamax
+ 
+/* BLAS2 routines */
+#define sgemv_ f2c_sgemv
+#define dgemv_ f2c_dgemv
+#define cgemv_ f2c_cgemv
+#define zgemv_ f2c_zgemv
+#define sgbmv_ f2c_sgbmv
+#define dgbmv_ f2c_dgbmv
+#define cgbmv_ f2c_cgbmv
+#define zgbmv_ f2c_zgbmv
+#define chemv_ f2c_chemv
+#define zhemv_ f2c_zhemv
+#define chbmv_ f2c_chbmv
+#define zhbmv_ f2c_zhbmv
+#define chpmv_ f2c_chpmv
+#define zhpmv_ f2c_zhpmv
+#define ssymv_ f2c_ssymv
+#define dsymv_ f2c_dsymv
+#define ssbmv_ f2c_ssbmv
+#define dsbmv_ f2c_dsbmv
+#define sspmv_ f2c_sspmv
+#define dspmv_ f2c_dspmv
+#define strmv_ f2c_strmv
+#define dtrmv_ f2c_dtrmv
+#define ctrmv_ f2c_ctrmv
+#define ztrmv_ f2c_ztrmv
+#define stbmv_ f2c_stbmv
+#define dtbmv_ f2c_dtbmv
+#define ctbmv_ f2c_ctbmv
+#define ztbmv_ f2c_ztbmv
+#define stpmv_ f2c_stpmv
+#define dtpmv_ f2c_dtpmv
+#define ctpmv_ f2c_ctpmv
+#define ztpmv_ f2c_ztpmv
+#define strsv_ f2c_strsv
+#define dtrsv_ f2c_dtrsv
+#define ctrsv_ f2c_ctrsv
+#define ztrsv_ f2c_ztrsv
+#define stbsv_ f2c_stbsv
+#define dtbsv_ f2c_dtbsv
+#define ctbsv_ f2c_ctbsv
+#define ztbsv_ f2c_ztbsv
+#define stpsv_ f2c_stpsv
+#define dtpsv_ f2c_dtpsv
+#define ctpsv_ f2c_ctpsv
+#define ztpsv_ f2c_ztpsv
+#define sger_ f2c_sger
+#define dger_ f2c_dger
+#define cgeru_ f2c_cgeru
+#define zgeru_ f2c_zgeru
+#define cgerc_ f2c_cgerc
+#define zgerc_ f2c_zgerc
+#define cher_ f2c_cher
+#define zher_ f2c_zher
+#define chpr_ f2c_chpr
+#define zhpr_ f2c_zhpr
+#define cher2_ f2c_cher2
+#define zher2_ f2c_zher2
+#define chpr2_ f2c_chpr2
+#define zhpr2_ f2c_zhpr2
+#define ssyr_ f2c_ssyr
+#define dsyr_ f2c_dsyr
+#define sspr_ f2c_sspr
+#define dspr_ f2c_dspr
+#define ssyr2_ f2c_ssyr2
+#define dsyr2_ f2c_dsyr2
+#define sspr2_ f2c_sspr2
+#define dspr2_ f2c_dspr2
+ 
+/* BLAS3 routines */
+#define sgemm_ f2c_sgemm
+#define dgemm_ f2c_dgemm
+#define cgemm_ f2c_cgemm
+#define zgemm_ f2c_zgemm
+#define ssymm_ f2c_ssymm
+#define dsymm_ f2c_dsymm
+#define csymm_ f2c_csymm
+#define zsymm_ f2c_zsymm
+#define chemm_ f2c_chemm
+#define zhemm_ f2c_zhemm
+#define ssyrk_ f2c_ssyrk
+#define dsyrk_ f2c_dsyrk
+#define csyrk_ f2c_csyrk
+#define zsyrk_ f2c_zsyrk
+#define cherk_ f2c_cherk
+#define zherk_ f2c_zherk
+#define ssyr2k_ f2c_ssyr2k
+#define dsyr2k_ f2c_dsyr2k
+#define csyr2k_ f2c_csyr2k
+#define zsyr2k_ f2c_zsyr2k
+#define cher2k_ f2c_cher2k
+#define zher2k_ f2c_zher2k
+#define strmm_ f2c_strmm
+#define dtrmm_ f2c_dtrmm
+#define ctrmm_ f2c_ctrmm
+#define ztrmm_ f2c_ztrmm
+#define strsm_ f2c_strsm
+#define dtrsm_ f2c_dtrsm
+#define ctrsm_ f2c_ctrsm
+#define ztrsm_ f2c_ztrsm
+
+#endif /* NO_BLAS_WRAP */
+
+#endif /* __BLASWRAP_H */

min-dgels/additional/d_lg10.c

@@ -0,0 +1,21 @@
+#include "f2c.h"
+
+#define log10e 0.43429448190325182765
+
+#ifdef KR_headers
+double log();
+double d_lg10(x) doublereal *x;
+#else
+#undef abs
+#include "math.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+double d_lg10(doublereal *x)
+#endif
+{
+return( log10e * log(*x) );
+}
+#ifdef __cplusplus
+}
+#endif

min-dgels/additional/d_sign.c

@@ -0,0 +1,18 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double d_sign(a,b) doublereal *a, *b;
+#else
+double d_sign(doublereal *a, doublereal *b)
+#endif
+{
+double x;
+x = (*a >= 0 ? *a : - *a);
+return( *b >= 0 ? x : -x);
+}
+#ifdef __cplusplus
+}
+#endif

min-dgels/additional/dcopy.c

@@ -0,0 +1,107 @@
+/* dcopy.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, 
+	doublereal *dy, integer *incy)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer i__, m, ix, iy, mp1;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     copies a vector, x, to a vector, y. */
+/*     uses unrolled loops for increments equal to one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dy;
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0) {
+	return 0;
+    }
+    if (*incx == 1 && *incy == 1) {
+	goto L20;
+    }
+
+/*        code for unequal increments or equal increments */
+/*          not equal to 1 */
+
+    ix = 1;
+    iy = 1;
+    if (*incx < 0) {
+	ix = (-(*n) + 1) * *incx + 1;
+    }
+    if (*incy < 0) {
+	iy = (-(*n) + 1) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dy[iy] = dx[ix];
+	ix += *incx;
+	iy += *incy;
+/* L10: */
+    }
+    return 0;
+
+/*        code for both increments equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 7;
+    if (m == 0) {
+	goto L40;
+    }
+    i__1 = m;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dy[i__] = dx[i__];
+/* L30: */
+    }
+    if (*n < 7) {
+	return 0;
+    }
+L40:
+    mp1 = m + 1;
+    i__1 = *n;
+    for (i__ = mp1; i__ <= i__1; i__ += 7) {
+	dy[i__] = dx[i__];
+	dy[i__ + 1] = dx[i__ + 1];
+	dy[i__ + 2] = dx[i__ + 2];
+	dy[i__ + 3] = dx[i__ + 3];
+	dy[i__ + 4] = dx[i__ + 4];
+	dy[i__ + 5] = dx[i__ + 5];
+	dy[i__ + 6] = dx[i__ + 6];
+/* L50: */
+    }
+    return 0;
+} /* dcopy_ */

min-dgels/additional/dgelq2.c

@@ -0,0 +1,157 @@
+/* dgelq2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgelq2_(integer *m, integer *n, doublereal *a, integer *
+	lda, doublereal *tau, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, k;
+    doublereal aii;
+    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *), dlarfp_(integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGELQ2 computes an LQ factorization of a real m by n matrix A: */
+/*  A = L * Q. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          On entry, the m by n matrix A. */
+/*          On exit, the elements on and below the diagonal of the array */
+/*          contain the m by min(m,n) lower trapezoidal matrix L (L is */
+/*          lower triangular if m <= n); the elements above the diagonal, */
+/*          with the array TAU, represent the orthogonal matrix Q as a */
+/*          product of elementary reflectors (see Further Details). */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/*          The scalar factors of the elementary reflectors (see Further */
+/*          Details). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension (M) */
+
+/*  INFO    (output) INTEGER */
+/*          = 0: successful exit */
+/*          < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/*  Further Details */
+/*  =============== */
+
+/*  The matrix Q is represented as a product of elementary reflectors */
+
+/*     Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/*  Each H(i) has the form */
+
+/*     H(i) = I - tau * v * v' */
+
+/*  where tau is a real scalar, and v is a real vector with */
+/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
+/*  and tau in TAU(i). */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < max(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGELQ2", &i__1);
+	return 0;
+    }
+
+    k = min(*m,*n);
+
+    i__1 = k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        Generate elementary reflector H(i) to annihilate A(i,i+1:n) */
+
+	i__2 = *n - i__ + 1;
+/* Computing MIN */
+	i__3 = i__ + 1;
+	dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[i__ + min(i__3, *n)* a_dim1]
+, lda, &tau[i__]);
+	if (i__ < *m) {
+
+/*           Apply H(i) to A(i+1:m,i:n) from the right */
+
+	    aii = a[i__ + i__ * a_dim1];
+	    a[i__ + i__ * a_dim1] = 1.;
+	    i__2 = *m - i__;
+	    i__3 = *n - i__ + 1;
+	    dlarf_("Right", &i__2, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[
+		    i__], &a[i__ + 1 + i__ * a_dim1], lda, &work[1]);
+	    a[i__ + i__ * a_dim1] = aii;
+	}
+/* L10: */
+    }
+    return 0;
+
+/*     End of DGELQ2 */
+
+} /* dgelq2_ */

min-dgels/additional/dgelqf.c

@@ -0,0 +1,251 @@
+/* dgelqf.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgelqf_(integer *m, integer *n, doublereal *a, integer *
+	lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+    /* Local variables */
+    integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+    extern /* Subroutine */ int dgelq2_(integer *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, 
+	     char *, char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal 
+	    *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *);
+    integer ldwork, lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGELQF computes an LQ factorization of a real M-by-N matrix A: */
+/*  A = L * Q. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          On entry, the M-by-N matrix A. */
+/*          On exit, the elements on and below the diagonal of the array */
+/*          contain the m-by-min(m,n) lower trapezoidal matrix L (L is */
+/*          lower triangular if m <= n); the elements above the diagonal, */
+/*          with the array TAU, represent the orthogonal matrix Q as a */
+/*          product of elementary reflectors (see Further Details). */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/*          The scalar factors of the elementary reflectors (see Further */
+/*          Details). */
+
+/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/*  LWORK   (input) INTEGER */
+/*          The dimension of the array WORK.  LWORK >= max(1,M). */
+/*          For optimum performance LWORK >= M*NB, where NB is the */
+/*          optimal blocksize. */
+
+/*          If LWORK = -1, then a workspace query is assumed; the routine */
+/*          only calculates the optimal size of the WORK array, returns */
+/*          this value as the first entry of the WORK array, and no error */
+/*          message related to LWORK is issued by XERBLA. */
+
+/*  INFO    (output) INTEGER */
+/*          = 0:  successful exit */
+/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
+
+/*  Further Details */
+/*  =============== */
+
+/*  The matrix Q is represented as a product of elementary reflectors */
+
+/*     Q = H(k) . . . H(2) H(1), where k = min(m,n). */
+
+/*  Each H(i) has the form */
+
+/*     H(i) = I - tau * v * v' */
+
+/*  where tau is a real scalar, and v is a real vector with */
+/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n), */
+/*  and tau in TAU(i). */
+
+/*  ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
+    lwkopt = *m * nb;
+    work[1] = (doublereal) lwkopt;
+    lquery = *lwork == -1;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < max(1,*m)) {
+	*info = -4;
+    } else if (*lwork < max(1,*m) && ! lquery) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGELQF", &i__1);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    k = min(*m,*n);
+    if (k == 0) {
+	work[1] = 1.;
+	return 0;
+    }
+
+    nbmin = 2;
+    nx = 0;
+    iws = *m;
+    if (nb > 1 && nb < k) {
+
+/*        Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+	i__1 = 0, i__2 = ilaenv_(&c__3, "DGELQF", " ", m, n, &c_n1, &c_n1);
+	nx = max(i__1,i__2);
+	if (nx < k) {
+
+/*           Determine if workspace is large enough for blocked code. */
+
+	    ldwork = *m;
+	    iws = ldwork * nb;
+	    if (*lwork < iws) {
+
+/*              Not enough workspace to use optimal NB:  reduce NB and */
+/*              determine the minimum value of NB. */
+
+		nb = *lwork / ldwork;
+/* Computing MAX */
+		i__1 = 2, i__2 = ilaenv_(&c__2, "DGELQF", " ", m, n, &c_n1, &
+			c_n1);
+		nbmin = max(i__1,i__2);
+	    }
+	}
+    }
+
+    if (nb >= nbmin && nb < k && nx < k) {
+
+/*        Use blocked code initially */
+
+	i__1 = k - nx;
+	i__2 = nb;
+	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+	    i__3 = k - i__ + 1;
+	    ib = min(i__3,nb);
+
+/*           Compute the LQ factorization of the current block */
+/*           A(i:i+ib-1,i:n) */
+
+	    i__3 = *n - i__ + 1;
+	    dgelq2_(&ib, &i__3, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+		    1], &iinfo);
+	    if (i__ + ib <= *m) {
+
+/*              Form the triangular factor of the block reflector */
+/*              H = H(i) H(i+1) . . . H(i+ib-1) */
+
+		i__3 = *n - i__ + 1;
+		dlarft_("Forward", "Rowwise", &i__3, &ib, &a[i__ + i__ * 
+			a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/*              Apply H to A(i+ib:m,i:n) from the right */
+
+		i__3 = *m - i__ - ib + 1;
+		i__4 = *n - i__ + 1;
+		dlarfb_("Right", "No transpose", "Forward", "Rowwise", &i__3, 
+			&i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+			ldwork, &a[i__ + ib + i__ * a_dim1], lda, &work[ib + 
+			1], &ldwork);
+	    }
+/* L10: */
+	}
+    } else {
+	i__ = 1;
+    }
+
+/*     Use unblocked code to factor the last or only block. */
+
+    if (i__ <= k) {
+	i__2 = *m - i__ + 1;
+	i__1 = *n - i__ + 1;
+	dgelq2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+    }
+
+    work[1] = (doublereal) iws;
+    return 0;
+
+/*     End of DGELQF */
+
+} /* dgelqf_ */

min-dgels/additional/dgels.c

@@ -0,0 +1,515 @@
+/* dgels.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static doublereal c_b33 = 0.;
+static integer c__0 = 0;
+
+/* Subroutine */ int dgels_(char *trans, integer *m, integer *n, integer *
+	nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, 
+	doublereal *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, nb, mn;
+    doublereal anrm, bnrm;
+    integer brow;
+    logical tpsd;
+    integer iascl, ibscl;
+    extern logical lsame_(char *, char *);
+    integer wsize;
+    doublereal rwork[1];
+    extern /* Subroutine */ int dlabad_(doublereal *, doublereal *);
+    extern doublereal dlamch_(char *), dlange_(char *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *);
+    extern /* Subroutine */ int dgelqf_(integer *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *, integer *), 
+	    dlascl_(char *, integer *, integer *, doublereal *, doublereal *, 
+	    integer *, integer *, doublereal *, integer *, integer *),
+	     dgeqrf_(integer *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *, integer *), dlaset_(char *, 
+	     integer *, integer *, doublereal *, doublereal *, doublereal *, 
+	    integer *), xerbla_(char *, integer *);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *);
+    integer scllen;
+    doublereal bignum;
+    extern /* Subroutine */ int dormlq_(char *, char *, integer *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
+	    integer *, doublereal *, integer *, integer *), 
+	    dormqr_(char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *, integer *);
+    doublereal smlnum;
+    logical lquery;
+    extern /* Subroutine */ int dtrtrs_(char *, char *, char *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *, integer *, 
+	    integer *);
+
+
+/*  -- LAPACK driver routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGELS solves overdetermined or underdetermined real linear systems */
+/*  involving an M-by-N matrix A, or its transpose, using a QR or LQ */
+/*  factorization of A.  It is assumed that A has full rank. */
+
+/*  The following options are provided: */
+
+/*  1. If TRANS = 'N' and m >= n:  find the least squares solution of */
+/*     an overdetermined system, i.e., solve the least squares problem */
+/*                  minimize || B - A*X ||. */
+
+/*  2. If TRANS = 'N' and m < n:  find the minimum norm solution of */
+/*     an underdetermined system A * X = B. */
+
+/*  3. If TRANS = 'T' and m >= n:  find the minimum norm solution of */
+/*     an undetermined system A**T * X = B. */
+
+/*  4. If TRANS = 'T' and m < n:  find the least squares solution of */
+/*     an overdetermined system, i.e., solve the least squares problem */
+/*                  minimize || B - A**T * X ||. */
+
+/*  Several right hand side vectors b and solution vectors x can be */
+/*  handled in a single call; they are stored as the columns of the */
+/*  M-by-NRHS right hand side matrix B and the N-by-NRHS solution */
+/*  matrix X. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          = 'N': the linear system involves A; */
+/*          = 'T': the linear system involves A**T. */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  NRHS    (input) INTEGER */
+/*          The number of right hand sides, i.e., the number of */
+/*          columns of the matrices B and X. NRHS >=0. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          On entry, the M-by-N matrix A. */
+/*          On exit, */
+/*            if M >= N, A is overwritten by details of its QR */
+/*                       factorization as returned by DGEQRF; */
+/*            if M <  N, A is overwritten by details of its LQ */
+/*                       factorization as returned by DGELQF. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/*          On entry, the matrix B of right hand side vectors, stored */
+/*          columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS */
+/*          if TRANS = 'T'. */
+/*          On exit, if INFO = 0, B is overwritten by the solution */
+/*          vectors, stored columnwise: */
+/*          if TRANS = 'N' and m >= n, rows 1 to n of B contain the least */
+/*          squares solution vectors; the residual sum of squares for the */
+/*          solution in each column is given by the sum of squares of */
+/*          elements N+1 to M in that column; */
+/*          if TRANS = 'N' and m < n, rows 1 to N of B contain the */
+/*          minimum norm solution vectors; */
+/*          if TRANS = 'T' and m >= n, rows 1 to M of B contain the */
+/*          minimum norm solution vectors; */
+/*          if TRANS = 'T' and m < n, rows 1 to M of B contain the */
+/*          least squares solution vectors; the residual sum of squares */
+/*          for the solution in each column is given by the sum of */
+/*          squares of elements M+1 to N in that column. */
+
+/*  LDB     (input) INTEGER */
+/*          The leading dimension of the array B. LDB >= MAX(1,M,N). */
+
+/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/*  LWORK   (input) INTEGER */
+/*          The dimension of the array WORK. */
+/*          LWORK >= max( 1, MN + max( MN, NRHS ) ). */
+/*          For optimal performance, */
+/*          LWORK >= max( 1, MN + max( MN, NRHS )*NB ). */
+/*          where MN = min(M,N) and NB is the optimum block size. */
+
+/*          If LWORK = -1, then a workspace query is assumed; the routine */
+/*          only calculates the optimal size of the WORK array, returns */
+/*          this value as the first entry of the WORK array, and no error */
+/*          message related to LWORK is issued by XERBLA. */
+
+/*  INFO    (output) INTEGER */
+/*          = 0:  successful exit */
+/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
+/*          > 0:  if INFO =  i, the i-th diagonal element of the */
+/*                triangular factor of A is zero, so that A does not have */
+/*                full rank; the least squares solution could not be */
+/*                computed. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Local Arrays .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    mn = min(*m,*n);
+    lquery = *lwork == -1;
+    if (! (lsame_(trans, "N") || lsame_(trans, "T"))) {
+	*info = -1;
+    } else if (*m < 0) {
+	*info = -2;
+    } else if (*n < 0) {
+	*info = -3;
+    } else if (*nrhs < 0) {
+	*info = -4;
+    } else if (*lda < max(1,*m)) {
+	*info = -6;
+    } else /* if(complicated condition) */ {
+/* Computing MAX */
+	i__1 = max(1,*m);
+	if (*ldb < max(i__1,*n)) {
+	    *info = -8;
+	} else /* if(complicated condition) */ {
+/* Computing MAX */
+	    i__1 = 1, i__2 = mn + max(mn,*nrhs);
+	    if (*lwork < max(i__1,i__2) && ! lquery) {
+		*info = -10;
+	    }
+	}
+    }
+
+/*     Figure out optimal block size */
+
+    if (*info == 0 || *info == -10) {
+
+	tpsd = TRUE_;
+	if (lsame_(trans, "N")) {
+	    tpsd = FALSE_;
+	}
+
+	if (*m >= *n) {
+	    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+	    if (tpsd) {
+/* Computing MAX */
+		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LN", m, nrhs, n, &
+			c_n1);
+		nb = max(i__1,i__2);
+	    } else {
+/* Computing MAX */
+		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMQR", "LT", m, nrhs, n, &
+			c_n1);
+		nb = max(i__1,i__2);
+	    }
+	} else {
+	    nb = ilaenv_(&c__1, "DGELQF", " ", m, n, &c_n1, &c_n1);
+	    if (tpsd) {
+/* Computing MAX */
+		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LT", n, nrhs, m, &
+			c_n1);
+		nb = max(i__1,i__2);
+	    } else {
+/* Computing MAX */
+		i__1 = nb, i__2 = ilaenv_(&c__1, "DORMLQ", "LN", n, nrhs, m, &
+			c_n1);
+		nb = max(i__1,i__2);
+	    }
+	}
+
+/* Computing MAX */
+	i__1 = 1, i__2 = mn + max(mn,*nrhs) * nb;
+	wsize = max(i__1,i__2);
+	work[1] = (doublereal) wsize;
+
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGELS ", &i__1);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+/* Computing MIN */
+    i__1 = min(*m,*n);
+    if (min(i__1,*nrhs) == 0) {
+	i__1 = max(*m,*n);
+	dlaset_("Full", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
+	return 0;
+    }
+
+/*     Get machine parameters */
+
+    smlnum = dlamch_("S") / dlamch_("P");
+    bignum = 1. / smlnum;
+    dlabad_(&smlnum, &bignum);
+
+/*     Scale A, B if max element outside range [SMLNUM,BIGNUM] */
+
+    anrm = dlange_("M", m, n, &a[a_offset], lda, rwork);
+    iascl = 0;
+    if (anrm > 0. && anrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 1;
+    } else if (anrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	dlascl_("G", &c__0, &c__0, &anrm, &bignum, m, n, &a[a_offset], lda, 
+		info);
+	iascl = 2;
+    } else if (anrm == 0.) {
+
+/*        Matrix all zero. Return zero solution. */
+
+	i__1 = max(*m,*n);
+	dlaset_("F", &i__1, nrhs, &c_b33, &c_b33, &b[b_offset], ldb);
+	goto L50;
+    }
+
+    brow = *m;
+    if (tpsd) {
+	brow = *n;
+    }
+    bnrm = dlange_("M", &brow, nrhs, &b[b_offset], ldb, rwork);
+    ibscl = 0;
+    if (bnrm > 0. && bnrm < smlnum) {
+
+/*        Scale matrix norm up to SMLNUM */
+
+	dlascl_("G", &c__0, &c__0, &bnrm, &smlnum, &brow, nrhs, &b[b_offset], 
+		ldb, info);
+	ibscl = 1;
+    } else if (bnrm > bignum) {
+
+/*        Scale matrix norm down to BIGNUM */
+
+	dlascl_("G", &c__0, &c__0, &bnrm, &bignum, &brow, nrhs, &b[b_offset], 
+		ldb, info);
+	ibscl = 2;
+    }
+
+    if (*m >= *n) {
+
+/*        compute QR factorization of A */
+
+	i__1 = *lwork - mn;
+	dgeqrf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+		;
+
+/*        workspace at least N, optimally N*NB */
+
+	if (! tpsd) {
+
+/*           Least-Squares Problem min || A * X - B || */
+
+/*           B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS) */
+
+	    i__1 = *lwork - mn;
+	    dormqr_("Left", "Transpose", m, nrhs, n, &a[a_offset], lda, &work[
+		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/*           workspace at least NRHS, optimally NRHS*NB */
+
+/*           B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS) */
+
+	    dtrtrs_("Upper", "No transpose", "Non-unit", n, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+	    if (*info > 0) {
+		return 0;
+	    }
+
+	    scllen = *n;
+
+	} else {
+
+/*           Overdetermined system of equations A' * X = B */
+
+/*           B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS) */
+
+	    dtrtrs_("Upper", "Transpose", "Non-unit", n, nrhs, &a[a_offset], 
+		    lda, &b[b_offset], ldb, info);
+
+	    if (*info > 0) {
+		return 0;
+	    }
+
+/*           B(N+1:M,1:NRHS) = ZERO */
+
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = *n + 1; i__ <= i__2; ++i__) {
+		    b[i__ + j * b_dim1] = 0.;
+/* L10: */
+		}
+/* L20: */
+	    }
+
+/*           B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS) */
+
+	    i__1 = *lwork - mn;
+	    dormqr_("Left", "No transpose", m, nrhs, n, &a[a_offset], lda, &
+		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/*           workspace at least NRHS, optimally NRHS*NB */
+
+	    scllen = *m;
+
+	}
+
+    } else {
+
+/*        Compute LQ factorization of A */
+
+	i__1 = *lwork - mn;
+	dgelqf_(m, n, &a[a_offset], lda, &work[1], &work[mn + 1], &i__1, info)
+		;
+
+/*        workspace at least M, optimally M*NB. */
+
+	if (! tpsd) {
+
+/*           underdetermined system of equations A * X = B */
+
+/*           B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS) */
+
+	    dtrtrs_("Lower", "No transpose", "Non-unit", m, nrhs, &a[a_offset]
+, lda, &b[b_offset], ldb, info);
+
+	    if (*info > 0) {
+		return 0;
+	    }
+
+/*           B(M+1:N,1:NRHS) = 0 */
+
+	    i__1 = *nrhs;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *n;
+		for (i__ = *m + 1; i__ <= i__2; ++i__) {
+		    b[i__ + j * b_dim1] = 0.;
+/* L30: */
+		}
+/* L40: */
+	    }
+
+/*           B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS) */
+
+	    i__1 = *lwork - mn;
+	    dormlq_("Left", "Transpose", n, nrhs, m, &a[a_offset], lda, &work[
+		    1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/*           workspace at least NRHS, optimally NRHS*NB */
+
+	    scllen = *n;
+
+	} else {
+
+/*           overdetermined system min || A' * X - B || */
+
+/*           B(1:N,1:NRHS) := Q * B(1:N,1:NRHS) */
+
+	    i__1 = *lwork - mn;
+	    dormlq_("Left", "No transpose", n, nrhs, m, &a[a_offset], lda, &
+		    work[1], &b[b_offset], ldb, &work[mn + 1], &i__1, info);
+
+/*           workspace at least NRHS, optimally NRHS*NB */
+
+/*           B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS) */
+
+	    dtrtrs_("Lower", "Transpose", "Non-unit", m, nrhs, &a[a_offset], 
+		    lda, &b[b_offset], ldb, info);
+
+	    if (*info > 0) {
+		return 0;
+	    }
+
+	    scllen = *m;
+
+	}
+
+    }
+
+/*     Undo scaling */
+
+    if (iascl == 1) {
+	dlascl_("G", &c__0, &c__0, &anrm, &smlnum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+    } else if (iascl == 2) {
+	dlascl_("G", &c__0, &c__0, &anrm, &bignum, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+    }
+    if (ibscl == 1) {
+	dlascl_("G", &c__0, &c__0, &smlnum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+    } else if (ibscl == 2) {
+	dlascl_("G", &c__0, &c__0, &bignum, &bnrm, &scllen, nrhs, &b[b_offset]
+, ldb, info);
+    }
+
+L50:
+    work[1] = (doublereal) wsize;
+
+    return 0;
+
+/*     End of DGELS */
+
+} /* dgels_ */

min-dgels/additional/dgemm.c

@@ -0,0 +1,389 @@
+/* dgemm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
+	n, integer *k, doublereal *alpha, doublereal *a, integer *lda, 
+	doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, 
+	integer *ldc)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
+	    i__3;
+
+    /* Local variables */
+    integer i__, j, l, info;
+    logical nota, notb;
+    doublereal temp;
+    integer ncola;
+    extern logical lsame_(char *, char *);
+    integer nrowa, nrowb;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGEMM  performs one of the matrix-matrix operations */
+
+/*     C := alpha*op( A )*op( B ) + beta*C, */
+
+/*  where  op( X ) is one of */
+
+/*     op( X ) = X   or   op( X ) = X', */
+
+/*  alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
+/*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  TRANSA - CHARACTER*1. */
+/*           On entry, TRANSA specifies the form of op( A ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSA = 'N' or 'n',  op( A ) = A. */
+
+/*              TRANSA = 'T' or 't',  op( A ) = A'. */
+
+/*              TRANSA = 'C' or 'c',  op( A ) = A'. */
+
+/*           Unchanged on exit. */
+
+/*  TRANSB - CHARACTER*1. */
+/*           On entry, TRANSB specifies the form of op( B ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSB = 'N' or 'n',  op( B ) = B. */
+
+/*              TRANSB = 'T' or 't',  op( B ) = B'. */
+
+/*              TRANSB = 'C' or 'c',  op( B ) = B'. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry,  M  specifies  the number  of rows  of the  matrix */
+/*           op( A )  and of the  matrix  C.  M  must  be at least  zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry,  N  specifies the number  of columns of the matrix */
+/*           op( B ) and the number of columns of the matrix C. N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry,  K  specifies  the number of columns of the matrix */
+/*           op( A ) and the number of rows of the matrix op( B ). K must */
+/*           be at least  zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise. */
+/*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k */
+/*           part of the array  A  must contain the matrix  A,  otherwise */
+/*           the leading  k by m  part of the array  A  must contain  the */
+/*           matrix A. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then */
+/*           LDA must be at least  max( 1, m ), otherwise  LDA must be at */
+/*           least  max( 1, k ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
+/*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise. */
+/*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n */
+/*           part of the array  B  must contain the matrix  B,  otherwise */
+/*           the leading  n by k  part of the array  B  must contain  the */
+/*           matrix B. */
+/*           Unchanged on exit. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then */
+/*           LDB must be at least  max( 1, k ), otherwise  LDB must be at */
+/*           least  max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is */
+/*           supplied as zero then C need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/*           Before entry, the leading  m by n  part of the array  C must */
+/*           contain the matrix  C,  except when  beta  is zero, in which */
+/*           case C need not be set on entry. */
+/*           On exit, the array  C  is overwritten by the  m by n  matrix */
+/*           ( alpha*op( A )*op( B ) + beta*C ). */
+
+/*  LDC    - INTEGER. */
+/*           On entry, LDC specifies the first dimension of C as declared */
+/*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not */
+/*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows */
+/*     and  columns of  A  and the  number of  rows  of  B  respectively. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+
+    /* Function Body */
+    nota = lsame_(transa, "N");
+    notb = lsame_(transb, "N");
+    if (nota) {
+	nrowa = *m;
+	ncola = *k;
+    } else {
+	nrowa = *k;
+	ncola = *m;
+    }
+    if (notb) {
+	nrowb = *k;
+    } else {
+	nrowb = *n;
+    }
+
+/*     Test the input parameters. */
+
+    info = 0;
+    if (! nota && ! lsame_(transa, "C") && ! lsame_(
+	    transa, "T")) {
+	info = 1;
+    } else if (! notb && ! lsame_(transb, "C") && ! 
+	    lsame_(transb, "T")) {
+	info = 2;
+    } else if (*m < 0) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*k < 0) {
+	info = 5;
+    } else if (*lda < max(1,nrowa)) {
+	info = 8;
+    } else if (*ldb < max(1,nrowb)) {
+	info = 10;
+    } else if (*ldc < max(1,*m)) {
+	info = 13;
+    }
+    if (info != 0) {
+	xerbla_("DGEMM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+	return 0;
+    }
+
+/*     And if  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	if (*beta == 0.) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+		}
+/* L20: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+		}
+/* L40: */
+	    }
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (notb) {
+	if (nota) {
+
+/*           Form  C := alpha*A*B + beta*C. */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L60: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (b[l + j * b_dim1] != 0.) {
+			temp = *alpha * b[l + j * b_dim1];
+			i__3 = *m;
+			for (i__ = 1; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
+				    a_dim1];
+/* L70: */
+			}
+		    }
+/* L80: */
+		}
+/* L90: */
+	    }
+	} else {
+
+/*           Form  C := alpha*A'*B + beta*C */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+/* L100: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp;
+		    } else {
+			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+				i__ + j * c_dim1];
+		    }
+/* L110: */
+		}
+/* L120: */
+	    }
+	}
+    } else {
+	if (nota) {
+
+/*           Form  C := alpha*A*B' + beta*C */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L130: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L140: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (b[j + l * b_dim1] != 0.) {
+			temp = *alpha * b[j + l * b_dim1];
+			i__3 = *m;
+			for (i__ = 1; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
+				    a_dim1];
+/* L150: */
+			}
+		    }
+/* L160: */
+		}
+/* L170: */
+	    }
+	} else {
+
+/*           Form  C := alpha*A'*B' + beta*C */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
+/* L180: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp;
+		    } else {
+			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+				i__ + j * c_dim1];
+		    }
+/* L190: */
+		}
+/* L200: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DGEMM . */
+
+} /* dgemm_ */

min-dgels/additional/dgemv.c

@@ -0,0 +1,312 @@
+/* dgemv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
+	alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, 
+	doublereal *beta, doublereal *y, integer *incy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp;
+    integer lenx, leny;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGEMV  performs one of the matrix-vector operations */
+
+/*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y, */
+
+/*  where alpha and beta are scalars, x and y are vectors and A is an */
+/*  m by n matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y. */
+
+/*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y. */
+
+/*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of the matrix A. */
+/*           M must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry, the leading m by n part of the array A must */
+/*           contain the matrix of coefficients. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/*           and at least */
+/*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/*           Before entry, the incremented array X must contain the */
+/*           vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. When BETA is */
+/*           supplied as zero then Y need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/*           and at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/*           Before entry with BETA non-zero, the incremented array Y */
+/*           must contain the vector y. On exit, Y is overwritten by the */
+/*           updated vector y. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+    --y;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+	    ) {
+	info = 1;
+    } else if (*m < 0) {
+	info = 2;
+    } else if (*n < 0) {
+	info = 3;
+    } else if (*lda < max(1,*m)) {
+	info = 6;
+    } else if (*incx == 0) {
+	info = 8;
+    } else if (*incy == 0) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DGEMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set */
+/*     up the start points in  X  and  Y. */
+
+    if (lsame_(trans, "N")) {
+	lenx = *n;
+	leny = *m;
+    } else {
+	lenx = *m;
+	leny = *n;
+    }
+    if (*incx > 0) {
+	kx = 1;
+    } else {
+	kx = 1 - (lenx - 1) * *incx;
+    }
+    if (*incy > 0) {
+	ky = 1;
+    } else {
+	ky = 1 - (leny - 1) * *incy;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+/*     First form  y := beta*y. */
+
+    if (*beta != 1.) {
+	if (*incy == 1) {
+	    if (*beta == 0.) {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = 0.;
+/* L10: */
+		}
+	    } else {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = *beta * y[i__];
+/* L20: */
+		}
+	    }
+	} else {
+	    iy = ky;
+	    if (*beta == 0.) {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = 0.;
+		    iy += *incy;
+/* L30: */
+		}
+	    } else {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = *beta * y[iy];
+		    iy += *incy;
+/* L40: */
+		}
+	    }
+	}
+    }
+    if (*alpha == 0.) {
+	return 0;
+    }
+    if (lsame_(trans, "N")) {
+
+/*        Form  y := alpha*A*x + y. */
+
+	jx = kx;
+	if (*incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			y[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+		    }
+		}
+		jx += *incx;
+/* L60: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    iy = ky;
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			y[iy] += temp * a[i__ + j * a_dim1];
+			iy += *incy;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+/* L80: */
+	    }
+	}
+    } else {
+
+/*        Form  y := alpha*A'*x + y. */
+
+	jy = ky;
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp = 0.;
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+		}
+		y[jy] += *alpha * temp;
+		jy += *incy;
+/* L100: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp = 0.;
+		ix = kx;
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp += a[i__ + j * a_dim1] * x[ix];
+		    ix += *incx;
+/* L110: */
+		}
+		y[jy] += *alpha * temp;
+		jy += *incy;
+/* L120: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DGEMV . */
+
+} /* dgemv_ */

min-dgels/additional/dgeqr2.c

@@ -0,0 +1,161 @@
+/* dgeqr2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dgeqr2_(integer *m, integer *n, doublereal *a, integer *
+	lda, doublereal *tau, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, k;
+    doublereal aii;
+    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *), dlarfp_(integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *), xerbla_(char *, integer *);
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGEQR2 computes a QR factorization of a real m by n matrix A: */
+/*  A = Q * R. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          On entry, the m by n matrix A. */
+/*          On exit, the elements on and above the diagonal of the array */
+/*          contain the min(m,n) by n upper trapezoidal matrix R (R is */
+/*          upper triangular if m >= n); the elements below the diagonal, */
+/*          with the array TAU, represent the orthogonal matrix Q as a */
+/*          product of elementary reflectors (see Further Details). */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/*          The scalar factors of the elementary reflectors (see Further */
+/*          Details). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension (N) */
+
+/*  INFO    (output) INTEGER */
+/*          = 0: successful exit */
+/*          < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/*  Further Details */
+/*  =============== */
+
+/*  The matrix Q is represented as a product of elementary reflectors */
+
+/*     Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/*  Each H(i) has the form */
+
+/*     H(i) = I - tau * v * v' */
+
+/*  where tau is a real scalar, and v is a real vector with */
+/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/*  and tau in TAU(i). */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < max(1,*m)) {
+	*info = -4;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGEQR2", &i__1);
+	return 0;
+    }
+
+    k = min(*m,*n);
+
+    i__1 = k;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+
+/*        Generate elementary reflector H(i) to annihilate A(i+1:m,i) */
+
+	i__2 = *m - i__ + 1;
+/* Computing MIN */
+	i__3 = i__ + 1;
+	dlarfp_(&i__2, &a[i__ + i__ * a_dim1], &a[min(i__3, *m)+ i__ * a_dim1]
+, &c__1, &tau[i__]);
+	if (i__ < *n) {
+
+/*           Apply H(i) to A(i:m,i+1:n) from the left */
+
+	    aii = a[i__ + i__ * a_dim1];
+	    a[i__ + i__ * a_dim1] = 1.;
+	    i__2 = *m - i__ + 1;
+	    i__3 = *n - i__;
+	    dlarf_("Left", &i__2, &i__3, &a[i__ + i__ * a_dim1], &c__1, &tau[
+		    i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
+	    a[i__ + i__ * a_dim1] = aii;
+	}
+/* L10: */
+    }
+    return 0;
+
+/*     End of DGEQR2 */
+
+} /* dgeqr2_ */

min-dgels/additional/dgeqrf.c

@@ -0,0 +1,252 @@
+/* dgeqrf.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__3 = 3;
+static integer c__2 = 2;
+
+/* Subroutine */ int dgeqrf_(integer *m, integer *n, doublereal *a, integer *
+	lda, doublereal *tau, doublereal *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+    /* Local variables */
+    integer i__, k, ib, nb, nx, iws, nbmin, iinfo;
+    extern /* Subroutine */ int dgeqr2_(integer *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *), dlarfb_(char *, 
+	     char *, char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal 
+	    *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *);
+    integer ldwork, lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGEQRF computes a QR factorization of a real M-by-N matrix A: */
+/*  A = Q * R. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          On entry, the M-by-N matrix A. */
+/*          On exit, the elements on and above the diagonal of the array */
+/*          contain the min(M,N)-by-N upper trapezoidal matrix R (R is */
+/*          upper triangular if m >= n); the elements below the diagonal, */
+/*          with the array TAU, represent the orthogonal matrix Q as a */
+/*          product of min(m,n) elementary reflectors (see Further */
+/*          Details). */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/*  TAU     (output) DOUBLE PRECISION array, dimension (min(M,N)) */
+/*          The scalar factors of the elementary reflectors (see Further */
+/*          Details). */
+
+/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/*  LWORK   (input) INTEGER */
+/*          The dimension of the array WORK.  LWORK >= max(1,N). */
+/*          For optimum performance LWORK >= N*NB, where NB is */
+/*          the optimal blocksize. */
+
+/*          If LWORK = -1, then a workspace query is assumed; the routine */
+/*          only calculates the optimal size of the WORK array, returns */
+/*          this value as the first entry of the WORK array, and no error */
+/*          message related to LWORK is issued by XERBLA. */
+
+/*  INFO    (output) INTEGER */
+/*          = 0:  successful exit */
+/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
+
+/*  Further Details */
+/*  =============== */
+
+/*  The matrix Q is represented as a product of elementary reflectors */
+
+/*     Q = H(1) H(2) . . . H(k), where k = min(m,n). */
+
+/*  Each H(i) has the form */
+
+/*     H(i) = I - tau * v * v' */
+
+/*  where tau is a real scalar, and v is a real vector with */
+/*  v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i), */
+/*  and tau in TAU(i). */
+
+/*  ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    nb = ilaenv_(&c__1, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+    lwkopt = *n * nb;
+    work[1] = (doublereal) lwkopt;
+    lquery = *lwork == -1;
+    if (*m < 0) {
+	*info = -1;
+    } else if (*n < 0) {
+	*info = -2;
+    } else if (*lda < max(1,*m)) {
+	*info = -4;
+    } else if (*lwork < max(1,*n) && ! lquery) {
+	*info = -7;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DGEQRF", &i__1);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    k = min(*m,*n);
+    if (k == 0) {
+	work[1] = 1.;
+	return 0;
+    }
+
+    nbmin = 2;
+    nx = 0;
+    iws = *n;
+    if (nb > 1 && nb < k) {
+
+/*        Determine when to cross over from blocked to unblocked code. */
+
+/* Computing MAX */
+	i__1 = 0, i__2 = ilaenv_(&c__3, "DGEQRF", " ", m, n, &c_n1, &c_n1);
+	nx = max(i__1,i__2);
+	if (nx < k) {
+
+/*           Determine if workspace is large enough for blocked code. */
+
+	    ldwork = *n;
+	    iws = ldwork * nb;
+	    if (*lwork < iws) {
+
+/*              Not enough workspace to use optimal NB:  reduce NB and */
+/*              determine the minimum value of NB. */
+
+		nb = *lwork / ldwork;
+/* Computing MAX */
+		i__1 = 2, i__2 = ilaenv_(&c__2, "DGEQRF", " ", m, n, &c_n1, &
+			c_n1);
+		nbmin = max(i__1,i__2);
+	    }
+	}
+    }
+
+    if (nb >= nbmin && nb < k && nx < k) {
+
+/*        Use blocked code initially */
+
+	i__1 = k - nx;
+	i__2 = nb;
+	for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+	    i__3 = k - i__ + 1;
+	    ib = min(i__3,nb);
+
+/*           Compute the QR factorization of the current block */
+/*           A(i:m,i:i+ib-1) */
+
+	    i__3 = *m - i__ + 1;
+	    dgeqr2_(&i__3, &ib, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[
+		    1], &iinfo);
+	    if (i__ + ib <= *n) {
+
+/*              Form the triangular factor of the block reflector */
+/*              H = H(i) H(i+1) . . . H(i+ib-1) */
+
+		i__3 = *m - i__ + 1;
+		dlarft_("Forward", "Columnwise", &i__3, &ib, &a[i__ + i__ * 
+			a_dim1], lda, &tau[i__], &work[1], &ldwork);
+
+/*              Apply H' to A(i:m,i+ib:n) from the left */
+
+		i__3 = *m - i__ + 1;
+		i__4 = *n - i__ - ib + 1;
+		dlarfb_("Left", "Transpose", "Forward", "Columnwise", &i__3, &
+			i__4, &ib, &a[i__ + i__ * a_dim1], lda, &work[1], &
+			ldwork, &a[i__ + (i__ + ib) * a_dim1], lda, &work[ib 
+			+ 1], &ldwork);
+	    }
+/* L10: */
+	}
+    } else {
+	i__ = 1;
+    }
+
+/*     Use unblocked code to factor the last or only block. */
+
+    if (i__ <= k) {
+	i__2 = *m - i__ + 1;
+	i__1 = *n - i__ + 1;
+	dgeqr2_(&i__2, &i__1, &a[i__ + i__ * a_dim1], lda, &tau[i__], &work[1]
+, &iinfo);
+    }
+
+    work[1] = (doublereal) iws;
+    return 0;
+
+/*     End of DGEQRF */
+
+} /* dgeqrf_ */

min-dgels/additional/dger.c

@@ -0,0 +1,194 @@
+/* dger.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, 
+	doublereal *x, integer *incx, doublereal *y, integer *incy, 
+	doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, jy, kx, info;
+    doublereal temp;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGER   performs the rank 1 operation */
+
+/*     A := alpha*x*y' + A, */
+
+/*  where alpha is a scalar, x is an m element vector, y is an n element */
+/*  vector and A is an m by n matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of the matrix A. */
+/*           M must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( m - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the m */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the n */
+/*           element vector y. */
+/*           Unchanged on exit. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry, the leading m by n part of the array A must */
+/*           contain the matrix of coefficients. On exit, A is */
+/*           overwritten by the updated matrix. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --x;
+    --y;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    info = 0;
+    if (*m < 0) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 5;
+    } else if (*incy == 0) {
+	info = 7;
+    } else if (*lda < max(1,*m)) {
+	info = 9;
+    }
+    if (info != 0) {
+	xerbla_("DGER  ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || *alpha == 0.) {
+	return 0;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+    if (*incy > 0) {
+	jy = 1;
+    } else {
+	jy = 1 - (*n - 1) * *incy;
+    }
+    if (*incx == 1) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    if (y[jy] != 0.) {
+		temp = *alpha * y[jy];
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+		}
+	    }
+	    jy += *incy;
+/* L20: */
+	}
+    } else {
+	if (*incx > 0) {
+	    kx = 1;
+	} else {
+	    kx = 1 - (*m - 1) * *incx;
+	}
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    if (y[jy] != 0.) {
+		temp = *alpha * y[jy];
+		ix = kx;
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    a[i__ + j * a_dim1] += x[ix] * temp;
+		    ix += *incx;
+/* L30: */
+		}
+	    }
+	    jy += *incy;
+/* L40: */
+	}
+    }
+
+    return 0;
+
+/*     End of DGER  . */
+
+} /* dger_ */

min-dgels/additional/disnan.c

@@ -0,0 +1,52 @@
+/* disnan.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical disnan_(doublereal *din)
+{
+    /* System generated locals */
+    logical ret_val;
+
+    /* Local variables */
+    extern logical dlaisnan_(doublereal *, doublereal *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DISNAN returns .TRUE. if its argument is NaN, and .FALSE. */
+/*  otherwise.  To be replaced by the Fortran 2003 intrinsic in the */
+/*  future. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  DIN      (input) DOUBLE PRECISION */
+/*          Input to test for NaN. */
+
+/*  ===================================================================== */
+
+/*  .. External Functions .. */
+/*  .. */
+/*  .. Executable Statements .. */
+    ret_val = dlaisnan_(din, din);
+    return ret_val;
+} /* disnan_ */

min-dgels/additional/dlabad.c

@@ -0,0 +1,72 @@
+/* dlabad.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlabad_(doublereal *small, doublereal *large)
+{
+    /* Builtin functions */
+    double d_lg10(doublereal *), sqrt(doublereal);
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLABAD takes as input the values computed by DLAMCH for underflow and */
+/*  overflow, and returns the square root of each of these values if the */
+/*  log of LARGE is sufficiently large.  This subroutine is intended to */
+/*  identify machines with a large exponent range, such as the Crays, and */
+/*  redefine the underflow and overflow limits to be the square roots of */
+/*  the values computed by DLAMCH.  This subroutine is needed because */
+/*  DLAMCH does not compensate for poor arithmetic in the upper half of */
+/*  the exponent range, as is found on a Cray. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SMALL   (input/output) DOUBLE PRECISION */
+/*          On entry, the underflow threshold as computed by DLAMCH. */
+/*          On exit, if LOG10(LARGE) is sufficiently large, the square */
+/*          root of SMALL, otherwise unchanged. */
+
+/*  LARGE   (input/output) DOUBLE PRECISION */
+/*          On entry, the overflow threshold as computed by DLAMCH. */
+/*          On exit, if LOG10(LARGE) is sufficiently large, the square */
+/*          root of LARGE, otherwise unchanged. */
+
+/*  ===================================================================== */
+
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     If it looks like we're on a Cray, take the square root of */
+/*     SMALL and LARGE to avoid overflow and underflow problems. */
+
+    if (d_lg10(large) > 2e3) {
+	*small = sqrt(*small);
+	*large = sqrt(*large);
+    }
+
+    return 0;
+
+/*     End of DLABAD */
+
+} /* dlabad_ */

min-dgels/additional/dlaisnan.c

@@ -0,0 +1,58 @@
+/* dlaisnan.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical dlaisnan_(doublereal *din1, doublereal *din2)
+{
+    /* System generated locals */
+    logical ret_val;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  This routine is not for general use.  It exists solely to avoid */
+/*  over-optimization in DISNAN. */
+
+/*  DLAISNAN checks for NaNs by comparing its two arguments for */
+/*  inequality.  NaN is the only floating-point value where NaN != NaN */
+/*  returns .TRUE.  To check for NaNs, pass the same variable as both */
+/*  arguments. */
+
+/*  A compiler must assume that the two arguments are */
+/*  not the same variable, and the test will not be optimized away. */
+/*  Interprocedural or whole-program optimization may delete this */
+/*  test.  The ISNAN functions will be replaced by the correct */
+/*  Fortran 03 intrinsic once the intrinsic is widely available. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  DIN1     (input) DOUBLE PRECISION */
+/*  DIN2     (input) DOUBLE PRECISION */
+/*          Two numbers to compare for inequality. */
+
+/*  ===================================================================== */
+
+/*  .. Executable Statements .. */
+    ret_val = *din1 != *din2;
+    return ret_val;
+} /* dlaisnan_ */

min-dgels/additional/dlange.c

@@ -0,0 +1,199 @@
+/* dlange.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+doublereal dlange_(char *norm, integer *m, integer *n, doublereal *a, integer 
+	*lda, doublereal *work)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+    doublereal ret_val, d__1, d__2, d__3;
+
+    /* Builtin functions */
+    double sqrt(doublereal);
+
+    /* Local variables */
+    integer i__, j;
+    doublereal sum, scale;
+    extern logical lsame_(char *, char *);
+    doublereal value;
+    extern /* Subroutine */ int dlassq_(integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLANGE  returns the value of the one norm,  or the Frobenius norm, or */
+/*  the  infinity norm,  or the  element of  largest absolute value  of a */
+/*  real matrix A. */
+
+/*  Description */
+/*  =========== */
+
+/*  DLANGE returns the value */
+
+/*     DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm' */
+/*              ( */
+/*              ( norm1(A),         NORM = '1', 'O' or 'o' */
+/*              ( */
+/*              ( normI(A),         NORM = 'I' or 'i' */
+/*              ( */
+/*              ( normF(A),         NORM = 'F', 'f', 'E' or 'e' */
+
+/*  where  norm1  denotes the  one norm of a matrix (maximum column sum), */
+/*  normI  denotes the  infinity norm  of a matrix  (maximum row sum) and */
+/*  normF  denotes the  Frobenius norm of a matrix (square root of sum of */
+/*  squares).  Note that  max(abs(A(i,j)))  is not a consistent matrix norm. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  NORM    (input) CHARACTER*1 */
+/*          Specifies the value to be returned in DLANGE as described */
+/*          above. */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0.  When M = 0, */
+/*          DLANGE is set to zero. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0.  When N = 0, */
+/*          DLANGE is set to zero. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          The m by n matrix A. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(M,1). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)), */
+/*          where LWORK >= M when NORM = 'I'; otherwise, WORK is not */
+/*          referenced. */
+
+/* ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --work;
+
+    /* Function Body */
+    if (min(*m,*n) == 0) {
+	value = 0.;
+    } else if (lsame_(norm, "M")) {
+
+/*        Find max(abs(A(i,j))). */
+
+	value = 0.;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+/* Computing MAX */
+		d__2 = value, d__3 = (d__1 = a[i__ + j * a_dim1], abs(d__1));
+		value = max(d__2,d__3);
+/* L10: */
+	    }
+/* L20: */
+	}
+    } else if (lsame_(norm, "O") || *(unsigned char *)
+	    norm == '1') {
+
+/*        Find norm1(A). */
+
+	value = 0.;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    sum = 0.;
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		sum += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L30: */
+	    }
+	    value = max(value,sum);
+/* L40: */
+	}
+    } else if (lsame_(norm, "I")) {
+
+/*        Find normI(A). */
+
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    work[i__] = 0.;
+/* L50: */
+	}
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		work[i__] += (d__1 = a[i__ + j * a_dim1], abs(d__1));
+/* L60: */
+	    }
+/* L70: */
+	}
+	value = 0.;
+	i__1 = *m;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+/* Computing MAX */
+	    d__1 = value, d__2 = work[i__];
+	    value = max(d__1,d__2);
+/* L80: */
+	}
+    } else if (lsame_(norm, "F") || lsame_(norm, "E")) {
+
+/*        Find normF(A). */
+
+	scale = 0.;
+	sum = 1.;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    dlassq_(m, &a[j * a_dim1 + 1], &c__1, &scale, &sum);
+/* L90: */
+	}
+	value = scale * sqrt(sum);
+    }
+
+    ret_val = value;
+    return ret_val;
+
+/*     End of DLANGE */
+
+} /* dlange_ */

min-dgels/additional/dlapy2.c

@@ -0,0 +1,73 @@
+/* dlapy2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dlapy2_(doublereal *x, doublereal *y)
+{
+    /* System generated locals */
+    doublereal ret_val, d__1;
+
+    /* Builtin functions */
+    double sqrt(doublereal);
+
+    /* Local variables */
+    doublereal w, z__, xabs, yabs;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary */
+/*  overflow. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  X       (input) DOUBLE PRECISION */
+/*  Y       (input) DOUBLE PRECISION */
+/*          X and Y specify the values x and y. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    xabs = abs(*x);
+    yabs = abs(*y);
+    w = max(xabs,yabs);
+    z__ = min(xabs,yabs);
+    if (z__ == 0.) {
+	ret_val = w;
+    } else {
+/* Computing 2nd power */
+	d__1 = z__ / w;
+	ret_val = w * sqrt(d__1 * d__1 + 1.);
+    }
+    return ret_val;
+
+/*     End of DLAPY2 */
+
+} /* dlapy2_ */

min-dgels/additional/dlarf.c

@@ -0,0 +1,193 @@
+/* dlarf.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+static doublereal c_b5 = 0.;
+static integer c__1 = 1;
+
+/* Subroutine */ int dlarf_(char *side, integer *m, integer *n, doublereal *v, 
+	 integer *incv, doublereal *tau, doublereal *c__, integer *ldc, 
+	doublereal *work)
+{
+    /* System generated locals */
+    integer c_dim1, c_offset;
+    doublereal d__1;
+
+    /* Local variables */
+    integer i__;
+    logical applyleft;
+    extern /* Subroutine */ int dger_(integer *, integer *, doublereal *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *);
+    integer lastc, lastv;
+    extern integer iladlc_(integer *, integer *, doublereal *, integer *), 
+	    iladlr_(integer *, integer *, doublereal *, integer *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLARF applies a real elementary reflector H to a real m by n matrix */
+/*  C, from either the left or the right. H is represented in the form */
+
+/*        H = I - tau * v * v' */
+
+/*  where tau is a real scalar and v is a real vector. */
+
+/*  If tau = 0, then H is taken to be the unit matrix. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SIDE    (input) CHARACTER*1 */
+/*          = 'L': form  H * C */
+/*          = 'R': form  C * H */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix C. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix C. */
+
+/*  V       (input) DOUBLE PRECISION array, dimension */
+/*                     (1 + (M-1)*abs(INCV)) if SIDE = 'L' */
+/*                  or (1 + (N-1)*abs(INCV)) if SIDE = 'R' */
+/*          The vector v in the representation of H. V is not used if */
+/*          TAU = 0. */
+
+/*  INCV    (input) INTEGER */
+/*          The increment between elements of v. INCV <> 0. */
+
+/*  TAU     (input) DOUBLE PRECISION */
+/*          The value tau in the representation of H. */
+
+/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/*          On entry, the m by n matrix C. */
+/*          On exit, C is overwritten by the matrix H * C if SIDE = 'L', */
+/*          or C * H if SIDE = 'R'. */
+
+/*  LDC     (input) INTEGER */
+/*          The leading dimension of the array C. LDC >= max(1,M). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension */
+/*                         (N) if SIDE = 'L' */
+/*                      or (M) if SIDE = 'R' */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    --v;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+    --work;
+
+    /* Function Body */
+    applyleft = lsame_(side, "L");
+    lastv = 0;
+    lastc = 0;
+    if (*tau != 0.) {
+/*     Set up variables for scanning V.  LASTV begins pointing to the end */
+/*     of V. */
+	if (applyleft) {
+	    lastv = *m;
+	} else {
+	    lastv = *n;
+	}
+	if (*incv > 0) {
+	    i__ = (lastv - 1) * *incv + 1;
+	} else {
+	    i__ = 1;
+	}
+/*     Look for the last non-zero row in V. */
+	while(lastv > 0 && v[i__] == 0.) {
+	    --lastv;
+	    i__ -= *incv;
+	}
+	if (applyleft) {
+/*     Scan for the last non-zero column in C(1:lastv,:). */
+	    lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+	} else {
+/*     Scan for the last non-zero row in C(:,1:lastv). */
+	    lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+	}
+    }
+/*     Note that lastc.eq.0 renders the BLAS operations null; no special */
+/*     case is needed at this level. */
+    if (applyleft) {
+
+/*        Form  H * C */
+
+	if (lastv > 0) {
+
+/*           w(1:lastc,1) := C(1:lastv,1:lastc)' * v(1:lastv,1) */
+
+	    dgemv_("Transpose", &lastv, &lastc, &c_b4, &c__[c_offset], ldc, &
+		    v[1], incv, &c_b5, &work[1], &c__1);
+
+/*           C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)' */
+
+	    d__1 = -(*tau);
+	    dger_(&lastv, &lastc, &d__1, &v[1], incv, &work[1], &c__1, &c__[
+		    c_offset], ldc);
+	}
+    } else {
+
+/*        Form  C * H */
+
+	if (lastv > 0) {
+
+/*           w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1) */
+
+	    dgemv_("No transpose", &lastc, &lastv, &c_b4, &c__[c_offset], ldc, 
+		     &v[1], incv, &c_b5, &work[1], &c__1);
+
+/*           C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)' */
+
+	    d__1 = -(*tau);
+	    dger_(&lastc, &lastv, &d__1, &work[1], &c__1, &v[1], incv, &c__[
+		    c_offset], ldc);
+	}
+    }
+    return 0;
+
+/*     End of DLARF */
+
+} /* dlarf_ */

min-dgels/additional/dlarfb.c

@@ -0,0 +1,774 @@
+/* dlarfb.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b14 = 1.;
+static doublereal c_b25 = -1.;
+
+/* Subroutine */ int dlarfb_(char *side, char *trans, char *direct, char *
+	storev, integer *m, integer *n, integer *k, doublereal *v, integer *
+	ldv, doublereal *t, integer *ldt, doublereal *c__, integer *ldc, 
+	doublereal *work, integer *ldwork)
+{
+    /* System generated locals */
+    integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, 
+	    work_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j;
+    extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, 
+	    integer *, doublereal *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, doublereal *, integer *);
+    extern logical lsame_(char *, char *);
+    integer lastc;
+    extern /* Subroutine */ int dcopy_(integer *, doublereal *, integer *, 
+	    doublereal *, integer *), dtrmm_(char *, char *, char *, char *, 
+	    integer *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *);
+    integer lastv;
+    extern integer iladlc_(integer *, integer *, doublereal *, integer *), 
+	    iladlr_(integer *, integer *, doublereal *, integer *);
+    char transt[1];
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLARFB applies a real block reflector H or its transpose H' to a */
+/*  real m by n matrix C, from either the left or the right. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SIDE    (input) CHARACTER*1 */
+/*          = 'L': apply H or H' from the Left */
+/*          = 'R': apply H or H' from the Right */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          = 'N': apply H (No transpose) */
+/*          = 'T': apply H' (Transpose) */
+
+/*  DIRECT  (input) CHARACTER*1 */
+/*          Indicates how H is formed from a product of elementary */
+/*          reflectors */
+/*          = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/*          = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/*  STOREV  (input) CHARACTER*1 */
+/*          Indicates how the vectors which define the elementary */
+/*          reflectors are stored: */
+/*          = 'C': Columnwise */
+/*          = 'R': Rowwise */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix C. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix C. */
+
+/*  K       (input) INTEGER */
+/*          The order of the matrix T (= the number of elementary */
+/*          reflectors whose product defines the block reflector). */
+
+/*  V       (input) DOUBLE PRECISION array, dimension */
+/*                                (LDV,K) if STOREV = 'C' */
+/*                                (LDV,M) if STOREV = 'R' and SIDE = 'L' */
+/*                                (LDV,N) if STOREV = 'R' and SIDE = 'R' */
+/*          The matrix V. See further details. */
+
+/*  LDV     (input) INTEGER */
+/*          The leading dimension of the array V. */
+/*          If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); */
+/*          if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); */
+/*          if STOREV = 'R', LDV >= K. */
+
+/*  T       (input) DOUBLE PRECISION array, dimension (LDT,K) */
+/*          The triangular k by k matrix T in the representation of the */
+/*          block reflector. */
+
+/*  LDT     (input) INTEGER */
+/*          The leading dimension of the array T. LDT >= K. */
+
+/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/*          On entry, the m by n matrix C. */
+/*          On exit, C is overwritten by H*C or H'*C or C*H or C*H'. */
+
+/*  LDC     (input) INTEGER */
+/*          The leading dimension of the array C. LDA >= max(1,M). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension (LDWORK,K) */
+
+/*  LDWORK  (input) INTEGER */
+/*          The leading dimension of the array WORK. */
+/*          If SIDE = 'L', LDWORK >= max(1,N); */
+/*          if SIDE = 'R', LDWORK >= max(1,M). */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Quick return if possible */
+
+    /* Parameter adjustments */
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1;
+    v -= v_offset;
+    t_dim1 = *ldt;
+    t_offset = 1 + t_dim1;
+    t -= t_offset;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+    work_dim1 = *ldwork;
+    work_offset = 1 + work_dim1;
+    work -= work_offset;
+
+    /* Function Body */
+    if (*m <= 0 || *n <= 0) {
+	return 0;
+    }
+
+    if (lsame_(trans, "N")) {
+	*(unsigned char *)transt = 'T';
+    } else {
+	*(unsigned char *)transt = 'N';
+    }
+
+    if (lsame_(storev, "C")) {
+
+	if (lsame_(direct, "F")) {
+
+/*           Let  V =  ( V1 )    (first K rows) */
+/*                     ( V2 ) */
+/*           where  V1  is unit lower triangular. */
+
+	    if (lsame_(side, "L")) {
+
+/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
+/*                                                  ( C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK) */
+
+/*              W := C1' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 
+			    + 1], &c__1);
+/* L10: */
+		}
+
+/*              W := W * V1 */
+
+		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C2'*V2 */
+
+		    i__1 = lastv - *k;
+		    dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
+			    c_b14, &c__[*k + 1 + c_dim1], ldc, &v[*k + 1 + 
+			    v_dim1], ldv, &c_b14, &work[work_offset], ldwork);
+		}
+
+/*              W := W * T'  or  W * T */
+
+		dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
+			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - V * W' */
+
+		if (lastv > *k) {
+
+/*                 C2 := C2 - V2 * W' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
+			    c_b25, &v[*k + 1 + v_dim1], ldv, &work[
+			    work_offset], ldwork, &c_b14, &c__[*k + 1 + 
+			    c_dim1], ldc);
+		}
+
+/*              W := W * V1' */
+
+		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/*              C1 := C1 - W' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
+/* L20: */
+		    }
+/* L30: */
+		}
+
+	    } else if (lsame_(side, "R")) {
+
+/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK) */
+
+/*              W := C1 */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * 
+			    work_dim1 + 1], &c__1);
+/* L40: */
+		}
+
+/*              W := W * V1 */
+
+		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C2 * V2 */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+			    c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[*k + 
+			    1 + v_dim1], ldv, &c_b14, &work[work_offset], 
+			    ldwork);
+		}
+
+/*              W := W * T  or  W * T' */
+
+		dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, 
+			 &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - W * V' */
+
+		if (lastv > *k) {
+
+/*                 C2 := C2 - W * V2' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
+			    c_b25, &work[work_offset], ldwork, &v[*k + 1 + 
+			    v_dim1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 + 1], 
+			     ldc);
+		}
+
+/*              W := W * V1' */
+
+		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/*              C1 := C1 - W */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L50: */
+		    }
+/* L60: */
+		}
+	    }
+
+	} else {
+
+/*           Let  V =  ( V1 ) */
+/*                     ( V2 )    (last K rows) */
+/*           where  V2  is unit upper triangular. */
+
+	    if (lsame_(side, "L")) {
+
+/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
+/*                                                  ( C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlr_(m, k, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/*              W := C' * V  =  (C1'*V1 + C2'*V2)  (stored in WORK) */
+
+/*              W := C2' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+			    j * work_dim1 + 1], &c__1);
+/* L70: */
+		}
+
+/*              W := W * V2 */
+
+		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+			work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C1'*V1 */
+
+		    i__1 = lastv - *k;
+		    dgemm_("Transpose", "No transpose", &lastc, k, &i__1, &
+			    c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+			    c_b14, &work[work_offset], ldwork);
+		}
+
+/*              W := W * T'  or  W * T */
+
+		dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
+			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - V * W' */
+
+		if (lastv > *k) {
+
+/*                 C1 := C1 - V1 * W' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "Transpose", &i__1, &lastc, k, &
+			    c_b25, &v[v_offset], ldv, &work[work_offset], 
+			    ldwork, &c_b14, &c__[c_offset], ldc);
+		}
+
+/*              W := W * V2' */
+
+		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+			work_offset], ldwork);
+
+/*              C2 := C2 - W' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * 
+				work_dim1];
+/* L80: */
+		    }
+/* L90: */
+		}
+
+	    } else if (lsame_(side, "R")) {
+
+/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlr_(n, k, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/*              W := C * V  =  (C1*V1 + C2*V2)  (stored in WORK) */
+
+/*              W := C2 */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[(*n - *k + j) * c_dim1 + 1], &c__1, &
+			    work[j * work_dim1 + 1], &c__1);
+/* L100: */
+		}
+
+/*              W := W * V2 */
+
+		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+			work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C1 * V1 */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "No transpose", &lastc, k, &i__1, &
+			    c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+			    c_b14, &work[work_offset], ldwork);
+		}
+
+/*              W := W * T  or  W * T' */
+
+		dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, 
+			 &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - W * V' */
+
+		if (lastv > *k) {
+
+/*                 C1 := C1 - W * V1' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "Transpose", &lastc, &i__1, k, &
+			    c_b25, &work[work_offset], ldwork, &v[v_offset], 
+			    ldv, &c_b14, &c__[c_offset], ldc);
+		}
+
+/*              W := W * V2' */
+
+		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[lastv - *k + 1 + v_dim1], ldv, &work[
+			work_offset], ldwork);
+
+/*              C2 := C2 - W */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
+				 work_dim1];
+/* L110: */
+		    }
+/* L120: */
+		}
+	    }
+	}
+
+    } else if (lsame_(storev, "R")) {
+
+	if (lsame_(direct, "F")) {
+
+/*           Let  V =  ( V1  V2 )    (V1: first K columns) */
+/*           where  V1  is unit upper triangular. */
+
+	    if (lsame_(side, "L")) {
+
+/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
+/*                                                  ( C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/*              W := C1' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[j + c_dim1], ldc, &work[j * work_dim1 
+			    + 1], &c__1);
+/* L130: */
+		}
+
+/*              W := W * V1' */
+
+		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C2'*V2' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, 
+			     &c__[*k + 1 + c_dim1], ldc, &v[(*k + 1) * v_dim1 
+			    + 1], ldv, &c_b14, &work[work_offset], ldwork);
+		}
+
+/*              W := W * T'  or  W * T */
+
+		dtrmm_("Right", "Upper", transt, "Non-unit", &lastc, k, &
+			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - V' * W' */
+
+		if (lastv > *k) {
+
+/*                 C2 := C2 - V2' * W' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, 
+			     &v[(*k + 1) * v_dim1 + 1], ldv, &work[
+			    work_offset], ldwork, &c_b14, &c__[*k + 1 + 
+			    c_dim1], ldc);
+		}
+
+/*              W := W * V1 */
+
+		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/*              C1 := C1 - W' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[j + i__ * c_dim1] -= work[i__ + j * work_dim1];
+/* L140: */
+		    }
+/* L150: */
+		}
+
+	    } else if (lsame_(side, "R")) {
+
+/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK) */
+
+/*              W := C1 */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[j * c_dim1 + 1], &c__1, &work[j * 
+			    work_dim1 + 1], &c__1);
+/* L160: */
+		}
+
+/*              W := W * V1' */
+
+		dtrmm_("Right", "Upper", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C2 * V2' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
+			    c_b14, &c__[(*k + 1) * c_dim1 + 1], ldc, &v[(*k + 
+			    1) * v_dim1 + 1], ldv, &c_b14, &work[work_offset], 
+			     ldwork);
+		}
+
+/*              W := W * T  or  W * T' */
+
+		dtrmm_("Right", "Upper", trans, "Non-unit", &lastc, k, &c_b14, 
+			 &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - W * V */
+
+		if (lastv > *k) {
+
+/*                 C2 := C2 - W * V2 */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+			    c_b25, &work[work_offset], ldwork, &v[(*k + 1) * 
+			    v_dim1 + 1], ldv, &c_b14, &c__[(*k + 1) * c_dim1 
+			    + 1], ldc);
+		}
+
+/*              W := W * V1 */
+
+		dtrmm_("Right", "Upper", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[v_offset], ldv, &work[work_offset], ldwork);
+
+/*              C1 := C1 - W */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] -= work[i__ + j * work_dim1];
+/* L170: */
+		    }
+/* L180: */
+		}
+
+	    }
+
+	} else {
+
+/*           Let  V =  ( V1  V2 )    (V2: last K columns) */
+/*           where  V2  is unit lower triangular. */
+
+	    if (lsame_(side, "L")) {
+
+/*              Form  H * C  or  H' * C  where  C = ( C1 ) */
+/*                                                  ( C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlc_(k, m, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlc_(&lastv, n, &c__[c_offset], ldc);
+
+/*              W := C' * V'  =  (C1'*V1' + C2'*V2') (stored in WORK) */
+
+/*              W := C2' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[lastv - *k + j + c_dim1], ldc, &work[
+			    j * work_dim1 + 1], &c__1);
+/* L190: */
+		}
+
+/*              W := W * V2' */
+
+		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+			work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C1'*V1' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("Transpose", "Transpose", &lastc, k, &i__1, &c_b14, 
+			     &c__[c_offset], ldc, &v[v_offset], ldv, &c_b14, &
+			    work[work_offset], ldwork);
+		}
+
+/*              W := W * T'  or  W * T */
+
+		dtrmm_("Right", "Lower", transt, "Non-unit", &lastc, k, &
+			c_b14, &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - V' * W' */
+
+		if (lastv > *k) {
+
+/*                 C1 := C1 - V1' * W' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("Transpose", "Transpose", &i__1, &lastc, k, &c_b25, 
+			     &v[v_offset], ldv, &work[work_offset], ldwork, &
+			    c_b14, &c__[c_offset], ldc);
+		}
+
+/*              W := W * V2 */
+
+		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+			work_offset], ldwork);
+
+/*              C2 := C2 - W' */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[lastv - *k + j + i__ * c_dim1] -= work[i__ + j * 
+				work_dim1];
+/* L200: */
+		    }
+/* L210: */
+		}
+
+	    } else if (lsame_(side, "R")) {
+
+/*              Form  C * H  or  C * H'  where  C = ( C1  C2 ) */
+
+/* Computing MAX */
+		i__1 = *k, i__2 = iladlc_(k, n, &v[v_offset], ldv);
+		lastv = max(i__1,i__2);
+		lastc = iladlr_(m, &lastv, &c__[c_offset], ldc);
+
+/*              W := C * V'  =  (C1*V1' + C2*V2')  (stored in WORK) */
+
+/*              W := C2 */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    dcopy_(&lastc, &c__[(lastv - *k + j) * c_dim1 + 1], &c__1, 
+			     &work[j * work_dim1 + 1], &c__1);
+/* L220: */
+		}
+
+/*              W := W * V2' */
+
+		dtrmm_("Right", "Lower", "Transpose", "Unit", &lastc, k, &
+			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+			work_offset], ldwork);
+		if (lastv > *k) {
+
+/*                 W := W + C1 * V1' */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "Transpose", &lastc, k, &i__1, &
+			    c_b14, &c__[c_offset], ldc, &v[v_offset], ldv, &
+			    c_b14, &work[work_offset], ldwork);
+		}
+
+/*              W := W * T  or  W * T' */
+
+		dtrmm_("Right", "Lower", trans, "Non-unit", &lastc, k, &c_b14, 
+			 &t[t_offset], ldt, &work[work_offset], ldwork);
+
+/*              C := C - W * V */
+
+		if (lastv > *k) {
+
+/*                 C1 := C1 - W * V1 */
+
+		    i__1 = lastv - *k;
+		    dgemm_("No transpose", "No transpose", &lastc, &i__1, k, &
+			    c_b25, &work[work_offset], ldwork, &v[v_offset], 
+			    ldv, &c_b14, &c__[c_offset], ldc);
+		}
+
+/*              W := W * V2 */
+
+		dtrmm_("Right", "Lower", "No transpose", "Unit", &lastc, k, &
+			c_b14, &v[(lastv - *k + 1) * v_dim1 + 1], ldv, &work[
+			work_offset], ldwork);
+
+/*              C1 := C1 - W */
+
+		i__1 = *k;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = lastc;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + (lastv - *k + j) * c_dim1] -= work[i__ + j *
+				 work_dim1];
+/* L230: */
+		    }
+/* L240: */
+		}
+
+	    }
+
+	}
+    }
+
+    return 0;
+
+/*     End of DLARFB */
+
+} /* dlarfb_ */

min-dgels/additional/dlarfg.c

@@ -0,0 +1,170 @@
+/* dlarfg.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarfg_(integer *n, doublereal *alpha, doublereal *x, 
+	integer *incx, doublereal *tau)
+{
+    /* System generated locals */
+    integer i__1;
+    doublereal d__1;
+
+    /* Builtin functions */
+    double d_sign(doublereal *, doublereal *);
+
+    /* Local variables */
+    integer j, knt;
+    doublereal beta;
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *);
+    doublereal xnorm;
+    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+    doublereal safmin, rsafmn;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLARFG generates a real elementary reflector H of order n, such */
+/*  that */
+
+/*        H * ( alpha ) = ( beta ),   H' * H = I. */
+/*            (   x   )   (   0  ) */
+
+/*  where alpha and beta are scalars, and x is an (n-1)-element real */
+/*  vector. H is represented in the form */
+
+/*        H = I - tau * ( 1 ) * ( 1 v' ) , */
+/*                      ( v ) */
+
+/*  where tau is a real scalar and v is a real (n-1)-element */
+/*  vector. */
+
+/*  If the elements of x are all zero, then tau = 0 and H is taken to be */
+/*  the unit matrix. */
+
+/*  Otherwise  1 <= tau <= 2. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  N       (input) INTEGER */
+/*          The order of the elementary reflector. */
+
+/*  ALPHA   (input/output) DOUBLE PRECISION */
+/*          On entry, the value alpha. */
+/*          On exit, it is overwritten with the value beta. */
+
+/*  X       (input/output) DOUBLE PRECISION array, dimension */
+/*                         (1+(N-2)*abs(INCX)) */
+/*          On entry, the vector x. */
+/*          On exit, it is overwritten with the vector v. */
+
+/*  INCX    (input) INTEGER */
+/*          The increment between elements of X. INCX > 0. */
+
+/*  TAU     (output) DOUBLE PRECISION */
+/*          The value tau. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n <= 1) {
+	*tau = 0.;
+	return 0;
+    }
+
+    i__1 = *n - 1;
+    xnorm = dnrm2_(&i__1, &x[1], incx);
+
+    if (xnorm == 0.) {
+
+/*        H  =  I */
+
+	*tau = 0.;
+    } else {
+
+/*        general case */
+
+	d__1 = dlapy2_(alpha, &xnorm);
+	beta = -d_sign(&d__1, alpha);
+	safmin = dlamch_("S") / dlamch_("E");
+	knt = 0;
+	if (abs(beta) < safmin) {
+
+/*           XNORM, BETA may be inaccurate; scale X and recompute them */
+
+	    rsafmn = 1. / safmin;
+L10:
+	    ++knt;
+	    i__1 = *n - 1;
+	    dscal_(&i__1, &rsafmn, &x[1], incx);
+	    beta *= rsafmn;
+	    *alpha *= rsafmn;
+	    if (abs(beta) < safmin) {
+		goto L10;
+	    }
+
+/*           New BETA is at most 1, at least SAFMIN */
+
+	    i__1 = *n - 1;
+	    xnorm = dnrm2_(&i__1, &x[1], incx);
+	    d__1 = dlapy2_(alpha, &xnorm);
+	    beta = -d_sign(&d__1, alpha);
+	}
+	*tau = (beta - *alpha) / beta;
+	i__1 = *n - 1;
+	d__1 = 1. / (*alpha - beta);
+	dscal_(&i__1, &d__1, &x[1], incx);
+
+/*        If ALPHA is subnormal, it may lose relative accuracy */
+
+	i__1 = knt;
+	for (j = 1; j <= i__1; ++j) {
+	    beta *= safmin;
+/* L20: */
+	}
+	*alpha = beta;
+    }
+
+    return 0;
+
+/*     End of DLARFG */
+
+} /* dlarfg_ */

min-dgels/additional/dlarfp.c

@@ -0,0 +1,192 @@
+/* dlarfp.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlarfp_(integer *n, doublereal *alpha, doublereal *x, 
+	integer *incx, doublereal *tau)
+{
+    /* System generated locals */
+    integer i__1;
+    doublereal d__1;
+
+    /* Builtin functions */
+    double d_sign(doublereal *, doublereal *);
+
+    /* Local variables */
+    integer j, knt;
+    doublereal beta;
+    extern doublereal dnrm2_(integer *, doublereal *, integer *);
+    extern /* Subroutine */ int dscal_(integer *, doublereal *, doublereal *, 
+	    integer *);
+    doublereal xnorm;
+    extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *);
+    doublereal safmin, rsafmn;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLARFP generates a real elementary reflector H of order n, such */
+/*  that */
+
+/*        H * ( alpha ) = ( beta ),   H' * H = I. */
+/*            (   x   )   (   0  ) */
+
+/*  where alpha and beta are scalars, beta is non-negative, and x is */
+/*  an (n-1)-element real vector.  H is represented in the form */
+
+/*        H = I - tau * ( 1 ) * ( 1 v' ) , */
+/*                      ( v ) */
+
+/*  where tau is a real scalar and v is a real (n-1)-element */
+/*  vector. */
+
+/*  If the elements of x are all zero, then tau = 0 and H is taken to be */
+/*  the unit matrix. */
+
+/*  Otherwise  1 <= tau <= 2. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  N       (input) INTEGER */
+/*          The order of the elementary reflector. */
+
+/*  ALPHA   (input/output) DOUBLE PRECISION */
+/*          On entry, the value alpha. */
+/*          On exit, it is overwritten with the value beta. */
+
+/*  X       (input/output) DOUBLE PRECISION array, dimension */
+/*                         (1+(N-2)*abs(INCX)) */
+/*          On entry, the vector x. */
+/*          On exit, it is overwritten with the vector v. */
+
+/*  INCX    (input) INTEGER */
+/*          The increment between elements of X. INCX > 0. */
+
+/*  TAU     (output) DOUBLE PRECISION */
+/*          The value tau. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n <= 0) {
+	*tau = 0.;
+	return 0;
+    }
+
+    i__1 = *n - 1;
+    xnorm = dnrm2_(&i__1, &x[1], incx);
+
+    if (xnorm == 0.) {
+
+/*        H  =  [+/-1, 0; I], sign chosen so ALPHA >= 0 */
+
+	if (*alpha >= 0.) {
+/*           When TAU.eq.ZERO, the vector is special-cased to be */
+/*           all zeros in the application routines.  We do not need */
+/*           to clear it. */
+	    *tau = 0.;
+	} else {
+/*           However, the application routines rely on explicit */
+/*           zero checks when TAU.ne.ZERO, and we must clear X. */
+	    *tau = 2.;
+	    i__1 = *n - 1;
+	    for (j = 1; j <= i__1; ++j) {
+		x[(j - 1) * *incx + 1] = 0.;
+	    }
+	    *alpha = -(*alpha);
+	}
+    } else {
+
+/*        general case */
+
+	d__1 = dlapy2_(alpha, &xnorm);
+	beta = d_sign(&d__1, alpha);
+	safmin = dlamch_("S") / dlamch_("E");
+	knt = 0;
+	if (abs(beta) < safmin) {
+
+/*           XNORM, BETA may be inaccurate; scale X and recompute them */
+
+	    rsafmn = 1. / safmin;
+L10:
+	    ++knt;
+	    i__1 = *n - 1;
+	    dscal_(&i__1, &rsafmn, &x[1], incx);
+	    beta *= rsafmn;
+	    *alpha *= rsafmn;
+	    if (abs(beta) < safmin) {
+		goto L10;
+	    }
+
+/*           New BETA is at most 1, at least SAFMIN */
+
+	    i__1 = *n - 1;
+	    xnorm = dnrm2_(&i__1, &x[1], incx);
+	    d__1 = dlapy2_(alpha, &xnorm);
+	    beta = d_sign(&d__1, alpha);
+	}
+	*alpha += beta;
+	if (beta < 0.) {
+	    beta = -beta;
+	    *tau = -(*alpha) / beta;
+	} else {
+	    *alpha = xnorm * (xnorm / *alpha);
+	    *tau = *alpha / beta;
+	    *alpha = -(*alpha);
+	}
+	i__1 = *n - 1;
+	d__1 = 1. / *alpha;
+	dscal_(&i__1, &d__1, &x[1], incx);
+
+/*        If BETA is subnormal, it may lose relative accuracy */
+
+	i__1 = knt;
+	for (j = 1; j <= i__1; ++j) {
+	    beta *= safmin;
+/* L20: */
+	}
+	*alpha = beta;
+    }
+
+    return 0;
+
+/*     End of DLARFP */
+
+} /* dlarfp_ */

min-dgels/additional/dlarft.c

@@ -0,0 +1,325 @@
+/* dlarft.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static doublereal c_b8 = 0.;
+
+/* Subroutine */ int dlarft_(char *direct, char *storev, integer *n, integer *
+	k, doublereal *v, integer *ldv, doublereal *tau, doublereal *t, 
+	integer *ldt)
+{
+    /* System generated locals */
+    integer t_dim1, t_offset, v_dim1, v_offset, i__1, i__2, i__3;
+    doublereal d__1;
+
+    /* Local variables */
+    integer i__, j, prevlastv;
+    doublereal vii;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int dgemv_(char *, integer *, integer *, 
+	    doublereal *, doublereal *, integer *, doublereal *, integer *, 
+	    doublereal *, doublereal *, integer *);
+    integer lastv;
+    extern /* Subroutine */ int dtrmv_(char *, char *, char *, integer *, 
+	    doublereal *, integer *, doublereal *, integer *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLARFT forms the triangular factor T of a real block reflector H */
+/*  of order n, which is defined as a product of k elementary reflectors. */
+
+/*  If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular; */
+
+/*  If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular. */
+
+/*  If STOREV = 'C', the vector which defines the elementary reflector */
+/*  H(i) is stored in the i-th column of the array V, and */
+
+/*     H  =  I - V * T * V' */
+
+/*  If STOREV = 'R', the vector which defines the elementary reflector */
+/*  H(i) is stored in the i-th row of the array V, and */
+
+/*     H  =  I - V' * T * V */
+
+/*  Arguments */
+/*  ========= */
+
+/*  DIRECT  (input) CHARACTER*1 */
+/*          Specifies the order in which the elementary reflectors are */
+/*          multiplied to form the block reflector: */
+/*          = 'F': H = H(1) H(2) . . . H(k) (Forward) */
+/*          = 'B': H = H(k) . . . H(2) H(1) (Backward) */
+
+/*  STOREV  (input) CHARACTER*1 */
+/*          Specifies how the vectors which define the elementary */
+/*          reflectors are stored (see also Further Details): */
+/*          = 'C': columnwise */
+/*          = 'R': rowwise */
+
+/*  N       (input) INTEGER */
+/*          The order of the block reflector H. N >= 0. */
+
+/*  K       (input) INTEGER */
+/*          The order of the triangular factor T (= the number of */
+/*          elementary reflectors). K >= 1. */
+
+/*  V       (input/output) DOUBLE PRECISION array, dimension */
+/*                               (LDV,K) if STOREV = 'C' */
+/*                               (LDV,N) if STOREV = 'R' */
+/*          The matrix V. See further details. */
+
+/*  LDV     (input) INTEGER */
+/*          The leading dimension of the array V. */
+/*          If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K. */
+
+/*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
+/*          TAU(i) must contain the scalar factor of the elementary */
+/*          reflector H(i). */
+
+/*  T       (output) DOUBLE PRECISION array, dimension (LDT,K) */
+/*          The k by k triangular factor T of the block reflector. */
+/*          If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is */
+/*          lower triangular. The rest of the array is not used. */
+
+/*  LDT     (input) INTEGER */
+/*          The leading dimension of the array T. LDT >= K. */
+
+/*  Further Details */
+/*  =============== */
+
+/*  The shape of the matrix V and the storage of the vectors which define */
+/*  the H(i) is best illustrated by the following example with n = 5 and */
+/*  k = 3. The elements equal to 1 are not stored; the corresponding */
+/*  array elements are modified but restored on exit. The rest of the */
+/*  array is not used. */
+
+/*  DIRECT = 'F' and STOREV = 'C':         DIRECT = 'F' and STOREV = 'R': */
+
+/*               V = (  1       )                 V = (  1 v1 v1 v1 v1 ) */
+/*                   ( v1  1    )                     (     1 v2 v2 v2 ) */
+/*                   ( v1 v2  1 )                     (        1 v3 v3 ) */
+/*                   ( v1 v2 v3 ) */
+/*                   ( v1 v2 v3 ) */
+
+/*  DIRECT = 'B' and STOREV = 'C':         DIRECT = 'B' and STOREV = 'R': */
+
+/*               V = ( v1 v2 v3 )                 V = ( v1 v1  1       ) */
+/*                   ( v1 v2 v3 )                     ( v2 v2 v2  1    ) */
+/*                   (  1 v2 v3 )                     ( v3 v3 v3 v3  1 ) */
+/*                   (     1 v3 ) */
+/*                   (        1 ) */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Quick return if possible */
+
+    /* Parameter adjustments */
+    v_dim1 = *ldv;
+    v_offset = 1 + v_dim1;
+    v -= v_offset;
+    --tau;
+    t_dim1 = *ldt;
+    t_offset = 1 + t_dim1;
+    t -= t_offset;
+
+    /* Function Body */
+    if (*n == 0) {
+	return 0;
+    }
+
+    if (lsame_(direct, "F")) {
+	prevlastv = *n;
+	i__1 = *k;
+	for (i__ = 1; i__ <= i__1; ++i__) {
+	    prevlastv = max(i__,prevlastv);
+	    if (tau[i__] == 0.) {
+
+/*              H(i)  =  I */
+
+		i__2 = i__;
+		for (j = 1; j <= i__2; ++j) {
+		    t[j + i__ * t_dim1] = 0.;
+/* L10: */
+		}
+	    } else {
+
+/*              general case */
+
+		vii = v[i__ + i__ * v_dim1];
+		v[i__ + i__ * v_dim1] = 1.;
+		if (lsame_(storev, "C")) {
+/*                 Skip any trailing zeros. */
+		    i__2 = i__ + 1;
+		    for (lastv = *n; lastv >= i__2; --lastv) {
+			if (v[lastv + i__ * v_dim1] != 0.) {
+			    break;
+			}
+		    }
+		    j = min(lastv,prevlastv);
+
+/*                 T(1:i-1,i) := - tau(i) * V(i:j,1:i-1)' * V(i:j,i) */
+
+		    i__2 = j - i__ + 1;
+		    i__3 = i__ - 1;
+		    d__1 = -tau[i__];
+		    dgemv_("Transpose", &i__2, &i__3, &d__1, &v[i__ + v_dim1], 
+			     ldv, &v[i__ + i__ * v_dim1], &c__1, &c_b8, &t[
+			    i__ * t_dim1 + 1], &c__1);
+		} else {
+/*                 Skip any trailing zeros. */
+		    i__2 = i__ + 1;
+		    for (lastv = *n; lastv >= i__2; --lastv) {
+			if (v[i__ + lastv * v_dim1] != 0.) {
+			    break;
+			}
+		    }
+		    j = min(lastv,prevlastv);
+
+/*                 T(1:i-1,i) := - tau(i) * V(1:i-1,i:j) * V(i,i:j)' */
+
+		    i__2 = i__ - 1;
+		    i__3 = j - i__ + 1;
+		    d__1 = -tau[i__];
+		    dgemv_("No transpose", &i__2, &i__3, &d__1, &v[i__ * 
+			    v_dim1 + 1], ldv, &v[i__ + i__ * v_dim1], ldv, &
+			    c_b8, &t[i__ * t_dim1 + 1], &c__1);
+		}
+		v[i__ + i__ * v_dim1] = vii;
+
+/*              T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i) */
+
+		i__2 = i__ - 1;
+		dtrmv_("Upper", "No transpose", "Non-unit", &i__2, &t[
+			t_offset], ldt, &t[i__ * t_dim1 + 1], &c__1);
+		t[i__ + i__ * t_dim1] = tau[i__];
+		if (i__ > 1) {
+		    prevlastv = max(prevlastv,lastv);
+		} else {
+		    prevlastv = lastv;
+		}
+	    }
+/* L20: */
+	}
+    } else {
+	prevlastv = 1;
+	for (i__ = *k; i__ >= 1; --i__) {
+	    if (tau[i__] == 0.) {
+
+/*              H(i)  =  I */
+
+		i__1 = *k;
+		for (j = i__; j <= i__1; ++j) {
+		    t[j + i__ * t_dim1] = 0.;
+/* L30: */
+		}
+	    } else {
+
+/*              general case */
+
+		if (i__ < *k) {
+		    if (lsame_(storev, "C")) {
+			vii = v[*n - *k + i__ + i__ * v_dim1];
+			v[*n - *k + i__ + i__ * v_dim1] = 1.;
+/*                    Skip any leading zeros. */
+			i__1 = i__ - 1;
+			for (lastv = 1; lastv <= i__1; ++lastv) {
+			    if (v[lastv + i__ * v_dim1] != 0.) {
+				break;
+			    }
+			}
+			j = max(lastv,prevlastv);
+
+/*                    T(i+1:k,i) := */
+/*                            - tau(i) * V(j:n-k+i,i+1:k)' * V(j:n-k+i,i) */
+
+			i__1 = *n - *k + i__ - j + 1;
+			i__2 = *k - i__;
+			d__1 = -tau[i__];
+			dgemv_("Transpose", &i__1, &i__2, &d__1, &v[j + (i__ 
+				+ 1) * v_dim1], ldv, &v[j + i__ * v_dim1], &
+				c__1, &c_b8, &t[i__ + 1 + i__ * t_dim1], &
+				c__1);
+			v[*n - *k + i__ + i__ * v_dim1] = vii;
+		    } else {
+			vii = v[i__ + (*n - *k + i__) * v_dim1];
+			v[i__ + (*n - *k + i__) * v_dim1] = 1.;
+/*                    Skip any leading zeros. */
+			i__1 = i__ - 1;
+			for (lastv = 1; lastv <= i__1; ++lastv) {
+			    if (v[i__ + lastv * v_dim1] != 0.) {
+				break;
+			    }
+			}
+			j = max(lastv,prevlastv);
+
+/*                    T(i+1:k,i) := */
+/*                            - tau(i) * V(i+1:k,j:n-k+i) * V(i,j:n-k+i)' */
+
+			i__1 = *k - i__;
+			i__2 = *n - *k + i__ - j + 1;
+			d__1 = -tau[i__];
+			dgemv_("No transpose", &i__1, &i__2, &d__1, &v[i__ + 
+				1 + j * v_dim1], ldv, &v[i__ + j * v_dim1], 
+				ldv, &c_b8, &t[i__ + 1 + i__ * t_dim1], &c__1);
+			v[i__ + (*n - *k + i__) * v_dim1] = vii;
+		    }
+
+/*                 T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i) */
+
+		    i__1 = *k - i__;
+		    dtrmv_("Lower", "No transpose", "Non-unit", &i__1, &t[i__ 
+			    + 1 + (i__ + 1) * t_dim1], ldt, &t[i__ + 1 + i__ *
+			     t_dim1], &c__1)
+			    ;
+		    if (i__ > 1) {
+			prevlastv = min(prevlastv,lastv);
+		    } else {
+			prevlastv = lastv;
+		    }
+		}
+		t[i__ + i__ * t_dim1] = tau[i__];
+	    }
+/* L40: */
+	}
+    }
+    return 0;
+
+/*     End of DLARFT */
+
+} /* dlarft_ */

min-dgels/additional/dlascl.c

@@ -0,0 +1,354 @@
+/* dlascl.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlascl_(char *type__, integer *kl, integer *ku, 
+	doublereal *cfrom, doublereal *cto, integer *m, integer *n, 
+	doublereal *a, integer *lda, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5;
+
+    /* Local variables */
+    integer i__, j, k1, k2, k3, k4;
+    doublereal mul, cto1;
+    logical done;
+    doublereal ctoc;
+    extern logical lsame_(char *, char *);
+    integer itype;
+    doublereal cfrom1;
+    extern doublereal dlamch_(char *);
+    doublereal cfromc;
+    extern logical disnan_(doublereal *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    doublereal bignum, smlnum;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLASCL multiplies the M by N real matrix A by the real scalar */
+/*  CTO/CFROM.  This is done without over/underflow as long as the final */
+/*  result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that */
+/*  A may be full, upper triangular, lower triangular, upper Hessenberg, */
+/*  or banded. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  TYPE    (input) CHARACTER*1 */
+/*          TYPE indices the storage type of the input matrix. */
+/*          = 'G':  A is a full matrix. */
+/*          = 'L':  A is a lower triangular matrix. */
+/*          = 'U':  A is an upper triangular matrix. */
+/*          = 'H':  A is an upper Hessenberg matrix. */
+/*          = 'B':  A is a symmetric band matrix with lower bandwidth KL */
+/*                  and upper bandwidth KU and with the only the lower */
+/*                  half stored. */
+/*          = 'Q':  A is a symmetric band matrix with lower bandwidth KL */
+/*                  and upper bandwidth KU and with the only the upper */
+/*                  half stored. */
+/*          = 'Z':  A is a band matrix with lower bandwidth KL and upper */
+/*                  bandwidth KU. */
+
+/*  KL      (input) INTEGER */
+/*          The lower bandwidth of A.  Referenced only if TYPE = 'B', */
+/*          'Q' or 'Z'. */
+
+/*  KU      (input) INTEGER */
+/*          The upper bandwidth of A.  Referenced only if TYPE = 'B', */
+/*          'Q' or 'Z'. */
+
+/*  CFROM   (input) DOUBLE PRECISION */
+/*  CTO     (input) DOUBLE PRECISION */
+/*          The matrix A is multiplied by CTO/CFROM. A(I,J) is computed */
+/*          without over/underflow if the final result CTO*A(I,J)/CFROM */
+/*          can be represented without over/underflow.  CFROM must be */
+/*          nonzero. */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          The matrix to be multiplied by CTO/CFROM.  See TYPE for the */
+/*          storage type. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/*  INFO    (output) INTEGER */
+/*          0  - successful exit */
+/*          <0 - if INFO = -i, the i-th argument had an illegal value. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    *info = 0;
+
+    if (lsame_(type__, "G")) {
+	itype = 0;
+    } else if (lsame_(type__, "L")) {
+	itype = 1;
+    } else if (lsame_(type__, "U")) {
+	itype = 2;
+    } else if (lsame_(type__, "H")) {
+	itype = 3;
+    } else if (lsame_(type__, "B")) {
+	itype = 4;
+    } else if (lsame_(type__, "Q")) {
+	itype = 5;
+    } else if (lsame_(type__, "Z")) {
+	itype = 6;
+    } else {
+	itype = -1;
+    }
+
+    if (itype == -1) {
+	*info = -1;
+    } else if (*cfrom == 0. || disnan_(cfrom)) {
+	*info = -4;
+    } else if (disnan_(cto)) {
+	*info = -5;
+    } else if (*m < 0) {
+	*info = -6;
+    } else if (*n < 0 || itype == 4 && *n != *m || itype == 5 && *n != *m) {
+	*info = -7;
+    } else if (itype <= 3 && *lda < max(1,*m)) {
+	*info = -9;
+    } else if (itype >= 4) {
+/* Computing MAX */
+	i__1 = *m - 1;
+	if (*kl < 0 || *kl > max(i__1,0)) {
+	    *info = -2;
+	} else /* if(complicated condition) */ {
+/* Computing MAX */
+	    i__1 = *n - 1;
+	    if (*ku < 0 || *ku > max(i__1,0) || (itype == 4 || itype == 5) && 
+		    *kl != *ku) {
+		*info = -3;
+	    } else if (itype == 4 && *lda < *kl + 1 || itype == 5 && *lda < *
+		    ku + 1 || itype == 6 && *lda < (*kl << 1) + *ku + 1) {
+		*info = -9;
+	    }
+	}
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DLASCL", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0 || *m == 0) {
+	return 0;
+    }
+
+/*     Get machine parameters */
+
+    smlnum = dlamch_("S");
+    bignum = 1. / smlnum;
+
+    cfromc = *cfrom;
+    ctoc = *cto;
+
+L10:
+    cfrom1 = cfromc * smlnum;
+    if (cfrom1 == cfromc) {
+/*        CFROMC is an inf.  Multiply by a correctly signed zero for */
+/*        finite CTOC, or a NaN if CTOC is infinite. */
+	mul = ctoc / cfromc;
+	done = TRUE_;
+	cto1 = ctoc;
+    } else {
+	cto1 = ctoc / bignum;
+	if (cto1 == ctoc) {
+/*           CTOC is either 0 or an inf.  In both cases, CTOC itself */
+/*           serves as the correct multiplication factor. */
+	    mul = ctoc;
+	    done = TRUE_;
+	    cfromc = 1.;
+	} else if (abs(cfrom1) > abs(ctoc) && ctoc != 0.) {
+	    mul = smlnum;
+	    done = FALSE_;
+	    cfromc = cfrom1;
+	} else if (abs(cto1) > abs(cfromc)) {
+	    mul = bignum;
+	    done = FALSE_;
+	    ctoc = cto1;
+	} else {
+	    mul = ctoc / cfromc;
+	    done = TRUE_;
+	}
+    }
+
+    if (itype == 0) {
+
+/*        Full matrix */
+
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L20: */
+	    }
+/* L30: */
+	}
+
+    } else if (itype == 1) {
+
+/*        Lower triangular matrix */
+
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = j; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L40: */
+	    }
+/* L50: */
+	}
+
+    } else if (itype == 2) {
+
+/*        Upper triangular matrix */
+
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = min(j,*m);
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L60: */
+	    }
+/* L70: */
+	}
+
+    } else if (itype == 3) {
+
+/*        Upper Hessenberg matrix */
+
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+	    i__3 = j + 1;
+	    i__2 = min(i__3,*m);
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L80: */
+	    }
+/* L90: */
+	}
+
+    } else if (itype == 4) {
+
+/*        Lower half of a symmetric band matrix */
+
+	k3 = *kl + 1;
+	k4 = *n + 1;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+/* Computing MIN */
+	    i__3 = k3, i__4 = k4 - j;
+	    i__2 = min(i__3,i__4);
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L100: */
+	    }
+/* L110: */
+	}
+
+    } else if (itype == 5) {
+
+/*        Upper half of a symmetric band matrix */
+
+	k1 = *ku + 2;
+	k3 = *ku + 1;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+	    i__2 = k1 - j;
+	    i__3 = k3;
+	    for (i__ = max(i__2,1); i__ <= i__3; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L120: */
+	    }
+/* L130: */
+	}
+
+    } else if (itype == 6) {
+
+/*        Band matrix */
+
+	k1 = *kl + *ku + 2;
+	k2 = *kl + 1;
+	k3 = (*kl << 1) + *ku + 1;
+	k4 = *kl + *ku + 1 + *m;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+/* Computing MAX */
+	    i__3 = k1 - j;
+/* Computing MIN */
+	    i__4 = k3, i__5 = k4 - j;
+	    i__2 = min(i__4,i__5);
+	    for (i__ = max(i__3,k2); i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] *= mul;
+/* L140: */
+	    }
+/* L150: */
+	}
+
+    }
+
+    if (! done) {
+	goto L10;
+    }
+
+    return 0;
+
+/*     End of DLASCL */
+
+} /* dlascl_ */

min-dgels/additional/dlaset.c

@@ -0,0 +1,152 @@
+/* dlaset.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlaset_(char *uplo, integer *m, integer *n, doublereal *
+	alpha, doublereal *beta, doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j;
+    extern logical lsame_(char *, char *);
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLASET initializes an m-by-n matrix A to BETA on the diagonal and */
+/*  ALPHA on the offdiagonals. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  UPLO    (input) CHARACTER*1 */
+/*          Specifies the part of the matrix A to be set. */
+/*          = 'U':      Upper triangular part is set; the strictly lower */
+/*                      triangular part of A is not changed. */
+/*          = 'L':      Lower triangular part is set; the strictly upper */
+/*                      triangular part of A is not changed. */
+/*          Otherwise:  All of the matrix A is set. */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A.  M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A.  N >= 0. */
+
+/*  ALPHA   (input) DOUBLE PRECISION */
+/*          The constant to which the offdiagonal elements are to be set. */
+
+/*  BETA    (input) DOUBLE PRECISION */
+/*          The constant to which the diagonal elements are to be set. */
+
+/*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          On exit, the leading m-by-n submatrix of A is set as follows: */
+
+/*          if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n, */
+/*          if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n, */
+/*          otherwise,     A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j, */
+
+/*          and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n). */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,M). */
+
+/* ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    if (lsame_(uplo, "U")) {
+
+/*        Set the strictly upper triangular or trapezoidal part of the */
+/*        array to ALPHA. */
+
+	i__1 = *n;
+	for (j = 2; j <= i__1; ++j) {
+/* Computing MIN */
+	    i__3 = j - 1;
+	    i__2 = min(i__3,*m);
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = *alpha;
+/* L10: */
+	    }
+/* L20: */
+	}
+
+    } else if (lsame_(uplo, "L")) {
+
+/*        Set the strictly lower triangular or trapezoidal part of the */
+/*        array to ALPHA. */
+
+	i__1 = min(*m,*n);
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = j + 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = *alpha;
+/* L30: */
+	    }
+/* L40: */
+	}
+
+    } else {
+
+/*        Set the leading m-by-n submatrix to ALPHA. */
+
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		a[i__ + j * a_dim1] = *alpha;
+/* L50: */
+	    }
+/* L60: */
+	}
+    }
+
+/*     Set the first min(M,N) diagonal elements to BETA. */
+
+    i__1 = min(*m,*n);
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	a[i__ + i__ * a_dim1] = *beta;
+/* L70: */
+    }
+
+    return 0;
+
+/*     End of DLASET */
+
+} /* dlaset_ */

min-dgels/additional/dlassq.c

@@ -0,0 +1,116 @@
+/* dlassq.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dlassq_(integer *n, doublereal *x, integer *incx, 
+	doublereal *scale, doublereal *sumsq)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal d__1;
+
+    /* Local variables */
+    integer ix;
+    doublereal absxi;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DLASSQ  returns the values  scl  and  smsq  such that */
+
+/*     ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq, */
+
+/*  where  x( i ) = X( 1 + ( i - 1 )*INCX ). The value of  sumsq  is */
+/*  assumed to be non-negative and  scl  returns the value */
+
+/*     scl = max( scale, abs( x( i ) ) ). */
+
+/*  scale and sumsq must be supplied in SCALE and SUMSQ and */
+/*  scl and smsq are overwritten on SCALE and SUMSQ respectively. */
+
+/*  The routine makes only one pass through the vector x. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  N       (input) INTEGER */
+/*          The number of elements to be used from the vector X. */
+
+/*  X       (input) DOUBLE PRECISION array, dimension (N) */
+/*          The vector for which a scaled sum of squares is computed. */
+/*             x( i )  = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n. */
+
+/*  INCX    (input) INTEGER */
+/*          The increment between successive values of the vector X. */
+/*          INCX > 0. */
+
+/*  SCALE   (input/output) DOUBLE PRECISION */
+/*          On entry, the value  scale  in the equation above. */
+/*          On exit, SCALE is overwritten with  scl , the scaling factor */
+/*          for the sum of squares. */
+
+/*  SUMSQ   (input/output) DOUBLE PRECISION */
+/*          On entry, the value  sumsq  in the equation above. */
+/*          On exit, SUMSQ is overwritten with  smsq , the basic sum of */
+/*          squares from which  scl  has been factored out. */
+
+/* ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n > 0) {
+	i__1 = (*n - 1) * *incx + 1;
+	i__2 = *incx;
+	for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+	    if (x[ix] != 0.) {
+		absxi = (d__1 = x[ix], abs(d__1));
+		if (*scale < absxi) {
+/* Computing 2nd power */
+		    d__1 = *scale / absxi;
+		    *sumsq = *sumsq * (d__1 * d__1) + 1;
+		    *scale = absxi;
+		} else {
+/* Computing 2nd power */
+		    d__1 = absxi / *scale;
+		    *sumsq += d__1 * d__1;
+		}
+	    }
+/* L10: */
+	}
+    }
+    return 0;
+
+/*     End of DLASSQ */
+
+} /* dlassq_ */

min-dgels/additional/dnrm2.c

@@ -0,0 +1,95 @@
+/* dnrm2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal ret_val, d__1;
+
+    /* Builtin functions */
+    double sqrt(doublereal);
+
+    /* Local variables */
+    integer ix;
+    doublereal ssq, norm, scale, absxi;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DNRM2 returns the euclidean norm of a vector via the function */
+/*  name, so that */
+
+/*     DNRM2 := sqrt( x'*x ) */
+
+
+/*  -- This version written on 25-October-1982. */
+/*     Modified on 14-October-1993 to inline the call to DLASSQ. */
+/*     Sven Hammarling, Nag Ltd. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n < 1 || *incx < 1) {
+	norm = 0.;
+    } else if (*n == 1) {
+	norm = abs(x[1]);
+    } else {
+	scale = 0.;
+	ssq = 1.;
+/*        The following loop is equivalent to this call to the LAPACK */
+/*        auxiliary routine: */
+/*        CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+	i__1 = (*n - 1) * *incx + 1;
+	i__2 = *incx;
+	for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+	    if (x[ix] != 0.) {
+		absxi = (d__1 = x[ix], abs(d__1));
+		if (scale < absxi) {
+/* Computing 2nd power */
+		    d__1 = scale / absxi;
+		    ssq = ssq * (d__1 * d__1) + 1.;
+		    scale = absxi;
+		} else {
+/* Computing 2nd power */
+		    d__1 = absxi / scale;
+		    ssq += d__1 * d__1;
+		}
+	    }
+/* L10: */
+	}
+	norm = scale * sqrt(ssq);
+    }
+
+    ret_val = norm;
+    return ret_val;
+
+/*     End of DNRM2. */
+
+} /* dnrm2_ */

min-dgels/additional/dorm2r.c

@@ -0,0 +1,235 @@
+/* dorm2r.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int dorm2r_(char *side, char *trans, integer *m, integer *n, 
+	integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+	c__, integer *ldc, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+    doublereal aii;
+    logical left;
+    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical notran;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DORM2R overwrites the general real m by n matrix C with */
+
+/*        Q * C  if SIDE = 'L' and TRANS = 'N', or */
+
+/*        Q'* C  if SIDE = 'L' and TRANS = 'T', or */
+
+/*        C * Q  if SIDE = 'R' and TRANS = 'N', or */
+
+/*        C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/*  where Q is a real orthogonal matrix defined as the product of k */
+/*  elementary reflectors */
+
+/*        Q = H(1) H(2) . . . H(k) */
+
+/*  as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n */
+/*  if SIDE = 'R'. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SIDE    (input) CHARACTER*1 */
+/*          = 'L': apply Q or Q' from the Left */
+/*          = 'R': apply Q or Q' from the Right */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          = 'N': apply Q  (No transpose) */
+/*          = 'T': apply Q' (Transpose) */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix C. M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix C. N >= 0. */
+
+/*  K       (input) INTEGER */
+/*          The number of elementary reflectors whose product defines */
+/*          the matrix Q. */
+/*          If SIDE = 'L', M >= K >= 0; */
+/*          if SIDE = 'R', N >= K >= 0. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/*          The i-th column must contain the vector which defines the */
+/*          elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/*          DGEQRF in the first k columns of its array argument A. */
+/*          A is modified by the routine but restored on exit. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A. */
+/*          If SIDE = 'L', LDA >= max(1,M); */
+/*          if SIDE = 'R', LDA >= max(1,N). */
+
+/*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
+/*          TAU(i) must contain the scalar factor of the elementary */
+/*          reflector H(i), as returned by DGEQRF. */
+
+/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/*          On entry, the m by n matrix C. */
+/*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/*  LDC     (input) INTEGER */
+/*          The leading dimension of the array C. LDC >= max(1,M). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension */
+/*                                   (N) if SIDE = 'L', */
+/*                                   (M) if SIDE = 'R' */
+
+/*  INFO    (output) INTEGER */
+/*          = 0: successful exit */
+/*          < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    left = lsame_(side, "L");
+    notran = lsame_(trans, "N");
+
+/*     NQ is the order of Q */
+
+    if (left) {
+	nq = *m;
+    } else {
+	nq = *n;
+    }
+    if (! left && ! lsame_(side, "R")) {
+	*info = -1;
+    } else if (! notran && ! lsame_(trans, "T")) {
+	*info = -2;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*k < 0 || *k > nq) {
+	*info = -5;
+    } else if (*lda < max(1,nq)) {
+	*info = -7;
+    } else if (*ldc < max(1,*m)) {
+	*info = -10;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DORM2R", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*m == 0 || *n == 0 || *k == 0) {
+	return 0;
+    }
+
+    if (left && ! notran || ! left && notran) {
+	i1 = 1;
+	i2 = *k;
+	i3 = 1;
+    } else {
+	i1 = *k;
+	i2 = 1;
+	i3 = -1;
+    }
+
+    if (left) {
+	ni = *n;
+	jc = 1;
+    } else {
+	mi = *m;
+	ic = 1;
+    }
+
+    i__1 = i2;
+    i__2 = i3;
+    for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	if (left) {
+
+/*           H(i) is applied to C(i:m,1:n) */
+
+	    mi = *m - i__ + 1;
+	    ic = i__;
+	} else {
+
+/*           H(i) is applied to C(1:m,i:n) */
+
+	    ni = *n - i__ + 1;
+	    jc = i__;
+	}
+
+/*        Apply H(i) */
+
+	aii = a[i__ + i__ * a_dim1];
+	a[i__ + i__ * a_dim1] = 1.;
+	dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[
+		ic + jc * c_dim1], ldc, &work[1]);
+	a[i__ + i__ * a_dim1] = aii;
+/* L10: */
+    }
+    return 0;
+
+/*     End of DORM2R */
+
+} /* dorm2r_ */

min-dgels/additional/dorml2.c

@@ -0,0 +1,231 @@
+/* dorml2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dorml2_(char *side, char *trans, integer *m, integer *n, 
+	integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+	c__, integer *ldc, doublereal *work, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
+    doublereal aii;
+    logical left;
+    extern /* Subroutine */ int dlarf_(char *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *);
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical notran;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DORML2 overwrites the general real m by n matrix C with */
+
+/*        Q * C  if SIDE = 'L' and TRANS = 'N', or */
+
+/*        Q'* C  if SIDE = 'L' and TRANS = 'T', or */
+
+/*        C * Q  if SIDE = 'R' and TRANS = 'N', or */
+
+/*        C * Q' if SIDE = 'R' and TRANS = 'T', */
+
+/*  where Q is a real orthogonal matrix defined as the product of k */
+/*  elementary reflectors */
+
+/*        Q = H(k) . . . H(2) H(1) */
+
+/*  as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n */
+/*  if SIDE = 'R'. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SIDE    (input) CHARACTER*1 */
+/*          = 'L': apply Q or Q' from the Left */
+/*          = 'R': apply Q or Q' from the Right */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          = 'N': apply Q  (No transpose) */
+/*          = 'T': apply Q' (Transpose) */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix C. M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix C. N >= 0. */
+
+/*  K       (input) INTEGER */
+/*          The number of elementary reflectors whose product defines */
+/*          the matrix Q. */
+/*          If SIDE = 'L', M >= K >= 0; */
+/*          if SIDE = 'R', N >= K >= 0. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension */
+/*                               (LDA,M) if SIDE = 'L', */
+/*                               (LDA,N) if SIDE = 'R' */
+/*          The i-th row must contain the vector which defines the */
+/*          elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/*          DGELQF in the first k rows of its array argument A. */
+/*          A is modified by the routine but restored on exit. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A. LDA >= max(1,K). */
+
+/*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
+/*          TAU(i) must contain the scalar factor of the elementary */
+/*          reflector H(i), as returned by DGELQF. */
+
+/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/*          On entry, the m by n matrix C. */
+/*          On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q. */
+
+/*  LDC     (input) INTEGER */
+/*          The leading dimension of the array C. LDC >= max(1,M). */
+
+/*  WORK    (workspace) DOUBLE PRECISION array, dimension */
+/*                                   (N) if SIDE = 'L', */
+/*                                   (M) if SIDE = 'R' */
+
+/*  INFO    (output) INTEGER */
+/*          = 0: successful exit */
+/*          < 0: if INFO = -i, the i-th argument had an illegal value */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    left = lsame_(side, "L");
+    notran = lsame_(trans, "N");
+
+/*     NQ is the order of Q */
+
+    if (left) {
+	nq = *m;
+    } else {
+	nq = *n;
+    }
+    if (! left && ! lsame_(side, "R")) {
+	*info = -1;
+    } else if (! notran && ! lsame_(trans, "T")) {
+	*info = -2;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*k < 0 || *k > nq) {
+	*info = -5;
+    } else if (*lda < max(1,*k)) {
+	*info = -7;
+    } else if (*ldc < max(1,*m)) {
+	*info = -10;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DORML2", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*m == 0 || *n == 0 || *k == 0) {
+	return 0;
+    }
+
+    if (left && notran || ! left && ! notran) {
+	i1 = 1;
+	i2 = *k;
+	i3 = 1;
+    } else {
+	i1 = *k;
+	i2 = 1;
+	i3 = -1;
+    }
+
+    if (left) {
+	ni = *n;
+	jc = 1;
+    } else {
+	mi = *m;
+	ic = 1;
+    }
+
+    i__1 = i2;
+    i__2 = i3;
+    for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	if (left) {
+
+/*           H(i) is applied to C(i:m,1:n) */
+
+	    mi = *m - i__ + 1;
+	    ic = i__;
+	} else {
+
+/*           H(i) is applied to C(1:m,i:n) */
+
+	    ni = *n - i__ + 1;
+	    jc = i__;
+	}
+
+/*        Apply H(i) */
+
+	aii = a[i__ + i__ * a_dim1];
+	a[i__ + i__ * a_dim1] = 1.;
+	dlarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], lda, &tau[i__], &c__[
+		ic + jc * c_dim1], ldc, &work[1]);
+	a[i__ + i__ * a_dim1] = aii;
+/* L10: */
+    }
+    return 0;
+
+/*     End of DORML2 */
+
+} /* dorml2_ */

min-dgels/additional/dormlq.c

@@ -0,0 +1,334 @@
+/* dormlq.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormlq_(char *side, char *trans, integer *m, integer *n, 
+	integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+	c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    address a__1[2];
+    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, 
+	    i__5;
+    char ch__1[2];
+
+    /* Builtin functions */
+    /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+    /* Local variables */
+    integer i__;
+    doublereal t[4160]	/* was [65][64] */;
+    integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+    logical left;
+    extern logical lsame_(char *, char *);
+    integer nbmin, iinfo;
+    extern /* Subroutine */ int dorml2_(char *, char *, integer *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
+	    integer *, doublereal *, integer *), dlarfb_(char 
+	    *, char *, char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal 
+	    *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *);
+    logical notran;
+    integer ldwork;
+    char transt[1];
+    integer lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DORMLQ overwrites the general real M-by-N matrix C with */
+
+/*                  SIDE = 'L'     SIDE = 'R' */
+/*  TRANS = 'N':      Q * C          C * Q */
+/*  TRANS = 'T':      Q**T * C       C * Q**T */
+
+/*  where Q is a real orthogonal matrix defined as the product of k */
+/*  elementary reflectors */
+
+/*        Q = H(k) . . . H(2) H(1) */
+
+/*  as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N */
+/*  if SIDE = 'R'. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SIDE    (input) CHARACTER*1 */
+/*          = 'L': apply Q or Q**T from the Left; */
+/*          = 'R': apply Q or Q**T from the Right. */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          = 'N':  No transpose, apply Q; */
+/*          = 'T':  Transpose, apply Q**T. */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix C. M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix C. N >= 0. */
+
+/*  K       (input) INTEGER */
+/*          The number of elementary reflectors whose product defines */
+/*          the matrix Q. */
+/*          If SIDE = 'L', M >= K >= 0; */
+/*          if SIDE = 'R', N >= K >= 0. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension */
+/*                               (LDA,M) if SIDE = 'L', */
+/*                               (LDA,N) if SIDE = 'R' */
+/*          The i-th row must contain the vector which defines the */
+/*          elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/*          DGELQF in the first k rows of its array argument A. */
+/*          A is modified by the routine but restored on exit. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A. LDA >= max(1,K). */
+
+/*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
+/*          TAU(i) must contain the scalar factor of the elementary */
+/*          reflector H(i), as returned by DGELQF. */
+
+/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/*          On entry, the M-by-N matrix C. */
+/*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/*  LDC     (input) INTEGER */
+/*          The leading dimension of the array C. LDC >= max(1,M). */
+
+/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/*  LWORK   (input) INTEGER */
+/*          The dimension of the array WORK. */
+/*          If SIDE = 'L', LWORK >= max(1,N); */
+/*          if SIDE = 'R', LWORK >= max(1,M). */
+/*          For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/*          blocksize. */
+
+/*          If LWORK = -1, then a workspace query is assumed; the routine */
+/*          only calculates the optimal size of the WORK array, returns */
+/*          this value as the first entry of the WORK array, and no error */
+/*          message related to LWORK is issued by XERBLA. */
+
+/*  INFO    (output) INTEGER */
+/*          = 0:  successful exit */
+/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Local Arrays .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    left = lsame_(side, "L");
+    notran = lsame_(trans, "N");
+    lquery = *lwork == -1;
+
+/*     NQ is the order of Q and NW is the minimum dimension of WORK */
+
+    if (left) {
+	nq = *m;
+	nw = *n;
+    } else {
+	nq = *n;
+	nw = *m;
+    }
+    if (! left && ! lsame_(side, "R")) {
+	*info = -1;
+    } else if (! notran && ! lsame_(trans, "T")) {
+	*info = -2;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*k < 0 || *k > nq) {
+	*info = -5;
+    } else if (*lda < max(1,*k)) {
+	*info = -7;
+    } else if (*ldc < max(1,*m)) {
+	*info = -10;
+    } else if (*lwork < max(1,nw) && ! lquery) {
+	*info = -12;
+    }
+
+    if (*info == 0) {
+
+/*        Determine the block size.  NB may be at most NBMAX, where NBMAX */
+/*        is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+	i__3[0] = 1, a__1[0] = side;
+	i__3[1] = 1, a__1[1] = trans;
+	s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+	i__1 = 64, i__2 = ilaenv_(&c__1, "DORMLQ", ch__1, m, n, k, &c_n1);
+	nb = min(i__1,i__2);
+	lwkopt = max(1,nw) * nb;
+	work[1] = (doublereal) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DORMLQ", &i__1);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*m == 0 || *n == 0 || *k == 0) {
+	work[1] = 1.;
+	return 0;
+    }
+
+    nbmin = 2;
+    ldwork = nw;
+    if (nb > 1 && nb < *k) {
+	iws = nw * nb;
+	if (*lwork < iws) {
+	    nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+	    i__3[0] = 1, a__1[0] = side;
+	    i__3[1] = 1, a__1[1] = trans;
+	    s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+	    i__1 = 2, i__2 = ilaenv_(&c__2, "DORMLQ", ch__1, m, n, k, &c_n1);
+	    nbmin = max(i__1,i__2);
+	}
+    } else {
+	iws = nw;
+    }
+
+    if (nb < nbmin || nb >= *k) {
+
+/*        Use unblocked code */
+
+	dorml2_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+		c_offset], ldc, &work[1], &iinfo);
+    } else {
+
+/*        Use blocked code */
+
+	if (left && notran || ! left && ! notran) {
+	    i1 = 1;
+	    i2 = *k;
+	    i3 = nb;
+	} else {
+	    i1 = (*k - 1) / nb * nb + 1;
+	    i2 = 1;
+	    i3 = -nb;
+	}
+
+	if (left) {
+	    ni = *n;
+	    jc = 1;
+	} else {
+	    mi = *m;
+	    ic = 1;
+	}
+
+	if (notran) {
+	    *(unsigned char *)transt = 'T';
+	} else {
+	    *(unsigned char *)transt = 'N';
+	}
+
+	i__1 = i2;
+	i__2 = i3;
+	for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+	    i__4 = nb, i__5 = *k - i__ + 1;
+	    ib = min(i__4,i__5);
+
+/*           Form the triangular factor of the block reflector */
+/*           H = H(i) H(i+1) . . . H(i+ib-1) */
+
+	    i__4 = nq - i__ + 1;
+	    dlarft_("Forward", "Rowwise", &i__4, &ib, &a[i__ + i__ * a_dim1], 
+		    lda, &tau[i__], t, &c__65);
+	    if (left) {
+
+/*              H or H' is applied to C(i:m,1:n) */
+
+		mi = *m - i__ + 1;
+		ic = i__;
+	    } else {
+
+/*              H or H' is applied to C(1:m,i:n) */
+
+		ni = *n - i__ + 1;
+		jc = i__;
+	    }
+
+/*           Apply H or H' */
+
+	    dlarfb_(side, transt, "Forward", "Rowwise", &mi, &ni, &ib, &a[i__ 
+		    + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * c_dim1], 
+		    ldc, &work[1], &ldwork);
+/* L10: */
+	}
+    }
+    work[1] = (doublereal) lwkopt;
+    return 0;
+
+/*     End of DORMLQ */
+
+} /* dormlq_ */

min-dgels/additional/dormqr.c

@@ -0,0 +1,327 @@
+/* dormqr.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static integer c_n1 = -1;
+static integer c__2 = 2;
+static integer c__65 = 65;
+
+/* Subroutine */ int dormqr_(char *side, char *trans, integer *m, integer *n, 
+	integer *k, doublereal *a, integer *lda, doublereal *tau, doublereal *
+	c__, integer *ldc, doublereal *work, integer *lwork, integer *info)
+{
+    /* System generated locals */
+    address a__1[2];
+    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3[2], i__4, 
+	    i__5;
+    char ch__1[2];
+
+    /* Builtin functions */
+    /* Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen);
+
+    /* Local variables */
+    integer i__;
+    doublereal t[4160]	/* was [65][64] */;
+    integer i1, i2, i3, ib, ic, jc, nb, mi, ni, nq, nw, iws;
+    logical left;
+    extern logical lsame_(char *, char *);
+    integer nbmin, iinfo;
+    extern /* Subroutine */ int dorm2r_(char *, char *, integer *, integer *, 
+	    integer *, doublereal *, integer *, doublereal *, doublereal *, 
+	    integer *, doublereal *, integer *), dlarfb_(char 
+	    *, char *, char *, char *, integer *, integer *, integer *, 
+	    doublereal *, integer *, doublereal *, integer *, doublereal *, 
+	    integer *, doublereal *, integer *), dlarft_(char *, char *, integer *, integer *, doublereal 
+	    *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *);
+    extern integer ilaenv_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *);
+    logical notran;
+    integer ldwork, lwkopt;
+    logical lquery;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DORMQR overwrites the general real M-by-N matrix C with */
+
+/*                  SIDE = 'L'     SIDE = 'R' */
+/*  TRANS = 'N':      Q * C          C * Q */
+/*  TRANS = 'T':      Q**T * C       C * Q**T */
+
+/*  where Q is a real orthogonal matrix defined as the product of k */
+/*  elementary reflectors */
+
+/*        Q = H(1) H(2) . . . H(k) */
+
+/*  as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N */
+/*  if SIDE = 'R'. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SIDE    (input) CHARACTER*1 */
+/*          = 'L': apply Q or Q**T from the Left; */
+/*          = 'R': apply Q or Q**T from the Right. */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          = 'N':  No transpose, apply Q; */
+/*          = 'T':  Transpose, apply Q**T. */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix C. M >= 0. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix C. N >= 0. */
+
+/*  K       (input) INTEGER */
+/*          The number of elementary reflectors whose product defines */
+/*          the matrix Q. */
+/*          If SIDE = 'L', M >= K >= 0; */
+/*          if SIDE = 'R', N >= K >= 0. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension (LDA,K) */
+/*          The i-th column must contain the vector which defines the */
+/*          elementary reflector H(i), for i = 1,2,...,k, as returned by */
+/*          DGEQRF in the first k columns of its array argument A. */
+/*          A is modified by the routine but restored on exit. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A. */
+/*          If SIDE = 'L', LDA >= max(1,M); */
+/*          if SIDE = 'R', LDA >= max(1,N). */
+
+/*  TAU     (input) DOUBLE PRECISION array, dimension (K) */
+/*          TAU(i) must contain the scalar factor of the elementary */
+/*          reflector H(i), as returned by DGEQRF. */
+
+/*  C       (input/output) DOUBLE PRECISION array, dimension (LDC,N) */
+/*          On entry, the M-by-N matrix C. */
+/*          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. */
+
+/*  LDC     (input) INTEGER */
+/*          The leading dimension of the array C. LDC >= max(1,M). */
+
+/*  WORK    (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */
+/*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */
+
+/*  LWORK   (input) INTEGER */
+/*          The dimension of the array WORK. */
+/*          If SIDE = 'L', LWORK >= max(1,N); */
+/*          if SIDE = 'R', LWORK >= max(1,M). */
+/*          For optimum performance LWORK >= N*NB if SIDE = 'L', and */
+/*          LWORK >= M*NB if SIDE = 'R', where NB is the optimal */
+/*          blocksize. */
+
+/*          If LWORK = -1, then a workspace query is assumed; the routine */
+/*          only calculates the optimal size of the WORK array, returns */
+/*          this value as the first entry of the WORK array, and no error */
+/*          message related to LWORK is issued by XERBLA. */
+
+/*  INFO    (output) INTEGER */
+/*          = 0:  successful exit */
+/*          < 0:  if INFO = -i, the i-th argument had an illegal value */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Local Arrays .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input arguments */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --tau;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+    --work;
+
+    /* Function Body */
+    *info = 0;
+    left = lsame_(side, "L");
+    notran = lsame_(trans, "N");
+    lquery = *lwork == -1;
+
+/*     NQ is the order of Q and NW is the minimum dimension of WORK */
+
+    if (left) {
+	nq = *m;
+	nw = *n;
+    } else {
+	nq = *n;
+	nw = *m;
+    }
+    if (! left && ! lsame_(side, "R")) {
+	*info = -1;
+    } else if (! notran && ! lsame_(trans, "T")) {
+	*info = -2;
+    } else if (*m < 0) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*k < 0 || *k > nq) {
+	*info = -5;
+    } else if (*lda < max(1,nq)) {
+	*info = -7;
+    } else if (*ldc < max(1,*m)) {
+	*info = -10;
+    } else if (*lwork < max(1,nw) && ! lquery) {
+	*info = -12;
+    }
+
+    if (*info == 0) {
+
+/*        Determine the block size.  NB may be at most NBMAX, where NBMAX */
+/*        is used to define the local array T. */
+
+/* Computing MIN */
+/* Writing concatenation */
+	i__3[0] = 1, a__1[0] = side;
+	i__3[1] = 1, a__1[1] = trans;
+	s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+	i__1 = 64, i__2 = ilaenv_(&c__1, "DORMQR", ch__1, m, n, k, &c_n1);
+	nb = min(i__1,i__2);
+	lwkopt = max(1,nw) * nb;
+	work[1] = (doublereal) lwkopt;
+    }
+
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DORMQR", &i__1);
+	return 0;
+    } else if (lquery) {
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*m == 0 || *n == 0 || *k == 0) {
+	work[1] = 1.;
+	return 0;
+    }
+
+    nbmin = 2;
+    ldwork = nw;
+    if (nb > 1 && nb < *k) {
+	iws = nw * nb;
+	if (*lwork < iws) {
+	    nb = *lwork / ldwork;
+/* Computing MAX */
+/* Writing concatenation */
+	    i__3[0] = 1, a__1[0] = side;
+	    i__3[1] = 1, a__1[1] = trans;
+	    s_cat(ch__1, a__1, i__3, &c__2, (ftnlen)2);
+	    i__1 = 2, i__2 = ilaenv_(&c__2, "DORMQR", ch__1, m, n, k, &c_n1);
+	    nbmin = max(i__1,i__2);
+	}
+    } else {
+	iws = nw;
+    }
+
+    if (nb < nbmin || nb >= *k) {
+
+/*        Use unblocked code */
+
+	dorm2r_(side, trans, m, n, k, &a[a_offset], lda, &tau[1], &c__[
+		c_offset], ldc, &work[1], &iinfo);
+    } else {
+
+/*        Use blocked code */
+
+	if (left && ! notran || ! left && notran) {
+	    i1 = 1;
+	    i2 = *k;
+	    i3 = nb;
+	} else {
+	    i1 = (*k - 1) / nb * nb + 1;
+	    i2 = 1;
+	    i3 = -nb;
+	}
+
+	if (left) {
+	    ni = *n;
+	    jc = 1;
+	} else {
+	    mi = *m;
+	    ic = 1;
+	}
+
+	i__1 = i2;
+	i__2 = i3;
+	for (i__ = i1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+/* Computing MIN */
+	    i__4 = nb, i__5 = *k - i__ + 1;
+	    ib = min(i__4,i__5);
+
+/*           Form the triangular factor of the block reflector */
+/*           H = H(i) H(i+1) . . . H(i+ib-1) */
+
+	    i__4 = nq - i__ + 1;
+	    dlarft_("Forward", "Columnwise", &i__4, &ib, &a[i__ + i__ * 
+		    a_dim1], lda, &tau[i__], t, &c__65)
+		    ;
+	    if (left) {
+
+/*              H or H' is applied to C(i:m,1:n) */
+
+		mi = *m - i__ + 1;
+		ic = i__;
+	    } else {
+
+/*              H or H' is applied to C(1:m,i:n) */
+
+		ni = *n - i__ + 1;
+		jc = i__;
+	    }
+
+/*           Apply H or H' */
+
+	    dlarfb_(side, trans, "Forward", "Columnwise", &mi, &ni, &ib, &a[
+		    i__ + i__ * a_dim1], lda, t, &c__65, &c__[ic + jc * 
+		    c_dim1], ldc, &work[1], &ldwork);
+/* L10: */
+	}
+    }
+    work[1] = (doublereal) lwkopt;
+    return 0;
+
+/*     End of DORMQR */
+
+} /* dormqr_ */

min-dgels/additional/dscal.c

@@ -0,0 +1,96 @@
+/* dscal.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, 
+	integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, m, mp1, nincx;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+/* * */
+/*     scales a vector by a constant. */
+/*     uses unrolled loops for increment equal to one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 3/93 to return if incx .le. 0. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0 || *incx <= 0) {
+	return 0;
+    }
+    if (*incx == 1) {
+	goto L20;
+    }
+
+/*        code for increment not equal to 1 */
+
+    nincx = *n * *incx;
+    i__1 = nincx;
+    i__2 = *incx;
+    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	dx[i__] = *da * dx[i__];
+/* L10: */
+    }
+    return 0;
+
+/*        code for increment equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 5;
+    if (m == 0) {
+	goto L40;
+    }
+    i__2 = m;
+    for (i__ = 1; i__ <= i__2; ++i__) {
+	dx[i__] = *da * dx[i__];
+/* L30: */
+    }
+    if (*n < 5) {
+	return 0;
+    }
+L40:
+    mp1 = m + 1;
+    i__2 = *n;
+    for (i__ = mp1; i__ <= i__2; i__ += 5) {
+	dx[i__] = *da * dx[i__];
+	dx[i__ + 1] = *da * dx[i__ + 1];
+	dx[i__ + 2] = *da * dx[i__ + 2];
+	dx[i__ + 3] = *da * dx[i__ + 3];
+	dx[i__ + 4] = *da * dx[i__ + 4];
+/* L50: */
+    }
+    return 0;
+} /* dscal_ */

min-dgels/additional/dtrmm.c

@@ -0,0 +1,453 @@
+/* dtrmm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, 
+	integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+	lda, doublereal *b, integer *ldb)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, k, info;
+    doublereal temp;
+    logical lside;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRMM  performs one of the matrix-matrix operations */
+
+/*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ), */
+
+/*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or */
+/*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of */
+
+/*     op( A ) = A   or   op( A ) = A'. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  SIDE   - CHARACTER*1. */
+/*           On entry,  SIDE specifies whether  op( A ) multiplies B from */
+/*           the left or right as follows: */
+
+/*              SIDE = 'L' or 'l'   B := alpha*op( A )*B. */
+
+/*              SIDE = 'R' or 'r'   B := alpha*B*op( A ). */
+
+/*           Unchanged on exit. */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix A is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANSA - CHARACTER*1. */
+/*           On entry, TRANSA specifies the form of op( A ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSA = 'N' or 'n'   op( A ) = A. */
+
+/*              TRANSA = 'T' or 't'   op( A ) = A'. */
+
+/*              TRANSA = 'C' or 'c'   op( A ) = A'. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit triangular */
+/*           as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of B. M must be at */
+/*           least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of B.  N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is */
+/*           zero then  A is not referenced and  B need not be set before */
+/*           entry. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
+/*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'. */
+/*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k */
+/*           upper triangular part of the array  A must contain the upper */
+/*           triangular matrix  and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k */
+/*           lower triangular part of the array  A must contain the lower */
+/*           triangular matrix  and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of */
+/*           A  are not referenced either,  but are assumed to be  unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then */
+/*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r' */
+/*           then LDA must be at least max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/*           Before entry,  the leading  m by n part of the array  B must */
+/*           contain the matrix  B,  and  on exit  is overwritten  by the */
+/*           transformed matrix. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in  the  calling  (sub)  program.   LDB  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+
+    /* Function Body */
+    lside = lsame_(side, "L");
+    if (lside) {
+	nrowa = *m;
+    } else {
+	nrowa = *n;
+    }
+    nounit = lsame_(diag, "N");
+    upper = lsame_(uplo, "U");
+
+    info = 0;
+    if (! lside && ! lsame_(side, "R")) {
+	info = 1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	info = 2;
+    } else if (! lsame_(transa, "N") && ! lsame_(transa, 
+	     "T") && ! lsame_(transa, "C")) {
+	info = 3;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 4;
+    } else if (*m < 0) {
+	info = 5;
+    } else if (*n < 0) {
+	info = 6;
+    } else if (*lda < max(1,nrowa)) {
+	info = 9;
+    } else if (*ldb < max(1,*m)) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DTRMM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		b[i__ + j * b_dim1] = 0.;
+/* L10: */
+	    }
+/* L20: */
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lside) {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*A*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *m;
+		    for (k = 1; k <= i__2; ++k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    temp = *alpha * b[k + j * b_dim1];
+			    i__3 = k - 1;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] += temp * a[i__ + k * 
+					a_dim1];
+/* L30: */
+			    }
+			    if (nounit) {
+				temp *= a[k + k * a_dim1];
+			    }
+			    b[k + j * b_dim1] = temp;
+			}
+/* L40: */
+		    }
+/* L50: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    for (k = *m; k >= 1; --k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    temp = *alpha * b[k + j * b_dim1];
+			    b[k + j * b_dim1] = temp;
+			    if (nounit) {
+				b[k + j * b_dim1] *= a[k + k * a_dim1];
+			    }
+			    i__2 = *m;
+			    for (i__ = k + 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] += temp * a[i__ + k * 
+					a_dim1];
+/* L60: */
+			    }
+			}
+/* L70: */
+		    }
+/* L80: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*A'*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    for (i__ = *m; i__ >= 1; --i__) {
+			temp = b[i__ + j * b_dim1];
+			if (nounit) {
+			    temp *= a[i__ + i__ * a_dim1];
+			}
+			i__2 = i__ - 1;
+			for (k = 1; k <= i__2; ++k) {
+			    temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L90: */
+			}
+			b[i__ + j * b_dim1] = *alpha * temp;
+/* L100: */
+		    }
+/* L110: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp = b[i__ + j * b_dim1];
+			if (nounit) {
+			    temp *= a[i__ + i__ * a_dim1];
+			}
+			i__3 = *m;
+			for (k = i__ + 1; k <= i__3; ++k) {
+			    temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L120: */
+			}
+			b[i__ + j * b_dim1] = *alpha * temp;
+/* L130: */
+		    }
+/* L140: */
+		}
+	    }
+	}
+    } else {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*B*A. */
+
+	    if (upper) {
+		for (j = *n; j >= 1; --j) {
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__1 = *m;
+		    for (i__ = 1; i__ <= i__1; ++i__) {
+			b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L150: */
+		    }
+		    i__1 = j - 1;
+		    for (k = 1; k <= i__1; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    temp = *alpha * a[k + j * a_dim1];
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L160: */
+			    }
+			}
+/* L170: */
+		    }
+/* L180: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L190: */
+		    }
+		    i__2 = *n;
+		    for (k = j + 1; k <= i__2; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    temp = *alpha * a[k + j * a_dim1];
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L200: */
+			    }
+			}
+/* L210: */
+		    }
+/* L220: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*B*A'. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (k = 1; k <= i__1; ++k) {
+		    i__2 = k - 1;
+		    for (j = 1; j <= i__2; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = *alpha * a[j + k * a_dim1];
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L230: */
+			    }
+			}
+/* L240: */
+		    }
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[k + k * a_dim1];
+		    }
+		    if (temp != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L250: */
+			}
+		    }
+/* L260: */
+		}
+	    } else {
+		for (k = *n; k >= 1; --k) {
+		    i__1 = *n;
+		    for (j = k + 1; j <= i__1; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = *alpha * a[j + k * a_dim1];
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L270: */
+			    }
+			}
+/* L280: */
+		    }
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[k + k * a_dim1];
+		    }
+		    if (temp != 1.) {
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L290: */
+			}
+		    }
+/* L300: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRMM . */
+
+} /* dtrmm_ */

min-dgels/additional/dtrmv.c

@@ -0,0 +1,345 @@
+/* dtrmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, 
+	doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRMV  performs one of the matrix-vector operations */
+
+/*     x := A*x,   or   x := A'*x, */
+
+/*  where x is an n element vector and  A is an n by n unit, or non-unit, */
+/*  upper or lower triangular matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   x := A*x. */
+
+/*              TRANS = 'T' or 't'   x := A'*x. */
+
+/*              TRANS = 'C' or 'c'   x := A'*x. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with  UPLO = 'U' or 'u', the leading n by n */
+/*           upper triangular part of the array A must contain the upper */
+/*           triangular matrix and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry with UPLO = 'L' or 'l', the leading n by n */
+/*           lower triangular part of the array A must contain the lower */
+/*           triangular matrix and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u', the diagonal elements of */
+/*           A are not referenced either, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. On exit, X is overwritten with the */
+/*           tranformed vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*lda < max(1,*n)) {
+	info = 6;
+    } else if (*incx == 0) {
+	info = 8;
+    }
+    if (info != 0) {
+	xerbla_("DTRMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX  too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  x := A*x. */
+
+	if (lsame_(uplo, "U")) {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			i__2 = j - 1;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    x[i__] += temp * a[i__ + j * a_dim1];
+/* L10: */
+			}
+			if (nounit) {
+			    x[j] *= a[j + j * a_dim1];
+			}
+		    }
+/* L20: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			i__2 = j - 1;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    x[ix] += temp * a[i__ + j * a_dim1];
+			    ix += *incx;
+/* L30: */
+			}
+			if (nounit) {
+			    x[jx] *= a[j + j * a_dim1];
+			}
+		    }
+		    jx += *incx;
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			i__1 = j + 1;
+			for (i__ = *n; i__ >= i__1; --i__) {
+			    x[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+			}
+			if (nounit) {
+			    x[j] *= a[j + j * a_dim1];
+			}
+		    }
+/* L60: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			i__1 = j + 1;
+			for (i__ = *n; i__ >= i__1; --i__) {
+			    x[ix] += temp * a[i__ + j * a_dim1];
+			    ix -= *incx;
+/* L70: */
+			}
+			if (nounit) {
+			    x[jx] *= a[j + j * a_dim1];
+			}
+		    }
+		    jx -= *incx;
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := A'*x. */
+
+	if (lsame_(uplo, "U")) {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    for (i__ = j - 1; i__ >= 1; --i__) {
+			temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+		    }
+		    x[j] = temp;
+/* L100: */
+		}
+	    } else {
+		jx = kx + (*n - 1) * *incx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    ix = jx;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    for (i__ = j - 1; i__ >= 1; --i__) {
+			ix -= *incx;
+			temp += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+/* L120: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[j];
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__2 = *n;
+		    for (i__ = j + 1; i__ <= i__2; ++i__) {
+			temp += a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+		    }
+		    x[j] = temp;
+/* L140: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[jx];
+		    ix = jx;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__2 = *n;
+		    for (i__ = j + 1; i__ <= i__2; ++i__) {
+			ix += *incx;
+			temp += a[i__ + j * a_dim1] * x[ix];
+/* L150: */
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRMV . */
+
+} /* dtrmv_ */

min-dgels/additional/dtrsm.c

@@ -0,0 +1,490 @@
+/* dtrsm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, 
+	integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+	lda, doublereal *b, integer *ldb)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, k, info;
+    doublereal temp;
+    logical lside;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRSM  solves one of the matrix equations */
+
+/*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B, */
+
+/*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of */
+
+/*     op( A ) = A   or   op( A ) = A'. */
+
+/*  The matrix X is overwritten on B. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  SIDE   - CHARACTER*1. */
+/*           On entry, SIDE specifies whether op( A ) appears on the left */
+/*           or right of X as follows: */
+
+/*              SIDE = 'L' or 'l'   op( A )*X = alpha*B. */
+
+/*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B. */
+
+/*           Unchanged on exit. */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix A is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANSA - CHARACTER*1. */
+/*           On entry, TRANSA specifies the form of op( A ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSA = 'N' or 'n'   op( A ) = A. */
+
+/*              TRANSA = 'T' or 't'   op( A ) = A'. */
+
+/*              TRANSA = 'C' or 'c'   op( A ) = A'. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit triangular */
+/*           as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of B. M must be at */
+/*           least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of B.  N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is */
+/*           zero then  A is not referenced and  B need not be set before */
+/*           entry. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
+/*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'. */
+/*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k */
+/*           upper triangular part of the array  A must contain the upper */
+/*           triangular matrix  and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k */
+/*           lower triangular part of the array  A must contain the lower */
+/*           triangular matrix  and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of */
+/*           A  are not referenced either,  but are assumed to be  unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then */
+/*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r' */
+/*           then LDA must be at least max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/*           Before entry,  the leading  m by n part of the array  B must */
+/*           contain  the  right-hand  side  matrix  B,  and  on exit  is */
+/*           overwritten by the solution matrix  X. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in  the  calling  (sub)  program.   LDB  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+
+    /* Function Body */
+    lside = lsame_(side, "L");
+    if (lside) {
+	nrowa = *m;
+    } else {
+	nrowa = *n;
+    }
+    nounit = lsame_(diag, "N");
+    upper = lsame_(uplo, "U");
+
+    info = 0;
+    if (! lside && ! lsame_(side, "R")) {
+	info = 1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	info = 2;
+    } else if (! lsame_(transa, "N") && ! lsame_(transa, 
+	     "T") && ! lsame_(transa, "C")) {
+	info = 3;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 4;
+    } else if (*m < 0) {
+	info = 5;
+    } else if (*n < 0) {
+	info = 6;
+    } else if (*lda < max(1,nrowa)) {
+	info = 9;
+    } else if (*ldb < max(1,*m)) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DTRSM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		b[i__ + j * b_dim1] = 0.;
+/* L10: */
+	    }
+/* L20: */
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lside) {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*inv( A )*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L30: */
+			}
+		    }
+		    for (k = *m; k >= 1; --k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    if (nounit) {
+				b[k + j * b_dim1] /= a[k + k * a_dim1];
+			    }
+			    i__2 = k - 1;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+					i__ + k * a_dim1];
+/* L40: */
+			    }
+			}
+/* L50: */
+		    }
+/* L60: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L70: */
+			}
+		    }
+		    i__2 = *m;
+		    for (k = 1; k <= i__2; ++k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    if (nounit) {
+				b[k + j * b_dim1] /= a[k + k * a_dim1];
+			    }
+			    i__3 = *m;
+			    for (i__ = k + 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+					i__ + k * a_dim1];
+/* L80: */
+			    }
+			}
+/* L90: */
+		    }
+/* L100: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*inv( A' )*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp = *alpha * b[i__ + j * b_dim1];
+			i__3 = i__ - 1;
+			for (k = 1; k <= i__3; ++k) {
+			    temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L110: */
+			}
+			if (nounit) {
+			    temp /= a[i__ + i__ * a_dim1];
+			}
+			b[i__ + j * b_dim1] = temp;
+/* L120: */
+		    }
+/* L130: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    for (i__ = *m; i__ >= 1; --i__) {
+			temp = *alpha * b[i__ + j * b_dim1];
+			i__2 = *m;
+			for (k = i__ + 1; k <= i__2; ++k) {
+			    temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L140: */
+			}
+			if (nounit) {
+			    temp /= a[i__ + i__ * a_dim1];
+			}
+			b[i__ + j * b_dim1] = temp;
+/* L150: */
+		    }
+/* L160: */
+		}
+	    }
+	}
+    } else {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*B*inv( A ). */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L170: */
+			}
+		    }
+		    i__2 = j - 1;
+		    for (k = 1; k <= i__2; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+					i__ + k * b_dim1];
+/* L180: */
+			    }
+			}
+/* L190: */
+		    }
+		    if (nounit) {
+			temp = 1. / a[j + j * a_dim1];
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L200: */
+			}
+		    }
+/* L210: */
+		}
+	    } else {
+		for (j = *n; j >= 1; --j) {
+		    if (*alpha != 1.) {
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L220: */
+			}
+		    }
+		    i__1 = *n;
+		    for (k = j + 1; k <= i__1; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+					i__ + k * b_dim1];
+/* L230: */
+			    }
+			}
+/* L240: */
+		    }
+		    if (nounit) {
+			temp = 1. / a[j + j * a_dim1];
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L250: */
+			}
+		    }
+/* L260: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*B*inv( A' ). */
+
+	    if (upper) {
+		for (k = *n; k >= 1; --k) {
+		    if (nounit) {
+			temp = 1. / a[k + k * a_dim1];
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L270: */
+			}
+		    }
+		    i__1 = k - 1;
+		    for (j = 1; j <= i__1; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = a[j + k * a_dim1];
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] -= temp * b[i__ + k * 
+					b_dim1];
+/* L280: */
+			    }
+			}
+/* L290: */
+		    }
+		    if (*alpha != 1.) {
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+				    ;
+/* L300: */
+			}
+		    }
+/* L310: */
+		}
+	    } else {
+		i__1 = *n;
+		for (k = 1; k <= i__1; ++k) {
+		    if (nounit) {
+			temp = 1. / a[k + k * a_dim1];
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L320: */
+			}
+		    }
+		    i__2 = *n;
+		    for (j = k + 1; j <= i__2; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = a[j + k * a_dim1];
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] -= temp * b[i__ + k * 
+					b_dim1];
+/* L330: */
+			    }
+			}
+/* L340: */
+		    }
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+				    ;
+/* L350: */
+			}
+		    }
+/* L360: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRSM . */
+
+} /* dtrsm_ */

min-dgels/additional/dtrtrs.c

@@ -0,0 +1,183 @@
+/* dtrtrs.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b12 = 1.;
+
+/* Subroutine */ int dtrtrs_(char *uplo, char *trans, char *diag, integer *n, 
+	integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *
+	ldb, integer *info)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1;
+
+    /* Local variables */
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int dtrsm_(char *, char *, char *, char *, 
+	    integer *, integer *, doublereal *, doublereal *, integer *, 
+	    doublereal *, integer *), xerbla_(
+	    char *, integer *);
+    logical nounit;
+
+
+/*  -- LAPACK routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRTRS solves a triangular system of the form */
+
+/*     A * X = B  or  A**T * X = B, */
+
+/*  where A is a triangular matrix of order N, and B is an N-by-NRHS */
+/*  matrix.  A check is made to verify that A is nonsingular. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  UPLO    (input) CHARACTER*1 */
+/*          = 'U':  A is upper triangular; */
+/*          = 'L':  A is lower triangular. */
+
+/*  TRANS   (input) CHARACTER*1 */
+/*          Specifies the form of the system of equations: */
+/*          = 'N':  A * X = B  (No transpose) */
+/*          = 'T':  A**T * X = B  (Transpose) */
+/*          = 'C':  A**H * X = B  (Conjugate transpose = Transpose) */
+
+/*  DIAG    (input) CHARACTER*1 */
+/*          = 'N':  A is non-unit triangular; */
+/*          = 'U':  A is unit triangular. */
+
+/*  N       (input) INTEGER */
+/*          The order of the matrix A.  N >= 0. */
+
+/*  NRHS    (input) INTEGER */
+/*          The number of right hand sides, i.e., the number of columns */
+/*          of the matrix B.  NRHS >= 0. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          The triangular matrix A.  If UPLO = 'U', the leading N-by-N */
+/*          upper triangular part of the array A contains the upper */
+/*          triangular matrix, and the strictly lower triangular part of */
+/*          A is not referenced.  If UPLO = 'L', the leading N-by-N lower */
+/*          triangular part of the array A contains the lower triangular */
+/*          matrix, and the strictly upper triangular part of A is not */
+/*          referenced.  If DIAG = 'U', the diagonal elements of A are */
+/*          also not referenced and are assumed to be 1. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A.  LDA >= max(1,N). */
+
+/*  B       (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS) */
+/*          On entry, the right hand side matrix B. */
+/*          On exit, if INFO = 0, the solution matrix X. */
+
+/*  LDB     (input) INTEGER */
+/*          The leading dimension of the array B.  LDB >= max(1,N). */
+
+/*  INFO    (output) INTEGER */
+/*          = 0:  successful exit */
+/*          < 0: if INFO = -i, the i-th argument had an illegal value */
+/*          > 0: if INFO = i, the i-th diagonal element of A is zero, */
+/*               indicating that the matrix is singular and the solutions */
+/*               X have not been computed. */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+
+    /* Function Body */
+    *info = 0;
+    nounit = lsame_(diag, "N");
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	*info = -1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	*info = -2;
+    } else if (! nounit && ! lsame_(diag, "U")) {
+	*info = -3;
+    } else if (*n < 0) {
+	*info = -4;
+    } else if (*nrhs < 0) {
+	*info = -5;
+    } else if (*lda < max(1,*n)) {
+	*info = -7;
+    } else if (*ldb < max(1,*n)) {
+	*info = -9;
+    }
+    if (*info != 0) {
+	i__1 = -(*info);
+	xerbla_("DTRTRS", &i__1);
+	return 0;
+    }
+
+/*     Quick return if possible */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+/*     Check for singularity. */
+
+    if (nounit) {
+	i__1 = *n;
+	for (*info = 1; *info <= i__1; ++(*info)) {
+	    if (a[*info + *info * a_dim1] == 0.) {
+		return 0;
+	    }
+/* L10: */
+	}
+    }
+    *info = 0;
+
+/*     Solve A * x = b  or  A' * x = b. */
+
+    dtrsm_("Left", uplo, trans, diag, n, nrhs, &c_b12, &a[a_offset], lda, &b[
+	    b_offset], ldb);
+
+    return 0;
+
+/*     End of DTRTRS */
+
+} /* dtrtrs_ */

min-dgels/additional/f2c.h

@@ -0,0 +1,223 @@
+/* f2c.h  --  Standard Fortran to C header file */
+
+/**  barf  [ba:rf]  2.  "He suggested using FORTRAN, and everybody barfed."
+
+	- From The Shogakukan DICTIONARY OF NEW ENGLISH (Second edition) */
+
+#ifndef F2C_INCLUDE
+#define F2C_INCLUDE
+
+typedef long int integer;
+typedef unsigned long int uinteger;
+typedef char *address;
+typedef short int shortint;
+typedef float real;
+typedef double doublereal;
+typedef struct { real r, i; } complex;
+typedef struct { doublereal r, i; } doublecomplex;
+typedef long int logical;
+typedef short int shortlogical;
+typedef char logical1;
+typedef char integer1;
+#ifdef INTEGER_STAR_8	/* Adjust for integer*8. */
+typedef long long longint;		/* system-dependent */
+typedef unsigned long long ulongint;	/* system-dependent */
+#define qbit_clear(a,b)	((a) & ~((ulongint)1 << (b)))
+#define qbit_set(a,b)	((a) |  ((ulongint)1 << (b)))
+#endif
+
+#define TRUE_ (1)
+#define FALSE_ (0)
+
+/* Extern is for use with -E */
+#ifndef Extern
+#define Extern extern
+#endif
+
+/* I/O stuff */
+
+#ifdef f2c_i2
+/* for -i2 */
+typedef short flag;
+typedef short ftnlen;
+typedef short ftnint;
+#else
+typedef long int flag;
+typedef long int ftnlen;
+typedef long int ftnint;
+#endif
+
+/*external read, write*/
+typedef struct
+{	flag cierr;
+	ftnint ciunit;
+	flag ciend;
+	char *cifmt;
+	ftnint cirec;
+} cilist;
+
+/*internal read, write*/
+typedef struct
+{	flag icierr;
+	char *iciunit;
+	flag iciend;
+	char *icifmt;
+	ftnint icirlen;
+	ftnint icirnum;
+} icilist;
+
+/*open*/
+typedef struct
+{	flag oerr;
+	ftnint ounit;
+	char *ofnm;
+	ftnlen ofnmlen;
+	char *osta;
+	char *oacc;
+	char *ofm;
+	ftnint orl;
+	char *oblnk;
+} olist;
+
+/*close*/
+typedef struct
+{	flag cerr;
+	ftnint cunit;
+	char *csta;
+} cllist;
+
+/*rewind, backspace, endfile*/
+typedef struct
+{	flag aerr;
+	ftnint aunit;
+} alist;
+
+/* inquire */
+typedef struct
+{	flag inerr;
+	ftnint inunit;
+	char *infile;
+	ftnlen infilen;
+	ftnint	*inex;	/*parameters in standard's order*/
+	ftnint	*inopen;
+	ftnint	*innum;
+	ftnint	*innamed;
+	char	*inname;
+	ftnlen	innamlen;
+	char	*inacc;
+	ftnlen	inacclen;
+	char	*inseq;
+	ftnlen	inseqlen;
+	char 	*indir;
+	ftnlen	indirlen;
+	char	*infmt;
+	ftnlen	infmtlen;
+	char	*inform;
+	ftnint	informlen;
+	char	*inunf;
+	ftnlen	inunflen;
+	ftnint	*inrecl;
+	ftnint	*innrec;
+	char	*inblank;
+	ftnlen	inblanklen;
+} inlist;
+
+#define VOID void
+
+union Multitype {	/* for multiple entry points */
+	integer1 g;
+	shortint h;
+	integer i;
+	/* longint j; */
+	real r;
+	doublereal d;
+	complex c;
+	doublecomplex z;
+	};
+
+typedef union Multitype Multitype;
+
+/*typedef long int Long;*/	/* No longer used; formerly in Namelist */
+
+struct Vardesc {	/* for Namelist */
+	char *name;
+	char *addr;
+	ftnlen *dims;
+	int  type;
+	};
+typedef struct Vardesc Vardesc;
+
+struct Namelist {
+	char *name;
+	Vardesc **vars;
+	int nvars;
+	};
+typedef struct Namelist Namelist;
+
+#define abs(x) ((x) >= 0 ? (x) : -(x))
+#define dabs(x) (doublereal)abs(x)
+#define min(a,b) ((a) <= (b) ? (a) : (b))
+#define max(a,b) ((a) >= (b) ? (a) : (b))
+#define dmin(a,b) (doublereal)min(a,b)
+#define dmax(a,b) (doublereal)max(a,b)
+#define bit_test(a,b)	((a) >> (b) & 1)
+#define bit_clear(a,b)	((a) & ~((uinteger)1 << (b)))
+#define bit_set(a,b)	((a) |  ((uinteger)1 << (b)))
+
+/* procedure parameter types for -A and -C++ */
+
+#define F2C_proc_par_types 1
+#ifdef __cplusplus
+typedef int /* Unknown procedure type */ (*U_fp)(...);
+typedef shortint (*J_fp)(...);
+typedef integer (*I_fp)(...);
+typedef real (*R_fp)(...);
+typedef doublereal (*D_fp)(...), (*E_fp)(...);
+typedef /* Complex */ VOID (*C_fp)(...);
+typedef /* Double Complex */ VOID (*Z_fp)(...);
+typedef logical (*L_fp)(...);
+typedef shortlogical (*K_fp)(...);
+typedef /* Character */ VOID (*H_fp)(...);
+typedef /* Subroutine */ int (*S_fp)(...);
+#else
+typedef int /* Unknown procedure type */ (*U_fp)();
+typedef shortint (*J_fp)();
+typedef integer (*I_fp)();
+typedef real (*R_fp)();
+typedef doublereal (*D_fp)(), (*E_fp)();
+typedef /* Complex */ VOID (*C_fp)();
+typedef /* Double Complex */ VOID (*Z_fp)();
+typedef logical (*L_fp)();
+typedef shortlogical (*K_fp)();
+typedef /* Character */ VOID (*H_fp)();
+typedef /* Subroutine */ int (*S_fp)();
+#endif
+/* E_fp is for real functions when -R is not specified */
+typedef VOID C_f;	/* complex function */
+typedef VOID H_f;	/* character function */
+typedef VOID Z_f;	/* double complex function */
+typedef doublereal E_f;	/* real function with -R not specified */
+
+/* undef any lower-case symbols that your C compiler predefines, e.g.: */
+
+#ifndef Skip_f2c_Undefs
+#undef cray
+#undef gcos
+#undef mc68010
+#undef mc68020
+#undef mips
+#undef pdp11
+#undef sgi
+#undef sparc
+#undef sun
+#undef sun2
+#undef sun3
+#undef sun4
+#undef u370
+#undef u3b
+#undef u3b2
+#undef u3b5
+#undef unix
+#undef vax
+#endif
+#endif

min-dgels/additional/fio.h

@@ -0,0 +1,141 @@
+#ifndef SYSDEP_H_INCLUDED
+#include "sysdep1.h"
+#endif
+#include "stdio.h"
+#include "errno.h"
+#ifndef NULL
+/* ANSI C */
+#include "stddef.h"
+#endif
+
+#ifndef SEEK_SET
+#define SEEK_SET 0
+#define SEEK_CUR 1
+#define SEEK_END 2
+#endif
+
+#ifndef FOPEN
+#define FOPEN fopen
+#endif
+
+#ifndef FREOPEN
+#define FREOPEN freopen
+#endif
+
+#ifndef FSEEK
+#define FSEEK fseek
+#endif
+
+#ifndef FSTAT
+#define FSTAT fstat
+#endif
+
+#ifndef FTELL
+#define FTELL ftell
+#endif
+
+#ifndef OFF_T
+#define OFF_T long
+#endif
+
+#ifndef STAT_ST
+#define STAT_ST stat
+#endif
+
+#ifndef STAT
+#define STAT stat
+#endif
+
+#ifdef MSDOS
+#ifndef NON_UNIX_STDIO
+#define NON_UNIX_STDIO
+#endif
+#endif
+
+#ifdef UIOLEN_int
+typedef int uiolen;
+#else
+typedef long uiolen;
+#endif
+
+/*units*/
+typedef struct
+{	FILE *ufd;	/*0=unconnected*/
+	char *ufnm;
+#ifndef MSDOS
+	long uinode;
+	int udev;
+#endif
+	int url;	/*0=sequential*/
+	flag useek;	/*true=can backspace, use dir, ...*/
+	flag ufmt;
+	flag urw;	/* (1 for can read) | (2 for can write) */
+	flag ublnk;
+	flag uend;
+	flag uwrt;	/*last io was write*/
+	flag uscrtch;
+} unit;
+
+#undef Void
+#ifdef KR_headers
+#define Void /*void*/
+extern int (*f__getn)();	/* for formatted input */
+extern void (*f__putn)();	/* for formatted output */
+extern void x_putc();
+extern long f__inode();
+extern VOID sig_die();
+extern int (*f__donewrec)(), t_putc(), x_wSL();
+extern int c_sfe(), err__fl(), xrd_SL(), f__putbuf();
+#else
+#define Void void
+#ifdef __cplusplus
+extern "C" {
+#endif
+extern int (*f__getn)(void);	/* for formatted input */
+extern void (*f__putn)(int);	/* for formatted output */
+extern void x_putc(int);
+extern long f__inode(char*,int*);
+extern void sig_die(const char*,int);
+extern void f__fatal(int, const char*);
+extern int t_runc(alist*);
+extern int f__nowreading(unit*), f__nowwriting(unit*);
+extern int fk_open(int,int,ftnint);
+extern int en_fio(void);
+extern void f_init(void);
+extern int (*f__donewrec)(void), t_putc(int), x_wSL(void);
+extern void b_char(const char*,char*,ftnlen), g_char(const char*,ftnlen,char*);
+extern int c_sfe(cilist*), z_rnew(void);
+extern int err__fl(int,int,const char*);
+extern int xrd_SL(void);
+extern int f__putbuf(int);
+#endif
+extern flag f__init;
+extern cilist *f__elist;	/*active external io list*/
+extern flag f__reading,f__external,f__sequential,f__formatted;
+extern int (*f__doend)(Void);
+extern FILE *f__cf;	/*current file*/
+extern unit *f__curunit;	/*current unit*/
+extern unit f__units[];
+#define err(f,m,s) {if(f) errno= m; else f__fatal(m,s); return(m);}
+#define errfl(f,m,s) return err__fl((int)f,m,s)
+
+/*Table sizes*/
+#define MXUNIT 100
+
+extern int f__recpos;	/*position in current record*/
+extern OFF_T f__cursor;	/* offset to move to */
+extern OFF_T f__hiwater;	/* so TL doesn't confuse us */
+#ifdef __cplusplus
+	}
+#endif
+
+#define WRITE	1
+#define READ	2
+#define SEQ	3
+#define DIR	4
+#define FMT	5
+#define UNF	6
+#define EXT	7
+#define INT	8
+
+#define buf_end(x) (x->_flag & _IONBF ? x->_ptr : x->_base + BUFSIZ)

min-dgels/additional/fmt.c

@@ -0,0 +1,530 @@
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+#define skip(s) while(*s==' ') s++
+#ifdef interdata
+#define SYLMX 300
+#endif
+#ifdef pdp11
+#define SYLMX 300
+#endif
+#ifdef vax
+#define SYLMX 300
+#endif
+#ifndef SYLMX
+#define SYLMX 300
+#endif
+#define GLITCH '\2'
+	/* special quote character for stu */
+extern flag f__cblank,f__cplus;	/*blanks in I and compulsory plus*/
+static struct syl f__syl[SYLMX];
+int f__parenlvl,f__pc,f__revloc;
+#ifdef KR_headers
+#define Const /*nothing*/
+#else
+#define Const const
+#endif
+
+ static
+#ifdef KR_headers
+char *ap_end(s) char *s;
+#else
+const char *ap_end(const char *s)
+#endif
+{	char quote;
+	quote= *s++;
+	for(;*s;s++)
+	{	if(*s!=quote) continue;
+		if(*++s!=quote) return(s);
+	}
+	if(f__elist->cierr) {
+		errno = 100;
+		return(NULL);
+	}
+	f__fatal(100, "bad string");
+	/*NOTREACHED*/ return 0;
+}
+ static int
+#ifdef KR_headers
+op_gen(a,b,c,d)
+#else
+op_gen(int a, int b, int c, int d)
+#endif
+{	struct syl *p= &f__syl[f__pc];
+	if(f__pc>=SYLMX)
+	{	fprintf(stderr,"format too complicated:\n");
+		sig_die(f__fmtbuf, 1);
+	}
+	p->op=a;
+	p->p1=b;
+	p->p2.i[0]=c;
+	p->p2.i[1]=d;
+	return(f__pc++);
+}
+#ifdef KR_headers
+static char *f_list();
+static char *gt_num(s,n,n1) char *s; int *n, n1;
+#else
+static const char *f_list(const char*);
+static const char *gt_num(const char *s, int *n, int n1)
+#endif
+{	int m=0,f__cnt=0;
+	char c;
+	for(c= *s;;c = *s)
+	{	if(c==' ')
+		{	s++;
+			continue;
+		}
+		if(c>'9' || c<'0') break;
+		m=10*m+c-'0';
+		f__cnt++;
+		s++;
+	}
+	if(f__cnt==0) {
+		if (!n1)
+			s = 0;
+		*n=n1;
+		}
+	else *n=m;
+	return(s);
+}
+
+ static
+#ifdef KR_headers
+char *f_s(s,curloc) char *s;
+#else
+const char *f_s(const char *s, int curloc)
+#endif
+{
+	skip(s);
+	if(*s++!='(')
+	{
+		return(NULL);
+	}
+	if(f__parenlvl++ ==1) f__revloc=curloc;
+	if(op_gen(RET1,curloc,0,0)<0 ||
+		(s=f_list(s))==NULL)
+	{
+		return(NULL);
+	}
+	skip(s);
+	return(s);
+}
+
+ static int
+#ifdef KR_headers
+ne_d(s,p) char *s,**p;
+#else
+ne_d(const char *s, const char **p)
+#endif
+{	int n,x,sign=0;
+	struct syl *sp;
+	switch(*s)
+	{
+	default:
+		return(0);
+	case ':': (void) op_gen(COLON,0,0,0); break;
+	case '$':
+		(void) op_gen(NONL, 0, 0, 0); break;
+	case 'B':
+	case 'b':
+		if(*++s=='z' || *s == 'Z') (void) op_gen(BZ,0,0,0);
+		else (void) op_gen(BN,0,0,0);
+		break;
+	case 'S':
+	case 's':
+		if(*(s+1)=='s' || *(s+1) == 'S')
+		{	x=SS;
+			s++;
+		}
+		else if(*(s+1)=='p' || *(s+1) == 'P')
+		{	x=SP;
+			s++;
+		}
+		else x=S;
+		(void) op_gen(x,0,0,0);
+		break;
+	case '/': (void) op_gen(SLASH,0,0,0); break;
+	case '-': sign=1;
+	case '+':	s++;	/*OUTRAGEOUS CODING TRICK*/
+	case '0': case '1': case '2': case '3': case '4':
+	case '5': case '6': case '7': case '8': case '9':
+		if (!(s=gt_num(s,&n,0))) {
+ bad:			*p = 0;
+			return 1;
+			}
+		switch(*s)
+		{
+		default:
+			return(0);
+		case 'P':
+		case 'p': if(sign) n= -n; (void) op_gen(P,n,0,0); break;
+		case 'X':
+		case 'x': (void) op_gen(X,n,0,0); break;
+		case 'H':
+		case 'h':
+			sp = &f__syl[op_gen(H,n,0,0)];
+			sp->p2.s = (char*)s + 1;
+			s+=n;
+			break;
+		}
+		break;
+	case GLITCH:
+	case '"':
+	case '\'':
+		sp = &f__syl[op_gen(APOS,0,0,0)];
+		sp->p2.s = (char*)s;
+		if((*p = ap_end(s)) == NULL)
+			return(0);
+		return(1);
+	case 'T':
+	case 't':
+		if(*(s+1)=='l' || *(s+1) == 'L')
+		{	x=TL;
+			s++;
+		}
+		else if(*(s+1)=='r'|| *(s+1) == 'R')
+		{	x=TR;
+			s++;
+		}
+		else x=T;
+		if (!(s=gt_num(s+1,&n,0)))
+			goto bad;
+		s--;
+		(void) op_gen(x,n,0,0);
+		break;
+	case 'X':
+	case 'x': (void) op_gen(X,1,0,0); break;
+	case 'P':
+	case 'p': (void) op_gen(P,1,0,0); break;
+	}
+	s++;
+	*p=s;
+	return(1);
+}
+
+ static int
+#ifdef KR_headers
+e_d(s,p) char *s,**p;
+#else
+e_d(const char *s, const char **p)
+#endif
+{	int i,im,n,w,d,e,found=0,x=0;
+	Const char *sv=s;
+	s=gt_num(s,&n,1);
+	(void) op_gen(STACK,n,0,0);
+	switch(*s++)
+	{
+	default: break;
+	case 'E':
+	case 'e':	x=1;
+	case 'G':
+	case 'g':
+		found=1;
+		if (!(s=gt_num(s,&w,0))) {
+ bad:
+			*p = 0;
+			return 1;
+			}
+		if(w==0) break;
+		if(*s=='.') {
+			if (!(s=gt_num(s+1,&d,0)))
+				goto bad;
+			}
+		else d=0;
+		if(*s!='E' && *s != 'e')
+			(void) op_gen(x==1?E:G,w,d,0);	/* default is Ew.dE2 */
+		else {
+			if (!(s=gt_num(s+1,&e,0)))
+				goto bad;
+			(void) op_gen(x==1?EE:GE,w,d,e);
+			}
+		break;
+	case 'O':
+	case 'o':
+		i = O;
+		im = OM;
+		goto finish_I;
+	case 'Z':
+	case 'z':
+		i = Z;
+		im = ZM;
+		goto finish_I;
+	case 'L':
+	case 'l':
+		found=1;
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
+		if(w==0) break;
+		(void) op_gen(L,w,0,0);
+		break;
+	case 'A':
+	case 'a':
+		found=1;
+		skip(s);
+		if(*s>='0' && *s<='9')
+		{	s=gt_num(s,&w,1);
+			if(w==0) break;
+			(void) op_gen(AW,w,0,0);
+			break;
+		}
+		(void) op_gen(A,0,0,0);
+		break;
+	case 'F':
+	case 'f':
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
+		found=1;
+		if(w==0) break;
+		if(*s=='.') {
+			if (!(s=gt_num(s+1,&d,0)))
+				goto bad;
+			}
+		else d=0;
+		(void) op_gen(F,w,d,0);
+		break;
+	case 'D':
+	case 'd':
+		found=1;
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
+		if(w==0) break;
+		if(*s=='.') {
+			if (!(s=gt_num(s+1,&d,0)))
+				goto bad;
+			}
+		else d=0;
+		(void) op_gen(D,w,d,0);
+		break;
+	case 'I':
+	case 'i':
+		i = I;
+		im = IM;
+ finish_I:
+		if (!(s=gt_num(s,&w,0)))
+			goto bad;
+		found=1;
+		if(w==0) break;
+		if(*s!='.')
+		{	(void) op_gen(i,w,0,0);
+			break;
+		}
+		if (!(s=gt_num(s+1,&d,0)))
+			goto bad;
+		(void) op_gen(im,w,d,0);
+		break;
+	}
+	if(found==0)
+	{	f__pc--; /*unSTACK*/
+		*p=sv;
+		return(0);
+	}
+	*p=s;
+	return(1);
+}
+ static
+#ifdef KR_headers
+char *i_tem(s) char *s;
+#else
+const char *i_tem(const char *s)
+#endif
+{	const char *t;
+	int n,curloc;
+	if(*s==')') return(s);
+	if(ne_d(s,&t)) return(t);
+	if(e_d(s,&t)) return(t);
+	s=gt_num(s,&n,1);
+	if((curloc=op_gen(STACK,n,0,0))<0) return(NULL);
+	return(f_s(s,curloc));
+}
+
+ static
+#ifdef KR_headers
+char *f_list(s) char *s;
+#else
+const char *f_list(const char *s)
+#endif
+{
+	for(;*s!=0;)
+	{	skip(s);
+		if((s=i_tem(s))==NULL) return(NULL);
+		skip(s);
+		if(*s==',') s++;
+		else if(*s==')')
+		{	if(--f__parenlvl==0)
+			{
+				(void) op_gen(REVERT,f__revloc,0,0);
+				return(++s);
+			}
+			(void) op_gen(GOTO,0,0,0);
+			return(++s);
+		}
+	}
+	return(NULL);
+}
+
+ int
+#ifdef KR_headers
+pars_f(s) char *s;
+#else
+pars_f(const char *s)
+#endif
+{
+	f__parenlvl=f__revloc=f__pc=0;
+	if(f_s(s,0) == NULL)
+	{
+		return(-1);
+	}
+	return(0);
+}
+#define STKSZ 10
+int f__cnt[STKSZ],f__ret[STKSZ],f__cp,f__rp;
+flag f__workdone, f__nonl;
+
+ static int
+#ifdef KR_headers
+type_f(n)
+#else
+type_f(int n)
+#endif
+{
+	switch(n)
+	{
+	default:
+		return(n);
+	case RET1:
+		return(RET1);
+	case REVERT: return(REVERT);
+	case GOTO: return(GOTO);
+	case STACK: return(STACK);
+	case X:
+	case SLASH:
+	case APOS: case H:
+	case T: case TL: case TR:
+		return(NED);
+	case F:
+	case I:
+	case IM:
+	case A: case AW:
+	case O: case OM:
+	case L:
+	case E: case EE: case D:
+	case G: case GE:
+	case Z: case ZM:
+		return(ED);
+	}
+}
+#ifdef KR_headers
+integer do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr;
+#else
+integer do_fio(ftnint *number, char *ptr, ftnlen len)
+#endif
+{	struct syl *p;
+	int n,i;
+	for(i=0;i<*number;i++,ptr+=len)
+	{
+loop:	switch(type_f((p= &f__syl[f__pc])->op))
+	{
+	default:
+		fprintf(stderr,"unknown code in do_fio: %d\n%s\n",
+			p->op,f__fmtbuf);
+		err(f__elist->cierr,100,"do_fio");
+	case NED:
+		if((*f__doned)(p))
+		{	f__pc++;
+			goto loop;
+		}
+		f__pc++;
+		continue;
+	case ED:
+		if(f__cnt[f__cp]<=0)
+		{	f__cp--;
+			f__pc++;
+			goto loop;
+		}
+		if(ptr==NULL)
+			return((*f__doend)());
+		f__cnt[f__cp]--;
+		f__workdone=1;
+		if((n=(*f__doed)(p,ptr,len))>0)
+			errfl(f__elist->cierr,errno,"fmt");
+		if(n<0)
+			err(f__elist->ciend,(EOF),"fmt");
+		continue;
+	case STACK:
+		f__cnt[++f__cp]=p->p1;
+		f__pc++;
+		goto loop;
+	case RET1:
+		f__ret[++f__rp]=p->p1;
+		f__pc++;
+		goto loop;
+	case GOTO:
+		if(--f__cnt[f__cp]<=0)
+		{	f__cp--;
+			f__rp--;
+			f__pc++;
+			goto loop;
+		}
+		f__pc=1+f__ret[f__rp--];
+		goto loop;
+	case REVERT:
+		f__rp=f__cp=0;
+		f__pc = p->p1;
+		if(ptr==NULL)
+			return((*f__doend)());
+		if(!f__workdone) return(0);
+		if((n=(*f__dorevert)()) != 0) return(n);
+		goto loop;
+	case COLON:
+		if(ptr==NULL)
+			return((*f__doend)());
+		f__pc++;
+		goto loop;
+	case NONL:
+		f__nonl = 1;
+		f__pc++;
+		goto loop;
+	case S:
+	case SS:
+		f__cplus=0;
+		f__pc++;
+		goto loop;
+	case SP:
+		f__cplus = 1;
+		f__pc++;
+		goto loop;
+	case P:	f__scale=p->p1;
+		f__pc++;
+		goto loop;
+	case BN:
+		f__cblank=0;
+		f__pc++;
+		goto loop;
+	case BZ:
+		f__cblank=1;
+		f__pc++;
+		goto loop;
+	}
+	}
+	return(0);
+}
+
+ int
+en_fio(Void)
+{	ftnint one=1;
+	return(do_fio(&one,(char *)NULL,(ftnint)0));
+}
+
+ VOID
+fmt_bg(Void)
+{
+	f__workdone=f__cp=f__rp=f__pc=f__cursor=0;
+	f__cnt[0]=f__ret[0]=0;
+}
+#ifdef __cplusplus
+}
+#endif

min-dgels/additional/fmt.h

@@ -0,0 +1,105 @@
+struct syl
+{	int op;
+	int p1;
+	union { int i[2]; char *s;} p2;
+	};
+#define RET1 1
+#define REVERT 2
+#define GOTO 3
+#define X 4
+#define SLASH 5
+#define STACK 6
+#define I 7
+#define ED 8
+#define NED 9
+#define IM 10
+#define APOS 11
+#define H 12
+#define TL 13
+#define TR 14
+#define T 15
+#define COLON 16
+#define S 17
+#define SP 18
+#define SS 19
+#define P 20
+#define BN 21
+#define BZ 22
+#define F 23
+#define E 24
+#define EE 25
+#define D 26
+#define G 27
+#define GE 28
+#define L 29
+#define A 30
+#define AW 31
+#define O 32
+#define NONL 33
+#define OM 34
+#define Z 35
+#define ZM 36
+typedef union
+{	real pf;
+	doublereal pd;
+} ufloat;
+typedef union
+{	short is;
+#ifndef KR_headers
+	signed
+#endif
+		char ic;
+	integer il;
+#ifdef Allow_TYQUAD
+	longint ili;
+#endif
+} Uint;
+#ifdef KR_headers
+extern int (*f__doed)(),(*f__doned)();
+extern int (*f__dorevert)();
+extern int rd_ed(),rd_ned();
+extern int w_ed(),w_ned();
+extern int signbit_f2c();
+extern char *f__fmtbuf;
+#else
+#ifdef __cplusplus
+extern "C" {
+#define Cextern extern "C"
+#else
+#define Cextern extern
+#endif
+extern const char *f__fmtbuf;
+extern int (*f__doed)(struct syl*, char*, ftnlen),(*f__doned)(struct syl*);
+extern int (*f__dorevert)(void);
+extern void fmt_bg(void);
+extern int pars_f(const char*);
+extern int rd_ed(struct syl*, char*, ftnlen),rd_ned(struct syl*);
+extern int signbit_f2c(double*);
+extern int w_ed(struct syl*, char*, ftnlen),w_ned(struct syl*);
+extern int wrt_E(ufloat*, int, int, int, ftnlen);
+extern int wrt_F(ufloat*, int, int, ftnlen);
+extern int wrt_L(Uint*, int, ftnlen);
+#endif
+extern int f__pc,f__parenlvl,f__revloc;
+extern flag f__cblank,f__cplus,f__workdone, f__nonl;
+extern int f__scale;
+#ifdef __cplusplus
+	}
+#endif
+#define GET(x) if((x=(*f__getn)())<0) return(x)
+#define VAL(x) (x!='\n'?x:' ')
+#define PUT(x) (*f__putn)(x)
+
+#undef TYQUAD
+#ifndef Allow_TYQUAD
+#undef longint
+#define longint long
+#else
+#define TYQUAD 14
+#endif
+
+#ifdef KR_headers
+extern char *f__icvt();
+#else
+Cextern char *f__icvt(longint, int*, int*, int);
+#endif

min-dgels/additional/ieeeck.c

@@ -0,0 +1,166 @@
+/* ieeeck.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer ieeeck_(integer *ispec, real *zero, real *one)
+{
+    /* System generated locals */
+    integer ret_val;
+
+    /* Local variables */
+    real nan1, nan2, nan3, nan4, nan5, nan6, neginf, posinf, negzro, newzro;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  IEEECK is called from the ILAENV to verify that Infinity and */
+/*  possibly NaN arithmetic is safe (i.e. will not trap). */
+
+/*  Arguments */
+/*  ========= */
+
+/*  ISPEC   (input) INTEGER */
+/*          Specifies whether to test just for inifinity arithmetic */
+/*          or whether to test for infinity and NaN arithmetic. */
+/*          = 0: Verify infinity arithmetic only. */
+/*          = 1: Verify infinity and NaN arithmetic. */
+
+/*  ZERO    (input) REAL */
+/*          Must contain the value 0.0 */
+/*          This is passed to prevent the compiler from optimizing */
+/*          away this code. */
+
+/*  ONE     (input) REAL */
+/*          Must contain the value 1.0 */
+/*          This is passed to prevent the compiler from optimizing */
+/*          away this code. */
+
+/*  RETURN VALUE:  INTEGER */
+/*          = 0:  Arithmetic failed to produce the correct answers */
+/*          = 1:  Arithmetic produced the correct answers */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Executable Statements .. */
+    ret_val = 1;
+
+    posinf = *one / *zero;
+    if (posinf <= *one) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    neginf = -(*one) / *zero;
+    if (neginf >= *zero) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    negzro = *one / (neginf + *one);
+    if (negzro != *zero) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    neginf = *one / negzro;
+    if (neginf >= *zero) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    newzro = negzro + *zero;
+    if (newzro != *zero) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    posinf = *one / newzro;
+    if (posinf <= *one) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    neginf *= posinf;
+    if (neginf >= *zero) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    posinf *= posinf;
+    if (posinf <= *one) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+
+
+
+/*     Return if we were only asked to check infinity arithmetic */
+
+    if (*ispec == 0) {
+	return ret_val;
+    }
+
+    nan1 = posinf + neginf;
+
+    nan2 = posinf / neginf;
+
+    nan3 = posinf / posinf;
+
+    nan4 = posinf * *zero;
+
+    nan5 = neginf * negzro;
+
+    nan6 = nan5 * 0.f;
+
+    if (nan1 == nan1) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    if (nan2 == nan2) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    if (nan3 == nan3) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    if (nan4 == nan4) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    if (nan5 == nan5) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    if (nan6 == nan6) {
+	ret_val = 0;
+	return ret_val;
+    }
+
+    return ret_val;
+} /* ieeeck_ */

min-dgels/additional/iladlc.c

@@ -0,0 +1,88 @@
+/* iladlc.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iladlc_(integer *m, integer *n, doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, ret_val, i__1;
+
+    /* Local variables */
+    integer i__;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2.1)                        -- */
+
+/*  -- April 2009                                                      -- */
+
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  ILADLC scans A for its last non-zero column. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          The m by n matrix A. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A. LDA >= max(1,M). */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Quick test for the common case where one corner is non-zero. */
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    if (*n == 0) {
+	ret_val = *n;
+    } else if (a[*n * a_dim1 + 1] != 0. || a[*m + *n * a_dim1] != 0.) {
+	ret_val = *n;
+    } else {
+/*     Now scan each column from the end, returning with the first non-zero. */
+	for (ret_val = *n; ret_val >= 1; --ret_val) {
+	    i__1 = *m;
+	    for (i__ = 1; i__ <= i__1; ++i__) {
+		if (a[i__ + ret_val * a_dim1] != 0.) {
+		    return ret_val;
+		}
+	    }
+	}
+    }
+    return ret_val;
+} /* iladlc_ */

min-dgels/additional/iladlr.c

@@ -0,0 +1,90 @@
+/* iladlr.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iladlr_(integer *m, integer *n, doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, ret_val, i__1;
+
+    /* Local variables */
+    integer i__, j;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2.1)                        -- */
+
+/*  -- April 2009                                                      -- */
+
+/*  -- LAPACK is a software package provided by Univ. of Tennessee,    -- */
+/*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  ILADLR scans A for its last non-zero row. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  M       (input) INTEGER */
+/*          The number of rows of the matrix A. */
+
+/*  N       (input) INTEGER */
+/*          The number of columns of the matrix A. */
+
+/*  A       (input) DOUBLE PRECISION array, dimension (LDA,N) */
+/*          The m by n matrix A. */
+
+/*  LDA     (input) INTEGER */
+/*          The leading dimension of the array A. LDA >= max(1,M). */
+
+/*  ===================================================================== */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Quick test for the common case where one corner is non-zero. */
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    if (*m == 0) {
+	ret_val = *m;
+    } else if (a[*m + a_dim1] != 0. || a[*m + *n * a_dim1] != 0.) {
+	ret_val = *m;
+    } else {
+/*     Scan up each column tracking the last zero row seen. */
+	ret_val = 0;
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    for (i__ = *m; i__ >= 1; --i__) {
+		if (a[i__ + j * a_dim1] != 0.) {
+		    break;
+		}
+	    }
+	    ret_val = max(ret_val,i__);
+	}
+    }
+    return ret_val;
+} /* iladlr_ */

min-dgels/additional/ilaenv.c

@@ -0,0 +1,654 @@
+/* ilaenv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "string.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+static real c_b163 = 0.f;
+static real c_b164 = 1.f;
+static integer c__0 = 0;
+
+integer ilaenv_(integer *ispec, char *name__, char *opts, integer *n1, 
+	integer *n2, integer *n3, integer *n4)
+{
+    /* System generated locals */
+    integer ret_val;
+
+    /* Builtin functions */
+    /* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
+    integer s_cmp(char *, char *, ftnlen, ftnlen);
+
+    /* Local variables */
+    integer i__;
+    char c1[1], c2[1], c3[1], c4[1];
+    integer ic, nb, iz, nx;
+    logical cname;
+    integer nbmin;
+    logical sname;
+    extern integer ieeeck_(integer *, real *, real *);
+    char subnam[1];
+    extern integer iparmq_(integer *, char *, char *, integer *, integer *, 
+	    integer *, integer *);
+
+    ftnlen name_len, opts_len;
+
+    name_len = strlen (name__);
+    opts_len = strlen (opts);
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     January 2007 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  ILAENV is called from the LAPACK routines to choose problem-dependent */
+/*  parameters for the local environment.  See ISPEC for a description of */
+/*  the parameters. */
+
+/*  ILAENV returns an INTEGER */
+/*  if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC */
+/*  if ILAENV < 0:  if ILAENV = -k, the k-th argument had an illegal value. */
+
+/*  This version provides a set of parameters which should give good, */
+/*  but not optimal, performance on many of the currently available */
+/*  computers.  Users are encouraged to modify this subroutine to set */
+/*  the tuning parameters for their particular machine using the option */
+/*  and problem size information in the arguments. */
+
+/*  This routine will not function correctly if it is converted to all */
+/*  lower case.  Converting it to all upper case is allowed. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  ISPEC   (input) INTEGER */
+/*          Specifies the parameter to be returned as the value of */
+/*          ILAENV. */
+/*          = 1: the optimal blocksize; if this value is 1, an unblocked */
+/*               algorithm will give the best performance. */
+/*          = 2: the minimum block size for which the block routine */
+/*               should be used; if the usable block size is less than */
+/*               this value, an unblocked routine should be used. */
+/*          = 3: the crossover point (in a block routine, for N less */
+/*               than this value, an unblocked routine should be used) */
+/*          = 4: the number of shifts, used in the nonsymmetric */
+/*               eigenvalue routines (DEPRECATED) */
+/*          = 5: the minimum column dimension for blocking to be used; */
+/*               rectangular blocks must have dimension at least k by m, */
+/*               where k is given by ILAENV(2,...) and m by ILAENV(5,...) */
+/*          = 6: the crossover point for the SVD (when reducing an m by n */
+/*               matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds */
+/*               this value, a QR factorization is used first to reduce */
+/*               the matrix to a triangular form.) */
+/*          = 7: the number of processors */
+/*          = 8: the crossover point for the multishift QR method */
+/*               for nonsymmetric eigenvalue problems (DEPRECATED) */
+/*          = 9: maximum size of the subproblems at the bottom of the */
+/*               computation tree in the divide-and-conquer algorithm */
+/*               (used by xGELSD and xGESDD) */
+/*          =10: ieee NaN arithmetic can be trusted not to trap */
+/*          =11: infinity arithmetic can be trusted not to trap */
+/*          12 <= ISPEC <= 16: */
+/*               xHSEQR or one of its subroutines, */
+/*               see IPARMQ for detailed explanation */
+
+/*  NAME    (input) CHARACTER*(*) */
+/*          The name of the calling subroutine, in either upper case or */
+/*          lower case. */
+
+/*  OPTS    (input) CHARACTER*(*) */
+/*          The character options to the subroutine NAME, concatenated */
+/*          into a single character string.  For example, UPLO = 'U', */
+/*          TRANS = 'T', and DIAG = 'N' for a triangular routine would */
+/*          be specified as OPTS = 'UTN'. */
+
+/*  N1      (input) INTEGER */
+/*  N2      (input) INTEGER */
+/*  N3      (input) INTEGER */
+/*  N4      (input) INTEGER */
+/*          Problem dimensions for the subroutine NAME; these may not all */
+/*          be required. */
+
+/*  Further Details */
+/*  =============== */
+
+/*  The following conventions have been used when calling ILAENV from the */
+/*  LAPACK routines: */
+/*  1)  OPTS is a concatenation of all of the character options to */
+/*      subroutine NAME, in the same order that they appear in the */
+/*      argument list for NAME, even if they are not used in determining */
+/*      the value of the parameter specified by ISPEC. */
+/*  2)  The problem dimensions N1, N2, N3, N4 are specified in the order */
+/*      that they appear in the argument list for NAME.  N1 is used */
+/*      first, N2 second, and so on, and unused problem dimensions are */
+/*      passed a value of -1. */
+/*  3)  The parameter value returned by ILAENV is checked for validity in */
+/*      the calling subroutine.  For example, ILAENV is used to retrieve */
+/*      the optimal blocksize for STRTRI as follows: */
+
+/*      NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 ) */
+/*      IF( NB.LE.1 ) NB = MAX( 1, N ) */
+
+/*  ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    switch (*ispec) {
+	case 1:  goto L10;
+	case 2:  goto L10;
+	case 3:  goto L10;
+	case 4:  goto L80;
+	case 5:  goto L90;
+	case 6:  goto L100;
+	case 7:  goto L110;
+	case 8:  goto L120;
+	case 9:  goto L130;
+	case 10:  goto L140;
+	case 11:  goto L150;
+	case 12:  goto L160;
+	case 13:  goto L160;
+	case 14:  goto L160;
+	case 15:  goto L160;
+	case 16:  goto L160;
+    }
+
+/*     Invalid value for ISPEC */
+
+    ret_val = -1;
+    return ret_val;
+
+L10:
+
+/*     Convert NAME to upper case if the first character is lower case. */
+
+    ret_val = 1;
+    s_copy(subnam, name__, (ftnlen)1, name_len);
+    ic = *(unsigned char *)subnam;
+    iz = 'Z';
+    if (iz == 90 || iz == 122) {
+
+/*        ASCII character set */
+
+	if (ic >= 97 && ic <= 122) {
+	    *(unsigned char *)subnam = (char) (ic - 32);
+	    for (i__ = 2; i__ <= 6; ++i__) {
+		ic = *(unsigned char *)&subnam[i__ - 1];
+		if (ic >= 97 && ic <= 122) {
+		    *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
+		}
+/* L20: */
+	    }
+	}
+
+    } else if (iz == 233 || iz == 169) {
+
+/*        EBCDIC character set */
+
+	if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 162 && 
+		ic <= 169) {
+	    *(unsigned char *)subnam = (char) (ic + 64);
+	    for (i__ = 2; i__ <= 6; ++i__) {
+		ic = *(unsigned char *)&subnam[i__ - 1];
+		if (ic >= 129 && ic <= 137 || ic >= 145 && ic <= 153 || ic >= 
+			162 && ic <= 169) {
+		    *(unsigned char *)&subnam[i__ - 1] = (char) (ic + 64);
+		}
+/* L30: */
+	    }
+	}
+
+    } else if (iz == 218 || iz == 250) {
+
+/*        Prime machines:  ASCII+128 */
+
+	if (ic >= 225 && ic <= 250) {
+	    *(unsigned char *)subnam = (char) (ic - 32);
+	    for (i__ = 2; i__ <= 6; ++i__) {
+		ic = *(unsigned char *)&subnam[i__ - 1];
+		if (ic >= 225 && ic <= 250) {
+		    *(unsigned char *)&subnam[i__ - 1] = (char) (ic - 32);
+		}
+/* L40: */
+	    }
+	}
+    }
+
+    *(unsigned char *)c1 = *(unsigned char *)subnam;
+    sname = *(unsigned char *)c1 == 'S' || *(unsigned char *)c1 == 'D';
+    cname = *(unsigned char *)c1 == 'C' || *(unsigned char *)c1 == 'Z';
+    if (! (cname || sname)) {
+	return ret_val;
+    }
+    s_copy(c2, subnam + 1, (ftnlen)1, (ftnlen)2);
+    s_copy(c3, subnam + 3, (ftnlen)1, (ftnlen)3);
+    s_copy(c4, c3 + 1, (ftnlen)1, (ftnlen)2);
+
+    switch (*ispec) {
+	case 1:  goto L50;
+	case 2:  goto L60;
+	case 3:  goto L70;
+    }
+
+L50:
+
+/*     ISPEC = 1:  block size */
+
+/*     In these examples, separate code is provided for setting NB for */
+/*     real and complex.  We assume that NB will take the same value in */
+/*     single or double precision. */
+
+    nb = 1;
+
+    if (s_cmp(c2, "GE", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 64;
+	    } else {
+		nb = 64;
+	    }
+	} else if (s_cmp(c3, "QRF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, 
+		"RQF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)
+		1, (ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)1, (ftnlen)3) 
+		== 0) {
+	    if (sname) {
+		nb = 32;
+	    } else {
+		nb = 32;
+	    }
+	} else if (s_cmp(c3, "HRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 32;
+	    } else {
+		nb = 32;
+	    }
+	} else if (s_cmp(c3, "BRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 32;
+	    } else {
+		nb = 32;
+	    }
+	} else if (s_cmp(c3, "TRI", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 64;
+	    } else {
+		nb = 64;
+	    }
+	}
+    } else if (s_cmp(c2, "PO", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 64;
+	    } else {
+		nb = 64;
+	    }
+	}
+    } else if (s_cmp(c2, "SY", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 64;
+	    } else {
+		nb = 64;
+	    }
+	} else if (sname && s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    nb = 32;
+	} else if (sname && s_cmp(c3, "GST", (ftnlen)1, (ftnlen)3) == 0) {
+	    nb = 64;
+	}
+    } else if (cname && s_cmp(c2, "HE", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    nb = 64;
+	} else if (s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    nb = 32;
+	} else if (s_cmp(c3, "GST", (ftnlen)1, (ftnlen)3) == 0) {
+	    nb = 64;
+	}
+    } else if (sname && s_cmp(c2, "OR", (ftnlen)1, (ftnlen)2) == 0) {
+	if (*(unsigned char *)c3 == 'G') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nb = 32;
+	    }
+	} else if (*(unsigned char *)c3 == 'M') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nb = 32;
+	    }
+	}
+    } else if (cname && s_cmp(c2, "UN", (ftnlen)1, (ftnlen)2) == 0) {
+	if (*(unsigned char *)c3 == 'G') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nb = 32;
+	    }
+	} else if (*(unsigned char *)c3 == 'M') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nb = 32;
+	    }
+	}
+    } else if (s_cmp(c2, "GB", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		if (*n4 <= 64) {
+		    nb = 1;
+		} else {
+		    nb = 32;
+		}
+	    } else {
+		if (*n4 <= 64) {
+		    nb = 1;
+		} else {
+		    nb = 32;
+		}
+	    }
+	}
+    } else if (s_cmp(c2, "PB", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		if (*n2 <= 64) {
+		    nb = 1;
+		} else {
+		    nb = 32;
+		}
+	    } else {
+		if (*n2 <= 64) {
+		    nb = 1;
+		} else {
+		    nb = 32;
+		}
+	    }
+	}
+    } else if (s_cmp(c2, "TR", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRI", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 64;
+	    } else {
+		nb = 64;
+	    }
+	}
+    } else if (s_cmp(c2, "LA", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "UUM", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nb = 64;
+	    } else {
+		nb = 64;
+	    }
+	}
+    } else if (sname && s_cmp(c2, "ST", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "EBZ", (ftnlen)1, (ftnlen)3) == 0) {
+	    nb = 1;
+	}
+    }
+    ret_val = nb;
+    return ret_val;
+
+L60:
+
+/*     ISPEC = 2:  minimum block size */
+
+    nbmin = 2;
+    if (s_cmp(c2, "GE", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "QRF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
+		ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)1, (
+		ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)1, (ftnlen)3) == 0)
+		 {
+	    if (sname) {
+		nbmin = 2;
+	    } else {
+		nbmin = 2;
+	    }
+	} else if (s_cmp(c3, "HRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nbmin = 2;
+	    } else {
+		nbmin = 2;
+	    }
+	} else if (s_cmp(c3, "BRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nbmin = 2;
+	    } else {
+		nbmin = 2;
+	    }
+	} else if (s_cmp(c3, "TRI", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nbmin = 2;
+	    } else {
+		nbmin = 2;
+	    }
+	}
+    } else if (s_cmp(c2, "SY", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRF", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nbmin = 8;
+	    } else {
+		nbmin = 8;
+	    }
+	} else if (sname && s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    nbmin = 2;
+	}
+    } else if (cname && s_cmp(c2, "HE", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    nbmin = 2;
+	}
+    } else if (sname && s_cmp(c2, "OR", (ftnlen)1, (ftnlen)2) == 0) {
+	if (*(unsigned char *)c3 == 'G') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nbmin = 2;
+	    }
+	} else if (*(unsigned char *)c3 == 'M') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nbmin = 2;
+	    }
+	}
+    } else if (cname && s_cmp(c2, "UN", (ftnlen)1, (ftnlen)2) == 0) {
+	if (*(unsigned char *)c3 == 'G') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nbmin = 2;
+	    }
+	} else if (*(unsigned char *)c3 == 'M') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nbmin = 2;
+	    }
+	}
+    }
+    ret_val = nbmin;
+    return ret_val;
+
+L70:
+
+/*     ISPEC = 3:  crossover point */
+
+    nx = 0;
+    if (s_cmp(c2, "GE", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "QRF", (ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "RQF", (
+		ftnlen)1, (ftnlen)3) == 0 || s_cmp(c3, "LQF", (ftnlen)1, (
+		ftnlen)3) == 0 || s_cmp(c3, "QLF", (ftnlen)1, (ftnlen)3) == 0)
+		 {
+	    if (sname) {
+		nx = 128;
+	    } else {
+		nx = 128;
+	    }
+	} else if (s_cmp(c3, "HRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nx = 128;
+	    } else {
+		nx = 128;
+	    }
+	} else if (s_cmp(c3, "BRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    if (sname) {
+		nx = 128;
+	    } else {
+		nx = 128;
+	    }
+	}
+    } else if (s_cmp(c2, "SY", (ftnlen)1, (ftnlen)2) == 0) {
+	if (sname && s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    nx = 32;
+	}
+    } else if (cname && s_cmp(c2, "HE", (ftnlen)1, (ftnlen)2) == 0) {
+	if (s_cmp(c3, "TRD", (ftnlen)1, (ftnlen)3) == 0) {
+	    nx = 32;
+	}
+    } else if (sname && s_cmp(c2, "OR", (ftnlen)1, (ftnlen)2) == 0) {
+	if (*(unsigned char *)c3 == 'G') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nx = 128;
+	    }
+	}
+    } else if (cname && s_cmp(c2, "UN", (ftnlen)1, (ftnlen)2) == 0) {
+	if (*(unsigned char *)c3 == 'G') {
+	    if (s_cmp(c4, "QR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "RQ", 
+		    (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "LQ", (ftnlen)1, (
+		    ftnlen)2) == 0 || s_cmp(c4, "QL", (ftnlen)1, (ftnlen)2) ==
+		     0 || s_cmp(c4, "HR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(
+		    c4, "TR", (ftnlen)1, (ftnlen)2) == 0 || s_cmp(c4, "BR", (
+		    ftnlen)1, (ftnlen)2) == 0) {
+		nx = 128;
+	    }
+	}
+    }
+    ret_val = nx;
+    return ret_val;
+
+L80:
+
+/*     ISPEC = 4:  number of shifts (used by xHSEQR) */
+
+    ret_val = 6;
+    return ret_val;
+
+L90:
+
+/*     ISPEC = 5:  minimum column dimension (not used) */
+
+    ret_val = 2;
+    return ret_val;
+
+L100:
+
+/*     ISPEC = 6:  crossover point for SVD (used by xGELSS and xGESVD) */
+
+    ret_val = (integer) ((real) min(*n1,*n2) * 1.6f);
+    return ret_val;
+
+L110:
+
+/*     ISPEC = 7:  number of processors (not used) */
+
+    ret_val = 1;
+    return ret_val;
+
+L120:
+
+/*     ISPEC = 8:  crossover point for multishift (used by xHSEQR) */
+
+    ret_val = 50;
+    return ret_val;
+
+L130:
+
+/*     ISPEC = 9:  maximum size of the subproblems at the bottom of the */
+/*                 computation tree in the divide-and-conquer algorithm */
+/*                 (used by xGELSD and xGESDD) */
+
+    ret_val = 25;
+    return ret_val;
+
+L140:
+
+/*     ISPEC = 10: ieee NaN arithmetic can be trusted not to trap */
+
+/*     ILAENV = 0 */
+    ret_val = 1;
+    if (ret_val == 1) {
+	ret_val = ieeeck_(&c__1, &c_b163, &c_b164);
+    }
+    return ret_val;
+
+L150:
+
+/*     ISPEC = 11: infinity arithmetic can be trusted not to trap */
+
+/*     ILAENV = 0 */
+    ret_val = 1;
+    if (ret_val == 1) {
+	ret_val = ieeeck_(&c__0, &c_b163, &c_b164);
+    }
+    return ret_val;
+
+L160:
+
+/*     12 <= ISPEC <= 16: xHSEQR or one of its subroutines. */
+
+    ret_val = iparmq_(ispec, name__, opts, n1, n2, n3, n4)
+	    ;
+    return ret_val;
+
+/*     End of ILAENV */
+
+} /* ilaenv_ */

min-dgels/additional/iparmq.c

@@ -0,0 +1,282 @@
+/* iparmq.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+integer iparmq_(integer *ispec, char *name__, char *opts, integer *n, integer 
+	*ilo, integer *ihi, integer *lwork)
+{
+    /* System generated locals */
+    integer ret_val, i__1, i__2;
+    real r__1;
+
+    /* Builtin functions */
+    double log(doublereal);
+    integer i_nint(real *);
+
+    /* Local variables */
+    integer nh, ns;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*       This program sets problem and machine dependent parameters */
+/*       useful for xHSEQR and its subroutines. It is called whenever */
+/*       ILAENV is called with 12 <= ISPEC <= 16 */
+
+/*  Arguments */
+/*  ========= */
+
+/*       ISPEC  (input) integer scalar */
+/*              ISPEC specifies which tunable parameter IPARMQ should */
+/*              return. */
+
+/*              ISPEC=12: (INMIN)  Matrices of order nmin or less */
+/*                        are sent directly to xLAHQR, the implicit */
+/*                        double shift QR algorithm.  NMIN must be */
+/*                        at least 11. */
+
+/*              ISPEC=13: (INWIN)  Size of the deflation window. */
+/*                        This is best set greater than or equal to */
+/*                        the number of simultaneous shifts NS. */
+/*                        Larger matrices benefit from larger deflation */
+/*                        windows. */
+
+/*              ISPEC=14: (INIBL) Determines when to stop nibbling and */
+/*                        invest in an (expensive) multi-shift QR sweep. */
+/*                        If the aggressive early deflation subroutine */
+/*                        finds LD converged eigenvalues from an order */
+/*                        NW deflation window and LD.GT.(NW*NIBBLE)/100, */
+/*                        then the next QR sweep is skipped and early */
+/*                        deflation is applied immediately to the */
+/*                        remaining active diagonal block.  Setting */
+/*                        IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a */
+/*                        multi-shift QR sweep whenever early deflation */
+/*                        finds a converged eigenvalue.  Setting */
+/*                        IPARMQ(ISPEC=14) greater than or equal to 100 */
+/*                        prevents TTQRE from skipping a multi-shift */
+/*                        QR sweep. */
+
+/*              ISPEC=15: (NSHFTS) The number of simultaneous shifts in */
+/*                        a multi-shift QR iteration. */
+
+/*              ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the */
+/*                        following meanings. */
+/*                        0:  During the multi-shift QR sweep, */
+/*                            xLAQR5 does not accumulate reflections and */
+/*                            does not use matrix-matrix multiply to */
+/*                            update the far-from-diagonal matrix */
+/*                            entries. */
+/*                        1:  During the multi-shift QR sweep, */
+/*                            xLAQR5 and/or xLAQRaccumulates reflections and uses */
+/*                            matrix-matrix multiply to update the */
+/*                            far-from-diagonal matrix entries. */
+/*                        2:  During the multi-shift QR sweep. */
+/*                            xLAQR5 accumulates reflections and takes */
+/*                            advantage of 2-by-2 block structure during */
+/*                            matrix-matrix multiplies. */
+/*                        (If xTRMM is slower than xGEMM, then */
+/*                        IPARMQ(ISPEC=16)=1 may be more efficient than */
+/*                        IPARMQ(ISPEC=16)=2 despite the greater level of */
+/*                        arithmetic work implied by the latter choice.) */
+
+/*       NAME    (input) character string */
+/*               Name of the calling subroutine */
+
+/*       OPTS    (input) character string */
+/*               This is a concatenation of the string arguments to */
+/*               TTQRE. */
+
+/*       N       (input) integer scalar */
+/*               N is the order of the Hessenberg matrix H. */
+
+/*       ILO     (input) INTEGER */
+/*       IHI     (input) INTEGER */
+/*               It is assumed that H is already upper triangular */
+/*               in rows and columns 1:ILO-1 and IHI+1:N. */
+
+/*       LWORK   (input) integer scalar */
+/*               The amount of workspace available. */
+
+/*  Further Details */
+/*  =============== */
+
+/*       Little is known about how best to choose these parameters. */
+/*       It is possible to use different values of the parameters */
+/*       for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR. */
+
+/*       It is probably best to choose different parameters for */
+/*       different matrices and different parameters at different */
+/*       times during the iteration, but this has not been */
+/*       implemented --- yet. */
+
+
+/*       The best choices of most of the parameters depend */
+/*       in an ill-understood way on the relative execution */
+/*       rate of xLAQR3 and xLAQR5 and on the nature of each */
+/*       particular eigenvalue problem.  Experiment may be the */
+/*       only practical way to determine which choices are most */
+/*       effective. */
+
+/*       Following is a list of default values supplied by IPARMQ. */
+/*       These defaults may be adjusted in order to attain better */
+/*       performance in any particular computational environment. */
+
+/*       IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point. */
+/*                        Default: 75. (Must be at least 11.) */
+
+/*       IPARMQ(ISPEC=13) Recommended deflation window size. */
+/*                        This depends on ILO, IHI and NS, the */
+/*                        number of simultaneous shifts returned */
+/*                        by IPARMQ(ISPEC=15).  The default for */
+/*                        (IHI-ILO+1).LE.500 is NS.  The default */
+/*                        for (IHI-ILO+1).GT.500 is 3*NS/2. */
+
+/*       IPARMQ(ISPEC=14) Nibble crossover point.  Default: 14. */
+
+/*       IPARMQ(ISPEC=15) Number of simultaneous shifts, NS. */
+/*                        a multi-shift QR iteration. */
+
+/*                        If IHI-ILO+1 is ... */
+
+/*                        greater than      ...but less    ... the */
+/*                        or equal to ...      than        default is */
+
+/*                                0               30       NS =   2+ */
+/*                               30               60       NS =   4+ */
+/*                               60              150       NS =  10 */
+/*                              150              590       NS =  ** */
+/*                              590             3000       NS =  64 */
+/*                             3000             6000       NS = 128 */
+/*                             6000             infinity   NS = 256 */
+
+/*                    (+)  By default matrices of this order are */
+/*                         passed to the implicit double shift routine */
+/*                         xLAHQR.  See IPARMQ(ISPEC=12) above.   These */
+/*                         values of NS are used only in case of a rare */
+/*                         xLAHQR failure. */
+
+/*                    (**) The asterisks (**) indicate an ad-hoc */
+/*                         function increasing from 10 to 64. */
+
+/*       IPARMQ(ISPEC=16) Select structured matrix multiply. */
+/*                        (See ISPEC=16 above for details.) */
+/*                        Default: 3. */
+
+/*     ================================================================ */
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+    if (*ispec == 15 || *ispec == 13 || *ispec == 16) {
+
+/*        ==== Set the number simultaneous shifts ==== */
+
+	nh = *ihi - *ilo + 1;
+	ns = 2;
+	if (nh >= 30) {
+	    ns = 4;
+	}
+	if (nh >= 60) {
+	    ns = 10;
+	}
+	if (nh >= 150) {
+/* Computing MAX */
+	    r__1 = log((real) nh) / log(2.f);
+	    i__1 = 10, i__2 = nh / i_nint(&r__1);
+	    ns = max(i__1,i__2);
+	}
+	if (nh >= 590) {
+	    ns = 64;
+	}
+	if (nh >= 3000) {
+	    ns = 128;
+	}
+	if (nh >= 6000) {
+	    ns = 256;
+	}
+/* Computing MAX */
+	i__1 = 2, i__2 = ns - ns % 2;
+	ns = max(i__1,i__2);
+    }
+
+    if (*ispec == 12) {
+
+
+/*        ===== Matrices of order smaller than NMIN get sent */
+/*        .     to xLAHQR, the classic double shift algorithm. */
+/*        .     This must be at least 11. ==== */
+
+	ret_val = 75;
+
+    } else if (*ispec == 14) {
+
+/*        ==== INIBL: skip a multi-shift qr iteration and */
+/*        .    whenever aggressive early deflation finds */
+/*        .    at least (NIBBLE*(window size)/100) deflations. ==== */
+
+	ret_val = 14;
+
+    } else if (*ispec == 15) {
+
+/*        ==== NSHFTS: The number of simultaneous shifts ===== */
+
+	ret_val = ns;
+
+    } else if (*ispec == 13) {
+
+/*        ==== NW: deflation window size.  ==== */
+
+	if (nh <= 500) {
+	    ret_val = ns;
+	} else {
+	    ret_val = ns * 3 / 2;
+	}
+
+    } else if (*ispec == 16) {
+
+/*        ==== IACC22: Whether to accumulate reflections */
+/*        .     before updating the far-from-diagonal elements */
+/*        .     and whether to use 2-by-2 block structure while */
+/*        .     doing it.  A small amount of work could be saved */
+/*        .     by making this choice dependent also upon the */
+/*        .     NH=IHI-ILO+1. */
+
+	ret_val = 0;
+	if (ns >= 14) {
+	    ret_val = 1;
+	}
+	if (ns >= 14) {
+	    ret_val = 2;
+	}
+
+    } else {
+/*        ===== invalid value of ispec ===== */
+	ret_val = -1;
+
+    }
+
+/*     ==== End of IPARMQ ==== */
+
+    return ret_val;
+} /* iparmq_ */

min-dgels/additional/lsame.c

@@ -0,0 +1,117 @@
+/* lsame.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+logical lsame_(char *ca, char *cb)
+{
+    /* System generated locals */
+    logical ret_val;
+
+    /* Local variables */
+    integer inta, intb, zcode;
+
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  LSAME returns .TRUE. if CA is the same letter as CB regardless of */
+/*  case. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  CA      (input) CHARACTER*1 */
+/*  CB      (input) CHARACTER*1 */
+/*          CA and CB specify the single characters to be compared. */
+
+/* ===================================================================== */
+
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+/*     Test if the characters are equal */
+
+    ret_val = *(unsigned char *)ca == *(unsigned char *)cb;
+    if (ret_val) {
+	return ret_val;
+    }
+
+/*     Now test for equivalence if both characters are alphabetic. */
+
+    zcode = 'Z';
+
+/*     Use 'Z' rather than 'A' so that ASCII can be detected on Prime */
+/*     machines, on which ICHAR returns a value with bit 8 set. */
+/*     ICHAR('A') on Prime machines returns 193 which is the same as */
+/*     ICHAR('A') on an EBCDIC machine. */
+
+    inta = *(unsigned char *)ca;
+    intb = *(unsigned char *)cb;
+
+    if (zcode == 90 || zcode == 122) {
+
+/*        ASCII is assumed - ZCODE is the ASCII code of either lower or */
+/*        upper case 'Z'. */
+
+	if (inta >= 97 && inta <= 122) {
+	    inta += -32;
+	}
+	if (intb >= 97 && intb <= 122) {
+	    intb += -32;
+	}
+
+    } else if (zcode == 233 || zcode == 169) {
+
+/*        EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or */
+/*        upper case 'Z'. */
+
+	if (inta >= 129 && inta <= 137 || inta >= 145 && inta <= 153 || inta 
+		>= 162 && inta <= 169) {
+	    inta += 64;
+	}
+	if (intb >= 129 && intb <= 137 || intb >= 145 && intb <= 153 || intb 
+		>= 162 && intb <= 169) {
+	    intb += 64;
+	}
+
+    } else if (zcode == 218 || zcode == 250) {
+
+/*        ASCII is assumed, on Prime machines - ZCODE is the ASCII code */
+/*        plus 128 of either lower or upper case 'Z'. */
+
+	if (inta >= 225 && inta <= 250) {
+	    inta += -32;
+	}
+	if (intb >= 225 && intb <= 250) {
+	    intb += -32;
+	}
+    }
+    ret_val = inta == intb;
+
+/*     RETURN */
+
+/*     End of LSAME */
+
+    return ret_val;
+} /* lsame_ */

min-dgels/additional/mindgels.h

@@ -0,0 +1,8 @@
+#ifndef DGELS_H 
+#define DGELS_H
+
+#include "f2c.h"
+
+int dgels_(char *trans, integer *m, integer *n, integer *nrhs, doublereal *a, integer *lda, doublereal *b, integer *ldb, doublereal *work, integer *lwork, integer *info);
+
+#endif

min-dgels/additional/pow_di.c

@@ -0,0 +1,41 @@
+#include "f2c.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+#ifdef KR_headers
+double pow_di(ap, bp) doublereal *ap; integer *bp;
+#else
+double pow_di(doublereal *ap, integer *bp)
+#endif
+{
+double pow, x;
+integer n;
+unsigned long u;
+
+pow = 1;
+x = *ap;
+n = *bp;
+
+if(n != 0)
+	{
+	if(n < 0)
+		{
+		n = -n;
+		x = 1/x;
+		}
+	for(u = n; ; )
+		{
+		if(u & 01)
+			pow *= x;
+		if(u >>= 1)
+			x *= x;
+		else
+			break;
+		}
+	}
+return(pow);
+}
+#ifdef __cplusplus
+}
+#endif

min-dgels/additional/s_cat.c

@@ -0,0 +1,86 @@
+/* Unless compiled with -DNO_OVERWRITE, this variant of s_cat allows the
+ * target of a concatenation to appear on its right-hand side (contrary
+ * to the Fortran 77 Standard, but in accordance with Fortran 90).
+ */
+
+#include "f2c.h"
+#ifndef NO_OVERWRITE
+#include "stdio.h"
+#undef abs
+#ifdef KR_headers
+ extern char *F77_aloc();
+ extern void free();
+ extern void exit_();
+#else
+#undef min
+#undef max
+#include "stdlib.h"
+extern
+#ifdef __cplusplus
+	"C"
+#endif
+	char *F77_aloc(ftnlen, const char*);
+#endif
+#include "string.h"
+#endif /* NO_OVERWRITE */
+
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ VOID
+#ifdef KR_headers
+s_cat(lp, rpp, rnp, np, ll) char *lp, *rpp[]; ftnint rnp[], *np; ftnlen ll;
+#else
+s_cat(char *lp, char *rpp[], ftnint rnp[], ftnint *np, ftnlen ll)
+#endif
+{
+	ftnlen i, nc;
+	char *rp;
+	ftnlen n = *np;
+#ifndef NO_OVERWRITE
+	ftnlen L, m;
+	char *lp0, *lp1;
+
+	lp0 = 0;
+	lp1 = lp;
+	L = ll;
+	i = 0;
+	while(i < n) {
+		rp = rpp[i];
+		m = rnp[i++];
+		if (rp >= lp1 || rp + m <= lp) {
+			if ((L -= m) <= 0) {
+				n = i;
+				break;
+				}
+			lp1 += m;
+			continue;
+			}
+		lp0 = lp;
+		lp = lp1 = F77_aloc(L = ll, "s_cat");
+		break;
+		}
+	lp1 = lp;
+#endif /* NO_OVERWRITE */
+	for(i = 0 ; i < n ; ++i) {
+		nc = ll;
+		if(rnp[i] < nc)
+			nc = rnp[i];
+		ll -= nc;
+		rp = rpp[i];
+		while(--nc >= 0)
+			*lp++ = *rp++;
+		}
+	while(--ll >= 0)
+		*lp++ = ' ';
+#ifndef NO_OVERWRITE
+	if (lp0) {
+		memcpy(lp0, lp1, L);
+		free(lp1);
+		}
+#endif
+	}
+#ifdef __cplusplus
+}
+#endif

min-dgels/additional/sysdep1.h

@@ -0,0 +1,66 @@
+#ifndef SYSDEP_H_INCLUDED
+#define SYSDEP_H_INCLUDED
+#undef USE_LARGEFILE
+#ifndef NO_LONG_LONG
+
+#ifdef __sun__
+#define USE_LARGEFILE
+#define OFF_T off64_t
+#endif
+
+#ifdef __linux__
+#define USE_LARGEFILE
+#define OFF_T __off64_t
+#endif
+
+#ifdef _AIX43
+#define _LARGE_FILES
+#define _LARGE_FILE_API
+#define USE_LARGEFILE
+#endif /*_AIX43*/
+
+#ifdef __hpux
+#define _FILE64
+#define _LARGEFILE64_SOURCE
+#define USE_LARGEFILE
+#endif /*__hpux*/
+
+#ifdef __sgi
+#define USE_LARGEFILE
+#endif /*__sgi*/
+
+#ifdef __FreeBSD__
+#define OFF_T off_t
+#define FSEEK fseeko
+#define FTELL ftello
+#endif
+
+#ifdef USE_LARGEFILE
+#ifndef OFF_T
+#define OFF_T off64_t
+#endif
+#define _LARGEFILE_SOURCE
+#define _LARGEFILE64_SOURCE
+#include <sys/types.h>
+#include <sys/stat.h>
+#define FOPEN fopen64
+#define FREOPEN freopen64
+#define FSEEK fseeko64
+#define FSTAT fstat64
+#define FTELL ftello64
+#define FTRUNCATE ftruncate64
+#define STAT stat64
+#define STAT_ST stat64
+#endif /*USE_LARGEFILE*/
+#endif /*NO_LONG_LONG*/
+
+#ifndef NON_UNIX_STDIO
+#ifndef USE_LARGEFILE
+#define _INCLUDE_POSIX_SOURCE	/* for HP-UX */
+#define _INCLUDE_XOPEN_SOURCE	/* for HP-UX */
+#include "sys/types.h"
+#include "sys/stat.h"
+#endif
+#endif
+
+#endif /*SYSDEP_H_INCLUDED*/

min-dgels/additional/wsfe.c

@@ -0,0 +1,78 @@
+/*write sequential formatted external*/
+#include "f2c.h"
+#include "fio.h"
+#include "fmt.h"
+#ifdef __cplusplus
+extern "C" {
+#endif
+
+ int
+x_wSL(Void)
+{
+	int n = f__putbuf('\n');
+	f__hiwater = f__recpos = f__cursor = 0;
+	return(n == 0);
+}
+
+ static int
+xw_end(Void)
+{
+	int n;
+
+	if(f__nonl) {
+		f__putbuf(n = 0);
+		fflush(f__cf);
+		}
+	else
+		n = f__putbuf('\n');
+	f__hiwater = f__recpos = f__cursor = 0;
+	return n;
+}
+
+ static int
+xw_rev(Void)
+{
+	int n = 0;
+	if(f__workdone) {
+		n = f__putbuf('\n');
+		f__workdone = 0;
+		}
+	f__hiwater = f__recpos = f__cursor = 0;
+	return n;
+}
+
+#ifdef KR_headers
+integer s_wsfe(a) cilist *a;	/*start*/
+#else
+integer s_wsfe(cilist *a)	/*start*/
+#endif
+{	int n;
+	if(!f__init) f_init();
+	f__reading=0;
+	f__sequential=1;
+	f__formatted=1;
+	f__external=1;
+	if(n=c_sfe(a)) return(n);
+	f__elist=a;
+	f__hiwater = f__cursor=f__recpos=0;
+	f__nonl = 0;
+	f__scale=0;
+	f__fmtbuf=a->cifmt;
+	f__cf=f__curunit->ufd;
+	if(pars_f(f__fmtbuf)<0) err(a->cierr,100,"startio");
+	f__putn= x_putc;
+	f__doed= w_ed;
+	f__doned= w_ned;
+	f__doend=xw_end;
+	f__dorevert=xw_rev;
+	f__donewrec=x_wSL;
+	fmt_bg();
+	f__cplus=0;
+	f__cblank=f__curunit->ublnk;
+	if(f__curunit->uwrt != 1 && f__nowwriting(f__curunit))
+		err(a->cierr,errno,"write start");
+	return(0);
+}
+#ifdef __cplusplus
+}
+#endif

min-dgels/additional/xerbla.c

@@ -0,0 +1,65 @@
+/* xerbla.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+#include "stdio.h"
+
+/* Table of constant values */
+
+static integer c__1 = 1;
+
+/* Subroutine */ int xerbla_(char *srname, integer *info)
+{
+    
+
+/*  -- LAPACK auxiliary routine (version 3.2) -- */
+/*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */
+/*     November 2006 */
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  XERBLA  is an error handler for the LAPACK routines. */
+/*  It is called by an LAPACK routine if an input parameter has an */
+/*  invalid value.  A message is printed and execution stops. */
+
+/*  Installers may consider modifying the STOP statement in order to */
+/*  call system-specific exception-handling facilities. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  SRNAME  (input) CHARACTER*(*) */
+/*          The name of the routine which called XERBLA. */
+
+/*  INFO    (input) INTEGER */
+/*          The position of the invalid parameter in the parameter list */
+/*          of the calling routine. */
+
+/* ===================================================================== */
+
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Executable Statements .. */
+
+    printf("** On entry to %s, parameter number %ld had an illegal value\n",
+		srname, *info);
+
+
+/*     End of XERBLA */
+
+    return 0;
+} /* xerbla_ */

min-dgels/base/BLAS/SRC/Makefile

@@ -0,0 +1,115 @@
+TOPDIR=../..
+include $(TOPDIR)/make.inc
+
+#######################################################################
+#  This is the makefile to create a library for the BLAS.
+#  The files are grouped as follows:
+#
+#       SBLAS1 -- Single precision real BLAS routines
+#       CBLAS1 -- Single precision complex BLAS routines
+#       DBLAS1 -- Double precision real BLAS routines
+#       ZBLAS1 -- Double precision complex BLAS routines
+#
+#       CB1AUX -- Real BLAS routines called by complex routines
+#       ZB1AUX -- D.P. real BLAS routines called by d.p. complex
+#                 routines
+#
+#      ALLBLAS -- Auxiliary routines for Level 2 and 3 BLAS
+#
+#       SBLAS2 -- Single precision real BLAS2 routines
+#       CBLAS2 -- Single precision complex BLAS2 routines
+#       DBLAS2 -- Double precision real BLAS2 routines
+#       ZBLAS2 -- Double precision complex BLAS2 routines
+#
+#       SBLAS3 -- Single precision real BLAS3 routines
+#       CBLAS3 -- Single precision complex BLAS3 routines
+#       DBLAS3 -- Double precision real BLAS3 routines
+#       ZBLAS3 -- Double precision complex BLAS3 routines
+#
+#  The library can be set up to include routines for any combination
+#  of the four precisions.  To create or add to the library, enter make
+#  followed by one or more of the precisions desired.  Some examples:
+#       make single
+#       make single complex
+#       make single double complex complex16
+#  Note that these commands are not safe for parallel builds.
+#
+#  Alternatively, the commands
+#       make all
+#  or
+#       make
+#  without any arguments creates a library of all four precisions.
+#  The name of the library is held in BLASLIB, which is set in the
+#  top-level make.inc
+#
+#  To remove the object files after the library is created, enter
+#       make clean
+#  To force the source files to be recompiled, enter, for example,
+#       make single FRC=FRC
+#
+#---------------------------------------------------------------------
+#
+#  Edward Anderson, University of Tennessee
+#  March 26, 1990
+#  Susan Ostrouchov, Last updated September 30, 1994
+#  ejr, May 2006.
+#
+#######################################################################
+
+all: $(BLASLIB)
+ 
+#---------------------------------------------------------
+#  Comment out the next 6 definitions if you already have
+#  the Level 1 BLAS.
+#---------------------------------------------------------
+
+DBLAS1 = idamax.o dasum.o daxpy.o dcopy.o ddot.o dnrm2.o \
+	drot.o drotg.o dscal.o dsdot.o dswap.o drotmg.o drotm.o
+$(DBLAS1): $(FRC)
+
+#---------------------------------------------------------------------
+#  The following line defines auxiliary routines needed by both the
+#  Level 2 and Level 3 BLAS.  Comment it out only if you already have
+#  both the Level 2 and 3 BLAS.
+#---------------------------------------------------------------------
+
+ALLBLAS  = lsame.o xerbla.o xerbla_array.o
+$(ALLBLAS) : $(FRC)
+
+#---------------------------------------------------------
+#  Comment out the next 4 definitions if you already have
+#  the Level 2 BLAS.
+#---------------------------------------------------------
+
+DBLAS2 = dgemv.o dgbmv.o dsymv.o dsbmv.o dspmv.o \
+	dtrmv.o dtbmv.o dtpmv.o dtrsv.o dtbsv.o dtpsv.o \
+	dger.o dsyr.o dspr.o dsyr2.o dspr2.o
+$(DBLAS2): $(FRC)
+
+#---------------------------------------------------------
+#  Comment out the next 4 definitions if you already have
+#  the Level 3 BLAS.
+#---------------------------------------------------------
+
+DBLAS3 = dgemm.o dsymm.o dsyrk.o dsyr2k.o dtrmm.o dtrsm.o
+$(DBLAS3): $(FRC)
+
+ALLOBJ= $(DBLAS1) $(DBLAS2) $(DBLAS3) $(ALLBLAS)
+
+$(BLASLIB): $(ALLOBJ)
+	$(ARCH) $(ARCHFLAGS) $@ $(ALLOBJ)
+	$(RANLIB) $@
+
+double: $(DBLAS1) $(ALLBLAS) $(DBLAS2) $(DBLAS3)
+	$(ARCH) $(ARCHFLAGS) $(BLASLIB) $(DBLAS1) $(ALLBLAS) \
+	$(DBLAS2) $(DBLAS3)
+	$(RANLIB) $(BLASLIB)
+
+FRC:
+	@FRC=$(FRC)
+
+clean:
+	rm -f *.o
+
+.c.o: 
+	$(CC) $(CFLAGS) -c $< -o $@

min-dgels/base/BLAS/SRC/dasum.c

@@ -0,0 +1,101 @@
+/* dasum.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dasum_(integer *n, doublereal *dx, integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal ret_val, d__1, d__2, d__3, d__4, d__5, d__6;
+
+    /* Local variables */
+    integer i__, m, mp1;
+    doublereal dtemp;
+    integer nincx;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     takes the sum of the absolute values. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 3/93 to return if incx .le. 0. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dx;
+
+    /* Function Body */
+    ret_val = 0.;
+    dtemp = 0.;
+    if (*n <= 0 || *incx <= 0) {
+	return ret_val;
+    }
+    if (*incx == 1) {
+	goto L20;
+    }
+
+/*        code for increment not equal to 1 */
+
+    nincx = *n * *incx;
+    i__1 = nincx;
+    i__2 = *incx;
+    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	dtemp += (d__1 = dx[i__], abs(d__1));
+/* L10: */
+    }
+    ret_val = dtemp;
+    return ret_val;
+
+/*        code for increment equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 6;
+    if (m == 0) {
+	goto L40;
+    }
+    i__2 = m;
+    for (i__ = 1; i__ <= i__2; ++i__) {
+	dtemp += (d__1 = dx[i__], abs(d__1));
+/* L30: */
+    }
+    if (*n < 6) {
+	goto L60;
+    }
+L40:
+    mp1 = m + 1;
+    i__2 = *n;
+    for (i__ = mp1; i__ <= i__2; i__ += 6) {
+	dtemp = dtemp + (d__1 = dx[i__], abs(d__1)) + (d__2 = dx[i__ + 1], 
+		abs(d__2)) + (d__3 = dx[i__ + 2], abs(d__3)) + (d__4 = dx[i__ 
+		+ 3], abs(d__4)) + (d__5 = dx[i__ + 4], abs(d__5)) + (d__6 = 
+		dx[i__ + 5], abs(d__6));
+/* L50: */
+    }
+L60:
+    ret_val = dtemp;
+    return ret_val;
+} /* dasum_ */

min-dgels/base/BLAS/SRC/daxpy.c

@@ -0,0 +1,107 @@
+/* daxpy.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int daxpy_(integer *n, doublereal *da, doublereal *dx, 
+	integer *incx, doublereal *dy, integer *incy)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer i__, m, ix, iy, mp1;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     constant times a vector plus a vector. */
+/*     uses unrolled loops for increments equal to one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dy;
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0) {
+	return 0;
+    }
+    if (*da == 0.) {
+	return 0;
+    }
+    if (*incx == 1 && *incy == 1) {
+	goto L20;
+    }
+
+/*        code for unequal increments or equal increments */
+/*          not equal to 1 */
+
+    ix = 1;
+    iy = 1;
+    if (*incx < 0) {
+	ix = (-(*n) + 1) * *incx + 1;
+    }
+    if (*incy < 0) {
+	iy = (-(*n) + 1) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dy[iy] += *da * dx[ix];
+	ix += *incx;
+	iy += *incy;
+/* L10: */
+    }
+    return 0;
+
+/*        code for both increments equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 4;
+    if (m == 0) {
+	goto L40;
+    }
+    i__1 = m;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dy[i__] += *da * dx[i__];
+/* L30: */
+    }
+    if (*n < 4) {
+	return 0;
+    }
+L40:
+    mp1 = m + 1;
+    i__1 = *n;
+    for (i__ = mp1; i__ <= i__1; i__ += 4) {
+	dy[i__] += *da * dx[i__];
+	dy[i__ + 1] += *da * dx[i__ + 1];
+	dy[i__ + 2] += *da * dx[i__ + 2];
+	dy[i__ + 3] += *da * dx[i__ + 3];
+/* L50: */
+    }
+    return 0;
+} /* daxpy_ */

min-dgels/base/BLAS/SRC/dcabs1.c

@@ -0,0 +1,36 @@
+/* dcabs1.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dcabs1_(doublecomplex *z__)
+{
+    /* System generated locals */
+    doublereal ret_val, d__1, d__2;
+
+    /* Builtin functions */
+    double d_imag(doublecomplex *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. */
+/*  Purpose */
+/*  ======= */
+
+/*  DCABS1 computes absolute value of a double complex number */
+
+/*     .. Intrinsic Functions .. */
+
+    ret_val = (d__1 = z__->r, abs(d__1)) + (d__2 = d_imag(z__), abs(d__2));
+    return ret_val;
+} /* dcabs1_ */

min-dgels/base/BLAS/SRC/dcopy.c

@@ -0,0 +1,107 @@
+/* dcopy.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dcopy_(integer *n, doublereal *dx, integer *incx, 
+	doublereal *dy, integer *incy)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer i__, m, ix, iy, mp1;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     copies a vector, x, to a vector, y. */
+/*     uses unrolled loops for increments equal to one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dy;
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0) {
+	return 0;
+    }
+    if (*incx == 1 && *incy == 1) {
+	goto L20;
+    }
+
+/*        code for unequal increments or equal increments */
+/*          not equal to 1 */
+
+    ix = 1;
+    iy = 1;
+    if (*incx < 0) {
+	ix = (-(*n) + 1) * *incx + 1;
+    }
+    if (*incy < 0) {
+	iy = (-(*n) + 1) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dy[iy] = dx[ix];
+	ix += *incx;
+	iy += *incy;
+/* L10: */
+    }
+    return 0;
+
+/*        code for both increments equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 7;
+    if (m == 0) {
+	goto L40;
+    }
+    i__1 = m;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dy[i__] = dx[i__];
+/* L30: */
+    }
+    if (*n < 7) {
+	return 0;
+    }
+L40:
+    mp1 = m + 1;
+    i__1 = *n;
+    for (i__ = mp1; i__ <= i__1; i__ += 7) {
+	dy[i__] = dx[i__];
+	dy[i__ + 1] = dx[i__ + 1];
+	dy[i__ + 2] = dx[i__ + 2];
+	dy[i__ + 3] = dx[i__ + 3];
+	dy[i__ + 4] = dx[i__ + 4];
+	dy[i__ + 5] = dx[i__ + 5];
+	dy[i__ + 6] = dx[i__ + 6];
+/* L50: */
+    }
+    return 0;
+} /* dcopy_ */

min-dgels/base/BLAS/SRC/ddot.c

@@ -0,0 +1,110 @@
+/* ddot.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal ddot_(integer *n, doublereal *dx, integer *incx, doublereal *dy, 
+	integer *incy)
+{
+    /* System generated locals */
+    integer i__1;
+    doublereal ret_val;
+
+    /* Local variables */
+    integer i__, m, ix, iy, mp1;
+    doublereal dtemp;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     forms the dot product of two vectors. */
+/*     uses unrolled loops for increments equal to one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dy;
+    --dx;
+
+    /* Function Body */
+    ret_val = 0.;
+    dtemp = 0.;
+    if (*n <= 0) {
+	return ret_val;
+    }
+    if (*incx == 1 && *incy == 1) {
+	goto L20;
+    }
+
+/*        code for unequal increments or equal increments */
+/*          not equal to 1 */
+
+    ix = 1;
+    iy = 1;
+    if (*incx < 0) {
+	ix = (-(*n) + 1) * *incx + 1;
+    }
+    if (*incy < 0) {
+	iy = (-(*n) + 1) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dtemp += dx[ix] * dy[iy];
+	ix += *incx;
+	iy += *incy;
+/* L10: */
+    }
+    ret_val = dtemp;
+    return ret_val;
+
+/*        code for both increments equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 5;
+    if (m == 0) {
+	goto L40;
+    }
+    i__1 = m;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dtemp += dx[i__] * dy[i__];
+/* L30: */
+    }
+    if (*n < 5) {
+	goto L60;
+    }
+L40:
+    mp1 = m + 1;
+    i__1 = *n;
+    for (i__ = mp1; i__ <= i__1; i__ += 5) {
+	dtemp = dtemp + dx[i__] * dy[i__] + dx[i__ + 1] * dy[i__ + 1] + dx[
+		i__ + 2] * dy[i__ + 2] + dx[i__ + 3] * dy[i__ + 3] + dx[i__ + 
+		4] * dy[i__ + 4];
+/* L50: */
+    }
+L60:
+    ret_val = dtemp;
+    return ret_val;
+} /* ddot_ */

min-dgels/base/BLAS/SRC/dgbmv.c

@@ -0,0 +1,369 @@
+/* dgbmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgbmv_(char *trans, integer *m, integer *n, integer *kl, 
+	integer *ku, doublereal *alpha, doublereal *a, integer *lda, 
+	doublereal *x, integer *incx, doublereal *beta, doublereal *y, 
+	integer *incy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4, i__5, i__6;
+
+    /* Local variables */
+    integer i__, j, k, ix, iy, jx, jy, kx, ky, kup1, info;
+    doublereal temp;
+    integer lenx, leny;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGBMV  performs one of the matrix-vector operations */
+
+/*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y, */
+
+/*  where alpha and beta are scalars, x and y are vectors and A is an */
+/*  m by n band matrix, with kl sub-diagonals and ku super-diagonals. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y. */
+
+/*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y. */
+
+/*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of the matrix A. */
+/*           M must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  KL     - INTEGER. */
+/*           On entry, KL specifies the number of sub-diagonals of the */
+/*           matrix A. KL must satisfy  0 .le. KL. */
+/*           Unchanged on exit. */
+
+/*  KU     - INTEGER. */
+/*           On entry, KU specifies the number of super-diagonals of the */
+/*           matrix A. KU must satisfy  0 .le. KU. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry, the leading ( kl + ku + 1 ) by n part of the */
+/*           array A must contain the matrix of coefficients, supplied */
+/*           column by column, with the leading diagonal of the matrix in */
+/*           row ( ku + 1 ) of the array, the first super-diagonal */
+/*           starting at position 2 in row ku, the first sub-diagonal */
+/*           starting at position 1 in row ( ku + 2 ), and so on. */
+/*           Elements in the array A that do not correspond to elements */
+/*           in the band matrix (such as the top left ku by ku triangle) */
+/*           are not referenced. */
+/*           The following program segment will transfer a band matrix */
+/*           from conventional full matrix storage to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    K = KU + 1 - J */
+/*                    DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL ) */
+/*                       A( K + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           ( kl + ku + 1 ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/*           and at least */
+/*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/*           Before entry, the incremented array X must contain the */
+/*           vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. When BETA is */
+/*           supplied as zero then Y need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/*           and at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/*           Before entry, the incremented array Y must contain the */
+/*           vector y. On exit, Y is overwritten by the updated vector y. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+    --y;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+	    ) {
+	info = 1;
+    } else if (*m < 0) {
+	info = 2;
+    } else if (*n < 0) {
+	info = 3;
+    } else if (*kl < 0) {
+	info = 4;
+    } else if (*ku < 0) {
+	info = 5;
+    } else if (*lda < *kl + *ku + 1) {
+	info = 8;
+    } else if (*incx == 0) {
+	info = 10;
+    } else if (*incy == 0) {
+	info = 13;
+    }
+    if (info != 0) {
+	xerbla_("DGBMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set */
+/*     up the start points in  X  and  Y. */
+
+    if (lsame_(trans, "N")) {
+	lenx = *n;
+	leny = *m;
+    } else {
+	lenx = *m;
+	leny = *n;
+    }
+    if (*incx > 0) {
+	kx = 1;
+    } else {
+	kx = 1 - (lenx - 1) * *incx;
+    }
+    if (*incy > 0) {
+	ky = 1;
+    } else {
+	ky = 1 - (leny - 1) * *incy;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through the band part of A. */
+
+/*     First form  y := beta*y. */
+
+    if (*beta != 1.) {
+	if (*incy == 1) {
+	    if (*beta == 0.) {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = 0.;
+/* L10: */
+		}
+	    } else {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = *beta * y[i__];
+/* L20: */
+		}
+	    }
+	} else {
+	    iy = ky;
+	    if (*beta == 0.) {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = 0.;
+		    iy += *incy;
+/* L30: */
+		}
+	    } else {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = *beta * y[iy];
+		    iy += *incy;
+/* L40: */
+		}
+	    }
+	}
+    }
+    if (*alpha == 0.) {
+	return 0;
+    }
+    kup1 = *ku + 1;
+    if (lsame_(trans, "N")) {
+
+/*        Form  y := alpha*A*x + y. */
+
+	jx = kx;
+	if (*incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    k = kup1 - j;
+/* Computing MAX */
+		    i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+		    i__5 = *m, i__6 = j + *kl;
+		    i__4 = min(i__5,i__6);
+		    for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+			y[i__] += temp * a[k + i__ + j * a_dim1];
+/* L50: */
+		    }
+		}
+		jx += *incx;
+/* L60: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    iy = ky;
+		    k = kup1 - j;
+/* Computing MAX */
+		    i__4 = 1, i__2 = j - *ku;
+/* Computing MIN */
+		    i__5 = *m, i__6 = j + *kl;
+		    i__3 = min(i__5,i__6);
+		    for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+			y[iy] += temp * a[k + i__ + j * a_dim1];
+			iy += *incy;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+		if (j > *ku) {
+		    ky += *incy;
+		}
+/* L80: */
+	    }
+	}
+    } else {
+
+/*        Form  y := alpha*A'*x + y. */
+
+	jy = ky;
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp = 0.;
+		k = kup1 - j;
+/* Computing MAX */
+		i__3 = 1, i__4 = j - *ku;
+/* Computing MIN */
+		i__5 = *m, i__6 = j + *kl;
+		i__2 = min(i__5,i__6);
+		for (i__ = max(i__3,i__4); i__ <= i__2; ++i__) {
+		    temp += a[k + i__ + j * a_dim1] * x[i__];
+/* L90: */
+		}
+		y[jy] += *alpha * temp;
+		jy += *incy;
+/* L100: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp = 0.;
+		ix = kx;
+		k = kup1 - j;
+/* Computing MAX */
+		i__2 = 1, i__3 = j - *ku;
+/* Computing MIN */
+		i__5 = *m, i__6 = j + *kl;
+		i__4 = min(i__5,i__6);
+		for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+		    temp += a[k + i__ + j * a_dim1] * x[ix];
+		    ix += *incx;
+/* L110: */
+		}
+		y[jy] += *alpha * temp;
+		jy += *incy;
+		if (j > *ku) {
+		    kx += *incx;
+		}
+/* L120: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DGBMV . */
+
+} /* dgbmv_ */

min-dgels/base/BLAS/SRC/dgemm.c

@@ -0,0 +1,389 @@
+/* dgemm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgemm_(char *transa, char *transb, integer *m, integer *
+	n, integer *k, doublereal *alpha, doublereal *a, integer *lda, 
+	doublereal *b, integer *ldb, doublereal *beta, doublereal *c__, 
+	integer *ldc)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
+	    i__3;
+
+    /* Local variables */
+    integer i__, j, l, info;
+    logical nota, notb;
+    doublereal temp;
+    integer ncola;
+    extern logical lsame_(char *, char *);
+    integer nrowa, nrowb;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGEMM  performs one of the matrix-matrix operations */
+
+/*     C := alpha*op( A )*op( B ) + beta*C, */
+
+/*  where  op( X ) is one of */
+
+/*     op( X ) = X   or   op( X ) = X', */
+
+/*  alpha and beta are scalars, and A, B and C are matrices, with op( A ) */
+/*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  TRANSA - CHARACTER*1. */
+/*           On entry, TRANSA specifies the form of op( A ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSA = 'N' or 'n',  op( A ) = A. */
+
+/*              TRANSA = 'T' or 't',  op( A ) = A'. */
+
+/*              TRANSA = 'C' or 'c',  op( A ) = A'. */
+
+/*           Unchanged on exit. */
+
+/*  TRANSB - CHARACTER*1. */
+/*           On entry, TRANSB specifies the form of op( B ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSB = 'N' or 'n',  op( B ) = B. */
+
+/*              TRANSB = 'T' or 't',  op( B ) = B'. */
+
+/*              TRANSB = 'C' or 'c',  op( B ) = B'. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry,  M  specifies  the number  of rows  of the  matrix */
+/*           op( A )  and of the  matrix  C.  M  must  be at least  zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry,  N  specifies the number  of columns of the matrix */
+/*           op( B ) and the number of columns of the matrix C. N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry,  K  specifies  the number of columns of the matrix */
+/*           op( A ) and the number of rows of the matrix op( B ). K must */
+/*           be at least  zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise. */
+/*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k */
+/*           part of the array  A  must contain the matrix  A,  otherwise */
+/*           the leading  k by m  part of the array  A  must contain  the */
+/*           matrix A. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then */
+/*           LDA must be at least  max( 1, m ), otherwise  LDA must be at */
+/*           least  max( 1, k ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
+/*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise. */
+/*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n */
+/*           part of the array  B  must contain the matrix  B,  otherwise */
+/*           the leading  n by k  part of the array  B  must contain  the */
+/*           matrix B. */
+/*           Unchanged on exit. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then */
+/*           LDB must be at least  max( 1, k ), otherwise  LDB must be at */
+/*           least  max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is */
+/*           supplied as zero then C need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/*           Before entry, the leading  m by n  part of the array  C must */
+/*           contain the matrix  C,  except when  beta  is zero, in which */
+/*           case C need not be set on entry. */
+/*           On exit, the array  C  is overwritten by the  m by n  matrix */
+/*           ( alpha*op( A )*op( B ) + beta*C ). */
+
+/*  LDC    - INTEGER. */
+/*           On entry, LDC specifies the first dimension of C as declared */
+/*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not */
+/*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows */
+/*     and  columns of  A  and the  number of  rows  of  B  respectively. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+
+    /* Function Body */
+    nota = lsame_(transa, "N");
+    notb = lsame_(transb, "N");
+    if (nota) {
+	nrowa = *m;
+	ncola = *k;
+    } else {
+	nrowa = *k;
+	ncola = *m;
+    }
+    if (notb) {
+	nrowb = *k;
+    } else {
+	nrowb = *n;
+    }
+
+/*     Test the input parameters. */
+
+    info = 0;
+    if (! nota && ! lsame_(transa, "C") && ! lsame_(
+	    transa, "T")) {
+	info = 1;
+    } else if (! notb && ! lsame_(transb, "C") && ! 
+	    lsame_(transb, "T")) {
+	info = 2;
+    } else if (*m < 0) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*k < 0) {
+	info = 5;
+    } else if (*lda < max(1,nrowa)) {
+	info = 8;
+    } else if (*ldb < max(1,nrowb)) {
+	info = 10;
+    } else if (*ldc < max(1,*m)) {
+	info = 13;
+    }
+    if (info != 0) {
+	xerbla_("DGEMM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+	return 0;
+    }
+
+/*     And if  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	if (*beta == 0.) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+		}
+/* L20: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+		}
+/* L40: */
+	    }
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (notb) {
+	if (nota) {
+
+/*           Form  C := alpha*A*B + beta*C. */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L60: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (b[l + j * b_dim1] != 0.) {
+			temp = *alpha * b[l + j * b_dim1];
+			i__3 = *m;
+			for (i__ = 1; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
+				    a_dim1];
+/* L70: */
+			}
+		    }
+/* L80: */
+		}
+/* L90: */
+	    }
+	} else {
+
+/*           Form  C := alpha*A'*B + beta*C */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+/* L100: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp;
+		    } else {
+			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+				i__ + j * c_dim1];
+		    }
+/* L110: */
+		}
+/* L120: */
+	    }
+	}
+    } else {
+	if (nota) {
+
+/*           Form  C := alpha*A*B' + beta*C */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L130: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L140: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (b[j + l * b_dim1] != 0.) {
+			temp = *alpha * b[j + l * b_dim1];
+			i__3 = *m;
+			for (i__ = 1; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
+				    a_dim1];
+/* L150: */
+			}
+		    }
+/* L160: */
+		}
+/* L170: */
+	    }
+	} else {
+
+/*           Form  C := alpha*A'*B' + beta*C */
+
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp += a[l + i__ * a_dim1] * b[j + l * b_dim1];
+/* L180: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp;
+		    } else {
+			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+				i__ + j * c_dim1];
+		    }
+/* L190: */
+		}
+/* L200: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DGEMM . */
+
+} /* dgemm_ */

min-dgels/base/BLAS/SRC/dgemv.c

@@ -0,0 +1,312 @@
+/* dgemv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dgemv_(char *trans, integer *m, integer *n, doublereal *
+	alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, 
+	doublereal *beta, doublereal *y, integer *incy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp;
+    integer lenx, leny;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGEMV  performs one of the matrix-vector operations */
+
+/*     y := alpha*A*x + beta*y,   or   y := alpha*A'*x + beta*y, */
+
+/*  where alpha and beta are scalars, x and y are vectors and A is an */
+/*  m by n matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y. */
+
+/*              TRANS = 'T' or 't'   y := alpha*A'*x + beta*y. */
+
+/*              TRANS = 'C' or 'c'   y := alpha*A'*x + beta*y. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of the matrix A. */
+/*           M must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry, the leading m by n part of the array A must */
+/*           contain the matrix of coefficients. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n' */
+/*           and at least */
+/*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise. */
+/*           Before entry, the incremented array X must contain the */
+/*           vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. When BETA is */
+/*           supplied as zero then Y need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n' */
+/*           and at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise. */
+/*           Before entry with BETA non-zero, the incremented array Y */
+/*           must contain the vector y. On exit, Y is overwritten by the */
+/*           updated vector y. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+    --y;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(trans, "N") && ! lsame_(trans, "T") && ! lsame_(trans, "C")
+	    ) {
+	info = 1;
+    } else if (*m < 0) {
+	info = 2;
+    } else if (*n < 0) {
+	info = 3;
+    } else if (*lda < max(1,*m)) {
+	info = 6;
+    } else if (*incx == 0) {
+	info = 8;
+    } else if (*incy == 0) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DGEMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set */
+/*     up the start points in  X  and  Y. */
+
+    if (lsame_(trans, "N")) {
+	lenx = *n;
+	leny = *m;
+    } else {
+	lenx = *m;
+	leny = *n;
+    }
+    if (*incx > 0) {
+	kx = 1;
+    } else {
+	kx = 1 - (lenx - 1) * *incx;
+    }
+    if (*incy > 0) {
+	ky = 1;
+    } else {
+	ky = 1 - (leny - 1) * *incy;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+/*     First form  y := beta*y. */
+
+    if (*beta != 1.) {
+	if (*incy == 1) {
+	    if (*beta == 0.) {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = 0.;
+/* L10: */
+		}
+	    } else {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = *beta * y[i__];
+/* L20: */
+		}
+	    }
+	} else {
+	    iy = ky;
+	    if (*beta == 0.) {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = 0.;
+		    iy += *incy;
+/* L30: */
+		}
+	    } else {
+		i__1 = leny;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = *beta * y[iy];
+		    iy += *incy;
+/* L40: */
+		}
+	    }
+	}
+    }
+    if (*alpha == 0.) {
+	return 0;
+    }
+    if (lsame_(trans, "N")) {
+
+/*        Form  y := alpha*A*x + y. */
+
+	jx = kx;
+	if (*incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			y[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+		    }
+		}
+		jx += *incx;
+/* L60: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    iy = ky;
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			y[iy] += temp * a[i__ + j * a_dim1];
+			iy += *incy;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+/* L80: */
+	    }
+	}
+    } else {
+
+/*        Form  y := alpha*A'*x + y. */
+
+	jy = ky;
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp = 0.;
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+		}
+		y[jy] += *alpha * temp;
+		jy += *incy;
+/* L100: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp = 0.;
+		ix = kx;
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp += a[i__ + j * a_dim1] * x[ix];
+		    ix += *incx;
+/* L110: */
+		}
+		y[jy] += *alpha * temp;
+		jy += *incy;
+/* L120: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DGEMV . */
+
+} /* dgemv_ */

min-dgels/base/BLAS/SRC/dger.c

@@ -0,0 +1,194 @@
+/* dger.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dger_(integer *m, integer *n, doublereal *alpha, 
+	doublereal *x, integer *incx, doublereal *y, integer *incy, 
+	doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, jy, kx, info;
+    doublereal temp;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DGER   performs the rank 1 operation */
+
+/*     A := alpha*x*y' + A, */
+
+/*  where alpha is a scalar, x is an m element vector, y is an n element */
+/*  vector and A is an m by n matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of the matrix A. */
+/*           M must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( m - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the m */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the n */
+/*           element vector y. */
+/*           Unchanged on exit. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry, the leading m by n part of the array A must */
+/*           contain the matrix of coefficients. On exit, A is */
+/*           overwritten by the updated matrix. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --x;
+    --y;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    info = 0;
+    if (*m < 0) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 5;
+    } else if (*incy == 0) {
+	info = 7;
+    } else if (*lda < max(1,*m)) {
+	info = 9;
+    }
+    if (info != 0) {
+	xerbla_("DGER  ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || *alpha == 0.) {
+	return 0;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+    if (*incy > 0) {
+	jy = 1;
+    } else {
+	jy = 1 - (*n - 1) * *incy;
+    }
+    if (*incx == 1) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    if (y[jy] != 0.) {
+		temp = *alpha * y[jy];
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+		}
+	    }
+	    jy += *incy;
+/* L20: */
+	}
+    } else {
+	if (*incx > 0) {
+	    kx = 1;
+	} else {
+	    kx = 1 - (*m - 1) * *incx;
+	}
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    if (y[jy] != 0.) {
+		temp = *alpha * y[jy];
+		ix = kx;
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    a[i__ + j * a_dim1] += x[ix] * temp;
+		    ix += *incx;
+/* L30: */
+		}
+	    }
+	    jy += *incy;
+/* L40: */
+	}
+    }
+
+    return 0;
+
+/*     End of DGER  . */
+
+} /* dger_ */

min-dgels/base/BLAS/SRC/dnrm2.c

@@ -0,0 +1,95 @@
+/* dnrm2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dnrm2_(integer *n, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal ret_val, d__1;
+
+    /* Builtin functions */
+    double sqrt(doublereal);
+
+    /* Local variables */
+    integer ix;
+    doublereal ssq, norm, scale, absxi;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DNRM2 returns the euclidean norm of a vector via the function */
+/*  name, so that */
+
+/*     DNRM2 := sqrt( x'*x ) */
+
+
+/*  -- This version written on 25-October-1982. */
+/*     Modified on 14-October-1993 to inline the call to DLASSQ. */
+/*     Sven Hammarling, Nag Ltd. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n < 1 || *incx < 1) {
+	norm = 0.;
+    } else if (*n == 1) {
+	norm = abs(x[1]);
+    } else {
+	scale = 0.;
+	ssq = 1.;
+/*        The following loop is equivalent to this call to the LAPACK */
+/*        auxiliary routine: */
+/*        CALL DLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+	i__1 = (*n - 1) * *incx + 1;
+	i__2 = *incx;
+	for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+	    if (x[ix] != 0.) {
+		absxi = (d__1 = x[ix], abs(d__1));
+		if (scale < absxi) {
+/* Computing 2nd power */
+		    d__1 = scale / absxi;
+		    ssq = ssq * (d__1 * d__1) + 1.;
+		    scale = absxi;
+		} else {
+/* Computing 2nd power */
+		    d__1 = absxi / scale;
+		    ssq += d__1 * d__1;
+		}
+	    }
+/* L10: */
+	}
+	norm = scale * sqrt(ssq);
+    }
+
+    ret_val = norm;
+    return ret_val;
+
+/*     End of DNRM2. */
+
+} /* dnrm2_ */

min-dgels/base/BLAS/SRC/drot.c

@@ -0,0 +1,86 @@
+/* drot.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drot_(integer *n, doublereal *dx, integer *incx, 
+	doublereal *dy, integer *incy, doublereal *c__, doublereal *s)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer i__, ix, iy;
+    doublereal dtemp;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     applies a plane rotation. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dy;
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0) {
+	return 0;
+    }
+    if (*incx == 1 && *incy == 1) {
+	goto L20;
+    }
+
+/*       code for unequal increments or equal increments not equal */
+/*         to 1 */
+
+    ix = 1;
+    iy = 1;
+    if (*incx < 0) {
+	ix = (-(*n) + 1) * *incx + 1;
+    }
+    if (*incy < 0) {
+	iy = (-(*n) + 1) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dtemp = *c__ * dx[ix] + *s * dy[iy];
+	dy[iy] = *c__ * dy[iy] - *s * dx[ix];
+	dx[ix] = dtemp;
+	ix += *incx;
+	iy += *incy;
+/* L10: */
+    }
+    return 0;
+
+/*       code for both increments equal to 1 */
+
+L20:
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dtemp = *c__ * dx[i__] + *s * dy[i__];
+	dy[i__] = *c__ * dy[i__] - *s * dx[i__];
+	dx[i__] = dtemp;
+/* L30: */
+    }
+    return 0;
+} /* drot_ */

min-dgels/base/BLAS/SRC/drotg.c

@@ -0,0 +1,79 @@
+/* drotg.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Table of constant values */
+
+static doublereal c_b4 = 1.;
+
+/* Subroutine */ int drotg_(doublereal *da, doublereal *db, doublereal *c__, 
+	doublereal *s)
+{
+    /* System generated locals */
+    doublereal d__1, d__2;
+
+    /* Builtin functions */
+    double sqrt(doublereal), d_sign(doublereal *, doublereal *);
+
+    /* Local variables */
+    doublereal r__, z__, roe, scale;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     construct givens plane rotation. */
+/*     jack dongarra, linpack, 3/11/78. */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    roe = *db;
+    if (abs(*da) > abs(*db)) {
+	roe = *da;
+    }
+    scale = abs(*da) + abs(*db);
+    if (scale != 0.) {
+	goto L10;
+    }
+    *c__ = 1.;
+    *s = 0.;
+    r__ = 0.;
+    z__ = 0.;
+    goto L20;
+L10:
+/* Computing 2nd power */
+    d__1 = *da / scale;
+/* Computing 2nd power */
+    d__2 = *db / scale;
+    r__ = scale * sqrt(d__1 * d__1 + d__2 * d__2);
+    r__ = d_sign(&c_b4, &roe) * r__;
+    *c__ = *da / r__;
+    *s = *db / r__;
+    z__ = 1.;
+    if (abs(*da) > abs(*db)) {
+	z__ = *s;
+    }
+    if (abs(*db) >= abs(*da) && *c__ != 0.) {
+	z__ = 1. / *c__;
+    }
+L20:
+    *da = r__;
+    *db = z__;
+    return 0;
+} /* drotg_ */

min-dgels/base/BLAS/SRC/drotm.c

@@ -0,0 +1,215 @@
+/* drotm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drotm_(integer *n, doublereal *dx, integer *incx, 
+	doublereal *dy, integer *incy, doublereal *dparam)
+{
+    /* Initialized data */
+
+    static doublereal zero = 0.;
+    static doublereal two = 2.;
+
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__;
+    doublereal w, z__;
+    integer kx, ky;
+    doublereal dh11, dh12, dh21, dh22, dflag;
+    integer nsteps;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX */
+
+/*     (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN */
+/*     (DY**T) */
+
+/*     DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE */
+/*     LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY. */
+/*     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
+
+/*     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0 */
+
+/*       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0) */
+/*     H=(          )    (          )    (          )    (          ) */
+/*       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0). */
+/*     SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  N      (input) INTEGER */
+/*         number of elements in input vector(s) */
+
+/*  DX     (input/output) DOUBLE PRECISION array, dimension N */
+/*         double precision vector with N elements */
+
+/*  INCX   (input) INTEGER */
+/*         storage spacing between elements of DX */
+
+/*  DY     (input/output) DOUBLE PRECISION array, dimension N */
+/*         double precision vector with N elements */
+
+/*  INCY   (input) INTEGER */
+/*         storage spacing between elements of DY */
+
+/*  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5 */
+/*     DPARAM(1)=DFLAG */
+/*     DPARAM(2)=DH11 */
+/*     DPARAM(3)=DH21 */
+/*     DPARAM(4)=DH12 */
+/*     DPARAM(5)=DH22 */
+
+/*  ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Data statements .. */
+    /* Parameter adjustments */
+    --dparam;
+    --dy;
+    --dx;
+
+    /* Function Body */
+/*     .. */
+
+    dflag = dparam[1];
+    if (*n <= 0 || dflag + two == zero) {
+	goto L140;
+    }
+    if (! (*incx == *incy && *incx > 0)) {
+	goto L70;
+    }
+
+    nsteps = *n * *incx;
+    if (dflag < 0.) {
+	goto L50;
+    } else if (dflag == 0) {
+	goto L10;
+    } else {
+	goto L30;
+    }
+L10:
+    dh12 = dparam[4];
+    dh21 = dparam[3];
+    i__1 = nsteps;
+    i__2 = *incx;
+    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	w = dx[i__];
+	z__ = dy[i__];
+	dx[i__] = w + z__ * dh12;
+	dy[i__] = w * dh21 + z__;
+/* L20: */
+    }
+    goto L140;
+L30:
+    dh11 = dparam[2];
+    dh22 = dparam[5];
+    i__2 = nsteps;
+    i__1 = *incx;
+    for (i__ = 1; i__1 < 0 ? i__ >= i__2 : i__ <= i__2; i__ += i__1) {
+	w = dx[i__];
+	z__ = dy[i__];
+	dx[i__] = w * dh11 + z__;
+	dy[i__] = -w + dh22 * z__;
+/* L40: */
+    }
+    goto L140;
+L50:
+    dh11 = dparam[2];
+    dh12 = dparam[4];
+    dh21 = dparam[3];
+    dh22 = dparam[5];
+    i__1 = nsteps;
+    i__2 = *incx;
+    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	w = dx[i__];
+	z__ = dy[i__];
+	dx[i__] = w * dh11 + z__ * dh12;
+	dy[i__] = w * dh21 + z__ * dh22;
+/* L60: */
+    }
+    goto L140;
+L70:
+    kx = 1;
+    ky = 1;
+    if (*incx < 0) {
+	kx = (1 - *n) * *incx + 1;
+    }
+    if (*incy < 0) {
+	ky = (1 - *n) * *incy + 1;
+    }
+
+    if (dflag < 0.) {
+	goto L120;
+    } else if (dflag == 0) {
+	goto L80;
+    } else {
+	goto L100;
+    }
+L80:
+    dh12 = dparam[4];
+    dh21 = dparam[3];
+    i__2 = *n;
+    for (i__ = 1; i__ <= i__2; ++i__) {
+	w = dx[kx];
+	z__ = dy[ky];
+	dx[kx] = w + z__ * dh12;
+	dy[ky] = w * dh21 + z__;
+	kx += *incx;
+	ky += *incy;
+/* L90: */
+    }
+    goto L140;
+L100:
+    dh11 = dparam[2];
+    dh22 = dparam[5];
+    i__2 = *n;
+    for (i__ = 1; i__ <= i__2; ++i__) {
+	w = dx[kx];
+	z__ = dy[ky];
+	dx[kx] = w * dh11 + z__;
+	dy[ky] = -w + dh22 * z__;
+	kx += *incx;
+	ky += *incy;
+/* L110: */
+    }
+    goto L140;
+L120:
+    dh11 = dparam[2];
+    dh12 = dparam[4];
+    dh21 = dparam[3];
+    dh22 = dparam[5];
+    i__2 = *n;
+    for (i__ = 1; i__ <= i__2; ++i__) {
+	w = dx[kx];
+	z__ = dy[ky];
+	dx[kx] = w * dh11 + z__ * dh12;
+	dy[ky] = w * dh21 + z__ * dh22;
+	kx += *incx;
+	ky += *incy;
+/* L130: */
+    }
+L140:
+    return 0;
+} /* drotm_ */

min-dgels/base/BLAS/SRC/drotmg.c

@@ -0,0 +1,293 @@
+/* drotmg.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int drotmg_(doublereal *dd1, doublereal *dd2, doublereal *
+	dx1, doublereal *dy1, doublereal *dparam)
+{
+    /* Initialized data */
+
+    static doublereal zero = 0.;
+    static doublereal one = 1.;
+    static doublereal two = 2.;
+    static doublereal gam = 4096.;
+    static doublereal gamsq = 16777216.;
+    static doublereal rgamsq = 5.9604645e-8;
+
+    /* Format strings */
+    static char fmt_120[] = "";
+    static char fmt_150[] = "";
+    static char fmt_180[] = "";
+    static char fmt_210[] = "";
+
+    /* System generated locals */
+    doublereal d__1;
+
+    /* Local variables */
+    doublereal du, dp1, dp2, dq1, dq2, dh11, dh12, dh21, dh22;
+    integer igo;
+    doublereal dflag, dtemp;
+
+    /* Assigned format variables */
+    static char *igo_fmt;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS */
+/*     THE SECOND COMPONENT OF THE 2-VECTOR  (DSQRT(DD1)*DX1,DSQRT(DD2)* */
+/*     DY2)**T. */
+/*     WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS.. */
+
+/*     DFLAG=-1.D0     DFLAG=0.D0        DFLAG=1.D0     DFLAG=-2.D0 */
+
+/*       (DH11  DH12)    (1.D0  DH12)    (DH11  1.D0)    (1.D0  0.D0) */
+/*     H=(          )    (          )    (          )    (          ) */
+/*       (DH21  DH22),   (DH21  1.D0),   (-1.D0 DH22),   (0.D0  1.D0). */
+/*     LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22 */
+/*     RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE */
+/*     VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.) */
+
+/*     THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE */
+/*     INEXACT.  THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE */
+/*     OF DD1 AND DD2.  ALL ACTUAL SCALING OF DATA IS DONE USING GAM. */
+
+
+/*  Arguments */
+/*  ========= */
+
+/*  DD1    (input/output) DOUBLE PRECISION */
+
+/*  DD2    (input/output) DOUBLE PRECISION */
+
+/*  DX1    (input/output) DOUBLE PRECISION */
+
+/*  DY1    (input) DOUBLE PRECISION */
+
+/*  DPARAM (input/output)  DOUBLE PRECISION array, dimension 5 */
+/*     DPARAM(1)=DFLAG */
+/*     DPARAM(2)=DH11 */
+/*     DPARAM(3)=DH21 */
+/*     DPARAM(4)=DH12 */
+/*     DPARAM(5)=DH22 */
+
+/*  ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Data statements .. */
+
+    /* Parameter adjustments */
+    --dparam;
+
+    /* Function Body */
+/*     .. */
+    if (! (*dd1 < zero)) {
+	goto L10;
+    }
+/*       GO ZERO-H-D-AND-DX1.. */
+    goto L60;
+L10:
+/*     CASE-DD1-NONNEGATIVE */
+    dp2 = *dd2 * *dy1;
+    if (! (dp2 == zero)) {
+	goto L20;
+    }
+    dflag = -two;
+    goto L260;
+/*     REGULAR-CASE.. */
+L20:
+    dp1 = *dd1 * *dx1;
+    dq2 = dp2 * *dy1;
+    dq1 = dp1 * *dx1;
+
+    if (! (abs(dq1) > abs(dq2))) {
+	goto L40;
+    }
+    dh21 = -(*dy1) / *dx1;
+    dh12 = dp2 / dp1;
+
+    du = one - dh12 * dh21;
+
+    if (! (du <= zero)) {
+	goto L30;
+    }
+/*         GO ZERO-H-D-AND-DX1.. */
+    goto L60;
+L30:
+    dflag = zero;
+    *dd1 /= du;
+    *dd2 /= du;
+    *dx1 *= du;
+/*         GO SCALE-CHECK.. */
+    goto L100;
+L40:
+    if (! (dq2 < zero)) {
+	goto L50;
+    }
+/*         GO ZERO-H-D-AND-DX1.. */
+    goto L60;
+L50:
+    dflag = one;
+    dh11 = dp1 / dp2;
+    dh22 = *dx1 / *dy1;
+    du = one + dh11 * dh22;
+    dtemp = *dd2 / du;
+    *dd2 = *dd1 / du;
+    *dd1 = dtemp;
+    *dx1 = *dy1 * du;
+/*         GO SCALE-CHECK */
+    goto L100;
+/*     PROCEDURE..ZERO-H-D-AND-DX1.. */
+L60:
+    dflag = -one;
+    dh11 = zero;
+    dh12 = zero;
+    dh21 = zero;
+    dh22 = zero;
+
+    *dd1 = zero;
+    *dd2 = zero;
+    *dx1 = zero;
+/*         RETURN.. */
+    goto L220;
+/*     PROCEDURE..FIX-H.. */
+L70:
+    if (! (dflag >= zero)) {
+	goto L90;
+    }
+
+    if (! (dflag == zero)) {
+	goto L80;
+    }
+    dh11 = one;
+    dh22 = one;
+    dflag = -one;
+    goto L90;
+L80:
+    dh21 = -one;
+    dh12 = one;
+    dflag = -one;
+L90:
+    switch (igo) {
+	case 0: goto L120;
+	case 1: goto L150;
+	case 2: goto L180;
+	case 3: goto L210;
+    }
+/*     PROCEDURE..SCALE-CHECK */
+L100:
+L110:
+    if (! (*dd1 <= rgamsq)) {
+	goto L130;
+    }
+    if (*dd1 == zero) {
+	goto L160;
+    }
+    igo = 0;
+    igo_fmt = fmt_120;
+/*              FIX-H.. */
+    goto L70;
+L120:
+/* Computing 2nd power */
+    d__1 = gam;
+    *dd1 *= d__1 * d__1;
+    *dx1 /= gam;
+    dh11 /= gam;
+    dh12 /= gam;
+    goto L110;
+L130:
+L140:
+    if (! (*dd1 >= gamsq)) {
+	goto L160;
+    }
+    igo = 1;
+    igo_fmt = fmt_150;
+/*              FIX-H.. */
+    goto L70;
+L150:
+/* Computing 2nd power */
+    d__1 = gam;
+    *dd1 /= d__1 * d__1;
+    *dx1 *= gam;
+    dh11 *= gam;
+    dh12 *= gam;
+    goto L140;
+L160:
+L170:
+    if (! (abs(*dd2) <= rgamsq)) {
+	goto L190;
+    }
+    if (*dd2 == zero) {
+	goto L220;
+    }
+    igo = 2;
+    igo_fmt = fmt_180;
+/*              FIX-H.. */
+    goto L70;
+L180:
+/* Computing 2nd power */
+    d__1 = gam;
+    *dd2 *= d__1 * d__1;
+    dh21 /= gam;
+    dh22 /= gam;
+    goto L170;
+L190:
+L200:
+    if (! (abs(*dd2) >= gamsq)) {
+	goto L220;
+    }
+    igo = 3;
+    igo_fmt = fmt_210;
+/*              FIX-H.. */
+    goto L70;
+L210:
+/* Computing 2nd power */
+    d__1 = gam;
+    *dd2 /= d__1 * d__1;
+    dh21 *= gam;
+    dh22 *= gam;
+    goto L200;
+L220:
+    if (dflag < 0.) {
+	goto L250;
+    } else if (dflag == 0) {
+	goto L230;
+    } else {
+	goto L240;
+    }
+L230:
+    dparam[3] = dh21;
+    dparam[4] = dh12;
+    goto L260;
+L240:
+    dparam[2] = dh11;
+    dparam[5] = dh22;
+    goto L260;
+L250:
+    dparam[2] = dh11;
+    dparam[3] = dh21;
+    dparam[4] = dh12;
+    dparam[5] = dh22;
+L260:
+    dparam[1] = dflag;
+    return 0;
+} /* drotmg_ */

min-dgels/base/BLAS/SRC/dsbmv.c

@@ -0,0 +1,364 @@
+/* dsbmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsbmv_(char *uplo, integer *n, integer *k, doublereal *
+	alpha, doublereal *a, integer *lda, doublereal *x, integer *incx, 
+	doublereal *beta, doublereal *y, integer *incy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+    /* Local variables */
+    integer i__, j, l, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    integer kplus1;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSBMV  performs the matrix-vector  operation */
+
+/*     y := alpha*A*x + beta*y, */
+
+/*  where alpha and beta are scalars, x and y are n element vectors and */
+/*  A is an n by n symmetric band matrix, with k super-diagonals. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the band matrix A is being supplied as */
+/*           follows: */
+
+/*              UPLO = 'U' or 'u'   The upper triangular part of A is */
+/*                                  being supplied. */
+
+/*              UPLO = 'L' or 'l'   The lower triangular part of A is */
+/*                                  being supplied. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry, K specifies the number of super-diagonals of the */
+/*           matrix A. K must satisfy  0 .le. K. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/*           by n part of the array A must contain the upper triangular */
+/*           band part of the symmetric matrix, supplied column by */
+/*           column, with the leading diagonal of the matrix in row */
+/*           ( k + 1 ) of the array, the first super-diagonal starting at */
+/*           position 2 in row k, and so on. The top left k by k triangle */
+/*           of the array A is not referenced. */
+/*           The following program segment will transfer the upper */
+/*           triangular part of a symmetric band matrix from conventional */
+/*           full matrix storage to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    M = K + 1 - J */
+/*                    DO 10, I = MAX( 1, J - K ), J */
+/*                       A( M + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/*           by n part of the array A must contain the lower triangular */
+/*           band part of the symmetric matrix, supplied column by */
+/*           column, with the leading diagonal of the matrix in row 1 of */
+/*           the array, the first sub-diagonal starting at position 1 in */
+/*           row 2, and so on. The bottom right k by k triangle of the */
+/*           array A is not referenced. */
+/*           The following program segment will transfer the lower */
+/*           triangular part of a symmetric band matrix from conventional */
+/*           full matrix storage to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    M = 1 - J */
+/*                    DO 10, I = J, MIN( N, J + K ) */
+/*                       A( M + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           ( k + 1 ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the */
+/*           vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the */
+/*           vector y. On exit, Y is overwritten by the updated vector y. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+    --y;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*k < 0) {
+	info = 3;
+    } else if (*lda < *k + 1) {
+	info = 6;
+    } else if (*incx == 0) {
+	info = 8;
+    } else if (*incy == 0) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DSBMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     Set up the start points in  X  and  Y. */
+
+    if (*incx > 0) {
+	kx = 1;
+    } else {
+	kx = 1 - (*n - 1) * *incx;
+    }
+    if (*incy > 0) {
+	ky = 1;
+    } else {
+	ky = 1 - (*n - 1) * *incy;
+    }
+
+/*     Start the operations. In this version the elements of the array A */
+/*     are accessed sequentially with one pass through A. */
+
+/*     First form  y := beta*y. */
+
+    if (*beta != 1.) {
+	if (*incy == 1) {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = 0.;
+/* L10: */
+		}
+	    } else {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = *beta * y[i__];
+/* L20: */
+		}
+	    }
+	} else {
+	    iy = ky;
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = 0.;
+		    iy += *incy;
+/* L30: */
+		}
+	    } else {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = *beta * y[iy];
+		    iy += *incy;
+/* L40: */
+		}
+	    }
+	}
+    }
+    if (*alpha == 0.) {
+	return 0;
+    }
+    if (lsame_(uplo, "U")) {
+
+/*        Form  y  when upper triangle of A is stored. */
+
+	kplus1 = *k + 1;
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[j];
+		temp2 = 0.;
+		l = kplus1 - j;
+/* Computing MAX */
+		i__2 = 1, i__3 = j - *k;
+		i__4 = j - 1;
+		for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+		    y[i__] += temp1 * a[l + i__ + j * a_dim1];
+		    temp2 += a[l + i__ + j * a_dim1] * x[i__];
+/* L50: */
+		}
+		y[j] = y[j] + temp1 * a[kplus1 + j * a_dim1] + *alpha * temp2;
+/* L60: */
+	    }
+	} else {
+	    jx = kx;
+	    jy = ky;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[jx];
+		temp2 = 0.;
+		ix = kx;
+		iy = ky;
+		l = kplus1 - j;
+/* Computing MAX */
+		i__4 = 1, i__2 = j - *k;
+		i__3 = j - 1;
+		for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+		    y[iy] += temp1 * a[l + i__ + j * a_dim1];
+		    temp2 += a[l + i__ + j * a_dim1] * x[ix];
+		    ix += *incx;
+		    iy += *incy;
+/* L70: */
+		}
+		y[jy] = y[jy] + temp1 * a[kplus1 + j * a_dim1] + *alpha * 
+			temp2;
+		jx += *incx;
+		jy += *incy;
+		if (j > *k) {
+		    kx += *incx;
+		    ky += *incy;
+		}
+/* L80: */
+	    }
+	}
+    } else {
+
+/*        Form  y  when lower triangle of A is stored. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[j];
+		temp2 = 0.;
+		y[j] += temp1 * a[j * a_dim1 + 1];
+		l = 1 - j;
+/* Computing MIN */
+		i__4 = *n, i__2 = j + *k;
+		i__3 = min(i__4,i__2);
+		for (i__ = j + 1; i__ <= i__3; ++i__) {
+		    y[i__] += temp1 * a[l + i__ + j * a_dim1];
+		    temp2 += a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+		}
+		y[j] += *alpha * temp2;
+/* L100: */
+	    }
+	} else {
+	    jx = kx;
+	    jy = ky;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[jx];
+		temp2 = 0.;
+		y[jy] += temp1 * a[j * a_dim1 + 1];
+		l = 1 - j;
+		ix = jx;
+		iy = jy;
+/* Computing MIN */
+		i__4 = *n, i__2 = j + *k;
+		i__3 = min(i__4,i__2);
+		for (i__ = j + 1; i__ <= i__3; ++i__) {
+		    ix += *incx;
+		    iy += *incy;
+		    y[iy] += temp1 * a[l + i__ + j * a_dim1];
+		    temp2 += a[l + i__ + j * a_dim1] * x[ix];
+/* L110: */
+		}
+		y[jy] += *alpha * temp2;
+		jx += *incx;
+		jy += *incy;
+/* L120: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSBMV . */
+
+} /* dsbmv_ */

min-dgels/base/BLAS/SRC/dscal.c

@@ -0,0 +1,96 @@
+/* dscal.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dscal_(integer *n, doublereal *da, doublereal *dx, 
+	integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, m, mp1, nincx;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+/* * */
+/*     scales a vector by a constant. */
+/*     uses unrolled loops for increment equal to one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 3/93 to return if incx .le. 0. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0 || *incx <= 0) {
+	return 0;
+    }
+    if (*incx == 1) {
+	goto L20;
+    }
+
+/*        code for increment not equal to 1 */
+
+    nincx = *n * *incx;
+    i__1 = nincx;
+    i__2 = *incx;
+    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	dx[i__] = *da * dx[i__];
+/* L10: */
+    }
+    return 0;
+
+/*        code for increment equal to 1 */
+
+
+/*        clean-up loop */
+
+L20:
+    m = *n % 5;
+    if (m == 0) {
+	goto L40;
+    }
+    i__2 = m;
+    for (i__ = 1; i__ <= i__2; ++i__) {
+	dx[i__] = *da * dx[i__];
+/* L30: */
+    }
+    if (*n < 5) {
+	return 0;
+    }
+L40:
+    mp1 = m + 1;
+    i__2 = *n;
+    for (i__ = mp1; i__ <= i__2; i__ += 5) {
+	dx[i__] = *da * dx[i__];
+	dx[i__ + 1] = *da * dx[i__ + 1];
+	dx[i__ + 2] = *da * dx[i__ + 2];
+	dx[i__ + 3] = *da * dx[i__ + 3];
+	dx[i__ + 4] = *da * dx[i__ + 4];
+/* L50: */
+    }
+    return 0;
+} /* dscal_ */

min-dgels/base/BLAS/SRC/dsdot.c

@@ -0,0 +1,135 @@
+/* dsdot.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dsdot_(integer *n, real *sx, integer *incx, real *sy, integer *
+	incy)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+    doublereal ret_val;
+
+    /* Local variables */
+    integer i__, ns, kx, ky;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  AUTHORS */
+/*  ======= */
+/*  Lawson, C. L., (JPL), Hanson, R. J., (SNLA), */
+/*  Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL) */
+
+/*  Purpose */
+/*  ======= */
+/*  Compute the inner product of two vectors with extended */
+/*  precision accumulation and result. */
+
+/*  Returns D.P. dot product accumulated in D.P., for S.P. SX and SY */
+/*  DSDOT = sum for I = 0 to N-1 of  SX(LX+I*INCX) * SY(LY+I*INCY), */
+/*  where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is */
+/*  defined in a similar way using INCY. */
+
+/*  Arguments */
+/*  ========= */
+
+/*  N      (input) INTEGER */
+/*         number of elements in input vector(s) */
+
+/*  SX     (input) REAL array, dimension(N) */
+/*         single precision vector with N elements */
+
+/*  INCX   (input) INTEGER */
+/*          storage spacing between elements of SX */
+
+/*  SY     (input) REAL array, dimension(N) */
+/*         single precision vector with N elements */
+
+/*  INCY   (input) INTEGER */
+/*         storage spacing between elements of SY */
+
+/*  DSDOT  (output) DOUBLE PRECISION */
+/*         DSDOT  double precision dot product (zero if N.LE.0) */
+
+/*  REFERENCES */
+/*  ========== */
+
+/*  C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T. */
+/*  Krogh, Basic linear algebra subprograms for Fortran */
+/*  usage, Algorithm No. 539, Transactions on Mathematical */
+/*  Software 5, 3 (September 1979), pp. 308-323. */
+
+/*  REVISION HISTORY  (YYMMDD) */
+/*  ========================== */
+
+/*  791001  DATE WRITTEN */
+/*  890831  Modified array declarations.  (WRB) */
+/*  890831  REVISION DATE from Version 3.2 */
+/*  891214  Prologue converted to Version 4.0 format.  (BAB) */
+/*  920310  Corrected definition of LX in DESCRIPTION.  (WRB) */
+/*  920501  Reformatted the REFERENCES section.  (WRB) */
+/*  070118  Reformat to LAPACK style (JL) */
+
+/*  ===================================================================== */
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --sy;
+    --sx;
+
+    /* Function Body */
+    ret_val = 0.;
+    if (*n <= 0) {
+	return ret_val;
+    }
+    if (*incx == *incy && *incx > 0) {
+	goto L20;
+    }
+
+/*     Code for unequal or nonpositive increments. */
+
+    kx = 1;
+    ky = 1;
+    if (*incx < 0) {
+	kx = (1 - *n) * *incx + 1;
+    }
+    if (*incy < 0) {
+	ky = (1 - *n) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	ret_val += (doublereal) sx[kx] * (doublereal) sy[ky];
+	kx += *incx;
+	ky += *incy;
+/* L10: */
+    }
+    return ret_val;
+
+/*     Code for equal, positive, non-unit increments. */
+
+L20:
+    ns = *n * *incx;
+    i__1 = ns;
+    i__2 = *incx;
+    for (i__ = 1; i__2 < 0 ? i__ >= i__1 : i__ <= i__1; i__ += i__2) {
+	ret_val += (doublereal) sx[i__] * (doublereal) sy[i__];
+/* L30: */
+    }
+    return ret_val;
+} /* dsdot_ */

min-dgels/base/BLAS/SRC/dspmv.c

@@ -0,0 +1,312 @@
+/* dspmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspmv_(char *uplo, integer *n, doublereal *alpha, 
+	doublereal *ap, doublereal *x, integer *incx, doublereal *beta, 
+	doublereal *y, integer *incy)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSPMV  performs the matrix-vector operation */
+
+/*     y := alpha*A*x + beta*y, */
+
+/*  where alpha and beta are scalars, x and y are n element vectors and */
+/*  A is an n by n symmetric matrix, supplied in packed form. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the matrix A is supplied in the packed */
+/*           array AP as follows: */
+
+/*              UPLO = 'U' or 'u'   The upper triangular part of A is */
+/*                                  supplied in AP. */
+
+/*              UPLO = 'L' or 'l'   The lower triangular part of A is */
+/*                                  supplied in AP. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  AP     - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( ( n*( n + 1 ) )/2 ). */
+/*           Before entry with UPLO = 'U' or 'u', the array AP must */
+/*           contain the upper triangular part of the symmetric matrix */
+/*           packed sequentially, column by column, so that AP( 1 ) */
+/*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/*           and a( 2, 2 ) respectively, and so on. */
+/*           Before entry with UPLO = 'L' or 'l', the array AP must */
+/*           contain the lower triangular part of the symmetric matrix */
+/*           packed sequentially, column by column, so that AP( 1 ) */
+/*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/*           and a( 3, 1 ) respectively, and so on. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. When BETA is */
+/*           supplied as zero then Y need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the n */
+/*           element vector y. On exit, Y is overwritten by the updated */
+/*           vector y. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --y;
+    --x;
+    --ap;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 6;
+    } else if (*incy == 0) {
+	info = 9;
+    }
+    if (info != 0) {
+	xerbla_("DSPMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     Set up the start points in  X  and  Y. */
+
+    if (*incx > 0) {
+	kx = 1;
+    } else {
+	kx = 1 - (*n - 1) * *incx;
+    }
+    if (*incy > 0) {
+	ky = 1;
+    } else {
+	ky = 1 - (*n - 1) * *incy;
+    }
+
+/*     Start the operations. In this version the elements of the array AP */
+/*     are accessed sequentially with one pass through AP. */
+
+/*     First form  y := beta*y. */
+
+    if (*beta != 1.) {
+	if (*incy == 1) {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = 0.;
+/* L10: */
+		}
+	    } else {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = *beta * y[i__];
+/* L20: */
+		}
+	    }
+	} else {
+	    iy = ky;
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = 0.;
+		    iy += *incy;
+/* L30: */
+		}
+	    } else {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = *beta * y[iy];
+		    iy += *incy;
+/* L40: */
+		}
+	    }
+	}
+    }
+    if (*alpha == 0.) {
+	return 0;
+    }
+    kk = 1;
+    if (lsame_(uplo, "U")) {
+
+/*        Form  y  when AP contains the upper triangle. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[j];
+		temp2 = 0.;
+		k = kk;
+		i__2 = j - 1;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    y[i__] += temp1 * ap[k];
+		    temp2 += ap[k] * x[i__];
+		    ++k;
+/* L50: */
+		}
+		y[j] = y[j] + temp1 * ap[kk + j - 1] + *alpha * temp2;
+		kk += j;
+/* L60: */
+	    }
+	} else {
+	    jx = kx;
+	    jy = ky;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[jx];
+		temp2 = 0.;
+		ix = kx;
+		iy = ky;
+		i__2 = kk + j - 2;
+		for (k = kk; k <= i__2; ++k) {
+		    y[iy] += temp1 * ap[k];
+		    temp2 += ap[k] * x[ix];
+		    ix += *incx;
+		    iy += *incy;
+/* L70: */
+		}
+		y[jy] = y[jy] + temp1 * ap[kk + j - 1] + *alpha * temp2;
+		jx += *incx;
+		jy += *incy;
+		kk += j;
+/* L80: */
+	    }
+	}
+    } else {
+
+/*        Form  y  when AP contains the lower triangle. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[j];
+		temp2 = 0.;
+		y[j] += temp1 * ap[kk];
+		k = kk + 1;
+		i__2 = *n;
+		for (i__ = j + 1; i__ <= i__2; ++i__) {
+		    y[i__] += temp1 * ap[k];
+		    temp2 += ap[k] * x[i__];
+		    ++k;
+/* L90: */
+		}
+		y[j] += *alpha * temp2;
+		kk += *n - j + 1;
+/* L100: */
+	    }
+	} else {
+	    jx = kx;
+	    jy = ky;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[jx];
+		temp2 = 0.;
+		y[jy] += temp1 * ap[kk];
+		ix = jx;
+		iy = jy;
+		i__2 = kk + *n - j;
+		for (k = kk + 1; k <= i__2; ++k) {
+		    ix += *incx;
+		    iy += *incy;
+		    y[iy] += temp1 * ap[k];
+		    temp2 += ap[k] * x[ix];
+/* L110: */
+		}
+		y[jy] += *alpha * temp2;
+		jx += *incx;
+		jy += *incy;
+		kk += *n - j + 1;
+/* L120: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSPMV . */
+
+} /* dspmv_ */

min-dgels/base/BLAS/SRC/dspr.c

@@ -0,0 +1,237 @@
+/* dspr.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspr_(char *uplo, integer *n, doublereal *alpha, 
+	doublereal *x, integer *incx, doublereal *ap)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k, kk, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSPR    performs the symmetric rank 1 operation */
+
+/*     A := alpha*x*x' + A, */
+
+/*  where alpha is a real scalar, x is an n element vector and A is an */
+/*  n by n symmetric matrix, supplied in packed form. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the matrix A is supplied in the packed */
+/*           array AP as follows: */
+
+/*              UPLO = 'U' or 'u'   The upper triangular part of A is */
+/*                                  supplied in AP. */
+
+/*              UPLO = 'L' or 'l'   The lower triangular part of A is */
+/*                                  supplied in AP. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  AP     - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( ( n*( n + 1 ) )/2 ). */
+/*           Before entry with  UPLO = 'U' or 'u', the array AP must */
+/*           contain the upper triangular part of the symmetric matrix */
+/*           packed sequentially, column by column, so that AP( 1 ) */
+/*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/*           and a( 2, 2 ) respectively, and so on. On exit, the array */
+/*           AP is overwritten by the upper triangular part of the */
+/*           updated matrix. */
+/*           Before entry with UPLO = 'L' or 'l', the array AP must */
+/*           contain the lower triangular part of the symmetric matrix */
+/*           packed sequentially, column by column, so that AP( 1 ) */
+/*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/*           and a( 3, 1 ) respectively, and so on. On exit, the array */
+/*           AP is overwritten by the lower triangular part of the */
+/*           updated matrix. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 5;
+    }
+    if (info != 0) {
+	xerbla_("DSPR  ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0.) {
+	return 0;
+    }
+
+/*     Set the start point in X if the increment is not unity. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of the array AP */
+/*     are accessed sequentially with one pass through AP. */
+
+    kk = 1;
+    if (lsame_(uplo, "U")) {
+
+/*        Form  A  when upper triangle is stored in AP. */
+
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0.) {
+		    temp = *alpha * x[j];
+		    k = kk;
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			ap[k] += x[i__] * temp;
+			++k;
+/* L10: */
+		    }
+		}
+		kk += j;
+/* L20: */
+	    }
+	} else {
+	    jx = kx;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    ix = kx;
+		    i__2 = kk + j - 1;
+		    for (k = kk; k <= i__2; ++k) {
+			ap[k] += x[ix] * temp;
+			ix += *incx;
+/* L30: */
+		    }
+		}
+		jx += *incx;
+		kk += j;
+/* L40: */
+	    }
+	}
+    } else {
+
+/*        Form  A  when lower triangle is stored in AP. */
+
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0.) {
+		    temp = *alpha * x[j];
+		    k = kk;
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			ap[k] += x[i__] * temp;
+			++k;
+/* L50: */
+		    }
+		}
+		kk = kk + *n - j + 1;
+/* L60: */
+	    }
+	} else {
+	    jx = kx;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    ix = jx;
+		    i__2 = kk + *n - j;
+		    for (k = kk; k <= i__2; ++k) {
+			ap[k] += x[ix] * temp;
+			ix += *incx;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+		kk = kk + *n - j + 1;
+/* L80: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSPR  . */
+
+} /* dspr_ */

min-dgels/base/BLAS/SRC/dspr2.c

@@ -0,0 +1,270 @@
+/* dspr2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dspr2_(char *uplo, integer *n, doublereal *alpha, 
+	doublereal *x, integer *incx, doublereal *y, integer *incy, 
+	doublereal *ap)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k, kk, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSPR2  performs the symmetric rank 2 operation */
+
+/*     A := alpha*x*y' + alpha*y*x' + A, */
+
+/*  where alpha is a scalar, x and y are n element vectors and A is an */
+/*  n by n symmetric matrix, supplied in packed form. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the matrix A is supplied in the packed */
+/*           array AP as follows: */
+
+/*              UPLO = 'U' or 'u'   The upper triangular part of A is */
+/*                                  supplied in AP. */
+
+/*              UPLO = 'L' or 'l'   The lower triangular part of A is */
+/*                                  supplied in AP. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the n */
+/*           element vector y. */
+/*           Unchanged on exit. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+/*  AP     - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( ( n*( n + 1 ) )/2 ). */
+/*           Before entry with  UPLO = 'U' or 'u', the array AP must */
+/*           contain the upper triangular part of the symmetric matrix */
+/*           packed sequentially, column by column, so that AP( 1 ) */
+/*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 ) */
+/*           and a( 2, 2 ) respectively, and so on. On exit, the array */
+/*           AP is overwritten by the upper triangular part of the */
+/*           updated matrix. */
+/*           Before entry with UPLO = 'L' or 'l', the array AP must */
+/*           contain the lower triangular part of the symmetric matrix */
+/*           packed sequentially, column by column, so that AP( 1 ) */
+/*           contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 ) */
+/*           and a( 3, 1 ) respectively, and so on. On exit, the array */
+/*           AP is overwritten by the lower triangular part of the */
+/*           updated matrix. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --ap;
+    --y;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 5;
+    } else if (*incy == 0) {
+	info = 7;
+    }
+    if (info != 0) {
+	xerbla_("DSPR2 ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0.) {
+	return 0;
+    }
+
+/*     Set up the start points in X and Y if the increments are not both */
+/*     unity. */
+
+    if (*incx != 1 || *incy != 1) {
+	if (*incx > 0) {
+	    kx = 1;
+	} else {
+	    kx = 1 - (*n - 1) * *incx;
+	}
+	if (*incy > 0) {
+	    ky = 1;
+	} else {
+	    ky = 1 - (*n - 1) * *incy;
+	}
+	jx = kx;
+	jy = ky;
+    }
+
+/*     Start the operations. In this version the elements of the array AP */
+/*     are accessed sequentially with one pass through AP. */
+
+    kk = 1;
+    if (lsame_(uplo, "U")) {
+
+/*        Form  A  when upper triangle is stored in AP. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0. || y[j] != 0.) {
+		    temp1 = *alpha * y[j];
+		    temp2 = *alpha * x[j];
+		    k = kk;
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
+			++k;
+/* L10: */
+		    }
+		}
+		kk += j;
+/* L20: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0. || y[jy] != 0.) {
+		    temp1 = *alpha * y[jy];
+		    temp2 = *alpha * x[jx];
+		    ix = kx;
+		    iy = ky;
+		    i__2 = kk + j - 1;
+		    for (k = kk; k <= i__2; ++k) {
+			ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
+			ix += *incx;
+			iy += *incy;
+/* L30: */
+		    }
+		}
+		jx += *incx;
+		jy += *incy;
+		kk += j;
+/* L40: */
+	    }
+	}
+    } else {
+
+/*        Form  A  when lower triangle is stored in AP. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0. || y[j] != 0.) {
+		    temp1 = *alpha * y[j];
+		    temp2 = *alpha * x[j];
+		    k = kk;
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			ap[k] = ap[k] + x[i__] * temp1 + y[i__] * temp2;
+			++k;
+/* L50: */
+		    }
+		}
+		kk = kk + *n - j + 1;
+/* L60: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0. || y[jy] != 0.) {
+		    temp1 = *alpha * y[jy];
+		    temp2 = *alpha * x[jx];
+		    ix = jx;
+		    iy = jy;
+		    i__2 = kk + *n - j;
+		    for (k = kk; k <= i__2; ++k) {
+			ap[k] = ap[k] + x[ix] * temp1 + y[iy] * temp2;
+			ix += *incx;
+			iy += *incy;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+		jy += *incy;
+		kk = kk + *n - j + 1;
+/* L80: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSPR2 . */
+
+} /* dspr2_ */

min-dgels/base/BLAS/SRC/dswap.c

@@ -0,0 +1,114 @@
+/* dswap.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dswap_(integer *n, doublereal *dx, integer *incx, 
+	doublereal *dy, integer *incy)
+{
+    /* System generated locals */
+    integer i__1;
+
+    /* Local variables */
+    integer i__, m, ix, iy, mp1;
+    doublereal dtemp;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     interchanges two vectors. */
+/*     uses unrolled loops for increments equal one. */
+/*     jack dongarra, linpack, 3/11/78. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --dy;
+    --dx;
+
+    /* Function Body */
+    if (*n <= 0) {
+	return 0;
+    }
+    if (*incx == 1 && *incy == 1) {
+	goto L20;
+    }
+
+/*       code for unequal increments or equal increments not equal */
+/*         to 1 */
+
+    ix = 1;
+    iy = 1;
+    if (*incx < 0) {
+	ix = (-(*n) + 1) * *incx + 1;
+    }
+    if (*incy < 0) {
+	iy = (-(*n) + 1) * *incy + 1;
+    }
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dtemp = dx[ix];
+	dx[ix] = dy[iy];
+	dy[iy] = dtemp;
+	ix += *incx;
+	iy += *incy;
+/* L10: */
+    }
+    return 0;
+
+/*       code for both increments equal to 1 */
+
+
+/*       clean-up loop */
+
+L20:
+    m = *n % 3;
+    if (m == 0) {
+	goto L40;
+    }
+    i__1 = m;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	dtemp = dx[i__];
+	dx[i__] = dy[i__];
+	dy[i__] = dtemp;
+/* L30: */
+    }
+    if (*n < 3) {
+	return 0;
+    }
+L40:
+    mp1 = m + 1;
+    i__1 = *n;
+    for (i__ = mp1; i__ <= i__1; i__ += 3) {
+	dtemp = dx[i__];
+	dx[i__] = dy[i__];
+	dy[i__] = dtemp;
+	dtemp = dx[i__ + 1];
+	dx[i__ + 1] = dy[i__ + 1];
+	dy[i__ + 1] = dtemp;
+	dtemp = dx[i__ + 2];
+	dx[i__ + 2] = dy[i__ + 2];
+	dy[i__ + 2] = dtemp;
+/* L50: */
+    }
+    return 0;
+} /* dswap_ */

min-dgels/base/BLAS/SRC/dsymm.c

@@ -0,0 +1,362 @@
+/* dsymm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsymm_(char *side, char *uplo, integer *m, integer *n, 
+	doublereal *alpha, doublereal *a, integer *lda, doublereal *b, 
+	integer *ldb, doublereal *beta, doublereal *c__, integer *ldc)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
+	    i__3;
+
+    /* Local variables */
+    integer i__, j, k, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSYMM  performs one of the matrix-matrix operations */
+
+/*     C := alpha*A*B + beta*C, */
+
+/*  or */
+
+/*     C := alpha*B*A + beta*C, */
+
+/*  where alpha and beta are scalars,  A is a symmetric matrix and  B and */
+/*  C are  m by n matrices. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  SIDE   - CHARACTER*1. */
+/*           On entry,  SIDE  specifies whether  the  symmetric matrix  A */
+/*           appears on the  left or right  in the  operation as follows: */
+
+/*              SIDE = 'L' or 'l'   C := alpha*A*B + beta*C, */
+
+/*              SIDE = 'R' or 'r'   C := alpha*B*A + beta*C, */
+
+/*           Unchanged on exit. */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On  entry,   UPLO  specifies  whether  the  upper  or  lower */
+/*           triangular  part  of  the  symmetric  matrix   A  is  to  be */
+/*           referenced as follows: */
+
+/*              UPLO = 'U' or 'u'   Only the upper triangular part of the */
+/*                                  symmetric matrix is to be referenced. */
+
+/*              UPLO = 'L' or 'l'   Only the lower triangular part of the */
+/*                                  symmetric matrix is to be referenced. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry,  M  specifies the number of rows of the matrix  C. */
+/*           M  must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of the matrix C. */
+/*           N  must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/*           m  when  SIDE = 'L' or 'l'  and is  n otherwise. */
+/*           Before entry  with  SIDE = 'L' or 'l',  the  m by m  part of */
+/*           the array  A  must contain the  symmetric matrix,  such that */
+/*           when  UPLO = 'U' or 'u', the leading m by m upper triangular */
+/*           part of the array  A  must contain the upper triangular part */
+/*           of the  symmetric matrix and the  strictly  lower triangular */
+/*           part of  A  is not referenced,  and when  UPLO = 'L' or 'l', */
+/*           the leading  m by m  lower triangular part  of the  array  A */
+/*           must  contain  the  lower triangular part  of the  symmetric */
+/*           matrix and the  strictly upper triangular part of  A  is not */
+/*           referenced. */
+/*           Before entry  with  SIDE = 'R' or 'r',  the  n by n  part of */
+/*           the array  A  must contain the  symmetric matrix,  such that */
+/*           when  UPLO = 'U' or 'u', the leading n by n upper triangular */
+/*           part of the array  A  must contain the upper triangular part */
+/*           of the  symmetric matrix and the  strictly  lower triangular */
+/*           part of  A  is not referenced,  and when  UPLO = 'L' or 'l', */
+/*           the leading  n by n  lower triangular part  of the  array  A */
+/*           must  contain  the  lower triangular part  of the  symmetric */
+/*           matrix and the  strictly upper triangular part of  A  is not */
+/*           referenced. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then */
+/*           LDA must be at least  max( 1, m ), otherwise  LDA must be at */
+/*           least  max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/*           Before entry, the leading  m by n part of the array  B  must */
+/*           contain the matrix B. */
+/*           Unchanged on exit. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in  the  calling  (sub)  program.   LDB  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is */
+/*           supplied as zero then C need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/*           Before entry, the leading  m by n  part of the array  C must */
+/*           contain the matrix  C,  except when  beta  is zero, in which */
+/*           case C need not be set on entry. */
+/*           On exit, the array  C  is overwritten by the  m by n updated */
+/*           matrix. */
+
+/*  LDC    - INTEGER. */
+/*           On entry, LDC specifies the first dimension of C as declared */
+/*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Set NROWA as the number of rows of A. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+
+    /* Function Body */
+    if (lsame_(side, "L")) {
+	nrowa = *m;
+    } else {
+	nrowa = *n;
+    }
+    upper = lsame_(uplo, "U");
+
+/*     Test the input parameters. */
+
+    info = 0;
+    if (! lsame_(side, "L") && ! lsame_(side, "R")) {
+	info = 1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	info = 2;
+    } else if (*m < 0) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*lda < max(1,nrowa)) {
+	info = 7;
+    } else if (*ldb < max(1,*m)) {
+	info = 9;
+    } else if (*ldc < max(1,*m)) {
+	info = 12;
+    }
+    if (info != 0) {
+	xerbla_("DSYMM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	if (*beta == 0.) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+		}
+/* L20: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+		}
+/* L40: */
+	    }
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lsame_(side, "L")) {
+
+/*        Form  C := alpha*A*B + beta*C. */
+
+	if (upper) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp1 = *alpha * b[i__ + j * b_dim1];
+		    temp2 = 0.;
+		    i__3 = i__ - 1;
+		    for (k = 1; k <= i__3; ++k) {
+			c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
+			temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
+/* L50: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] 
+				+ *alpha * temp2;
+		    } else {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] 
+				+ temp1 * a[i__ + i__ * a_dim1] + *alpha * 
+				temp2;
+		    }
+/* L60: */
+		}
+/* L70: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		for (i__ = *m; i__ >= 1; --i__) {
+		    temp1 = *alpha * b[i__ + j * b_dim1];
+		    temp2 = 0.;
+		    i__2 = *m;
+		    for (k = i__ + 1; k <= i__2; ++k) {
+			c__[k + j * c_dim1] += temp1 * a[k + i__ * a_dim1];
+			temp2 += b[k + j * b_dim1] * a[k + i__ * a_dim1];
+/* L80: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = temp1 * a[i__ + i__ * a_dim1] 
+				+ *alpha * temp2;
+		    } else {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] 
+				+ temp1 * a[i__ + i__ * a_dim1] + *alpha * 
+				temp2;
+		    }
+/* L90: */
+		}
+/* L100: */
+	    }
+	}
+    } else {
+
+/*        Form  C := alpha*B*A + beta*C. */
+
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    temp1 = *alpha * a[j + j * a_dim1];
+	    if (*beta == 0.) {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = temp1 * b[i__ + j * b_dim1];
+/* L110: */
+		}
+	    } else {
+		i__2 = *m;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] + 
+			    temp1 * b[i__ + j * b_dim1];
+/* L120: */
+		}
+	    }
+	    i__2 = j - 1;
+	    for (k = 1; k <= i__2; ++k) {
+		if (upper) {
+		    temp1 = *alpha * a[k + j * a_dim1];
+		} else {
+		    temp1 = *alpha * a[j + k * a_dim1];
+		}
+		i__3 = *m;
+		for (i__ = 1; i__ <= i__3; ++i__) {
+		    c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
+/* L130: */
+		}
+/* L140: */
+	    }
+	    i__2 = *n;
+	    for (k = j + 1; k <= i__2; ++k) {
+		if (upper) {
+		    temp1 = *alpha * a[j + k * a_dim1];
+		} else {
+		    temp1 = *alpha * a[k + j * a_dim1];
+		}
+		i__3 = *m;
+		for (i__ = 1; i__ <= i__3; ++i__) {
+		    c__[i__ + j * c_dim1] += temp1 * b[i__ + k * b_dim1];
+/* L150: */
+		}
+/* L160: */
+	    }
+/* L170: */
+	}
+    }
+
+    return 0;
+
+/*     End of DSYMM . */
+
+} /* dsymm_ */

min-dgels/base/BLAS/SRC/dsymv.c

@@ -0,0 +1,313 @@
+/* dsymv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsymv_(char *uplo, integer *n, doublereal *alpha, 
+	doublereal *a, integer *lda, doublereal *x, integer *incx, doublereal 
+	*beta, doublereal *y, integer *incy)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSYMV  performs the matrix-vector  operation */
+
+/*     y := alpha*A*x + beta*y, */
+
+/*  where alpha and beta are scalars, x and y are n element vectors and */
+/*  A is an n by n symmetric matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the array A is to be referenced as */
+/*           follows: */
+
+/*              UPLO = 'U' or 'u'   Only the upper triangular part of A */
+/*                                  is to be referenced. */
+
+/*              UPLO = 'L' or 'l'   Only the lower triangular part of A */
+/*                                  is to be referenced. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with  UPLO = 'U' or 'u', the leading n by n */
+/*           upper triangular part of the array A must contain the upper */
+/*           triangular part of the symmetric matrix and the strictly */
+/*           lower triangular part of A is not referenced. */
+/*           Before entry with UPLO = 'L' or 'l', the leading n by n */
+/*           lower triangular part of the array A must contain the lower */
+/*           triangular part of the symmetric matrix and the strictly */
+/*           upper triangular part of A is not referenced. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. When BETA is */
+/*           supplied as zero then Y need not be set on input. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the n */
+/*           element vector y. On exit, Y is overwritten by the updated */
+/*           vector y. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+    --y;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*lda < max(1,*n)) {
+	info = 5;
+    } else if (*incx == 0) {
+	info = 7;
+    } else if (*incy == 0) {
+	info = 10;
+    }
+    if (info != 0) {
+	xerbla_("DSYMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0. && *beta == 1.) {
+	return 0;
+    }
+
+/*     Set up the start points in  X  and  Y. */
+
+    if (*incx > 0) {
+	kx = 1;
+    } else {
+	kx = 1 - (*n - 1) * *incx;
+    }
+    if (*incy > 0) {
+	ky = 1;
+    } else {
+	ky = 1 - (*n - 1) * *incy;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through the triangular part */
+/*     of A. */
+
+/*     First form  y := beta*y. */
+
+    if (*beta != 1.) {
+	if (*incy == 1) {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = 0.;
+/* L10: */
+		}
+	    } else {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[i__] = *beta * y[i__];
+/* L20: */
+		}
+	    }
+	} else {
+	    iy = ky;
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = 0.;
+		    iy += *incy;
+/* L30: */
+		}
+	    } else {
+		i__1 = *n;
+		for (i__ = 1; i__ <= i__1; ++i__) {
+		    y[iy] = *beta * y[iy];
+		    iy += *incy;
+/* L40: */
+		}
+	    }
+	}
+    }
+    if (*alpha == 0.) {
+	return 0;
+    }
+    if (lsame_(uplo, "U")) {
+
+/*        Form  y  when A is stored in upper triangle. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[j];
+		temp2 = 0.;
+		i__2 = j - 1;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    y[i__] += temp1 * a[i__ + j * a_dim1];
+		    temp2 += a[i__ + j * a_dim1] * x[i__];
+/* L50: */
+		}
+		y[j] = y[j] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
+/* L60: */
+	    }
+	} else {
+	    jx = kx;
+	    jy = ky;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[jx];
+		temp2 = 0.;
+		ix = kx;
+		iy = ky;
+		i__2 = j - 1;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    y[iy] += temp1 * a[i__ + j * a_dim1];
+		    temp2 += a[i__ + j * a_dim1] * x[ix];
+		    ix += *incx;
+		    iy += *incy;
+/* L70: */
+		}
+		y[jy] = y[jy] + temp1 * a[j + j * a_dim1] + *alpha * temp2;
+		jx += *incx;
+		jy += *incy;
+/* L80: */
+	    }
+	}
+    } else {
+
+/*        Form  y  when A is stored in lower triangle. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[j];
+		temp2 = 0.;
+		y[j] += temp1 * a[j + j * a_dim1];
+		i__2 = *n;
+		for (i__ = j + 1; i__ <= i__2; ++i__) {
+		    y[i__] += temp1 * a[i__ + j * a_dim1];
+		    temp2 += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+		}
+		y[j] += *alpha * temp2;
+/* L100: */
+	    }
+	} else {
+	    jx = kx;
+	    jy = ky;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		temp1 = *alpha * x[jx];
+		temp2 = 0.;
+		y[jy] += temp1 * a[j + j * a_dim1];
+		ix = jx;
+		iy = jy;
+		i__2 = *n;
+		for (i__ = j + 1; i__ <= i__2; ++i__) {
+		    ix += *incx;
+		    iy += *incy;
+		    y[iy] += temp1 * a[i__ + j * a_dim1];
+		    temp2 += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+		}
+		y[jy] += *alpha * temp2;
+		jx += *incx;
+		jy += *incy;
+/* L120: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSYMV . */
+
+} /* dsymv_ */

min-dgels/base/BLAS/SRC/dsyr.c

@@ -0,0 +1,238 @@
+/* dsyr.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyr_(char *uplo, integer *n, doublereal *alpha, 
+	doublereal *x, integer *incx, doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSYR   performs the symmetric rank 1 operation */
+
+/*     A := alpha*x*x' + A, */
+
+/*  where alpha is a real scalar, x is an n element vector and A is an */
+/*  n by n symmetric matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the array A is to be referenced as */
+/*           follows: */
+
+/*              UPLO = 'U' or 'u'   Only the upper triangular part of A */
+/*                                  is to be referenced. */
+
+/*              UPLO = 'L' or 'l'   Only the lower triangular part of A */
+/*                                  is to be referenced. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with  UPLO = 'U' or 'u', the leading n by n */
+/*           upper triangular part of the array A must contain the upper */
+/*           triangular part of the symmetric matrix and the strictly */
+/*           lower triangular part of A is not referenced. On exit, the */
+/*           upper triangular part of the array A is overwritten by the */
+/*           upper triangular part of the updated matrix. */
+/*           Before entry with UPLO = 'L' or 'l', the leading n by n */
+/*           lower triangular part of the array A must contain the lower */
+/*           triangular part of the symmetric matrix and the strictly */
+/*           upper triangular part of A is not referenced. On exit, the */
+/*           lower triangular part of the array A is overwritten by the */
+/*           lower triangular part of the updated matrix. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --x;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 5;
+    } else if (*lda < max(1,*n)) {
+	info = 7;
+    }
+    if (info != 0) {
+	xerbla_("DSYR  ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0.) {
+	return 0;
+    }
+
+/*     Set the start point in X if the increment is not unity. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through the triangular part */
+/*     of A. */
+
+    if (lsame_(uplo, "U")) {
+
+/*        Form  A  when A is stored in upper triangle. */
+
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0.) {
+		    temp = *alpha * x[j];
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] += x[i__] * temp;
+/* L10: */
+		    }
+		}
+/* L20: */
+	    }
+	} else {
+	    jx = kx;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    ix = kx;
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] += x[ix] * temp;
+			ix += *incx;
+/* L30: */
+		    }
+		}
+		jx += *incx;
+/* L40: */
+	    }
+	}
+    } else {
+
+/*        Form  A  when A is stored in lower triangle. */
+
+	if (*incx == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0.) {
+		    temp = *alpha * x[j];
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] += x[i__] * temp;
+/* L50: */
+		    }
+		}
+/* L60: */
+	    }
+	} else {
+	    jx = kx;
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0.) {
+		    temp = *alpha * x[jx];
+		    ix = jx;
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] += x[ix] * temp;
+			ix += *incx;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+/* L80: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSYR  . */
+
+} /* dsyr_ */

min-dgels/base/BLAS/SRC/dsyr2.c

@@ -0,0 +1,275 @@
+/* dsyr2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyr2_(char *uplo, integer *n, doublereal *alpha, 
+	doublereal *x, integer *incx, doublereal *y, integer *incy, 
+	doublereal *a, integer *lda)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, iy, jx, jy, kx, ky, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSYR2  performs the symmetric rank 2 operation */
+
+/*     A := alpha*x*y' + alpha*y*x' + A, */
+
+/*  where alpha is a scalar, x and y are n element vectors and A is an n */
+/*  by n symmetric matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the upper or lower */
+/*           triangular part of the array A is to be referenced as */
+/*           follows: */
+
+/*              UPLO = 'U' or 'u'   Only the upper triangular part of A */
+/*                                  is to be referenced. */
+
+/*              UPLO = 'L' or 'l'   Only the lower triangular part of A */
+/*                                  is to be referenced. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. */
+/*           Unchanged on exit. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+/*  Y      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCY ) ). */
+/*           Before entry, the incremented array Y must contain the n */
+/*           element vector y. */
+/*           Unchanged on exit. */
+
+/*  INCY   - INTEGER. */
+/*           On entry, INCY specifies the increment for the elements of */
+/*           Y. INCY must not be zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with  UPLO = 'U' or 'u', the leading n by n */
+/*           upper triangular part of the array A must contain the upper */
+/*           triangular part of the symmetric matrix and the strictly */
+/*           lower triangular part of A is not referenced. On exit, the */
+/*           upper triangular part of the array A is overwritten by the */
+/*           upper triangular part of the updated matrix. */
+/*           Before entry with UPLO = 'L' or 'l', the leading n by n */
+/*           lower triangular part of the array A must contain the lower */
+/*           triangular part of the symmetric matrix and the strictly */
+/*           upper triangular part of A is not referenced. On exit, the */
+/*           lower triangular part of the array A is overwritten by the */
+/*           lower triangular part of the updated matrix. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --x;
+    --y;
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (*n < 0) {
+	info = 2;
+    } else if (*incx == 0) {
+	info = 5;
+    } else if (*incy == 0) {
+	info = 7;
+    } else if (*lda < max(1,*n)) {
+	info = 9;
+    }
+    if (info != 0) {
+	xerbla_("DSYR2 ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || *alpha == 0.) {
+	return 0;
+    }
+
+/*     Set up the start points in X and Y if the increments are not both */
+/*     unity. */
+
+    if (*incx != 1 || *incy != 1) {
+	if (*incx > 0) {
+	    kx = 1;
+	} else {
+	    kx = 1 - (*n - 1) * *incx;
+	}
+	if (*incy > 0) {
+	    ky = 1;
+	} else {
+	    ky = 1 - (*n - 1) * *incy;
+	}
+	jx = kx;
+	jy = ky;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through the triangular part */
+/*     of A. */
+
+    if (lsame_(uplo, "U")) {
+
+/*        Form  A  when A is stored in the upper triangle. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0. || y[j] != 0.) {
+		    temp1 = *alpha * y[j];
+		    temp2 = *alpha * x[j];
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * 
+				temp1 + y[i__] * temp2;
+/* L10: */
+		    }
+		}
+/* L20: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0. || y[jy] != 0.) {
+		    temp1 = *alpha * y[jy];
+		    temp2 = *alpha * x[jx];
+		    ix = kx;
+		    iy = ky;
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * 
+				temp1 + y[iy] * temp2;
+			ix += *incx;
+			iy += *incy;
+/* L30: */
+		    }
+		}
+		jx += *incx;
+		jy += *incy;
+/* L40: */
+	    }
+	}
+    } else {
+
+/*        Form  A  when A is stored in the lower triangle. */
+
+	if (*incx == 1 && *incy == 1) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[j] != 0. || y[j] != 0.) {
+		    temp1 = *alpha * y[j];
+		    temp2 = *alpha * x[j];
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[i__] * 
+				temp1 + y[i__] * temp2;
+/* L50: */
+		    }
+		}
+/* L60: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (x[jx] != 0. || y[jy] != 0.) {
+		    temp1 = *alpha * y[jy];
+		    temp2 = *alpha * x[jx];
+		    ix = jx;
+		    iy = jy;
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			a[i__ + j * a_dim1] = a[i__ + j * a_dim1] + x[ix] * 
+				temp1 + y[iy] * temp2;
+			ix += *incx;
+			iy += *incy;
+/* L70: */
+		    }
+		}
+		jx += *incx;
+		jy += *incy;
+/* L80: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSYR2 . */
+
+} /* dsyr2_ */

min-dgels/base/BLAS/SRC/dsyr2k.c

@@ -0,0 +1,407 @@
+/* dsyr2k.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyr2k_(char *uplo, char *trans, integer *n, integer *k, 
+	doublereal *alpha, doublereal *a, integer *lda, doublereal *b, 
+	integer *ldb, doublereal *beta, doublereal *c__, integer *ldc)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, 
+	    i__3;
+
+    /* Local variables */
+    integer i__, j, l, info;
+    doublereal temp1, temp2;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSYR2K  performs one of the symmetric rank 2k operations */
+
+/*     C := alpha*A*B' + alpha*B*A' + beta*C, */
+
+/*  or */
+
+/*     C := alpha*A'*B + alpha*B'*A + beta*C, */
+
+/*  where  alpha and beta  are scalars, C is an  n by n  symmetric matrix */
+/*  and  A and B  are  n by k  matrices  in the  first  case  and  k by n */
+/*  matrices in the second case. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On  entry,   UPLO  specifies  whether  the  upper  or  lower */
+/*           triangular  part  of the  array  C  is to be  referenced  as */
+/*           follows: */
+
+/*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C */
+/*                                  is to be referenced. */
+
+/*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C */
+/*                                  is to be referenced. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry,  TRANS  specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   C := alpha*A*B' + alpha*B*A' + */
+/*                                        beta*C. */
+
+/*              TRANS = 'T' or 't'   C := alpha*A'*B + alpha*B'*A + */
+/*                                        beta*C. */
+
+/*              TRANS = 'C' or 'c'   C := alpha*A'*B + alpha*B'*A + */
+/*                                        beta*C. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry,  N specifies the order of the matrix C.  N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number */
+/*           of  columns  of the  matrices  A and B,  and on  entry  with */
+/*           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number */
+/*           of rows of the matrices  A and B.  K must be at least  zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise. */
+/*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k */
+/*           part of the array  A  must contain the matrix  A,  otherwise */
+/*           the leading  k by n  part of the array  A  must contain  the */
+/*           matrix A. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n' */
+/*           then  LDA must be at least  max( 1, n ), otherwise  LDA must */
+/*           be at least  max( 1, k ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is */
+/*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise. */
+/*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k */
+/*           part of the array  B  must contain the matrix  B,  otherwise */
+/*           the leading  k by n  part of the array  B  must contain  the */
+/*           matrix B. */
+/*           Unchanged on exit. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n' */
+/*           then  LDB must be at least  max( 1, n ), otherwise  LDB must */
+/*           be at least  max( 1, k ). */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. */
+/*           Unchanged on exit. */
+
+/*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/*           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n */
+/*           upper triangular part of the array C must contain the upper */
+/*           triangular part  of the  symmetric matrix  and the strictly */
+/*           lower triangular part of C is not referenced.  On exit, the */
+/*           upper triangular part of the array  C is overwritten by the */
+/*           upper triangular part of the updated matrix. */
+/*           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n */
+/*           lower triangular part of the array C must contain the lower */
+/*           triangular part  of the  symmetric matrix  and the strictly */
+/*           upper triangular part of C is not referenced.  On exit, the */
+/*           lower triangular part of the array  C is overwritten by the */
+/*           lower triangular part of the updated matrix. */
+
+/*  LDC    - INTEGER. */
+/*           On entry, LDC specifies the first dimension of C as declared */
+/*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+
+    /* Function Body */
+    if (lsame_(trans, "N")) {
+	nrowa = *n;
+    } else {
+	nrowa = *k;
+    }
+    upper = lsame_(uplo, "U");
+
+    info = 0;
+    if (! upper && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (*n < 0) {
+	info = 3;
+    } else if (*k < 0) {
+	info = 4;
+    } else if (*lda < max(1,nrowa)) {
+	info = 7;
+    } else if (*ldb < max(1,nrowa)) {
+	info = 9;
+    } else if (*ldc < max(1,*n)) {
+	info = 12;
+    }
+    if (info != 0) {
+	xerbla_("DSYR2K", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	if (upper) {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+		    }
+/* L20: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+		    }
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+		    }
+/* L60: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L70: */
+		    }
+/* L80: */
+		}
+	    }
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  C := alpha*A*B' + alpha*B*A' + C. */
+
+	if (upper) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L90: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L100: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
+			temp1 = *alpha * b[j + l * b_dim1];
+			temp2 = *alpha * a[j + l * a_dim1];
+			i__3 = j;
+			for (i__ = 1; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
+				    i__ + l * a_dim1] * temp1 + b[i__ + l * 
+				    b_dim1] * temp2;
+/* L110: */
+			}
+		    }
+/* L120: */
+		}
+/* L130: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L140: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L150: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (a[j + l * a_dim1] != 0. || b[j + l * b_dim1] != 0.) {
+			temp1 = *alpha * b[j + l * b_dim1];
+			temp2 = *alpha * a[j + l * a_dim1];
+			i__3 = *n;
+			for (i__ = j; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] = c__[i__ + j * c_dim1] + a[
+				    i__ + l * a_dim1] * temp1 + b[i__ + l * 
+				    b_dim1] * temp2;
+/* L160: */
+			}
+		    }
+/* L170: */
+		}
+/* L180: */
+	    }
+	}
+    } else {
+
+/*        Form  C := alpha*A'*B + alpha*B'*A + C. */
+
+	if (upper) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = j;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp1 = 0.;
+		    temp2 = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+			temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
+/* L190: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * 
+				temp2;
+		    } else {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] 
+				+ *alpha * temp1 + *alpha * temp2;
+		    }
+/* L200: */
+		}
+/* L210: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *n;
+		for (i__ = j; i__ <= i__2; ++i__) {
+		    temp1 = 0.;
+		    temp2 = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp1 += a[l + i__ * a_dim1] * b[l + j * b_dim1];
+			temp2 += b[l + i__ * b_dim1] * a[l + j * a_dim1];
+/* L220: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp1 + *alpha * 
+				temp2;
+		    } else {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1] 
+				+ *alpha * temp1 + *alpha * temp2;
+		    }
+/* L230: */
+		}
+/* L240: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSYR2K. */
+
+} /* dsyr2k_ */

min-dgels/base/BLAS/SRC/dsyrk.c

@@ -0,0 +1,372 @@
+/* dsyrk.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dsyrk_(char *uplo, char *trans, integer *n, integer *k, 
+	doublereal *alpha, doublereal *a, integer *lda, doublereal *beta, 
+	doublereal *c__, integer *ldc)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, l, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DSYRK  performs one of the symmetric rank k operations */
+
+/*     C := alpha*A*A' + beta*C, */
+
+/*  or */
+
+/*     C := alpha*A'*A + beta*C, */
+
+/*  where  alpha and beta  are scalars, C is an  n by n  symmetric matrix */
+/*  and  A  is an  n by k  matrix in the first case and a  k by n  matrix */
+/*  in the second case. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On  entry,   UPLO  specifies  whether  the  upper  or  lower */
+/*           triangular  part  of the  array  C  is to be  referenced  as */
+/*           follows: */
+
+/*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C */
+/*                                  is to be referenced. */
+
+/*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C */
+/*                                  is to be referenced. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry,  TRANS  specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   C := alpha*A*A' + beta*C. */
+
+/*              TRANS = 'T' or 't'   C := alpha*A'*A + beta*C. */
+
+/*              TRANS = 'C' or 'c'   C := alpha*A'*A + beta*C. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry,  N specifies the order of the matrix C.  N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number */
+/*           of  columns   of  the   matrix   A,   and  on   entry   with */
+/*           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number */
+/*           of rows of the matrix  A.  K must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry, ALPHA specifies the scalar alpha. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is */
+/*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise. */
+/*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k */
+/*           part of the array  A  must contain the matrix  A,  otherwise */
+/*           the leading  k by n  part of the array  A  must contain  the */
+/*           matrix A. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n' */
+/*           then  LDA must be at least  max( 1, n ), otherwise  LDA must */
+/*           be at least  max( 1, k ). */
+/*           Unchanged on exit. */
+
+/*  BETA   - DOUBLE PRECISION. */
+/*           On entry, BETA specifies the scalar beta. */
+/*           Unchanged on exit. */
+
+/*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ). */
+/*           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n */
+/*           upper triangular part of the array C must contain the upper */
+/*           triangular part  of the  symmetric matrix  and the strictly */
+/*           lower triangular part of C is not referenced.  On exit, the */
+/*           upper triangular part of the array  C is overwritten by the */
+/*           upper triangular part of the updated matrix. */
+/*           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n */
+/*           lower triangular part of the array C must contain the lower */
+/*           triangular part  of the  symmetric matrix  and the strictly */
+/*           upper triangular part of C is not referenced.  On exit, the */
+/*           lower triangular part of the array  C is overwritten by the */
+/*           lower triangular part of the updated matrix. */
+
+/*  LDC    - INTEGER. */
+/*           On entry, LDC specifies the first dimension of C as declared */
+/*           in  the  calling  (sub)  program.   LDC  must  be  at  least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    c_dim1 = *ldc;
+    c_offset = 1 + c_dim1;
+    c__ -= c_offset;
+
+    /* Function Body */
+    if (lsame_(trans, "N")) {
+	nrowa = *n;
+    } else {
+	nrowa = *k;
+    }
+    upper = lsame_(uplo, "U");
+
+    info = 0;
+    if (! upper && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (*n < 0) {
+	info = 3;
+    } else if (*k < 0) {
+	info = 4;
+    } else if (*lda < max(1,nrowa)) {
+	info = 7;
+    } else if (*ldc < max(1,*n)) {
+	info = 10;
+    }
+    if (info != 0) {
+	xerbla_("DSYRK ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0 || (*alpha == 0. || *k == 0) && *beta == 1.) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	if (upper) {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L10: */
+		    }
+/* L20: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L30: */
+		    }
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*beta == 0.) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L50: */
+		    }
+/* L60: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L70: */
+		    }
+/* L80: */
+		}
+	    }
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  C := alpha*A*A' + beta*C. */
+
+	if (upper) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L90: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = j;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L100: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (a[j + l * a_dim1] != 0.) {
+			temp = *alpha * a[j + l * a_dim1];
+			i__3 = j;
+			for (i__ = 1; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
+				    a_dim1];
+/* L110: */
+			}
+		    }
+/* L120: */
+		}
+/* L130: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		if (*beta == 0.) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = 0.;
+/* L140: */
+		    }
+		} else if (*beta != 1.) {
+		    i__2 = *n;
+		    for (i__ = j; i__ <= i__2; ++i__) {
+			c__[i__ + j * c_dim1] = *beta * c__[i__ + j * c_dim1];
+/* L150: */
+		    }
+		}
+		i__2 = *k;
+		for (l = 1; l <= i__2; ++l) {
+		    if (a[j + l * a_dim1] != 0.) {
+			temp = *alpha * a[j + l * a_dim1];
+			i__3 = *n;
+			for (i__ = j; i__ <= i__3; ++i__) {
+			    c__[i__ + j * c_dim1] += temp * a[i__ + l * 
+				    a_dim1];
+/* L160: */
+			}
+		    }
+/* L170: */
+		}
+/* L180: */
+	    }
+	}
+    } else {
+
+/*        Form  C := alpha*A'*A + beta*C. */
+
+	if (upper) {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = j;
+		for (i__ = 1; i__ <= i__2; ++i__) {
+		    temp = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
+/* L190: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp;
+		    } else {
+			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+				i__ + j * c_dim1];
+		    }
+/* L200: */
+		}
+/* L210: */
+	    }
+	} else {
+	    i__1 = *n;
+	    for (j = 1; j <= i__1; ++j) {
+		i__2 = *n;
+		for (i__ = j; i__ <= i__2; ++i__) {
+		    temp = 0.;
+		    i__3 = *k;
+		    for (l = 1; l <= i__3; ++l) {
+			temp += a[l + i__ * a_dim1] * a[l + j * a_dim1];
+/* L220: */
+		    }
+		    if (*beta == 0.) {
+			c__[i__ + j * c_dim1] = *alpha * temp;
+		    } else {
+			c__[i__ + j * c_dim1] = *alpha * temp + *beta * c__[
+				i__ + j * c_dim1];
+		    }
+/* L230: */
+		}
+/* L240: */
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DSYRK . */
+
+} /* dsyrk_ */

min-dgels/base/BLAS/SRC/dtbmv.c

@@ -0,0 +1,422 @@
+/* dtbmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtbmv_(char *uplo, char *trans, char *diag, integer *n, 
+	integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+    /* Local variables */
+    integer i__, j, l, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    integer kplus1;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTBMV  performs one of the matrix-vector operations */
+
+/*     x := A*x,   or   x := A'*x, */
+
+/*  where x is an n element vector and  A is an n by n unit, or non-unit, */
+/*  upper or lower triangular band matrix, with ( k + 1 ) diagonals. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   x := A*x. */
+
+/*              TRANS = 'T' or 't'   x := A'*x. */
+
+/*              TRANS = 'C' or 'c'   x := A'*x. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry with UPLO = 'U' or 'u', K specifies the number of */
+/*           super-diagonals of the matrix A. */
+/*           On entry with UPLO = 'L' or 'l', K specifies the number of */
+/*           sub-diagonals of the matrix A. */
+/*           K must satisfy  0 .le. K. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/*           by n part of the array A must contain the upper triangular */
+/*           band part of the matrix of coefficients, supplied column by */
+/*           column, with the leading diagonal of the matrix in row */
+/*           ( k + 1 ) of the array, the first super-diagonal starting at */
+/*           position 2 in row k, and so on. The top left k by k triangle */
+/*           of the array A is not referenced. */
+/*           The following program segment will transfer an upper */
+/*           triangular band matrix from conventional full matrix storage */
+/*           to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    M = K + 1 - J */
+/*                    DO 10, I = MAX( 1, J - K ), J */
+/*                       A( M + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/*           by n part of the array A must contain the lower triangular */
+/*           band part of the matrix of coefficients, supplied column by */
+/*           column, with the leading diagonal of the matrix in row 1 of */
+/*           the array, the first sub-diagonal starting at position 1 in */
+/*           row 2, and so on. The bottom right k by k triangle of the */
+/*           array A is not referenced. */
+/*           The following program segment will transfer a lower */
+/*           triangular band matrix from conventional full matrix storage */
+/*           to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    M = 1 - J */
+/*                    DO 10, I = J, MIN( N, J + K ) */
+/*                       A( M + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Note that when DIAG = 'U' or 'u' the elements of the array A */
+/*           corresponding to the diagonal elements of the matrix are not */
+/*           referenced, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           ( k + 1 ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. On exit, X is overwritten with the */
+/*           tranformed vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*k < 0) {
+	info = 5;
+    } else if (*lda < *k + 1) {
+	info = 7;
+    } else if (*incx == 0) {
+	info = 9;
+    }
+    if (info != 0) {
+	xerbla_("DTBMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX   too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+    if (lsame_(trans, "N")) {
+
+/*         Form  x := A*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kplus1 = *k + 1;
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			l = kplus1 - j;
+/* Computing MAX */
+			i__2 = 1, i__3 = j - *k;
+			i__4 = j - 1;
+			for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+			    x[i__] += temp * a[l + i__ + j * a_dim1];
+/* L10: */
+			}
+			if (nounit) {
+			    x[j] *= a[kplus1 + j * a_dim1];
+			}
+		    }
+/* L20: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			l = kplus1 - j;
+/* Computing MAX */
+			i__4 = 1, i__2 = j - *k;
+			i__3 = j - 1;
+			for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+			    x[ix] += temp * a[l + i__ + j * a_dim1];
+			    ix += *incx;
+/* L30: */
+			}
+			if (nounit) {
+			    x[jx] *= a[kplus1 + j * a_dim1];
+			}
+		    }
+		    jx += *incx;
+		    if (j > *k) {
+			kx += *incx;
+		    }
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			l = 1 - j;
+/* Computing MIN */
+			i__1 = *n, i__3 = j + *k;
+			i__4 = j + 1;
+			for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+			    x[i__] += temp * a[l + i__ + j * a_dim1];
+/* L50: */
+			}
+			if (nounit) {
+			    x[j] *= a[j * a_dim1 + 1];
+			}
+		    }
+/* L60: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			l = 1 - j;
+/* Computing MIN */
+			i__4 = *n, i__1 = j + *k;
+			i__3 = j + 1;
+			for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+			    x[ix] += temp * a[l + i__ + j * a_dim1];
+			    ix -= *incx;
+/* L70: */
+			}
+			if (nounit) {
+			    x[jx] *= a[j * a_dim1 + 1];
+			}
+		    }
+		    jx -= *incx;
+		    if (*n - j >= *k) {
+			kx -= *incx;
+		    }
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := A'*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kplus1 = *k + 1;
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    l = kplus1 - j;
+		    if (nounit) {
+			temp *= a[kplus1 + j * a_dim1];
+		    }
+/* Computing MAX */
+		    i__4 = 1, i__1 = j - *k;
+		    i__3 = max(i__4,i__1);
+		    for (i__ = j - 1; i__ >= i__3; --i__) {
+			temp += a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+		    }
+		    x[j] = temp;
+/* L100: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    kx -= *incx;
+		    ix = kx;
+		    l = kplus1 - j;
+		    if (nounit) {
+			temp *= a[kplus1 + j * a_dim1];
+		    }
+/* Computing MAX */
+		    i__4 = 1, i__1 = j - *k;
+		    i__3 = max(i__4,i__1);
+		    for (i__ = j - 1; i__ >= i__3; --i__) {
+			temp += a[l + i__ + j * a_dim1] * x[ix];
+			ix -= *incx;
+/* L110: */
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+/* L120: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		i__3 = *n;
+		for (j = 1; j <= i__3; ++j) {
+		    temp = x[j];
+		    l = 1 - j;
+		    if (nounit) {
+			temp *= a[j * a_dim1 + 1];
+		    }
+/* Computing MIN */
+		    i__1 = *n, i__2 = j + *k;
+		    i__4 = min(i__1,i__2);
+		    for (i__ = j + 1; i__ <= i__4; ++i__) {
+			temp += a[l + i__ + j * a_dim1] * x[i__];
+/* L130: */
+		    }
+		    x[j] = temp;
+/* L140: */
+		}
+	    } else {
+		jx = kx;
+		i__3 = *n;
+		for (j = 1; j <= i__3; ++j) {
+		    temp = x[jx];
+		    kx += *incx;
+		    ix = kx;
+		    l = 1 - j;
+		    if (nounit) {
+			temp *= a[j * a_dim1 + 1];
+		    }
+/* Computing MIN */
+		    i__1 = *n, i__2 = j + *k;
+		    i__4 = min(i__1,i__2);
+		    for (i__ = j + 1; i__ <= i__4; ++i__) {
+			temp += a[l + i__ + j * a_dim1] * x[ix];
+			ix += *incx;
+/* L150: */
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTBMV . */
+
+} /* dtbmv_ */

min-dgels/base/BLAS/SRC/dtbsv.c

@@ -0,0 +1,426 @@
+/* dtbsv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtbsv_(char *uplo, char *trans, char *diag, integer *n, 
+	integer *k, doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2, i__3, i__4;
+
+    /* Local variables */
+    integer i__, j, l, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    integer kplus1;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTBSV  solves one of the systems of equations */
+
+/*     A*x = b,   or   A'*x = b, */
+
+/*  where b and x are n element vectors and A is an n by n unit, or */
+/*  non-unit, upper or lower triangular band matrix, with ( k + 1 ) */
+/*  diagonals. */
+
+/*  No test for singularity or near-singularity is included in this */
+/*  routine. Such tests must be performed before calling this routine. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the equations to be solved as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   A*x = b. */
+
+/*              TRANS = 'T' or 't'   A'*x = b. */
+
+/*              TRANS = 'C' or 'c'   A'*x = b. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  K      - INTEGER. */
+/*           On entry with UPLO = 'U' or 'u', K specifies the number of */
+/*           super-diagonals of the matrix A. */
+/*           On entry with UPLO = 'L' or 'l', K specifies the number of */
+/*           sub-diagonals of the matrix A. */
+/*           K must satisfy  0 .le. K. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with UPLO = 'U' or 'u', the leading ( k + 1 ) */
+/*           by n part of the array A must contain the upper triangular */
+/*           band part of the matrix of coefficients, supplied column by */
+/*           column, with the leading diagonal of the matrix in row */
+/*           ( k + 1 ) of the array, the first super-diagonal starting at */
+/*           position 2 in row k, and so on. The top left k by k triangle */
+/*           of the array A is not referenced. */
+/*           The following program segment will transfer an upper */
+/*           triangular band matrix from conventional full matrix storage */
+/*           to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    M = K + 1 - J */
+/*                    DO 10, I = MAX( 1, J - K ), J */
+/*                       A( M + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Before entry with UPLO = 'L' or 'l', the leading ( k + 1 ) */
+/*           by n part of the array A must contain the lower triangular */
+/*           band part of the matrix of coefficients, supplied column by */
+/*           column, with the leading diagonal of the matrix in row 1 of */
+/*           the array, the first sub-diagonal starting at position 1 in */
+/*           row 2, and so on. The bottom right k by k triangle of the */
+/*           array A is not referenced. */
+/*           The following program segment will transfer a lower */
+/*           triangular band matrix from conventional full matrix storage */
+/*           to band storage: */
+
+/*                 DO 20, J = 1, N */
+/*                    M = 1 - J */
+/*                    DO 10, I = J, MIN( N, J + K ) */
+/*                       A( M + I, J ) = matrix( I, J ) */
+/*              10    CONTINUE */
+/*              20 CONTINUE */
+
+/*           Note that when DIAG = 'U' or 'u' the elements of the array A */
+/*           corresponding to the diagonal elements of the matrix are not */
+/*           referenced, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           ( k + 1 ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element right-hand side vector b. On exit, X is overwritten */
+/*           with the solution vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*k < 0) {
+	info = 5;
+    } else if (*lda < *k + 1) {
+	info = 7;
+    } else if (*incx == 0) {
+	info = 9;
+    }
+    if (info != 0) {
+	xerbla_("DTBSV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX  too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed by sequentially with one pass through A. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  x := inv( A )*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kplus1 = *k + 1;
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			l = kplus1 - j;
+			if (nounit) {
+			    x[j] /= a[kplus1 + j * a_dim1];
+			}
+			temp = x[j];
+/* Computing MAX */
+			i__2 = 1, i__3 = j - *k;
+			i__1 = max(i__2,i__3);
+			for (i__ = j - 1; i__ >= i__1; --i__) {
+			    x[i__] -= temp * a[l + i__ + j * a_dim1];
+/* L10: */
+			}
+		    }
+/* L20: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    kx -= *incx;
+		    if (x[jx] != 0.) {
+			ix = kx;
+			l = kplus1 - j;
+			if (nounit) {
+			    x[jx] /= a[kplus1 + j * a_dim1];
+			}
+			temp = x[jx];
+/* Computing MAX */
+			i__2 = 1, i__3 = j - *k;
+			i__1 = max(i__2,i__3);
+			for (i__ = j - 1; i__ >= i__1; --i__) {
+			    x[ix] -= temp * a[l + i__ + j * a_dim1];
+			    ix -= *incx;
+/* L30: */
+			}
+		    }
+		    jx -= *incx;
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			l = 1 - j;
+			if (nounit) {
+			    x[j] /= a[j * a_dim1 + 1];
+			}
+			temp = x[j];
+/* Computing MIN */
+			i__3 = *n, i__4 = j + *k;
+			i__2 = min(i__3,i__4);
+			for (i__ = j + 1; i__ <= i__2; ++i__) {
+			    x[i__] -= temp * a[l + i__ + j * a_dim1];
+/* L50: */
+			}
+		    }
+/* L60: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    kx += *incx;
+		    if (x[jx] != 0.) {
+			ix = kx;
+			l = 1 - j;
+			if (nounit) {
+			    x[jx] /= a[j * a_dim1 + 1];
+			}
+			temp = x[jx];
+/* Computing MIN */
+			i__3 = *n, i__4 = j + *k;
+			i__2 = min(i__3,i__4);
+			for (i__ = j + 1; i__ <= i__2; ++i__) {
+			    x[ix] -= temp * a[l + i__ + j * a_dim1];
+			    ix += *incx;
+/* L70: */
+			}
+		    }
+		    jx += *incx;
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := inv( A')*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kplus1 = *k + 1;
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[j];
+		    l = kplus1 - j;
+/* Computing MAX */
+		    i__2 = 1, i__3 = j - *k;
+		    i__4 = j - 1;
+		    for (i__ = max(i__2,i__3); i__ <= i__4; ++i__) {
+			temp -= a[l + i__ + j * a_dim1] * x[i__];
+/* L90: */
+		    }
+		    if (nounit) {
+			temp /= a[kplus1 + j * a_dim1];
+		    }
+		    x[j] = temp;
+/* L100: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[jx];
+		    ix = kx;
+		    l = kplus1 - j;
+/* Computing MAX */
+		    i__4 = 1, i__2 = j - *k;
+		    i__3 = j - 1;
+		    for (i__ = max(i__4,i__2); i__ <= i__3; ++i__) {
+			temp -= a[l + i__ + j * a_dim1] * x[ix];
+			ix += *incx;
+/* L110: */
+		    }
+		    if (nounit) {
+			temp /= a[kplus1 + j * a_dim1];
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+		    if (j > *k) {
+			kx += *incx;
+		    }
+/* L120: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    l = 1 - j;
+/* Computing MIN */
+		    i__1 = *n, i__3 = j + *k;
+		    i__4 = j + 1;
+		    for (i__ = min(i__1,i__3); i__ >= i__4; --i__) {
+			temp -= a[l + i__ + j * a_dim1] * x[i__];
+/* L130: */
+		    }
+		    if (nounit) {
+			temp /= a[j * a_dim1 + 1];
+		    }
+		    x[j] = temp;
+/* L140: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    ix = kx;
+		    l = 1 - j;
+/* Computing MIN */
+		    i__4 = *n, i__1 = j + *k;
+		    i__3 = j + 1;
+		    for (i__ = min(i__4,i__1); i__ >= i__3; --i__) {
+			temp -= a[l + i__ + j * a_dim1] * x[ix];
+			ix -= *incx;
+/* L150: */
+		    }
+		    if (nounit) {
+			temp /= a[j * a_dim1 + 1];
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+		    if (*n - j >= *k) {
+			kx -= *incx;
+		    }
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTBSV . */
+
+} /* dtbsv_ */

min-dgels/base/BLAS/SRC/dtpmv.c

@@ -0,0 +1,357 @@
+/* dtpmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpmv_(char *uplo, char *trans, char *diag, integer *n, 
+	doublereal *ap, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k, kk, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTPMV  performs one of the matrix-vector operations */
+
+/*     x := A*x,   or   x := A'*x, */
+
+/*  where x is an n element vector and  A is an n by n unit, or non-unit, */
+/*  upper or lower triangular matrix, supplied in packed form. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   x := A*x. */
+
+/*              TRANS = 'T' or 't'   x := A'*x. */
+
+/*              TRANS = 'C' or 'c'   x := A'*x. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  AP     - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( ( n*( n + 1 ) )/2 ). */
+/*           Before entry with  UPLO = 'U' or 'u', the array AP must */
+/*           contain the upper triangular matrix packed sequentially, */
+/*           column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/*           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/*           respectively, and so on. */
+/*           Before entry with UPLO = 'L' or 'l', the array AP must */
+/*           contain the lower triangular matrix packed sequentially, */
+/*           column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/*           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/*           respectively, and so on. */
+/*           Note that when  DIAG = 'U' or 'u', the diagonal elements of */
+/*           A are not referenced, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. On exit, X is overwritten with the */
+/*           tranformed vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --x;
+    --ap;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*incx == 0) {
+	info = 7;
+    }
+    if (info != 0) {
+	xerbla_("DTPMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX  too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of AP are */
+/*     accessed sequentially with one pass through AP. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  x:= A*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kk = 1;
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			k = kk;
+			i__2 = j - 1;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    x[i__] += temp * ap[k];
+			    ++k;
+/* L10: */
+			}
+			if (nounit) {
+			    x[j] *= ap[kk + j - 1];
+			}
+		    }
+		    kk += j;
+/* L20: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			i__2 = kk + j - 2;
+			for (k = kk; k <= i__2; ++k) {
+			    x[ix] += temp * ap[k];
+			    ix += *incx;
+/* L30: */
+			}
+			if (nounit) {
+			    x[jx] *= ap[kk + j - 1];
+			}
+		    }
+		    jx += *incx;
+		    kk += j;
+/* L40: */
+		}
+	    }
+	} else {
+	    kk = *n * (*n + 1) / 2;
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			k = kk;
+			i__1 = j + 1;
+			for (i__ = *n; i__ >= i__1; --i__) {
+			    x[i__] += temp * ap[k];
+			    --k;
+/* L50: */
+			}
+			if (nounit) {
+			    x[j] *= ap[kk - *n + j];
+			}
+		    }
+		    kk -= *n - j + 1;
+/* L60: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			i__1 = kk - (*n - (j + 1));
+			for (k = kk; k >= i__1; --k) {
+			    x[ix] += temp * ap[k];
+			    ix -= *incx;
+/* L70: */
+			}
+			if (nounit) {
+			    x[jx] *= ap[kk - *n + j];
+			}
+		    }
+		    jx -= *incx;
+		    kk -= *n - j + 1;
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := A'*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kk = *n * (*n + 1) / 2;
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    if (nounit) {
+			temp *= ap[kk];
+		    }
+		    k = kk - 1;
+		    for (i__ = j - 1; i__ >= 1; --i__) {
+			temp += ap[k] * x[i__];
+			--k;
+/* L90: */
+		    }
+		    x[j] = temp;
+		    kk -= j;
+/* L100: */
+		}
+	    } else {
+		jx = kx + (*n - 1) * *incx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    ix = jx;
+		    if (nounit) {
+			temp *= ap[kk];
+		    }
+		    i__1 = kk - j + 1;
+		    for (k = kk - 1; k >= i__1; --k) {
+			ix -= *incx;
+			temp += ap[k] * x[ix];
+/* L110: */
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+		    kk -= j;
+/* L120: */
+		}
+	    }
+	} else {
+	    kk = 1;
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[j];
+		    if (nounit) {
+			temp *= ap[kk];
+		    }
+		    k = kk + 1;
+		    i__2 = *n;
+		    for (i__ = j + 1; i__ <= i__2; ++i__) {
+			temp += ap[k] * x[i__];
+			++k;
+/* L130: */
+		    }
+		    x[j] = temp;
+		    kk += *n - j + 1;
+/* L140: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[jx];
+		    ix = jx;
+		    if (nounit) {
+			temp *= ap[kk];
+		    }
+		    i__2 = kk + *n - j;
+		    for (k = kk + 1; k <= i__2; ++k) {
+			ix += *incx;
+			temp += ap[k] * x[ix];
+/* L150: */
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+		    kk += *n - j + 1;
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTPMV . */
+
+} /* dtpmv_ */

min-dgels/base/BLAS/SRC/dtpsv.c

@@ -0,0 +1,360 @@
+/* dtpsv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtpsv_(char *uplo, char *trans, char *diag, integer *n, 
+	doublereal *ap, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, k, kk, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTPSV  solves one of the systems of equations */
+
+/*     A*x = b,   or   A'*x = b, */
+
+/*  where b and x are n element vectors and A is an n by n unit, or */
+/*  non-unit, upper or lower triangular matrix, supplied in packed form. */
+
+/*  No test for singularity or near-singularity is included in this */
+/*  routine. Such tests must be performed before calling this routine. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the equations to be solved as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   A*x = b. */
+
+/*              TRANS = 'T' or 't'   A'*x = b. */
+
+/*              TRANS = 'C' or 'c'   A'*x = b. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  AP     - DOUBLE PRECISION array of DIMENSION at least */
+/*           ( ( n*( n + 1 ) )/2 ). */
+/*           Before entry with  UPLO = 'U' or 'u', the array AP must */
+/*           contain the upper triangular matrix packed sequentially, */
+/*           column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/*           AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 ) */
+/*           respectively, and so on. */
+/*           Before entry with UPLO = 'L' or 'l', the array AP must */
+/*           contain the lower triangular matrix packed sequentially, */
+/*           column by column, so that AP( 1 ) contains a( 1, 1 ), */
+/*           AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 ) */
+/*           respectively, and so on. */
+/*           Note that when  DIAG = 'U' or 'u', the diagonal elements of */
+/*           A are not referenced, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element right-hand side vector b. On exit, X is overwritten */
+/*           with the solution vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    --x;
+    --ap;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*incx == 0) {
+	info = 7;
+    }
+    if (info != 0) {
+	xerbla_("DTPSV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX  too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of AP are */
+/*     accessed sequentially with one pass through AP. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  x := inv( A )*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kk = *n * (*n + 1) / 2;
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			if (nounit) {
+			    x[j] /= ap[kk];
+			}
+			temp = x[j];
+			k = kk - 1;
+			for (i__ = j - 1; i__ >= 1; --i__) {
+			    x[i__] -= temp * ap[k];
+			    --k;
+/* L10: */
+			}
+		    }
+		    kk -= j;
+/* L20: */
+		}
+	    } else {
+		jx = kx + (*n - 1) * *incx;
+		for (j = *n; j >= 1; --j) {
+		    if (x[jx] != 0.) {
+			if (nounit) {
+			    x[jx] /= ap[kk];
+			}
+			temp = x[jx];
+			ix = jx;
+			i__1 = kk - j + 1;
+			for (k = kk - 1; k >= i__1; --k) {
+			    ix -= *incx;
+			    x[ix] -= temp * ap[k];
+/* L30: */
+			}
+		    }
+		    jx -= *incx;
+		    kk -= j;
+/* L40: */
+		}
+	    }
+	} else {
+	    kk = 1;
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			if (nounit) {
+			    x[j] /= ap[kk];
+			}
+			temp = x[j];
+			k = kk + 1;
+			i__2 = *n;
+			for (i__ = j + 1; i__ <= i__2; ++i__) {
+			    x[i__] -= temp * ap[k];
+			    ++k;
+/* L50: */
+			}
+		    }
+		    kk += *n - j + 1;
+/* L60: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[jx] != 0.) {
+			if (nounit) {
+			    x[jx] /= ap[kk];
+			}
+			temp = x[jx];
+			ix = jx;
+			i__2 = kk + *n - j;
+			for (k = kk + 1; k <= i__2; ++k) {
+			    ix += *incx;
+			    x[ix] -= temp * ap[k];
+/* L70: */
+			}
+		    }
+		    jx += *incx;
+		    kk += *n - j + 1;
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := inv( A' )*x. */
+
+	if (lsame_(uplo, "U")) {
+	    kk = 1;
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[j];
+		    k = kk;
+		    i__2 = j - 1;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp -= ap[k] * x[i__];
+			++k;
+/* L90: */
+		    }
+		    if (nounit) {
+			temp /= ap[kk + j - 1];
+		    }
+		    x[j] = temp;
+		    kk += j;
+/* L100: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[jx];
+		    ix = kx;
+		    i__2 = kk + j - 2;
+		    for (k = kk; k <= i__2; ++k) {
+			temp -= ap[k] * x[ix];
+			ix += *incx;
+/* L110: */
+		    }
+		    if (nounit) {
+			temp /= ap[kk + j - 1];
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+		    kk += j;
+/* L120: */
+		}
+	    }
+	} else {
+	    kk = *n * (*n + 1) / 2;
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    k = kk;
+		    i__1 = j + 1;
+		    for (i__ = *n; i__ >= i__1; --i__) {
+			temp -= ap[k] * x[i__];
+			--k;
+/* L130: */
+		    }
+		    if (nounit) {
+			temp /= ap[kk - *n + j];
+		    }
+		    x[j] = temp;
+		    kk -= *n - j + 1;
+/* L140: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    ix = kx;
+		    i__1 = kk - (*n - (j + 1));
+		    for (k = kk; k >= i__1; --k) {
+			temp -= ap[k] * x[ix];
+			ix -= *incx;
+/* L150: */
+		    }
+		    if (nounit) {
+			temp /= ap[kk - *n + j];
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+		    kk -= *n - j + 1;
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTPSV . */
+
+} /* dtpsv_ */

min-dgels/base/BLAS/SRC/dtrmm.c

@@ -0,0 +1,453 @@
+/* dtrmm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrmm_(char *side, char *uplo, char *transa, char *diag, 
+	integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+	lda, doublereal *b, integer *ldb)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, k, info;
+    doublereal temp;
+    logical lside;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRMM  performs one of the matrix-matrix operations */
+
+/*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ), */
+
+/*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or */
+/*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of */
+
+/*     op( A ) = A   or   op( A ) = A'. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  SIDE   - CHARACTER*1. */
+/*           On entry,  SIDE specifies whether  op( A ) multiplies B from */
+/*           the left or right as follows: */
+
+/*              SIDE = 'L' or 'l'   B := alpha*op( A )*B. */
+
+/*              SIDE = 'R' or 'r'   B := alpha*B*op( A ). */
+
+/*           Unchanged on exit. */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix A is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANSA - CHARACTER*1. */
+/*           On entry, TRANSA specifies the form of op( A ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSA = 'N' or 'n'   op( A ) = A. */
+
+/*              TRANSA = 'T' or 't'   op( A ) = A'. */
+
+/*              TRANSA = 'C' or 'c'   op( A ) = A'. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit triangular */
+/*           as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of B. M must be at */
+/*           least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of B.  N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is */
+/*           zero then  A is not referenced and  B need not be set before */
+/*           entry. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
+/*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'. */
+/*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k */
+/*           upper triangular part of the array  A must contain the upper */
+/*           triangular matrix  and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k */
+/*           lower triangular part of the array  A must contain the lower */
+/*           triangular matrix  and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of */
+/*           A  are not referenced either,  but are assumed to be  unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then */
+/*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r' */
+/*           then LDA must be at least max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/*           Before entry,  the leading  m by n part of the array  B must */
+/*           contain the matrix  B,  and  on exit  is overwritten  by the */
+/*           transformed matrix. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in  the  calling  (sub)  program.   LDB  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+
+    /* Function Body */
+    lside = lsame_(side, "L");
+    if (lside) {
+	nrowa = *m;
+    } else {
+	nrowa = *n;
+    }
+    nounit = lsame_(diag, "N");
+    upper = lsame_(uplo, "U");
+
+    info = 0;
+    if (! lside && ! lsame_(side, "R")) {
+	info = 1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	info = 2;
+    } else if (! lsame_(transa, "N") && ! lsame_(transa, 
+	     "T") && ! lsame_(transa, "C")) {
+	info = 3;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 4;
+    } else if (*m < 0) {
+	info = 5;
+    } else if (*n < 0) {
+	info = 6;
+    } else if (*lda < max(1,nrowa)) {
+	info = 9;
+    } else if (*ldb < max(1,*m)) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DTRMM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		b[i__ + j * b_dim1] = 0.;
+/* L10: */
+	    }
+/* L20: */
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lside) {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*A*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *m;
+		    for (k = 1; k <= i__2; ++k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    temp = *alpha * b[k + j * b_dim1];
+			    i__3 = k - 1;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] += temp * a[i__ + k * 
+					a_dim1];
+/* L30: */
+			    }
+			    if (nounit) {
+				temp *= a[k + k * a_dim1];
+			    }
+			    b[k + j * b_dim1] = temp;
+			}
+/* L40: */
+		    }
+/* L50: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    for (k = *m; k >= 1; --k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    temp = *alpha * b[k + j * b_dim1];
+			    b[k + j * b_dim1] = temp;
+			    if (nounit) {
+				b[k + j * b_dim1] *= a[k + k * a_dim1];
+			    }
+			    i__2 = *m;
+			    for (i__ = k + 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] += temp * a[i__ + k * 
+					a_dim1];
+/* L60: */
+			    }
+			}
+/* L70: */
+		    }
+/* L80: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*A'*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    for (i__ = *m; i__ >= 1; --i__) {
+			temp = b[i__ + j * b_dim1];
+			if (nounit) {
+			    temp *= a[i__ + i__ * a_dim1];
+			}
+			i__2 = i__ - 1;
+			for (k = 1; k <= i__2; ++k) {
+			    temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L90: */
+			}
+			b[i__ + j * b_dim1] = *alpha * temp;
+/* L100: */
+		    }
+/* L110: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp = b[i__ + j * b_dim1];
+			if (nounit) {
+			    temp *= a[i__ + i__ * a_dim1];
+			}
+			i__3 = *m;
+			for (k = i__ + 1; k <= i__3; ++k) {
+			    temp += a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L120: */
+			}
+			b[i__ + j * b_dim1] = *alpha * temp;
+/* L130: */
+		    }
+/* L140: */
+		}
+	    }
+	}
+    } else {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*B*A. */
+
+	    if (upper) {
+		for (j = *n; j >= 1; --j) {
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__1 = *m;
+		    for (i__ = 1; i__ <= i__1; ++i__) {
+			b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L150: */
+		    }
+		    i__1 = j - 1;
+		    for (k = 1; k <= i__1; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    temp = *alpha * a[k + j * a_dim1];
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L160: */
+			    }
+			}
+/* L170: */
+		    }
+/* L180: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L190: */
+		    }
+		    i__2 = *n;
+		    for (k = j + 1; k <= i__2; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    temp = *alpha * a[k + j * a_dim1];
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L200: */
+			    }
+			}
+/* L210: */
+		    }
+/* L220: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*B*A'. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (k = 1; k <= i__1; ++k) {
+		    i__2 = k - 1;
+		    for (j = 1; j <= i__2; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = *alpha * a[j + k * a_dim1];
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L230: */
+			    }
+			}
+/* L240: */
+		    }
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[k + k * a_dim1];
+		    }
+		    if (temp != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L250: */
+			}
+		    }
+/* L260: */
+		}
+	    } else {
+		for (k = *n; k >= 1; --k) {
+		    i__1 = *n;
+		    for (j = k + 1; j <= i__1; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = *alpha * a[j + k * a_dim1];
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] += temp * b[i__ + k * 
+					b_dim1];
+/* L270: */
+			    }
+			}
+/* L280: */
+		    }
+		    temp = *alpha;
+		    if (nounit) {
+			temp *= a[k + k * a_dim1];
+		    }
+		    if (temp != 1.) {
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L290: */
+			}
+		    }
+/* L300: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRMM . */
+
+} /* dtrmm_ */

min-dgels/base/BLAS/SRC/dtrmv.c

@@ -0,0 +1,345 @@
+/* dtrmv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrmv_(char *uplo, char *trans, char *diag, integer *n, 
+	doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRMV  performs one of the matrix-vector operations */
+
+/*     x := A*x,   or   x := A'*x, */
+
+/*  where x is an n element vector and  A is an n by n unit, or non-unit, */
+/*  upper or lower triangular matrix. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the operation to be performed as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   x := A*x. */
+
+/*              TRANS = 'T' or 't'   x := A'*x. */
+
+/*              TRANS = 'C' or 'c'   x := A'*x. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with  UPLO = 'U' or 'u', the leading n by n */
+/*           upper triangular part of the array A must contain the upper */
+/*           triangular matrix and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry with UPLO = 'L' or 'l', the leading n by n */
+/*           lower triangular part of the array A must contain the lower */
+/*           triangular matrix and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u', the diagonal elements of */
+/*           A are not referenced either, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element vector x. On exit, X is overwritten with the */
+/*           tranformed vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*lda < max(1,*n)) {
+	info = 6;
+    } else if (*incx == 0) {
+	info = 8;
+    }
+    if (info != 0) {
+	xerbla_("DTRMV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX  too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  x := A*x. */
+
+	if (lsame_(uplo, "U")) {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			i__2 = j - 1;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    x[i__] += temp * a[i__ + j * a_dim1];
+/* L10: */
+			}
+			if (nounit) {
+			    x[j] *= a[j + j * a_dim1];
+			}
+		    }
+/* L20: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			i__2 = j - 1;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    x[ix] += temp * a[i__ + j * a_dim1];
+			    ix += *incx;
+/* L30: */
+			}
+			if (nounit) {
+			    x[jx] *= a[j + j * a_dim1];
+			}
+		    }
+		    jx += *incx;
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			temp = x[j];
+			i__1 = j + 1;
+			for (i__ = *n; i__ >= i__1; --i__) {
+			    x[i__] += temp * a[i__ + j * a_dim1];
+/* L50: */
+			}
+			if (nounit) {
+			    x[j] *= a[j + j * a_dim1];
+			}
+		    }
+/* L60: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    if (x[jx] != 0.) {
+			temp = x[jx];
+			ix = kx;
+			i__1 = j + 1;
+			for (i__ = *n; i__ >= i__1; --i__) {
+			    x[ix] += temp * a[i__ + j * a_dim1];
+			    ix -= *incx;
+/* L70: */
+			}
+			if (nounit) {
+			    x[jx] *= a[j + j * a_dim1];
+			}
+		    }
+		    jx -= *incx;
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := A'*x. */
+
+	if (lsame_(uplo, "U")) {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    for (i__ = j - 1; i__ >= 1; --i__) {
+			temp += a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+		    }
+		    x[j] = temp;
+/* L100: */
+		}
+	    } else {
+		jx = kx + (*n - 1) * *incx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    ix = jx;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    for (i__ = j - 1; i__ >= 1; --i__) {
+			ix -= *incx;
+			temp += a[i__ + j * a_dim1] * x[ix];
+/* L110: */
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+/* L120: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[j];
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__2 = *n;
+		    for (i__ = j + 1; i__ <= i__2; ++i__) {
+			temp += a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+		    }
+		    x[j] = temp;
+/* L140: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[jx];
+		    ix = jx;
+		    if (nounit) {
+			temp *= a[j + j * a_dim1];
+		    }
+		    i__2 = *n;
+		    for (i__ = j + 1; i__ <= i__2; ++i__) {
+			ix += *incx;
+			temp += a[i__ + j * a_dim1] * x[ix];
+/* L150: */
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRMV . */
+
+} /* dtrmv_ */

min-dgels/base/BLAS/SRC/dtrsm.c

@@ -0,0 +1,490 @@
+/* dtrsm.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrsm_(char *side, char *uplo, char *transa, char *diag, 
+	integer *m, integer *n, doublereal *alpha, doublereal *a, integer *
+	lda, doublereal *b, integer *ldb)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3;
+
+    /* Local variables */
+    integer i__, j, k, info;
+    doublereal temp;
+    logical lside;
+    extern logical lsame_(char *, char *);
+    integer nrowa;
+    logical upper;
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRSM  solves one of the matrix equations */
+
+/*     op( A )*X = alpha*B,   or   X*op( A ) = alpha*B, */
+
+/*  where alpha is a scalar, X and B are m by n matrices, A is a unit, or */
+/*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of */
+
+/*     op( A ) = A   or   op( A ) = A'. */
+
+/*  The matrix X is overwritten on B. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  SIDE   - CHARACTER*1. */
+/*           On entry, SIDE specifies whether op( A ) appears on the left */
+/*           or right of X as follows: */
+
+/*              SIDE = 'L' or 'l'   op( A )*X = alpha*B. */
+
+/*              SIDE = 'R' or 'r'   X*op( A ) = alpha*B. */
+
+/*           Unchanged on exit. */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix A is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANSA - CHARACTER*1. */
+/*           On entry, TRANSA specifies the form of op( A ) to be used in */
+/*           the matrix multiplication as follows: */
+
+/*              TRANSA = 'N' or 'n'   op( A ) = A. */
+
+/*              TRANSA = 'T' or 't'   op( A ) = A'. */
+
+/*              TRANSA = 'C' or 'c'   op( A ) = A'. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit triangular */
+/*           as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  M      - INTEGER. */
+/*           On entry, M specifies the number of rows of B. M must be at */
+/*           least zero. */
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the number of columns of B.  N must be */
+/*           at least zero. */
+/*           Unchanged on exit. */
+
+/*  ALPHA  - DOUBLE PRECISION. */
+/*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is */
+/*           zero then  A is not referenced and  B need not be set before */
+/*           entry. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m */
+/*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'. */
+/*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k */
+/*           upper triangular part of the array  A must contain the upper */
+/*           triangular matrix  and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k */
+/*           lower triangular part of the array  A must contain the lower */
+/*           triangular matrix  and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of */
+/*           A  are not referenced either,  but are assumed to be  unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then */
+/*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r' */
+/*           then LDA must be at least max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ). */
+/*           Before entry,  the leading  m by n part of the array  B must */
+/*           contain  the  right-hand  side  matrix  B,  and  on exit  is */
+/*           overwritten by the solution matrix  X. */
+
+/*  LDB    - INTEGER. */
+/*           On entry, LDB specifies the first dimension of B as declared */
+/*           in  the  calling  (sub)  program.   LDB  must  be  at  least */
+/*           max( 1, m ). */
+/*           Unchanged on exit. */
+
+
+/*  Level 3 Blas routine. */
+
+
+/*  -- Written on 8-February-1989. */
+/*     Jack Dongarra, Argonne National Laboratory. */
+/*     Iain Duff, AERE Harwell. */
+/*     Jeremy Du Croz, Numerical Algorithms Group Ltd. */
+/*     Sven Hammarling, Numerical Algorithms Group Ltd. */
+
+
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Parameters .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    b_dim1 = *ldb;
+    b_offset = 1 + b_dim1;
+    b -= b_offset;
+
+    /* Function Body */
+    lside = lsame_(side, "L");
+    if (lside) {
+	nrowa = *m;
+    } else {
+	nrowa = *n;
+    }
+    nounit = lsame_(diag, "N");
+    upper = lsame_(uplo, "U");
+
+    info = 0;
+    if (! lside && ! lsame_(side, "R")) {
+	info = 1;
+    } else if (! upper && ! lsame_(uplo, "L")) {
+	info = 2;
+    } else if (! lsame_(transa, "N") && ! lsame_(transa, 
+	     "T") && ! lsame_(transa, "C")) {
+	info = 3;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 4;
+    } else if (*m < 0) {
+	info = 5;
+    } else if (*n < 0) {
+	info = 6;
+    } else if (*lda < max(1,nrowa)) {
+	info = 9;
+    } else if (*ldb < max(1,*m)) {
+	info = 11;
+    }
+    if (info != 0) {
+	xerbla_("DTRSM ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*m == 0 || *n == 0) {
+	return 0;
+    }
+
+/*     And when  alpha.eq.zero. */
+
+    if (*alpha == 0.) {
+	i__1 = *n;
+	for (j = 1; j <= i__1; ++j) {
+	    i__2 = *m;
+	    for (i__ = 1; i__ <= i__2; ++i__) {
+		b[i__ + j * b_dim1] = 0.;
+/* L10: */
+	    }
+/* L20: */
+	}
+	return 0;
+    }
+
+/*     Start the operations. */
+
+    if (lside) {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*inv( A )*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L30: */
+			}
+		    }
+		    for (k = *m; k >= 1; --k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    if (nounit) {
+				b[k + j * b_dim1] /= a[k + k * a_dim1];
+			    }
+			    i__2 = k - 1;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+					i__ + k * a_dim1];
+/* L40: */
+			    }
+			}
+/* L50: */
+		    }
+/* L60: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L70: */
+			}
+		    }
+		    i__2 = *m;
+		    for (k = 1; k <= i__2; ++k) {
+			if (b[k + j * b_dim1] != 0.) {
+			    if (nounit) {
+				b[k + j * b_dim1] /= a[k + k * a_dim1];
+			    }
+			    i__3 = *m;
+			    for (i__ = k + 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] -= b[k + j * b_dim1] * a[
+					i__ + k * a_dim1];
+/* L80: */
+			    }
+			}
+/* L90: */
+		    }
+/* L100: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*inv( A' )*B. */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    i__2 = *m;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp = *alpha * b[i__ + j * b_dim1];
+			i__3 = i__ - 1;
+			for (k = 1; k <= i__3; ++k) {
+			    temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L110: */
+			}
+			if (nounit) {
+			    temp /= a[i__ + i__ * a_dim1];
+			}
+			b[i__ + j * b_dim1] = temp;
+/* L120: */
+		    }
+/* L130: */
+		}
+	    } else {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    for (i__ = *m; i__ >= 1; --i__) {
+			temp = *alpha * b[i__ + j * b_dim1];
+			i__2 = *m;
+			for (k = i__ + 1; k <= i__2; ++k) {
+			    temp -= a[k + i__ * a_dim1] * b[k + j * b_dim1];
+/* L140: */
+			}
+			if (nounit) {
+			    temp /= a[i__ + i__ * a_dim1];
+			}
+			b[i__ + j * b_dim1] = temp;
+/* L150: */
+		    }
+/* L160: */
+		}
+	    }
+	}
+    } else {
+	if (lsame_(transa, "N")) {
+
+/*           Form  B := alpha*B*inv( A ). */
+
+	    if (upper) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L170: */
+			}
+		    }
+		    i__2 = j - 1;
+		    for (k = 1; k <= i__2; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+					i__ + k * b_dim1];
+/* L180: */
+			    }
+			}
+/* L190: */
+		    }
+		    if (nounit) {
+			temp = 1. / a[j + j * a_dim1];
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L200: */
+			}
+		    }
+/* L210: */
+		}
+	    } else {
+		for (j = *n; j >= 1; --j) {
+		    if (*alpha != 1.) {
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + j * b_dim1] = *alpha * b[i__ + j * b_dim1]
+				    ;
+/* L220: */
+			}
+		    }
+		    i__1 = *n;
+		    for (k = j + 1; k <= i__1; ++k) {
+			if (a[k + j * a_dim1] != 0.) {
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] -= a[k + j * a_dim1] * b[
+					i__ + k * b_dim1];
+/* L230: */
+			    }
+			}
+/* L240: */
+		    }
+		    if (nounit) {
+			temp = 1. / a[j + j * a_dim1];
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + j * b_dim1] = temp * b[i__ + j * b_dim1];
+/* L250: */
+			}
+		    }
+/* L260: */
+		}
+	    }
+	} else {
+
+/*           Form  B := alpha*B*inv( A' ). */
+
+	    if (upper) {
+		for (k = *n; k >= 1; --k) {
+		    if (nounit) {
+			temp = 1. / a[k + k * a_dim1];
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L270: */
+			}
+		    }
+		    i__1 = k - 1;
+		    for (j = 1; j <= i__1; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = a[j + k * a_dim1];
+			    i__2 = *m;
+			    for (i__ = 1; i__ <= i__2; ++i__) {
+				b[i__ + j * b_dim1] -= temp * b[i__ + k * 
+					b_dim1];
+/* L280: */
+			    }
+			}
+/* L290: */
+		    }
+		    if (*alpha != 1.) {
+			i__1 = *m;
+			for (i__ = 1; i__ <= i__1; ++i__) {
+			    b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+				    ;
+/* L300: */
+			}
+		    }
+/* L310: */
+		}
+	    } else {
+		i__1 = *n;
+		for (k = 1; k <= i__1; ++k) {
+		    if (nounit) {
+			temp = 1. / a[k + k * a_dim1];
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + k * b_dim1] = temp * b[i__ + k * b_dim1];
+/* L320: */
+			}
+		    }
+		    i__2 = *n;
+		    for (j = k + 1; j <= i__2; ++j) {
+			if (a[j + k * a_dim1] != 0.) {
+			    temp = a[j + k * a_dim1];
+			    i__3 = *m;
+			    for (i__ = 1; i__ <= i__3; ++i__) {
+				b[i__ + j * b_dim1] -= temp * b[i__ + k * 
+					b_dim1];
+/* L330: */
+			    }
+			}
+/* L340: */
+		    }
+		    if (*alpha != 1.) {
+			i__2 = *m;
+			for (i__ = 1; i__ <= i__2; ++i__) {
+			    b[i__ + k * b_dim1] = *alpha * b[i__ + k * b_dim1]
+				    ;
+/* L350: */
+			}
+		    }
+/* L360: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRSM . */
+
+} /* dtrsm_ */

min-dgels/base/BLAS/SRC/dtrsv.c

@@ -0,0 +1,348 @@
+/* dtrsv.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+/* Subroutine */ int dtrsv_(char *uplo, char *trans, char *diag, integer *n, 
+	doublereal *a, integer *lda, doublereal *x, integer *incx)
+{
+    /* System generated locals */
+    integer a_dim1, a_offset, i__1, i__2;
+
+    /* Local variables */
+    integer i__, j, ix, jx, kx, info;
+    doublereal temp;
+    extern logical lsame_(char *, char *);
+    extern /* Subroutine */ int xerbla_(char *, integer *);
+    logical nounit;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DTRSV  solves one of the systems of equations */
+
+/*     A*x = b,   or   A'*x = b, */
+
+/*  where b and x are n element vectors and A is an n by n unit, or */
+/*  non-unit, upper or lower triangular matrix. */
+
+/*  No test for singularity or near-singularity is included in this */
+/*  routine. Such tests must be performed before calling this routine. */
+
+/*  Arguments */
+/*  ========== */
+
+/*  UPLO   - CHARACTER*1. */
+/*           On entry, UPLO specifies whether the matrix is an upper or */
+/*           lower triangular matrix as follows: */
+
+/*              UPLO = 'U' or 'u'   A is an upper triangular matrix. */
+
+/*              UPLO = 'L' or 'l'   A is a lower triangular matrix. */
+
+/*           Unchanged on exit. */
+
+/*  TRANS  - CHARACTER*1. */
+/*           On entry, TRANS specifies the equations to be solved as */
+/*           follows: */
+
+/*              TRANS = 'N' or 'n'   A*x = b. */
+
+/*              TRANS = 'T' or 't'   A'*x = b. */
+
+/*              TRANS = 'C' or 'c'   A'*x = b. */
+
+/*           Unchanged on exit. */
+
+/*  DIAG   - CHARACTER*1. */
+/*           On entry, DIAG specifies whether or not A is unit */
+/*           triangular as follows: */
+
+/*              DIAG = 'U' or 'u'   A is assumed to be unit triangular. */
+
+/*              DIAG = 'N' or 'n'   A is not assumed to be unit */
+/*                                  triangular. */
+
+/*           Unchanged on exit. */
+
+/*  N      - INTEGER. */
+/*           On entry, N specifies the order of the matrix A. */
+/*           N must be at least zero. */
+/*           Unchanged on exit. */
+
+/*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ). */
+/*           Before entry with  UPLO = 'U' or 'u', the leading n by n */
+/*           upper triangular part of the array A must contain the upper */
+/*           triangular matrix and the strictly lower triangular part of */
+/*           A is not referenced. */
+/*           Before entry with UPLO = 'L' or 'l', the leading n by n */
+/*           lower triangular part of the array A must contain the lower */
+/*           triangular matrix and the strictly upper triangular part of */
+/*           A is not referenced. */
+/*           Note that when  DIAG = 'U' or 'u', the diagonal elements of */
+/*           A are not referenced either, but are assumed to be unity. */
+/*           Unchanged on exit. */
+
+/*  LDA    - INTEGER. */
+/*           On entry, LDA specifies the first dimension of A as declared */
+/*           in the calling (sub) program. LDA must be at least */
+/*           max( 1, n ). */
+/*           Unchanged on exit. */
+
+/*  X      - DOUBLE PRECISION array of dimension at least */
+/*           ( 1 + ( n - 1 )*abs( INCX ) ). */
+/*           Before entry, the incremented array X must contain the n */
+/*           element right-hand side vector b. On exit, X is overwritten */
+/*           with the solution vector x. */
+
+/*  INCX   - INTEGER. */
+/*           On entry, INCX specifies the increment for the elements of */
+/*           X. INCX must not be zero. */
+/*           Unchanged on exit. */
+
+
+/*  Level 2 Blas routine. */
+
+/*  -- Written on 22-October-1986. */
+/*     Jack Dongarra, Argonne National Lab. */
+/*     Jeremy Du Croz, Nag Central Office. */
+/*     Sven Hammarling, Nag Central Office. */
+/*     Richard Hanson, Sandia National Labs. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+/*     .. External Subroutines .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+
+/*     Test the input parameters. */
+
+    /* Parameter adjustments */
+    a_dim1 = *lda;
+    a_offset = 1 + a_dim1;
+    a -= a_offset;
+    --x;
+
+    /* Function Body */
+    info = 0;
+    if (! lsame_(uplo, "U") && ! lsame_(uplo, "L")) {
+	info = 1;
+    } else if (! lsame_(trans, "N") && ! lsame_(trans, 
+	    "T") && ! lsame_(trans, "C")) {
+	info = 2;
+    } else if (! lsame_(diag, "U") && ! lsame_(diag, 
+	    "N")) {
+	info = 3;
+    } else if (*n < 0) {
+	info = 4;
+    } else if (*lda < max(1,*n)) {
+	info = 6;
+    } else if (*incx == 0) {
+	info = 8;
+    }
+    if (info != 0) {
+	xerbla_("DTRSV ", &info);
+	return 0;
+    }
+
+/*     Quick return if possible. */
+
+    if (*n == 0) {
+	return 0;
+    }
+
+    nounit = lsame_(diag, "N");
+
+/*     Set up the start point in X if the increment is not unity. This */
+/*     will be  ( N - 1 )*INCX  too small for descending loops. */
+
+    if (*incx <= 0) {
+	kx = 1 - (*n - 1) * *incx;
+    } else if (*incx != 1) {
+	kx = 1;
+    }
+
+/*     Start the operations. In this version the elements of A are */
+/*     accessed sequentially with one pass through A. */
+
+    if (lsame_(trans, "N")) {
+
+/*        Form  x := inv( A )*x. */
+
+	if (lsame_(uplo, "U")) {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    if (x[j] != 0.) {
+			if (nounit) {
+			    x[j] /= a[j + j * a_dim1];
+			}
+			temp = x[j];
+			for (i__ = j - 1; i__ >= 1; --i__) {
+			    x[i__] -= temp * a[i__ + j * a_dim1];
+/* L10: */
+			}
+		    }
+/* L20: */
+		}
+	    } else {
+		jx = kx + (*n - 1) * *incx;
+		for (j = *n; j >= 1; --j) {
+		    if (x[jx] != 0.) {
+			if (nounit) {
+			    x[jx] /= a[j + j * a_dim1];
+			}
+			temp = x[jx];
+			ix = jx;
+			for (i__ = j - 1; i__ >= 1; --i__) {
+			    ix -= *incx;
+			    x[ix] -= temp * a[i__ + j * a_dim1];
+/* L30: */
+			}
+		    }
+		    jx -= *incx;
+/* L40: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[j] != 0.) {
+			if (nounit) {
+			    x[j] /= a[j + j * a_dim1];
+			}
+			temp = x[j];
+			i__2 = *n;
+			for (i__ = j + 1; i__ <= i__2; ++i__) {
+			    x[i__] -= temp * a[i__ + j * a_dim1];
+/* L50: */
+			}
+		    }
+/* L60: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    if (x[jx] != 0.) {
+			if (nounit) {
+			    x[jx] /= a[j + j * a_dim1];
+			}
+			temp = x[jx];
+			ix = jx;
+			i__2 = *n;
+			for (i__ = j + 1; i__ <= i__2; ++i__) {
+			    ix += *incx;
+			    x[ix] -= temp * a[i__ + j * a_dim1];
+/* L70: */
+			}
+		    }
+		    jx += *incx;
+/* L80: */
+		}
+	    }
+	}
+    } else {
+
+/*        Form  x := inv( A' )*x. */
+
+	if (lsame_(uplo, "U")) {
+	    if (*incx == 1) {
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[j];
+		    i__2 = j - 1;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp -= a[i__ + j * a_dim1] * x[i__];
+/* L90: */
+		    }
+		    if (nounit) {
+			temp /= a[j + j * a_dim1];
+		    }
+		    x[j] = temp;
+/* L100: */
+		}
+	    } else {
+		jx = kx;
+		i__1 = *n;
+		for (j = 1; j <= i__1; ++j) {
+		    temp = x[jx];
+		    ix = kx;
+		    i__2 = j - 1;
+		    for (i__ = 1; i__ <= i__2; ++i__) {
+			temp -= a[i__ + j * a_dim1] * x[ix];
+			ix += *incx;
+/* L110: */
+		    }
+		    if (nounit) {
+			temp /= a[j + j * a_dim1];
+		    }
+		    x[jx] = temp;
+		    jx += *incx;
+/* L120: */
+		}
+	    }
+	} else {
+	    if (*incx == 1) {
+		for (j = *n; j >= 1; --j) {
+		    temp = x[j];
+		    i__1 = j + 1;
+		    for (i__ = *n; i__ >= i__1; --i__) {
+			temp -= a[i__ + j * a_dim1] * x[i__];
+/* L130: */
+		    }
+		    if (nounit) {
+			temp /= a[j + j * a_dim1];
+		    }
+		    x[j] = temp;
+/* L140: */
+		}
+	    } else {
+		kx += (*n - 1) * *incx;
+		jx = kx;
+		for (j = *n; j >= 1; --j) {
+		    temp = x[jx];
+		    ix = kx;
+		    i__1 = j + 1;
+		    for (i__ = *n; i__ >= i__1; --i__) {
+			temp -= a[i__ + j * a_dim1] * x[ix];
+			ix -= *incx;
+/* L150: */
+		    }
+		    if (nounit) {
+			temp /= a[j + j * a_dim1];
+		    }
+		    x[jx] = temp;
+		    jx -= *incx;
+/* L160: */
+		}
+	    }
+	}
+    }
+
+    return 0;
+
+/*     End of DTRSV . */
+
+} /* dtrsv_ */

min-dgels/base/BLAS/SRC/dzasum.c

@@ -0,0 +1,80 @@
+/* dzasum.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dzasum_(integer *n, doublecomplex *zx, integer *incx)
+{
+    /* System generated locals */
+    integer i__1;
+    doublereal ret_val;
+
+    /* Local variables */
+    integer i__, ix;
+    doublereal stemp;
+    extern doublereal dcabs1_(doublecomplex *);
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*     takes the sum of the absolute values. */
+/*     jack dongarra, 3/11/78. */
+/*     modified 3/93 to return if incx .le. 0. */
+/*     modified 12/3/93, array(1) declarations changed to array(*) */
+
+
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. External Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --zx;
+
+    /* Function Body */
+    ret_val = 0.;
+    stemp = 0.;
+    if (*n <= 0 || *incx <= 0) {
+	return ret_val;
+    }
+    if (*incx == 1) {
+	goto L20;
+    }
+
+/*        code for increment not equal to 1 */
+
+    ix = 1;
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	stemp += dcabs1_(&zx[ix]);
+	ix += *incx;
+/* L10: */
+    }
+    ret_val = stemp;
+    return ret_val;
+
+/*        code for increment equal to 1 */
+
+L20:
+    i__1 = *n;
+    for (i__ = 1; i__ <= i__1; ++i__) {
+	stemp += dcabs1_(&zx[i__]);
+/* L30: */
+    }
+    ret_val = stemp;
+    return ret_val;
+} /* dzasum_ */

min-dgels/base/BLAS/SRC/dznrm2.c

@@ -0,0 +1,108 @@
+/* dznrm2.f -- translated by f2c (version 20061008).
+   You must link the resulting object file with libf2c:
+	on Microsoft Windows system, link with libf2c.lib;
+	on Linux or Unix systems, link with .../path/to/libf2c.a -lm
+	or, if you install libf2c.a in a standard place, with -lf2c -lm
+	-- in that order, at the end of the command line, as in
+		cc *.o -lf2c -lm
+	Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
+
+		http://www.netlib.org/f2c/libf2c.zip
+*/
+
+#include "f2c.h"
+#include "blaswrap.h"
+
+doublereal dznrm2_(integer *n, doublecomplex *x, integer *incx)
+{
+    /* System generated locals */
+    integer i__1, i__2, i__3;
+    doublereal ret_val, d__1;
+
+    /* Builtin functions */
+    double d_imag(doublecomplex *), sqrt(doublereal);
+
+    /* Local variables */
+    integer ix;
+    doublereal ssq, temp, norm, scale;
+
+/*     .. Scalar Arguments .. */
+/*     .. */
+/*     .. Array Arguments .. */
+/*     .. */
+
+/*  Purpose */
+/*  ======= */
+
+/*  DZNRM2 returns the euclidean norm of a vector via the function */
+/*  name, so that */
+
+/*     DZNRM2 := sqrt( conjg( x' )*x ) */
+
+
+/*  -- This version written on 25-October-1982. */
+/*     Modified on 14-October-1993 to inline the call to ZLASSQ. */
+/*     Sven Hammarling, Nag Ltd. */
+
+
+/*     .. Parameters .. */
+/*     .. */
+/*     .. Local Scalars .. */
+/*     .. */
+/*     .. Intrinsic Functions .. */
+/*     .. */
+    /* Parameter adjustments */
+    --x;
+
+    /* Function Body */
+    if (*n < 1 || *incx < 1) {
+	norm = 0.;
+    } else {
+	scale = 0.;
+	ssq = 1.;
+/*        The following loop is equivalent to this call to the LAPACK */
+/*        auxiliary routine: */
+/*        CALL ZLASSQ( N, X, INCX, SCALE, SSQ ) */
+
+	i__1 = (*n - 1) * *incx + 1;
+	i__2 = *incx;
+	for (ix = 1; i__2 < 0 ? ix >= i__1 : ix <= i__1; ix += i__2) {
+	    i__3 = ix;
+	    if (x[i__3].r != 0.) {
+		i__3 = ix;
+		temp = (d__1 = x[i__3].r, abs(d__1));
+		if (scale < temp) {
+/* Computing 2nd power */
+		    d__1 = scale / temp;
+		    ssq = ssq * (d__1 * d__1) + 1.;
+		    scale = temp;
+		} else {
+/* Computing 2nd power */
+		    d__1 = temp / scale;
+		    ssq += d__1 * d__1;
+		}
+	    }
+	    if (d_imag(&x[ix]) != 0.) {
+		temp = (d__1 = d_imag(&x[ix]), abs(d__1));
+		if (scale < temp) {
+/* Computing 2nd power */
+		    d__1 = scale / temp;
+		    ssq = ssq * (d__1 * d__1) + 1.;
+		    scale = temp;
+		} else {
+/* Computing 2nd power */
+		    d__1 = temp / scale;
+		    ssq += d__1 * d__1;
+		}
+	    }
+/* L10: */
+	}
+	norm = scale * sqrt(ssq);
+    }
+
+    ret_val = norm;
+    return ret_val;
+
+/*     End of DZNRM2. */
+
+} /* dznrm2_ */