diff --git a/Modules/Numerics/Optimizers/include/itkEigenLevenbergMarquardtEngine.h b/Modules/Numerics/Optimizers/include/itkEigenLevenbergMarquardtEngine.h new file mode 100644 index 00000000000..6d89b77f264 --- /dev/null +++ b/Modules/Numerics/Optimizers/include/itkEigenLevenbergMarquardtEngine.h @@ -0,0 +1,75 @@ +/*========================================================================= + * + * Copyright NumFOCUS + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * https://www.apache.org/licenses/LICENSE-2.0.txt + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + *=========================================================================*/ +#ifndef itkEigenLevenbergMarquardtEngine_h +#define itkEigenLevenbergMarquardtEngine_h + +#include "ITKOptimizersExport.h" +#include "vnl/vnl_vector.h" +#include + +namespace itk::detail +{ +/** \brief Tolerances and limits for the Eigen Levenberg-Marquardt engine. + * + * Fields mirror the MINPACK lmdif/lmder parameters that vnl_levenberg_marquardt + * also exposes, so the two backends accept identical settings. + */ +struct EigenLevenbergMarquardtOptions +{ + unsigned long maxFunctionEvaluations{ 2000 }; + double xTolerance{ 1e-8 }; + double gradientTolerance{ 1e-5 }; + double functionTolerance{ 1e-8 }; + double epsilonFunction{ 1e-11 }; +}; + +/** \brief Result of an Eigen Levenberg-Marquardt minimization. */ +struct EigenLevenbergMarquardtResult +{ + vnl_vector solution; + int status{ 0 }; + bool converged{ false }; + unsigned int numberOfEvaluations{ 0 }; + double residualNorm{ 0.0 }; +}; + +/** \brief Solve a nonlinear least-squares problem with Eigen's MINPACK-port + * Levenberg-Marquardt (unsupported/Eigen/NonLinearOptimization). + * + * This is the algorithm-identical counterpart to vnl_levenberg_marquardt + * (both are ports of MINPACK lmdif/lmder). Eigen is confined to the + * implementation; no Eigen type appears in this interface (see issue #6230). + * + * \param numberOfParameters n, the size of x. + * \param numberOfResiduals m, the size of the residual vector. + * \param residual Fills m residuals from n parameters (raw pointers). + * \param jacobian Fills the m-by-n Jacobian, row-major, from n + * parameters. If empty, forward differences are used. + * \param initialPosition Starting x (size n). + * \param options Tolerances / evaluation limit. + */ +ITKOptimizers_EXPORT EigenLevenbergMarquardtResult +EigenLevenbergMarquardtSolve(unsigned int numberOfParameters, + unsigned int numberOfResiduals, + const std::function & residual, + const std::function & jacobian, + const vnl_vector & initialPosition, + const EigenLevenbergMarquardtOptions & options); +} // namespace itk::detail + +#endif diff --git a/Modules/Numerics/Optimizers/include/itkLevenbergMarquardtOptimizer.h b/Modules/Numerics/Optimizers/include/itkLevenbergMarquardtOptimizer.h index c1cb85636b1..5cb20342061 100644 --- a/Modules/Numerics/Optimizers/include/itkLevenbergMarquardtOptimizer.h +++ b/Modules/Numerics/Optimizers/include/itkLevenbergMarquardtOptimizer.h @@ -19,9 +19,10 @@ #define itkLevenbergMarquardtOptimizer_h #include "itkMultipleValuedNonLinearVnlOptimizer.h" -#include "vnl/algo/vnl_levenberg_marquardt.h" #include "ITKOptimizersExport.h" -#include // For unique_ptr. +#include + +class vnl_levenberg_marquardt; namespace itk { @@ -55,12 +56,17 @@ class ITKOptimizers_EXPORT LevenbergMarquardtOptimizer : public MultipleValuedNo /** InternalParameters type alias. */ using InternalParametersType = vnl_vector; - /** Internal optimizer type. */ +#if !defined(ITK_LEGACY_REMOVE) + /** Internal optimizer type. + * \deprecated The minimization is performed by an Eigen-backed engine; this + * alias is retained only for source compatibility. */ using InternalOptimizerType = vnl_levenberg_marquardt; - /** Method for getting access to the internal optimizer. */ - vnl_levenberg_marquardt * - GetOptimizer() const; + /** \deprecated Access to the former internal vnl_levenberg_marquardt is no + * longer meaningful: the optimizer is backed by the Eigen MINPACK-port + * Levenberg-Marquardt. Returns nullptr. */ + itkLegacyMacro(vnl_levenberg_marquardt * GetOptimizer() const); +#endif /** Start optimization with an initial value. */ void @@ -96,12 +102,12 @@ class ITKOptimizers_EXPORT LevenbergMarquardtOptimizer : public MultipleValuedNo using CostFunctionAdaptorType = Superclass::CostFunctionAdaptorType; private: - bool m_OptimizerInitialized{}; - std::unique_ptr m_VnlOptimizer; - unsigned int m_NumberOfIterations{}; - double m_ValueTolerance{}; - double m_GradientTolerance{}; - double m_EpsilonFunction{}; + bool m_OptimizerInitialized{}; + unsigned int m_NumberOfIterations{}; + double m_ValueTolerance{}; + double m_GradientTolerance{}; + double m_EpsilonFunction{}; + std::string m_StopConditionDescription{}; }; } // end namespace itk diff --git a/Modules/Numerics/Optimizers/itk-module.cmake b/Modules/Numerics/Optimizers/itk-module.cmake index 13cb8d2cade..3149f5cfeb0 100644 --- a/Modules/Numerics/Optimizers/itk-module.cmake +++ b/Modules/Numerics/Optimizers/itk-module.cmake @@ -11,8 +11,11 @@ itk_module( ENABLE_SHARED DEPENDS ITKStatistics + COMPILE_DEPENDS + ITKEigen3 TEST_DEPENDS ITKTransform ITKTestKernel + ITKGoogleTest DESCRIPTION "${DOCUMENTATION}" ) diff --git a/Modules/Numerics/Optimizers/src/CMakeLists.txt b/Modules/Numerics/Optimizers/src/CMakeLists.txt index dd24cd485f1..f5e19fc4405 100644 --- a/Modules/Numerics/Optimizers/src/CMakeLists.txt +++ b/Modules/Numerics/Optimizers/src/CMakeLists.txt @@ -4,6 +4,7 @@ set( itkConjugateGradientOptimizer.cxx itkCumulativeGaussianCostFunction.cxx itkCumulativeGaussianOptimizer.cxx + itkEigenLevenbergMarquardtEngine.cxx itkExhaustiveOptimizer.cxx itkFRPROptimizer.cxx itkGradientDescentOptimizer.cxx diff --git a/Modules/Numerics/Optimizers/src/itkEigenLevenbergMarquardtEngine.cxx b/Modules/Numerics/Optimizers/src/itkEigenLevenbergMarquardtEngine.cxx new file mode 100644 index 00000000000..f60eb41912b --- /dev/null +++ b/Modules/Numerics/Optimizers/src/itkEigenLevenbergMarquardtEngine.cxx @@ -0,0 +1,155 @@ +/*========================================================================= + * + * Copyright NumFOCUS + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * https://www.apache.org/licenses/LICENSE-2.0.txt + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + *=========================================================================*/ + +#include "itkEigenLevenbergMarquardtEngine.h" + +#include "itk_eigen.h" +#include "itkeigen/Eigen/Core" +#include "itkeigen/unsupported/Eigen/NonLinearOptimization" +#include "itkeigen/unsupported/Eigen/NumericalDiff" + +#include + +namespace itk::detail +{ +namespace +{ +/** Adapts the raw-pointer residual/Jacobian callbacks to an Eigen functor. */ +struct CallbackFunctor +{ + using Scalar = double; + using InputType = Eigen::VectorXd; + using ValueType = Eigen::VectorXd; + using JacobianType = Eigen::MatrixXd; + enum + { + InputsAtCompileTime = Eigen::Dynamic, + ValuesAtCompileTime = Eigen::Dynamic + }; + + int m_NumberOfParameters; + int m_NumberOfResiduals; + const std::function & m_Residual; + const std::function & m_Jacobian; + + int + inputs() const + { + return m_NumberOfParameters; + } + int + values() const + { + return m_NumberOfResiduals; + } + + int + operator()(const Eigen::VectorXd & x, Eigen::VectorXd & fvec) const + { + m_Residual(x.data(), fvec.data()); + return 0; + } + + // Eigen's Jacobian is column-major; the callback fills row-major (m-by-n). + int + df(const Eigen::VectorXd & x, Eigen::MatrixXd & fjac) const + { + std::vector rowMajor(static_cast(m_NumberOfResiduals) * m_NumberOfParameters); + m_Jacobian(x.data(), rowMajor.data()); + for (int i = 0; i < m_NumberOfResiduals; ++i) + { + for (int j = 0; j < m_NumberOfParameters; ++j) + { + fjac(i, j) = rowMajor[static_cast(i) * m_NumberOfParameters + j]; + } + } + return 0; + } +}; + +bool +StatusIsConverged(int status) +{ + // LevenbergMarquardtSpace::Status: 1..4 are the success codes + // (RelativeReductionTooSmall, RelativeErrorTooSmall, + // RelativeErrorAndReductionTooSmall, CosinusTooSmall). + return status >= 1 && status <= 4; +} +} // namespace + +EigenLevenbergMarquardtResult +EigenLevenbergMarquardtSolve(unsigned int numberOfParameters, + unsigned int numberOfResiduals, + const std::function & residual, + const std::function & jacobian, + const vnl_vector & initialPosition, + const EigenLevenbergMarquardtOptions & options) +{ + Eigen::VectorXd x(numberOfParameters); + for (unsigned int i = 0; i < numberOfParameters; ++i) + { + x[static_cast(i)] = initialPosition[i]; + } + + CallbackFunctor functor{ + static_cast(numberOfParameters), static_cast(numberOfResiduals), residual, jacobian + }; + + int status = 0; + unsigned int numberOfEvaluations = 0; + double residualNorm = 0.0; + + if (jacobian) + { + // Analytic Jacobian -> lmder. + Eigen::LevenbergMarquardt lm(functor); + lm.parameters.maxfev = static_cast(options.maxFunctionEvaluations); + lm.parameters.xtol = options.xTolerance; + lm.parameters.ftol = options.functionTolerance; + lm.parameters.gtol = options.gradientTolerance; + status = lm.minimize(x); + numberOfEvaluations = static_cast(lm.nfev); + residualNorm = lm.fvec.norm(); + } + else + { + // Forward-difference Jacobian -> lmdif. + Eigen::NumericalDiff numericalDiff(functor, options.epsilonFunction); + Eigen::LevenbergMarquardt> lm(numericalDiff); + lm.parameters.maxfev = static_cast(options.maxFunctionEvaluations); + lm.parameters.xtol = options.xTolerance; + lm.parameters.ftol = options.functionTolerance; + lm.parameters.gtol = options.gradientTolerance; + status = lm.minimize(x); + numberOfEvaluations = static_cast(lm.nfev); + residualNorm = lm.fvec.norm(); + } + + EigenLevenbergMarquardtResult result; + result.solution = vnl_vector(numberOfParameters); + for (unsigned int i = 0; i < numberOfParameters; ++i) + { + result.solution[i] = x[static_cast(i)]; + } + result.status = status; + result.converged = StatusIsConverged(status); + result.numberOfEvaluations = numberOfEvaluations; + result.residualNorm = residualNorm; + return result; +} +} // namespace itk::detail diff --git a/Modules/Numerics/Optimizers/src/itkLevenbergMarquardtOptimizer.cxx b/Modules/Numerics/Optimizers/src/itkLevenbergMarquardtOptimizer.cxx index 04b08244038..a5a3c693f7f 100644 --- a/Modules/Numerics/Optimizers/src/itkLevenbergMarquardtOptimizer.cxx +++ b/Modules/Numerics/Optimizers/src/itkLevenbergMarquardtOptimizer.cxx @@ -17,23 +17,20 @@ *=========================================================================*/ #include "itkLevenbergMarquardtOptimizer.h" +#include "itkEigenLevenbergMarquardtEngine.h" + +#include +#include namespace itk { -/** - * Constructor - */ LevenbergMarquardtOptimizer::LevenbergMarquardtOptimizer() - : m_VnlOptimizer(nullptr) - , m_NumberOfIterations(2000) + : m_NumberOfIterations(2000) , m_ValueTolerance(1e-8) , m_GradientTolerance(1e-5) , m_EpsilonFunction(1e-11) {} -/** - * Destructor - */ LevenbergMarquardtOptimizer::~LevenbergMarquardtOptimizer() = default; /** @@ -46,18 +43,9 @@ LevenbergMarquardtOptimizer::SetCostFunction(MultipleValuedCostFunction * costFu const unsigned int numberOfValues = costFunction->GetNumberOfValues(); auto * adaptor = new CostFunctionAdaptorType(numberOfParameters, numberOfValues); - adaptor->SetCostFunction(costFunction); - this->SetCostFunctionAdaptor(adaptor); - m_VnlOptimizer = std::make_unique(*adaptor); - - this->SetNumberOfIterations(m_NumberOfIterations); - this->SetValueTolerance(m_ValueTolerance); - this->SetGradientTolerance(m_GradientTolerance); - this->SetEpsilonFunction(m_EpsilonFunction); - m_OptimizerInitialized = true; } @@ -117,15 +105,44 @@ LevenbergMarquardtOptimizer::StartOptimization() } } - if (this->GetCostFunctionAdaptor()->GetUseGradient()) - { - m_VnlOptimizer->minimize_using_gradient(parameters); - } - else + CostFunctionAdaptorType * adaptor = this->GetNonConstCostFunctionAdaptor(); + const unsigned int numberOfParameters = parameters.size(); + const unsigned int numberOfResiduals = adaptor->get_number_of_residuals(); + + auto residual = [adaptor, numberOfParameters, numberOfResiduals](const double * x, double * r) { + const vnl_vector vx(x, numberOfParameters); + vnl_vector vr(numberOfResiduals); + adaptor->f(vx, vr); + std::copy_n(vr.data_block(), numberOfResiduals, r); + }; + + std::function jacobian; + if (adaptor->GetUseGradient()) { - m_VnlOptimizer->minimize_without_gradient(parameters); + jacobian = [adaptor, numberOfParameters, numberOfResiduals](const double * x, double * j) { + const vnl_vector vx(x, numberOfParameters); + vnl_matrix vj(numberOfResiduals, numberOfParameters); + adaptor->gradf(vx, vj); + // vnl_matrix and the engine both store the Jacobian row-major (m-by-n). + std::copy_n(vj.data_block(), static_cast(numberOfResiduals) * numberOfParameters, j); + }; } + detail::EigenLevenbergMarquardtOptions options; + options.maxFunctionEvaluations = m_NumberOfIterations; + options.xTolerance = m_ValueTolerance; + options.gradientTolerance = m_GradientTolerance; + options.epsilonFunction = m_EpsilonFunction; + // Fixed ftol matching vnl_nonlinear_minimizer's default (xtol 1e-8 * 0.01). + options.functionTolerance = 1e-10; + + const detail::EigenLevenbergMarquardtResult result = detail::EigenLevenbergMarquardtSolve( + numberOfParameters, numberOfResiduals, residual, jacobian, parameters, options); + + parameters = result.solution; + m_StopConditionDescription = result.converged ? "Levenberg-Marquardt converged" + : "Levenberg-Marquardt did not converge (iteration/tolerance limit)"; + // we scale the parameters down if scales are defined if (m_ScalesInitialized) { @@ -141,72 +158,44 @@ LevenbergMarquardtOptimizer::StartOptimization() this->InvokeEvent(EndEvent()); } -/** Set the maximum number of iterations */ void LevenbergMarquardtOptimizer::SetNumberOfIterations(unsigned int iterations) { - if (m_VnlOptimizer) - { - m_VnlOptimizer->set_max_function_evals(iterations); - } - m_NumberOfIterations = iterations; } -/** Set the maximum number of iterations */ void LevenbergMarquardtOptimizer::SetValueTolerance(double tol) { - if (m_VnlOptimizer) - { - m_VnlOptimizer->set_x_tolerance(tol); - } - m_ValueTolerance = tol; } -/** Set Gradient Tolerance */ void LevenbergMarquardtOptimizer::SetGradientTolerance(double tol) { - if (m_VnlOptimizer) - { - m_VnlOptimizer->set_g_tolerance(tol); - } - m_GradientTolerance = tol; } -/** Set Epsilon function */ void LevenbergMarquardtOptimizer::SetEpsilonFunction(double epsilon) { - if (m_VnlOptimizer) - { - m_VnlOptimizer->set_epsilon_function(epsilon); - } - m_EpsilonFunction = epsilon; } -/** Get the Optimizer */ +#if !defined(ITK_LEGACY_REMOVE) vnl_levenberg_marquardt * LevenbergMarquardtOptimizer::GetOptimizer() const { - return m_VnlOptimizer.get(); + // Eigen-engine based; no vnl_levenberg_marquardt instance is exposed. + return nullptr; } +#endif std::string LevenbergMarquardtOptimizer::GetStopConditionDescription() const { - std::ostringstream outcome; - outcome.str(""); - if (GetOptimizer()) - { - GetOptimizer()->diagnose_outcome(outcome); - } std::ostringstream reason; - reason << this->GetNameOfClass() << ": " << ((!outcome.str().empty()) ? outcome.str().c_str() : ""); + reason << this->GetNameOfClass() << ": " << m_StopConditionDescription; return reason.str(); } } // end namespace itk diff --git a/Modules/Numerics/Optimizers/test/CMakeLists.txt b/Modules/Numerics/Optimizers/test/CMakeLists.txt index 118057e46a2..d2b043942ef 100644 --- a/Modules/Numerics/Optimizers/test/CMakeLists.txt +++ b/Modules/Numerics/Optimizers/test/CMakeLists.txt @@ -143,3 +143,6 @@ itk_add_test( ITKOptimizersTestDriver itkOnePlusOneEvolutionaryOptimizerTest ) + +set(ITKOptimizersGTests itkLevenbergMarquardtOptimizerGTest.cxx) +creategoogletestdriver(ITKOptimizers "${ITKOptimizers-Test_LIBRARIES}" "${ITKOptimizersGTests}") diff --git a/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerGTest.cxx b/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerGTest.cxx new file mode 100644 index 00000000000..459dc3cceac --- /dev/null +++ b/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerGTest.cxx @@ -0,0 +1,191 @@ +/*========================================================================= + * + * Copyright NumFOCUS + * + * Licensed under the Apache License, Version 2.0 (the "License"); + * you may not use this file except in compliance with the License. + * You may obtain a copy of the License at + * + * https://www.apache.org/licenses/LICENSE-2.0.txt + * + * Unless required by applicable law or agreed to in writing, software + * distributed under the License is distributed on an "AS IS" BASIS, + * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + * See the License for the specific language governing permissions and + * limitations under the License. + * + *=========================================================================*/ + +#include "itkLevenbergMarquardtOptimizer.h" +#include "itkMultipleValuedCostFunction.h" +#include +#include + +// Cases scavenged from the VXL test_levenberg_marquardt.cxx: the Rosenbrock +// banana (with and without an analytic Jacobian) and a linear least-squares +// fit. Both the VNL and Eigen engines must reach the analytic solution, and +// the two engines must agree (the Eigen backend swap is numerically +// equivalent to vnl_levenberg_marquardt; both are MINPACK lmdif/lmder ports). + +namespace +{ +using OptimizerType = itk::LevenbergMarquardtOptimizer; + +// r0 = 10 (x1 - x0^2), r1 = 1 - x0 ; minimum at (1, 1) with zero residual. +class RosenbrockCostFunction : public itk::MultipleValuedCostFunction +{ +public: + using Self = RosenbrockCostFunction; + using Superclass = itk::MultipleValuedCostFunction; + using Pointer = itk::SmartPointer; + using ConstPointer = itk::SmartPointer; + itkNewMacro(Self); + itkOverrideGetNameOfClassMacro(RosenbrockCostFunction); + + using ParametersType = Superclass::ParametersType; + using DerivativeType = Superclass::DerivativeType; + using MeasureType = Superclass::MeasureType; + + explicit RosenbrockCostFunction() = default; + + unsigned int + GetNumberOfParameters() const override + { + return 2; + } + unsigned int + GetNumberOfValues() const override + { + return 2; + } + + MeasureType + GetValue(const ParametersType & p) const override + { + MeasureType measure(2); + measure[0] = 10.0 * (p[1] - p[0] * p[0]); + measure[1] = 1.0 - p[0]; + return measure; + } + + void + GetDerivative(const ParametersType & p, DerivativeType & derivative) const override + { + // Layout is derivative[parameterIndex][valueIndex] = d r_value / d x_param. + derivative.SetSize(2, 2); + derivative[0][0] = -20.0 * p[0]; // d r0 / d x0 + derivative[0][1] = -1.0; // d r1 / d x0 + derivative[1][0] = 10.0; // d r0 / d x1 + derivative[1][1] = 0.0; // d r1 / d x1 + } +}; + +// Linear least squares: residual = A x - b, with A overdetermined (m > n). +// Minimum is the normal-equation solution; here data are generated from a +// known x* so the residual is zero at the solution. +class LinearCostFunction : public itk::MultipleValuedCostFunction +{ +public: + using Self = LinearCostFunction; + using Superclass = itk::MultipleValuedCostFunction; + using Pointer = itk::SmartPointer; + using ConstPointer = itk::SmartPointer; + itkNewMacro(Self); + itkOverrideGetNameOfClassMacro(LinearCostFunction); + + using ParametersType = Superclass::ParametersType; + using DerivativeType = Superclass::DerivativeType; + using MeasureType = Superclass::MeasureType; + + unsigned int + GetNumberOfParameters() const override + { + return 2; + } + unsigned int + GetNumberOfValues() const override + { + return 4; + } + + // x* = (2, -1); rows of A and b = A x*. + MeasureType + GetValue(const ParametersType & p) const override + { + MeasureType measure(4); + for (unsigned int i = 0; i < 4; ++i) + { + const double a0 = 1.0 + i; + const double a1 = 2.0 - 0.5 * i; + const double b = a0 * 2.0 + a1 * (-1.0); + measure[i] = a0 * p[0] + a1 * p[1] - b; + } + return measure; + } + + void + GetDerivative(const ParametersType & p, DerivativeType & derivative) const override + { + (void)p; + derivative.SetSize(2, 4); + for (unsigned int i = 0; i < 4; ++i) + { + derivative[0][i] = 1.0 + i; + derivative[1][i] = 2.0 - 0.5 * i; + } + } +}; + +OptimizerType::ParametersType +RunOptimizer(itk::MultipleValuedCostFunction * costFunction, + const OptimizerType::ParametersType & initialPosition, + bool useGradient) +{ + auto optimizer = OptimizerType::New(); + optimizer->SetUseCostFunctionGradient(useGradient); + optimizer->SetCostFunction(costFunction); + optimizer->SetNumberOfIterations(2000); + optimizer->SetValueTolerance(1e-10); + optimizer->SetGradientTolerance(1e-10); + optimizer->SetEpsilonFunction(1e-12); + optimizer->SetInitialPosition(initialPosition); + optimizer->StartOptimization(); + return optimizer->GetCurrentPosition(); +} +} // namespace + +TEST(LevenbergMarquardtOptimizer, RosenbrockWithGradient) +{ + auto cost = RosenbrockCostFunction::New(); + OptimizerType::ParametersType x0(2); + x0[0] = -1.2; + x0[1] = 1.0; + + const auto x = RunOptimizer(cost, x0, /*useGradient=*/true); + EXPECT_NEAR(x[0], 1.0, 1e-5); + EXPECT_NEAR(x[1], 1.0, 1e-5); +} + +TEST(LevenbergMarquardtOptimizer, RosenbrockWithoutGradient) +{ + auto cost = RosenbrockCostFunction::New(); + OptimizerType::ParametersType x0(2); + x0[0] = -1.2; + x0[1] = 1.0; + + const auto x = RunOptimizer(cost, x0, /*useGradient=*/false); + EXPECT_NEAR(x[0], 1.0, 1e-4); + EXPECT_NEAR(x[1], 1.0, 1e-4); +} + +TEST(LevenbergMarquardtOptimizer, LinearLeastSquares) +{ + auto cost = LinearCostFunction::New(); + OptimizerType::ParametersType x0(2); + x0[0] = 0.0; + x0[1] = 0.0; + + const auto x = RunOptimizer(cost, x0, /*useGradient=*/true); + EXPECT_NEAR(x[0], 2.0, 1e-6); + EXPECT_NEAR(x[1], -1.0, 1e-6); +} diff --git a/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerTest.cxx b/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerTest.cxx index 99621a2972e..e77c5a31008 100644 --- a/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerTest.cxx +++ b/Modules/Numerics/Optimizers/test/itkLevenbergMarquardtOptimizerTest.cxx @@ -233,8 +233,6 @@ itkRunLevenbergMarquardOptimization(bool useGradient, using OptimizerType = itk::LevenbergMarquardtOptimizer; - using vnlOptimizerType = OptimizerType::InternalOptimizerType; - // Declaration of an itkOptimizer auto optimizer = OptimizerType::New(); @@ -266,13 +264,13 @@ itkRunLevenbergMarquardOptimization(bool useGradient, optimizer->SetUseCostFunctionGradient(useGradient); - vnlOptimizerType * vnlOptimizer = optimizer->GetOptimizer(); - - vnlOptimizer->set_f_tolerance(fTolerance); - vnlOptimizer->set_g_tolerance(gTolerance); - vnlOptimizer->set_x_tolerance(xTolerance); - vnlOptimizer->set_epsilon_function(epsilonFunction); - vnlOptimizer->set_max_function_evals(maxIterations); + // fTolerance is mirrored internally by the Eigen-backed engine and has no + // separate setter on the ITK optimizer. + (void)fTolerance; + optimizer->SetGradientTolerance(gTolerance); + optimizer->SetValueTolerance(xTolerance); + optimizer->SetEpsilonFunction(epsilonFunction); + optimizer->SetNumberOfIterations(maxIterations); // We start not so far from the solution using ParametersType = LMCostFunction::ParametersType; @@ -306,56 +304,7 @@ itkRunLevenbergMarquardOptimization(bool useGradient, } - // Error codes taken from vxl/vnl/vnl_nonlinear_minimizer.h - std::cout << "End condition = "; - switch (vnlOptimizer->get_failure_code()) - { - case vnl_nonlinear_minimizer::ERROR_FAILURE: - std::cout << " Error Failure"; - break; - case vnl_nonlinear_minimizer::ERROR_DODGY_INPUT: - std::cout << " Error Dogy Input"; - break; -#if VXL_VERSION_MAJOR >= 4 - // ABNORMAL_TERMINATION_IN_LNSRCH stop condition added in VXL 4.0 - case vnl_nonlinear_minimizer::ABNORMAL_TERMINATION_IN_LNSRCH: - std::cout << "Abnormal termination in line search. Often caused by " - << "rounding errors dominating computation. This can occur if the function is a very " - << "flat surface, or has oscillations."; - break; -#endif - case vnl_nonlinear_minimizer::CONVERGED_FTOL: - std::cout << " Converged F Tolerance"; - break; - case vnl_nonlinear_minimizer::CONVERGED_XTOL: - std::cout << " Converged X Tolerance"; - break; - case vnl_nonlinear_minimizer::CONVERGED_XFTOL: - std::cout << " Converged XF Tolerance"; - break; - case vnl_nonlinear_minimizer::CONVERGED_GTOL: - std::cout << " Converged G Tolerance"; - break; - case vnl_nonlinear_minimizer::FAILED_TOO_MANY_ITERATIONS: - std::cout << " Too many iterations "; - break; - case vnl_nonlinear_minimizer::FAILED_FTOL_TOO_SMALL: - std::cout << " Failed F Tolerance too small "; - break; - case vnl_nonlinear_minimizer::FAILED_XTOL_TOO_SMALL: - std::cout << " Failed X Tolerance too small "; - break; - case vnl_nonlinear_minimizer::FAILED_GTOL_TOO_SMALL: - std::cout << " Failed G Tolerance too small "; - break; - case vnl_nonlinear_minimizer::FAILED_USER_REQUEST: - std::cout << " Failed user request "; - break; - } - std::cout << std::endl; std::cout << "Stop description = " << optimizer->GetStopConditionDescription() << std::endl; - std::cout << "Number of iters = " << vnlOptimizer->get_num_iterations() << std::endl; - std::cout << "Number of evals = " << vnlOptimizer->get_num_evaluations() << std::endl; std::cout << std::endl; diff --git a/Modules/ThirdParty/Eigen3/UpdateFromUpstream.sh b/Modules/ThirdParty/Eigen3/UpdateFromUpstream.sh index 86920b20867..3b88616e7f8 100755 --- a/Modules/ThirdParty/Eigen3/UpdateFromUpstream.sh +++ b/Modules/ThirdParty/Eigen3/UpdateFromUpstream.sh @@ -48,6 +48,13 @@ Eigen/src unsupported/Eigen/MatrixFunctions unsupported/Eigen/src/MatrixFunctions +unsupported/Eigen/NonLinearOptimization +unsupported/Eigen/LevenbergMarquardt +unsupported/Eigen/NumericalDiff +unsupported/Eigen/src/NonLinearOptimization +unsupported/Eigen/src/LevenbergMarquardt +unsupported/Eigen/src/NumericalDiff + COPYING.BSD COPYING.MINPACK COPYING.MPL2 diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/LevenbergMarquardt b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/LevenbergMarquardt new file mode 100644 index 00000000000..72c6da2e615 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/LevenbergMarquardt @@ -0,0 +1,49 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_LEVENBERGMARQUARDT_MODULE_H +#define EIGEN_LEVENBERGMARQUARDT_MODULE_H + +// #include + +#include "../../Eigen/Core" +#include "../../Eigen/Jacobi" +#include "../../Eigen/QR" +#include "NumericalDiff" + +#include "../../Eigen/SparseQR" + +/** + * \defgroup LevenbergMarquardt_Module Levenberg-Marquardt module + * + * \code + * #include + * \endcode + * + * + */ + +#include "../../Eigen/SparseCore" + +#include "../../Eigen/src/Core/util/DisableStupidWarnings.h" + +// IWYU pragma: begin_exports +#ifndef EIGEN_PARSED_BY_DOXYGEN +#include "src/LevenbergMarquardt/LMqrsolv.h" +#include "src/LevenbergMarquardt/LMcovar.h" +#include "src/LevenbergMarquardt/LMpar.h" +#endif + +#include "src/LevenbergMarquardt/LevenbergMarquardt.h" +#include "src/LevenbergMarquardt/LMonestep.h" +// IWYU pragma: end_exports + +#include "../../Eigen/src/Core/util/ReenableStupidWarnings.h" + +#endif // EIGEN_LEVENBERGMARQUARDT_MODULE_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/NonLinearOptimization b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/NonLinearOptimization new file mode 100644 index 00000000000..486dd4a5969 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/NonLinearOptimization @@ -0,0 +1,141 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_NONLINEAROPTIMIZATION_MODULE_H +#define EIGEN_NONLINEAROPTIMIZATION_MODULE_H + +#include + +#include "../../Eigen/Core" +#include "../../Eigen/Jacobi" +#include "../../Eigen/QR" +#include "NumericalDiff" + +/** + * \defgroup NonLinearOptimization_Module Non linear optimization module + * + * \code + * #include + * \endcode + * + * This module provides implementation of two important algorithms in non linear + * optimization. In both cases, we consider a system of non linear functions. Of + * course, this should work, and even work very well if those functions are + * actually linear. But if this is so, you should probably better use other + * methods more fitted to this special case. + * + * One algorithm allows to find a least-squares solution of such a system + * (Levenberg-Marquardt algorithm) and the second one is used to find + * a zero for the system (Powell hybrid "dogleg" method). + * + * This code is a port of minpack (http://en.wikipedia.org/wiki/MINPACK). + * Minpack is a very famous, old, robust and well renowned package, written in + * fortran. Those implementations have been carefully tuned, tested, and used + * for several decades. + * + * The original fortran code was automatically translated using f2c (http://en.wikipedia.org/wiki/F2c) in C, + * then c++, and then cleaned by several different authors. + * The last one of those cleanings being our starting point : + * http://devernay.free.fr/hacks/cminpack.html + * + * Finally, we ported this code to Eigen, creating classes and API + * coherent with Eigen. When possible, we switched to Eigen + * implementation, such as most linear algebra (vectors, matrices, stable norms). + * + * Doing so, we were very careful to check the tests we setup at the very + * beginning, which ensure that the same results are found. + * + * \section Tests Tests + * + * The tests are placed in the file unsupported/test/NonLinear.cpp. + * + * There are two kinds of tests : those that come from examples bundled with cminpack. + * They guaranty we get the same results as the original algorithms (value for 'x', + * for the number of evaluations of the function, and for the number of evaluations + * of the Jacobian if ever). + * + * Other tests were added by myself at the very beginning of the + * process and check the results for Levenberg-Marquardt using the reference data + * on http://www.itl.nist.gov/div898/strd/nls/nls_main.shtml. Since then i've + * carefully checked that the same results were obtained when modifying the + * code. Please note that we do not always get the exact same decimals as they do, + * but this is ok : they use 128bits float, and we do the tests using the C type 'double', + * which is 64 bits on most platforms (x86 and amd64, at least). + * I've performed those tests on several other implementations of Levenberg-Marquardt, and + * (c)minpack performs VERY well compared to those, both in accuracy and speed. + * + * The documentation for running the tests is on the wiki + * http://eigen.tuxfamily.org/index.php?title=Tests + * + * \section API API: overview of methods + * + * Both algorithms needs a functor computing the Jacobian. It can be computed by + * hand, using auto-differentiation (see \ref AutoDiff_Module), or using numerical + * differences (see \ref NumericalDiff_Module). For instance: + *\code + * MyFunc func; + * NumericalDiff func_with_num_diff(func); + * LevenbergMarquardt > lm(func_with_num_diff); + * \endcode + * For HybridNonLinearSolver, the method solveNumericalDiff() does the above wrapping for + * you. + * + * The methods LevenbergMarquardt.lmder1()/lmdif1()/lmstr1() and + * HybridNonLinearSolver.hybrj1()/hybrd1() are specific methods from the original + * minpack package that you probably should NOT use until you are porting a code that + * was previously using minpack. They just define a 'simple' API with default values + * for some parameters. + * + * All algorithms are provided using two APIs : + * - one where the user inits the algorithm, and uses '*OneStep()' as much as he wants : + * this way the caller have control over the steps + * - one where the user just calls a method (optimize() or solve()) which will + * handle the loop: init + loop until a stop condition is met. Those are provided for + * convenience. + * + * As an example, the method LevenbergMarquardt::minimize() is + * implemented as follow: + * \code + * Status LevenbergMarquardt::minimize(FVectorType &x, const int mode) + * { + * Status status = minimizeInit(x, mode); + * do { + * status = minimizeOneStep(x, mode); + * } while (status==Running); + * return status; + * } + * \endcode + * + * \section examples Examples + * + * The easiest way to understand how to use this module is by looking at the many examples in the file + * unsupported/test/NonLinearOptimization.cpp. + */ + +// IWYU pragma: begin_exports +#ifndef EIGEN_PARSED_BY_DOXYGEN + +#include "src/NonLinearOptimization/qrsolv.h" +#include "src/NonLinearOptimization/r1updt.h" +#include "src/NonLinearOptimization/r1mpyq.h" +#include "src/NonLinearOptimization/rwupdt.h" +#include "src/NonLinearOptimization/fdjac1.h" +#include "src/NonLinearOptimization/lmpar.h" +#include "src/NonLinearOptimization/dogleg.h" +#include "src/NonLinearOptimization/covar.h" + +#include "src/NonLinearOptimization/chkder.h" + +#endif + +#include "src/NonLinearOptimization/HybridNonLinearSolver.h" +#include "src/NonLinearOptimization/LevenbergMarquardt.h" +// IWYU pragma: end_exports + +#endif // EIGEN_NONLINEAROPTIMIZATION_MODULE_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/NumericalDiff b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/NumericalDiff new file mode 100644 index 00000000000..ed236c860cb --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/NumericalDiff @@ -0,0 +1,57 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_NUMERICALDIFF_MODULE_H +#define EIGEN_NUMERICALDIFF_MODULE_H + +#include "../../Eigen/Core" + +namespace Eigen { + +/** + * \defgroup NumericalDiff_Module Numerical differentiation module + * + * \code + * #include + * \endcode + * + * See http://en.wikipedia.org/wiki/Numerical_differentiation + * + * Warning : this should NOT be confused with automatic differentiation, which + * is a different method and has its own module in Eigen : \ref + * AutoDiff_Module. + * + * Currently only "Forward" and "Central" schemes are implemented. Those + * are basic methods, and there exist some more elaborated way of + * computing such approximates. They are implemented using both + * proprietary and free software, and usually requires linking to an + * external library. It is very easy for you to write a functor + * using such software, and the purpose is quite orthogonal to what we + * want to achieve with Eigen. + * + * This is why we will not provide wrappers for every great numerical + * differentiation software that exist, but should rather stick with those + * basic ones, that still are useful for testing. + * + * Also, the \ref NonLinearOptimization_Module needs this in order to + * provide full features compatibility with the original (c)minpack + * package. + * + */ +} + +//@{ + +// IWYU pragma: begin_exports +#include "src/NumericalDiff/NumericalDiff.h" +// IWYU pragma: end_exports + +//@} + +#endif // EIGEN_NUMERICALDIFF_MODULE_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/CopyrightMINPACK.txt b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/CopyrightMINPACK.txt new file mode 100644 index 00000000000..ae7984daec9 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/CopyrightMINPACK.txt @@ -0,0 +1,52 @@ +Minpack Copyright Notice (1999) University of Chicago. All rights reserved + +Redistribution and use in source and binary forms, with or +without modification, are permitted provided that the +following conditions are met: + +1. Redistributions of source code must retain the above +copyright notice, this list of conditions and the following +disclaimer. + +2. Redistributions in binary form must reproduce the above +copyright notice, this list of conditions and the following +disclaimer in the documentation and/or other materials +provided with the distribution. + +3. The end-user documentation included with the +redistribution, if any, must include the following +acknowledgment: + + "This product includes software developed by the + University of Chicago, as Operator of Argonne National + Laboratory. + +Alternately, this acknowledgment may appear in the software +itself, if and wherever such third-party acknowledgments +normally appear. + +4. WARRANTY DISCLAIMER. THE SOFTWARE IS SUPPLIED "AS IS" +WITHOUT WARRANTY OF ANY KIND. THE COPYRIGHT HOLDER, THE +UNITED STATES, THE UNITED STATES DEPARTMENT OF ENERGY, AND +THEIR EMPLOYEES: (1) DISCLAIM ANY WARRANTIES, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO ANY IMPLIED WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, TITLE +OR NON-INFRINGEMENT, (2) DO NOT ASSUME ANY LEGAL LIABILITY +OR RESPONSIBILITY FOR THE ACCURACY, COMPLETENESS, OR +USEFULNESS OF THE SOFTWARE, (3) DO NOT REPRESENT THAT USE OF +THE SOFTWARE WOULD NOT INFRINGE PRIVATELY OWNED RIGHTS, (4) +DO NOT WARRANT THAT THE SOFTWARE WILL FUNCTION +UNINTERRUPTED, THAT IT IS ERROR-FREE OR THAT ANY ERRORS WILL +BE CORRECTED. + +5. LIMITATION OF LIABILITY. IN NO EVENT WILL THE COPYRIGHT +HOLDER, THE UNITED STATES, THE UNITED STATES DEPARTMENT OF +ENERGY, OR THEIR EMPLOYEES: BE LIABLE FOR ANY INDIRECT, +INCIDENTAL, CONSEQUENTIAL, SPECIAL OR PUNITIVE DAMAGES OF +ANY KIND OR NATURE, INCLUDING BUT NOT LIMITED TO LOSS OF +PROFITS OR LOSS OF DATA, FOR ANY REASON WHATSOEVER, WHETHER +SUCH LIABILITY IS ASSERTED ON THE BASIS OF CONTRACT, TORT +(INCLUDING NEGLIGENCE OR STRICT LIABILITY), OR OTHERWISE, +EVEN IF ANY OF SAID PARTIES HAS BEEN WARNED OF THE +POSSIBILITY OF SUCH LOSS OR DAMAGES. + diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/InternalHeaderCheck.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/InternalHeaderCheck.h new file mode 100644 index 00000000000..a9a646f9dee --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/InternalHeaderCheck.h @@ -0,0 +1,4 @@ +#ifndef EIGEN_LEVENBERGMARQUARDT_MODULE_H +#error \ + "Please include unsupported/Eigen/LevenbergMarquardt instead of including headers inside the src directory directly." +#endif diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMcovar.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMcovar.h new file mode 100644 index 00000000000..b81d5a3ea28 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMcovar.h @@ -0,0 +1,80 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// This code initially comes from MINPACK whose original authors are: +// Copyright Jorge More - Argonne National Laboratory +// Copyright Burt Garbow - Argonne National Laboratory +// Copyright Ken Hillstrom - Argonne National Laboratory +// +// This Source Code Form is subject to the terms of the Minpack license +// (a BSD-like license) described in the campaigned CopyrightMINPACK.txt file. + +#ifndef EIGEN_LMCOVAR_H +#define EIGEN_LMCOVAR_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void covar(Matrix& r, const VectorXi& ipvt, + Scalar tol = std::sqrt(NumTraits::epsilon())) { + using std::abs; + /* Local variables */ + Index i, j, k, l, ii, jj; + bool sing; + Scalar temp; + + /* Function Body */ + const Index n = r.cols(); + const Scalar tolr = tol * abs(r(0, 0)); + Matrix wa(n); + eigen_assert(ipvt.size() == n); + + /* form the inverse of r in the full upper triangle of r. */ + l = -1; + for (k = 0; k < n; ++k) + if (abs(r(k, k)) > tolr) { + r(k, k) = 1. / r(k, k); + for (j = 0; j <= k - 1; ++j) { + temp = r(k, k) * r(j, k); + r(j, k) = 0.; + r.col(k).head(j + 1) -= r.col(j).head(j + 1) * temp; + } + l = k; + } + + /* form the full upper triangle of the inverse of (r transpose)*r */ + /* in the full upper triangle of r. */ + for (k = 0; k <= l; ++k) { + for (j = 0; j <= k - 1; ++j) r.col(j).head(j + 1) += r.col(k).head(j + 1) * r(j, k); + r.col(k).head(k + 1) *= r(k, k); + } + + /* form the full lower triangle of the covariance matrix */ + /* in the strict lower triangle of r and in wa. */ + for (j = 0; j < n; ++j) { + jj = ipvt[j]; + sing = j > l; + for (i = 0; i <= j; ++i) { + if (sing) r(i, j) = 0.; + ii = ipvt[i]; + if (ii > jj) r(ii, jj) = r(i, j); + if (ii < jj) r(jj, ii) = r(i, j); + } + wa[jj] = r(j, j); + } + + /* symmetrize the covariance matrix in r. */ + r.topLeftCorner(n, n).template triangularView() = r.topLeftCorner(n, n).transpose(); + r.diagonal() = wa; +} + +} // end namespace internal + +} // end namespace Eigen + +#endif // EIGEN_LMCOVAR_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMonestep.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMonestep.h new file mode 100644 index 00000000000..f0697ceec78 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMonestep.h @@ -0,0 +1,187 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This code initially comes from MINPACK whose original authors are: +// Copyright Jorge More - Argonne National Laboratory +// Copyright Burt Garbow - Argonne National Laboratory +// Copyright Ken Hillstrom - Argonne National Laboratory +// +// This Source Code Form is subject to the terms of the Minpack license +// (a BSD-like license) described in the campaigned CopyrightMINPACK.txt file. + +#ifndef EIGEN_LMONESTEP_H +#define EIGEN_LMONESTEP_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeOneStep(FVectorType &x) { + using std::abs; + using std::sqrt; + RealScalar temp, temp1, temp2; + RealScalar ratio; + RealScalar pnorm, xnorm, fnorm1, actred, dirder, prered; + eigen_assert(x.size() == n); // check the caller is not cheating us + + temp = 0.0; + xnorm = 0.0; + /* calculate the jacobian matrix. */ + Index df_ret = m_functor.df(x, m_fjac); + if (df_ret < 0) return LevenbergMarquardtSpace::UserAsked; + if (df_ret > 0) + // numerical diff, we evaluated the function df_ret times + m_nfev += df_ret; + else + m_njev++; + + /* compute the qr factorization of the jacobian. */ + for (int j = 0; j < x.size(); ++j) m_wa2(j) = m_fjac.col(j).blueNorm(); + QRSolver qrfac(m_fjac); + if (qrfac.info() != Success) { + m_info = NumericalIssue; + return LevenbergMarquardtSpace::ImproperInputParameters; + } + // Make a copy of the first factor with the associated permutation + m_rfactor = qrfac.matrixR(); + m_permutation = (qrfac.colsPermutation()); + + /* on the first iteration and if external scaling is not used, scale according */ + /* to the norms of the columns of the initial jacobian. */ + if (m_iter == 1) { + if (!m_useExternalScaling) + for (Index j = 0; j < n; ++j) m_diag[j] = (m_wa2[j] == 0.) ? 1. : m_wa2[j]; + + /* on the first iteration, calculate the norm of the scaled x */ + /* and initialize the step bound m_delta. */ + xnorm = m_diag.cwiseProduct(x).stableNorm(); + m_delta = m_factor * xnorm; + if (m_delta == 0.) m_delta = m_factor; + } + + /* form (q transpose)*m_fvec and store the first n components in */ + /* m_qtf. */ + m_wa4 = m_fvec; + m_wa4 = qrfac.matrixQ().adjoint() * m_fvec; + m_qtf = m_wa4.head(n); + + /* compute the norm of the scaled gradient. */ + m_gnorm = 0.; + if (m_fnorm != 0.) + for (Index j = 0; j < n; ++j) + if (m_wa2[m_permutation.indices()[j]] != 0.) + m_gnorm = (std::max)(m_gnorm, abs(m_rfactor.col(j).head(j + 1).dot(m_qtf.head(j + 1) / m_fnorm) / + m_wa2[m_permutation.indices()[j]])); + + /* test for convergence of the gradient norm. */ + if (m_gnorm <= m_gtol) { + m_info = Success; + return LevenbergMarquardtSpace::CosinusTooSmall; + } + + /* rescale if necessary. */ + if (!m_useExternalScaling) m_diag = m_diag.cwiseMax(m_wa2); + + do { + /* determine the levenberg-marquardt parameter. */ + internal::lmpar2(qrfac, m_diag, m_qtf, m_delta, m_par, m_wa1); + + /* store the direction p and x + p. calculate the norm of p. */ + m_wa1 = -m_wa1; + m_wa2 = x + m_wa1; + pnorm = m_diag.cwiseProduct(m_wa1).stableNorm(); + + /* on the first iteration, adjust the initial step bound. */ + if (m_iter == 1) m_delta = (std::min)(m_delta, pnorm); + + /* evaluate the function at x + p and calculate its norm. */ + if (m_functor(m_wa2, m_wa4) < 0) return LevenbergMarquardtSpace::UserAsked; + ++m_nfev; + fnorm1 = m_wa4.stableNorm(); + + /* compute the scaled actual reduction. */ + actred = -1.; + if (Scalar(.1) * fnorm1 < m_fnorm) actred = 1. - numext::abs2(fnorm1 / m_fnorm); + + /* compute the scaled predicted reduction and */ + /* the scaled directional derivative. */ + m_wa3 = m_rfactor.template triangularView() * (m_permutation.inverse() * m_wa1); + temp1 = numext::abs2(m_wa3.stableNorm() / m_fnorm); + temp2 = numext::abs2(sqrt(m_par) * pnorm / m_fnorm); + prered = temp1 + temp2 / Scalar(.5); + dirder = -(temp1 + temp2); + + /* compute the ratio of the actual to the predicted */ + /* reduction. */ + ratio = 0.; + if (prered != 0.) ratio = actred / prered; + + /* update the step bound. */ + if (ratio <= Scalar(.25)) { + if (actred >= 0.) temp = RealScalar(.5); + if (actred < 0.) temp = RealScalar(.5) * dirder / (dirder + RealScalar(.5) * actred); + if (RealScalar(.1) * fnorm1 >= m_fnorm || temp < RealScalar(.1)) temp = Scalar(.1); + /* Computing MIN */ + m_delta = temp * (std::min)(m_delta, pnorm / RealScalar(.1)); + m_par /= temp; + } else if (!(m_par != 0. && ratio < RealScalar(.75))) { + m_delta = pnorm / RealScalar(.5); + m_par = RealScalar(.5) * m_par; + } + + /* test for successful iteration. */ + if (ratio >= RealScalar(1e-4)) { + /* successful iteration. update x, m_fvec, and their norms. */ + x = m_wa2; + m_wa2 = m_diag.cwiseProduct(x); + m_fvec = m_wa4; + xnorm = m_wa2.stableNorm(); + m_fnorm = fnorm1; + ++m_iter; + } + + /* tests for convergence. */ + if (abs(actred) <= m_ftol && prered <= m_ftol && Scalar(.5) * ratio <= 1. && m_delta <= m_xtol * xnorm) { + m_info = Success; + return LevenbergMarquardtSpace::RelativeErrorAndReductionTooSmall; + } + if (abs(actred) <= m_ftol && prered <= m_ftol && Scalar(.5) * ratio <= 1.) { + m_info = Success; + return LevenbergMarquardtSpace::RelativeReductionTooSmall; + } + if (m_delta <= m_xtol * xnorm) { + m_info = Success; + return LevenbergMarquardtSpace::RelativeErrorTooSmall; + } + + /* tests for termination and stringent tolerances. */ + if (m_nfev >= m_maxfev) { + m_info = NoConvergence; + return LevenbergMarquardtSpace::TooManyFunctionEvaluation; + } + if (abs(actred) <= NumTraits::epsilon() && prered <= NumTraits::epsilon() && + Scalar(.5) * ratio <= 1.) { + m_info = Success; + return LevenbergMarquardtSpace::FtolTooSmall; + } + if (m_delta <= NumTraits::epsilon() * xnorm) { + m_info = Success; + return LevenbergMarquardtSpace::XtolTooSmall; + } + if (m_gnorm <= NumTraits::epsilon()) { + m_info = Success; + return LevenbergMarquardtSpace::GtolTooSmall; + } + + } while (ratio < Scalar(1e-4)); + + return LevenbergMarquardtSpace::Running; +} + +} // end namespace Eigen + +#endif // EIGEN_LMONESTEP_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMpar.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMpar.h new file mode 100644 index 00000000000..01fcfdc253e --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMpar.h @@ -0,0 +1,149 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// This code initially comes from MINPACK whose original authors are: +// Copyright Jorge More - Argonne National Laboratory +// Copyright Burt Garbow - Argonne National Laboratory +// Copyright Ken Hillstrom - Argonne National Laboratory +// +// This Source Code Form is subject to the terms of the Minpack license +// (a BSD-like license) described in the campaigned CopyrightMINPACK.txt file. + +#ifndef EIGEN_LMPAR_H +#define EIGEN_LMPAR_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void lmpar2(const QRSolver &qr, const VectorType &diag, const VectorType &qtb, typename VectorType::Scalar m_delta, + typename VectorType::Scalar &par, VectorType &x) + +{ + using std::abs; + using std::sqrt; + typedef typename QRSolver::MatrixType MatrixType; + typedef typename QRSolver::Scalar Scalar; + // typedef typename QRSolver::StorageIndex StorageIndex; + + /* Local variables */ + Index j; + Scalar fp; + Scalar parc, parl; + Index iter; + Scalar temp, paru; + Scalar gnorm; + Scalar dxnorm; + + // Make a copy of the triangular factor. + // This copy is modified during call the qrsolv + MatrixType s; + s = qr.matrixR(); + + /* Function Body */ + const Scalar dwarf = (std::numeric_limits::min)(); + const Index n = qr.matrixR().cols(); + eigen_assert(n == diag.size()); + eigen_assert(n == qtb.size()); + + VectorType wa1, wa2; + + /* compute and store in x the gauss-newton direction. if the */ + /* jacobian is rank-deficient, obtain a least squares solution. */ + + // const Index rank = qr.nonzeroPivots(); // exactly double(0.) + const Index rank = qr.rank(); // use a threshold + wa1 = qtb; + wa1.tail(n - rank).setZero(); + // FIXME There is no solve in place for sparse triangularView + wa1.head(rank) = s.topLeftCorner(rank, rank).template triangularView().solve(qtb.head(rank)); + + x = qr.colsPermutation() * wa1; + + /* initialize the iteration counter. */ + /* evaluate the function at the origin, and test */ + /* for acceptance of the gauss-newton direction. */ + iter = 0; + wa2 = diag.cwiseProduct(x); + dxnorm = wa2.blueNorm(); + fp = dxnorm - m_delta; + if (fp <= Scalar(0.1) * m_delta) { + par = 0; + return; + } + + /* if the jacobian is not rank deficient, the newton */ + /* step provides a lower bound, parl, for the zero of */ + /* the function. otherwise set this bound to zero. */ + parl = 0.; + if (rank == n) { + wa1 = qr.colsPermutation().inverse() * diag.cwiseProduct(wa2) / dxnorm; + s.topLeftCorner(n, n).transpose().template triangularView().solveInPlace(wa1); + temp = wa1.blueNorm(); + parl = fp / m_delta / temp / temp; + } + + /* calculate an upper bound, paru, for the zero of the function. */ + for (j = 0; j < n; ++j) wa1[j] = s.col(j).head(j + 1).dot(qtb.head(j + 1)) / diag[qr.colsPermutation().indices()(j)]; + + gnorm = wa1.stableNorm(); + paru = gnorm / m_delta; + if (paru == 0.) paru = dwarf / (std::min)(m_delta, Scalar(0.1)); + + /* if the input par lies outside of the interval (parl,paru), */ + /* set par to the closer endpoint. */ + par = (std::max)(par, parl); + par = (std::min)(par, paru); + if (par == 0.) par = gnorm / dxnorm; + + /* beginning of an iteration. */ + while (true) { + ++iter; + + /* evaluate the function at the current value of par. */ + if (par == 0.) par = (std::max)(dwarf, Scalar(.001) * paru); /* Computing MAX */ + wa1 = sqrt(par) * diag; + + VectorType sdiag(n); + lmqrsolv(s, qr.colsPermutation(), wa1, qtb, x, sdiag); + + wa2 = diag.cwiseProduct(x); + dxnorm = wa2.blueNorm(); + temp = fp; + fp = dxnorm - m_delta; + + /* if the function is small enough, accept the current value */ + /* of par. also test for the exceptional cases where parl */ + /* is zero or the number of iterations has reached 10. */ + if (abs(fp) <= Scalar(0.1) * m_delta || (parl == 0. && fp <= temp && temp < 0.) || iter == 10) break; + + /* compute the newton correction. */ + wa1 = qr.colsPermutation().inverse() * diag.cwiseProduct(wa2 / dxnorm); + // we could almost use this here, but the diagonal is outside qr, in sdiag[] + for (j = 0; j < n; ++j) { + wa1[j] /= sdiag[j]; + temp = wa1[j]; + for (Index i = j + 1; i < n; ++i) wa1[i] -= s.coeff(i, j) * temp; + } + temp = wa1.blueNorm(); + parc = fp / m_delta / temp / temp; + + /* depending on the sign of the function, update parl or paru. */ + if (fp > 0.) parl = (std::max)(parl, par); + if (fp < 0.) paru = (std::min)(paru, par); + + /* compute an improved estimate for par. */ + par = (std::max)(parl, par + parc); + } + if (iter == 0) par = 0.; + return; +} +} // end namespace internal + +} // end namespace Eigen + +#endif // EIGEN_LMPAR_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMqrsolv.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMqrsolv.h new file mode 100644 index 00000000000..49bf6e1a586 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LMqrsolv.h @@ -0,0 +1,178 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// Copyright (C) 2012 Desire Nuentsa +// +// This code initially comes from MINPACK whose original authors are: +// Copyright Jorge More - Argonne National Laboratory +// Copyright Burt Garbow - Argonne National Laboratory +// Copyright Ken Hillstrom - Argonne National Laboratory +// +// This Source Code Form is subject to the terms of the Minpack license +// (a BSD-like license) described in the campaigned CopyrightMINPACK.txt file. + +#ifndef EIGEN_LMQRSOLV_H +#define EIGEN_LMQRSOLV_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void lmqrsolv(Matrix &s, const PermutationMatrix &iPerm, + const Matrix &diag, const Matrix &qtb, + Matrix &x, Matrix &sdiag) { + /* Local variables */ + Index i, j, k; + Scalar temp; + Index n = s.cols(); + Matrix wa(n); + JacobiRotation givens; + + /* Function Body */ + // the following will only change the lower triangular part of s, including + // the diagonal, though the diagonal is restored afterward + + /* copy r and (q transpose)*b to preserve input and initialize s. */ + /* in particular, save the diagonal elements of r in x. */ + x = s.diagonal(); + wa = qtb; + + s.topLeftCorner(n, n).template triangularView() = s.topLeftCorner(n, n).transpose(); + /* eliminate the diagonal matrix d using a givens rotation. */ + for (j = 0; j < n; ++j) { + /* prepare the row of d to be eliminated, locating the */ + /* diagonal element using p from the qr factorization. */ + const PermIndex l = iPerm.indices()(j); + if (diag[l] == 0.) break; + sdiag.tail(n - j).setZero(); + sdiag[j] = diag[l]; + + /* the transformations to eliminate the row of d */ + /* modify only a single element of (q transpose)*b */ + /* beyond the first n, which is initially zero. */ + Scalar qtbpj = 0.; + for (k = j; k < n; ++k) { + /* determine a givens rotation which eliminates the */ + /* appropriate element in the current row of d. */ + givens.makeGivens(-s(k, k), sdiag[k]); + + /* compute the modified diagonal element of r and */ + /* the modified element of ((q transpose)*b,0). */ + s(k, k) = givens.c() * s(k, k) + givens.s() * sdiag[k]; + temp = givens.c() * wa[k] + givens.s() * qtbpj; + qtbpj = -givens.s() * wa[k] + givens.c() * qtbpj; + wa[k] = temp; + + /* accumulate the transformation in the row of s. */ + for (i = k + 1; i < n; ++i) { + temp = givens.c() * s(i, k) + givens.s() * sdiag[i]; + sdiag[i] = -givens.s() * s(i, k) + givens.c() * sdiag[i]; + s(i, k) = temp; + } + } + } + + /* solve the triangular system for z. if the system is */ + /* singular, then obtain a least squares solution. */ + Index nsing; + for (nsing = 0; nsing < n && sdiag[nsing] != 0; nsing++) { + } + + wa.tail(n - nsing).setZero(); + s.topLeftCorner(nsing, nsing).transpose().template triangularView().solveInPlace(wa.head(nsing)); + + // restore + sdiag = s.diagonal(); + s.diagonal() = x; + + /* permute the components of z back to components of x. */ + x = iPerm * wa; +} + +template +void lmqrsolv(SparseMatrix &s, const PermutationMatrix &iPerm, + const Matrix &diag, const Matrix &qtb, + Matrix &x, Matrix &sdiag) { + /* Local variables */ + typedef SparseMatrix FactorType; + Index i, j, k, l; + Scalar temp; + Index n = s.cols(); + Matrix wa(n); + JacobiRotation givens; + + /* Function Body */ + // the following will only change the lower triangular part of s, including + // the diagonal, though the diagonal is restored afterward + + /* copy r and (q transpose)*b to preserve input and initialize R. */ + wa = qtb; + FactorType R(s); + // Eliminate the diagonal matrix d using a givens rotation + for (j = 0; j < n; ++j) { + // Prepare the row of d to be eliminated, locating the + // diagonal element using p from the qr factorization + l = iPerm.indices()(j); + if (diag(l) == Scalar(0)) break; + sdiag.tail(n - j).setZero(); + sdiag[j] = diag[l]; + // the transformations to eliminate the row of d + // modify only a single element of (q transpose)*b + // beyond the first n, which is initially zero. + + Scalar qtbpj = 0; + // Browse the nonzero elements of row j of the upper triangular s + for (k = j; k < n; ++k) { + typename FactorType::InnerIterator itk(R, k); + for (; itk; ++itk) { + if (itk.index() < k) + continue; + else + break; + } + // At this point, we have the diagonal element R(k,k) + // Determine a givens rotation which eliminates + // the appropriate element in the current row of d + givens.makeGivens(-itk.value(), sdiag(k)); + + // Compute the modified diagonal element of r and + // the modified element of ((q transpose)*b,0). + itk.valueRef() = givens.c() * itk.value() + givens.s() * sdiag(k); + temp = givens.c() * wa(k) + givens.s() * qtbpj; + qtbpj = -givens.s() * wa(k) + givens.c() * qtbpj; + wa(k) = temp; + + // Accumulate the transformation in the remaining k row/column of R + for (++itk; itk; ++itk) { + i = itk.index(); + temp = givens.c() * itk.value() + givens.s() * sdiag(i); + sdiag(i) = -givens.s() * itk.value() + givens.c() * sdiag(i); + itk.valueRef() = temp; + } + } + } + + // Solve the triangular system for z. If the system is + // singular, then obtain a least squares solution + Index nsing; + for (nsing = 0; nsing < n && sdiag(nsing) != 0; nsing++) { + } + + wa.tail(n - nsing).setZero(); + // x = wa; + wa.head(nsing) = R.topLeftCorner(nsing, nsing).template triangularView().solve /*InPlace*/ (wa.head(nsing)); + + sdiag = R.diagonal(); + // Permute the components of z back to components of x + x = iPerm * wa; +} +} // end namespace internal + +} // end namespace Eigen + +#endif // EIGEN_LMQRSOLV_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LevenbergMarquardt.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LevenbergMarquardt.h new file mode 100644 index 00000000000..b8a6ddae958 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/LevenbergMarquardt/LevenbergMarquardt.h @@ -0,0 +1,362 @@ +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// Copyright (C) 2012 Desire Nuentsa +// +// The algorithm of this class initially comes from MINPACK whose original authors are: +// Copyright Jorge More - Argonne National Laboratory +// Copyright Burt Garbow - Argonne National Laboratory +// Copyright Ken Hillstrom - Argonne National Laboratory +// +// This Source Code Form is subject to the terms of the Minpack license +// (a BSD-like license) described in the campaigned CopyrightMINPACK.txt file. +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_LEVENBERGMARQUARDT_H +#define EIGEN_LEVENBERGMARQUARDT_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { +namespace LevenbergMarquardtSpace { +enum Status { + NotStarted = -2, + Running = -1, + ImproperInputParameters = 0, + RelativeReductionTooSmall = 1, + RelativeErrorTooSmall = 2, + RelativeErrorAndReductionTooSmall = 3, + CosinusTooSmall = 4, + TooManyFunctionEvaluation = 5, + FtolTooSmall = 6, + XtolTooSmall = 7, + GtolTooSmall = 8, + UserAsked = 9 +}; +} + +template +struct DenseFunctor { + typedef Scalar_ Scalar; + enum { InputsAtCompileTime = NX, ValuesAtCompileTime = NY }; + typedef Matrix InputType; + typedef Matrix ValueType; + typedef Matrix JacobianType; + typedef ColPivHouseholderQR QRSolver; + const int m_inputs, m_values; + + DenseFunctor() : m_inputs(InputsAtCompileTime), m_values(ValuesAtCompileTime) {} + DenseFunctor(int inputs, int values) : m_inputs(inputs), m_values(values) {} + + int inputs() const { return m_inputs; } + int values() const { return m_values; } + + // int operator()(const InputType &x, ValueType& fvec) { } + // should be defined in derived classes + + // int df(const InputType &x, JacobianType& fjac) { } + // should be defined in derived classes +}; + +template +struct SparseFunctor { + typedef Scalar_ Scalar; + typedef Index_ Index; + typedef Matrix InputType; + typedef Matrix ValueType; + typedef SparseMatrix JacobianType; + typedef SparseQR > QRSolver; + enum { InputsAtCompileTime = Dynamic, ValuesAtCompileTime = Dynamic }; + + SparseFunctor(int inputs, int values) : m_inputs(inputs), m_values(values) {} + + int inputs() const { return m_inputs; } + int values() const { return m_values; } + + const int m_inputs, m_values; + // int operator()(const InputType &x, ValueType& fvec) { } + // to be defined in the functor + + // int df(const InputType &x, JacobianType& fjac) { } + // to be defined in the functor if no automatic differentiation +}; +namespace internal { +template +void lmpar2(const QRSolver &qr, const VectorType &diag, const VectorType &qtb, typename VectorType::Scalar m_delta, + typename VectorType::Scalar &par, VectorType &x); +} +/** + * \ingroup NonLinearOptimization_Module + * \brief Performs non linear optimization over a non-linear function, + * using a variant of the Levenberg Marquardt algorithm. + * + * Check wikipedia for more information. + * http://en.wikipedia.org/wiki/Levenberg%E2%80%93Marquardt_algorithm + */ +template +class LevenbergMarquardt : internal::no_assignment_operator { + public: + typedef FunctorType_ FunctorType; + typedef typename FunctorType::QRSolver QRSolver; + typedef typename FunctorType::JacobianType JacobianType; + typedef typename JacobianType::Scalar Scalar; + typedef typename JacobianType::RealScalar RealScalar; + typedef typename QRSolver::StorageIndex PermIndex; + typedef Matrix FVectorType; + typedef PermutationMatrix PermutationType; + + public: + LevenbergMarquardt(FunctorType &functor) + : m_functor(functor), + m_nfev(0), + m_njev(0), + m_fnorm(0.0), + m_gnorm(0), + m_isInitialized(false), + m_info(InvalidInput) { + resetParameters(); + m_useExternalScaling = false; + } + + LevenbergMarquardtSpace::Status minimize(FVectorType &x); + LevenbergMarquardtSpace::Status minimizeInit(FVectorType &x); + LevenbergMarquardtSpace::Status minimizeOneStep(FVectorType &x); + LevenbergMarquardtSpace::Status lmder1(FVectorType &x, const Scalar tol = std::sqrt(NumTraits::epsilon())); + static LevenbergMarquardtSpace::Status lmdif1(FunctorType &functor, FVectorType &x, Index *nfev, + const Scalar tol = std::sqrt(NumTraits::epsilon())); + + /** Sets the default parameters */ + void resetParameters() { + using std::sqrt; + + m_factor = 100.; + m_maxfev = 400; + m_ftol = sqrt(NumTraits::epsilon()); + m_xtol = sqrt(NumTraits::epsilon()); + m_gtol = 0.; + m_epsfcn = 0.; + } + + /** Sets the tolerance for the norm of the solution vector*/ + void setXtol(RealScalar xtol) { m_xtol = xtol; } + + /** Sets the tolerance for the norm of the vector function*/ + void setFtol(RealScalar ftol) { m_ftol = ftol; } + + /** Sets the tolerance for the norm of the gradient of the error vector*/ + void setGtol(RealScalar gtol) { m_gtol = gtol; } + + /** Sets the step bound for the diagonal shift */ + void setFactor(RealScalar factor) { m_factor = factor; } + + /** Sets the error precision */ + void setEpsilon(RealScalar epsfcn) { m_epsfcn = epsfcn; } + + /** Sets the maximum number of function evaluation */ + void setMaxfev(Index maxfev) { m_maxfev = maxfev; } + + /** Use an external Scaling. If set to true, pass a nonzero diagonal to diag() */ + void setExternalScaling(bool value) { m_useExternalScaling = value; } + + /** \returns the tolerance for the norm of the solution vector */ + RealScalar xtol() const { return m_xtol; } + + /** \returns the tolerance for the norm of the vector function */ + RealScalar ftol() const { return m_ftol; } + + /** \returns the tolerance for the norm of the gradient of the error vector */ + RealScalar gtol() const { return m_gtol; } + + /** \returns the step bound for the diagonal shift */ + RealScalar factor() const { return m_factor; } + + /** \returns the error precision */ + RealScalar epsilon() const { return m_epsfcn; } + + /** \returns the maximum number of function evaluation */ + Index maxfev() const { return m_maxfev; } + + /** \returns a reference to the diagonal of the jacobian */ + FVectorType &diag() { return m_diag; } + + /** \returns the number of iterations performed */ + Index iterations() { return m_iter; } + + /** \returns the number of functions evaluation */ + Index nfev() { return m_nfev; } + + /** \returns the number of jacobian evaluation */ + Index njev() { return m_njev; } + + /** \returns the norm of current vector function */ + RealScalar fnorm() { return m_fnorm; } + + /** \returns the norm of the gradient of the error */ + RealScalar gnorm() { return m_gnorm; } + + /** \returns the LevenbergMarquardt parameter */ + RealScalar lm_param(void) { return m_par; } + + /** \returns a reference to the current vector function + */ + FVectorType &fvec() { return m_fvec; } + + /** \returns a reference to the matrix where the current Jacobian matrix is stored + */ + JacobianType &jacobian() { return m_fjac; } + + /** \returns a reference to the triangular matrix R from the QR of the jacobian matrix. + * \sa jacobian() + */ + JacobianType &matrixR() { return m_rfactor; } + + /** the permutation used in the QR factorization + */ + PermutationType permutation() { return m_permutation; } + + /** + * \brief Reports whether the minimization was successful + * \returns \c Success if the minimization was successful, + * \c NumericalIssue if a numerical problem arises during the + * minimization process, for example during the QR factorization + * \c NoConvergence if the minimization did not converge after + * the maximum number of function evaluation allowed + * \c InvalidInput if the input matrix is invalid + */ + ComputationInfo info() const { return m_info; } + + private: + JacobianType m_fjac; + JacobianType m_rfactor; // The triangular matrix R from the QR of the jacobian matrix m_fjac + FunctorType &m_functor; + FVectorType m_fvec, m_qtf, m_diag; + Index n; + Index m; + Index m_nfev; + Index m_njev; + RealScalar m_fnorm; // Norm of the current vector function + RealScalar m_gnorm; // Norm of the gradient of the error + RealScalar m_factor; // + Index m_maxfev; // Maximum number of function evaluation + RealScalar m_ftol; // Tolerance in the norm of the vector function + RealScalar m_xtol; // + RealScalar m_gtol; // tolerance of the norm of the error gradient + RealScalar m_epsfcn; // + Index m_iter; // Number of iterations performed + RealScalar m_delta; + bool m_useExternalScaling; + PermutationType m_permutation; + FVectorType m_wa1, m_wa2, m_wa3, m_wa4; // Temporary vectors + RealScalar m_par; + bool m_isInitialized; // Check whether the minimization step has been called + ComputationInfo m_info; +}; + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimize(FVectorType &x) { + LevenbergMarquardtSpace::Status status = minimizeInit(x); + if (status == LevenbergMarquardtSpace::ImproperInputParameters) { + m_isInitialized = true; + return status; + } + do { + // std::cout << " uv " << x.transpose() << "\n"; + status = minimizeOneStep(x); + } while (status == LevenbergMarquardtSpace::Running); + m_isInitialized = true; + return status; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeInit(FVectorType &x) { + n = x.size(); + m = m_functor.values(); + + m_wa1.resize(n); + m_wa2.resize(n); + m_wa3.resize(n); + m_wa4.resize(m); + m_fvec.resize(m); + // FIXME Sparse Case : Allocate space for the jacobian + m_fjac.resize(m, n); + // m_fjac.reserve(VectorXi::Constant(n,5)); // FIXME Find a better alternative + if (!m_useExternalScaling) m_diag.resize(n); + eigen_assert((!m_useExternalScaling || m_diag.size() == n) && + "When m_useExternalScaling is set, the caller must provide a valid 'm_diag'"); + m_qtf.resize(n); + + /* Function Body */ + m_nfev = 0; + m_njev = 0; + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || m_ftol < 0. || m_xtol < 0. || m_gtol < 0. || m_maxfev <= 0 || m_factor <= 0.) { + m_info = InvalidInput; + return LevenbergMarquardtSpace::ImproperInputParameters; + } + + if (m_useExternalScaling) + for (Index j = 0; j < n; ++j) + if (m_diag[j] <= 0.) { + m_info = InvalidInput; + return LevenbergMarquardtSpace::ImproperInputParameters; + } + + /* evaluate the function at the starting point */ + /* and calculate its norm. */ + m_nfev = 1; + if (m_functor(x, m_fvec) < 0) return LevenbergMarquardtSpace::UserAsked; + m_fnorm = m_fvec.stableNorm(); + + /* initialize levenberg-marquardt parameter and iteration counter. */ + m_par = 0.; + m_iter = 1; + + return LevenbergMarquardtSpace::NotStarted; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::lmder1(FVectorType &x, const Scalar tol) { + n = x.size(); + m = m_functor.values(); + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || tol < 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + resetParameters(); + m_ftol = tol; + m_xtol = tol; + m_maxfev = 100 * (n + 1); + + return minimize(x); +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::lmdif1(FunctorType &functor, FVectorType &x, + Index *nfev, const Scalar tol) { + Index n = x.size(); + Index m = functor.values(); + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || tol < 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + NumericalDiff numDiff(functor); + // embedded LevenbergMarquardt + LevenbergMarquardt > lm(numDiff); + lm.setFtol(tol); + lm.setXtol(tol); + lm.setMaxfev(200 * (n + 1)); + + LevenbergMarquardtSpace::Status info = LevenbergMarquardtSpace::Status(lm.minimize(x)); + if (nfev) *nfev = lm.nfev(); + return info; +} + +} // end namespace Eigen + +#endif // EIGEN_LEVENBERGMARQUARDT_H diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/HybridNonLinearSolver.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/HybridNonLinearSolver.h new file mode 100644 index 00000000000..079772e6c2a --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/HybridNonLinearSolver.h @@ -0,0 +1,545 @@ +// -*- coding: utf-8 +// vim: set fileencoding=utf-8 + +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_HYBRIDNONLINEARSOLVER_H +#define EIGEN_HYBRIDNONLINEARSOLVER_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace HybridNonLinearSolverSpace { +enum Status { + Running = -1, + ImproperInputParameters = 0, + RelativeErrorTooSmall = 1, + TooManyFunctionEvaluation = 2, + TolTooSmall = 3, + NotMakingProgressJacobian = 4, + NotMakingProgressIterations = 5, + UserAsked = 6 +}; +} + +/** + * \ingroup NonLinearOptimization_Module + * \brief Finds a zero of a system of n + * nonlinear functions in n variables by a modification of the Powell + * hybrid method ("dogleg"). + * + * The user must provide a subroutine which calculates the + * functions. The Jacobian is either provided by the user, or approximated + * using a forward-difference method. + * + */ +template +class HybridNonLinearSolver { + public: + typedef DenseIndex Index; + + HybridNonLinearSolver(FunctorType &_functor) : functor(_functor) { + nfev = njev = iter = 0; + fnorm = 0.; + useExternalScaling = false; + } + + struct Parameters { + Parameters() + : factor(Scalar(100.)), + maxfev(1000), + xtol(numext::sqrt(NumTraits::epsilon())), + nb_of_subdiagonals(-1), + nb_of_superdiagonals(-1), + epsfcn(Scalar(0.)) {} + Scalar factor; + Index maxfev; // maximum number of function evaluation + Scalar xtol; + Index nb_of_subdiagonals; + Index nb_of_superdiagonals; + Scalar epsfcn; + }; + typedef Matrix FVectorType; + typedef Matrix JacobianType; + /* TODO: if eigen provides a triangular storage, use it here */ + typedef Matrix UpperTriangularType; + + HybridNonLinearSolverSpace::Status hybrj1(FVectorType &x, + const Scalar tol = numext::sqrt(NumTraits::epsilon())); + + HybridNonLinearSolverSpace::Status solveInit(FVectorType &x); + HybridNonLinearSolverSpace::Status solveOneStep(FVectorType &x); + HybridNonLinearSolverSpace::Status solve(FVectorType &x); + + HybridNonLinearSolverSpace::Status hybrd1(FVectorType &x, + const Scalar tol = numext::sqrt(NumTraits::epsilon())); + + HybridNonLinearSolverSpace::Status solveNumericalDiffInit(FVectorType &x); + HybridNonLinearSolverSpace::Status solveNumericalDiffOneStep(FVectorType &x); + HybridNonLinearSolverSpace::Status solveNumericalDiff(FVectorType &x); + + void resetParameters(void) { parameters = Parameters(); } + Parameters parameters; + FVectorType fvec, qtf, diag; + JacobianType fjac; + UpperTriangularType R; + Index nfev; + Index njev; + Index iter; + Scalar fnorm; + bool useExternalScaling; + + private: + FunctorType &functor; + Index n; + Scalar sum; + bool sing; + Scalar temp; + Scalar delta; + bool jeval; + Index ncsuc; + Scalar ratio; + Scalar pnorm, xnorm, fnorm1; + Index nslow1, nslow2; + Index ncfail; + Scalar actred, prered; + FVectorType wa1, wa2, wa3, wa4; + + HybridNonLinearSolver &operator=(const HybridNonLinearSolver &); +}; + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::hybrj1(FVectorType &x, + const Scalar tol) { + n = x.size(); + + /* check the input parameters for errors. */ + if (n <= 0 || tol < 0.) return HybridNonLinearSolverSpace::ImproperInputParameters; + + resetParameters(); + parameters.maxfev = 100 * (n + 1); + parameters.xtol = tol; + diag.setConstant(n, 1.); + useExternalScaling = true; + return solve(x); +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::solveInit(FVectorType &x) { + n = x.size(); + + wa1.resize(n); + wa2.resize(n); + wa3.resize(n); + wa4.resize(n); + fvec.resize(n); + qtf.resize(n); + fjac.resize(n, n); + if (!useExternalScaling) diag.resize(n); + eigen_assert((!useExternalScaling || diag.size() == n) && + "When useExternalScaling is set, the caller must provide a valid 'diag'"); + + /* Function Body */ + nfev = 0; + njev = 0; + + /* check the input parameters for errors. */ + if (n <= 0 || parameters.xtol < 0. || parameters.maxfev <= 0 || parameters.factor <= 0.) + return HybridNonLinearSolverSpace::ImproperInputParameters; + if (useExternalScaling) + for (Index j = 0; j < n; ++j) + if (diag[j] <= 0.) return HybridNonLinearSolverSpace::ImproperInputParameters; + + /* evaluate the function at the starting point */ + /* and calculate its norm. */ + nfev = 1; + if (functor(x, fvec) < 0) return HybridNonLinearSolverSpace::UserAsked; + fnorm = fvec.stableNorm(); + + /* initialize iteration counter and monitors. */ + iter = 1; + ncsuc = 0; + ncfail = 0; + nslow1 = 0; + nslow2 = 0; + + return HybridNonLinearSolverSpace::Running; +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::solveOneStep(FVectorType &x) { + using std::abs; + + eigen_assert(x.size() == n); // check the caller is not cheating us + + Index j; + std::vector > v_givens(n), w_givens(n); + + jeval = true; + + /* calculate the jacobian matrix. */ + if (functor.df(x, fjac) < 0) return HybridNonLinearSolverSpace::UserAsked; + ++njev; + + wa2 = fjac.colwise().blueNorm(); + + /* on the first iteration and if external scaling is not used, scale according */ + /* to the norms of the columns of the initial jacobian. */ + if (iter == 1) { + if (!useExternalScaling) + for (j = 0; j < n; ++j) diag[j] = (wa2[j] == 0.) ? 1. : wa2[j]; + + /* on the first iteration, calculate the norm of the scaled x */ + /* and initialize the step bound delta. */ + xnorm = diag.cwiseProduct(x).stableNorm(); + delta = parameters.factor * xnorm; + if (delta == 0.) delta = parameters.factor; + } + + /* compute the qr factorization of the jacobian. */ + HouseholderQR qrfac(fjac); // no pivoting: + + /* copy the triangular factor of the qr factorization into r. */ + R = qrfac.matrixQR(); + + /* accumulate the orthogonal factor in fjac. */ + fjac = qrfac.householderQ(); + + /* form (q transpose)*fvec and store in qtf. */ + qtf = fjac.transpose() * fvec; + + /* rescale if necessary. */ + if (!useExternalScaling) diag = diag.cwiseMax(wa2); + + while (true) { + /* determine the direction p. */ + internal::dogleg(R, diag, qtf, delta, wa1); + + /* store the direction p and x + p. calculate the norm of p. */ + wa1 = -wa1; + wa2 = x + wa1; + pnorm = diag.cwiseProduct(wa1).stableNorm(); + + /* on the first iteration, adjust the initial step bound. */ + if (iter == 1) delta = (std::min)(delta, pnorm); + + /* evaluate the function at x + p and calculate its norm. */ + if (functor(wa2, wa4) < 0) return HybridNonLinearSolverSpace::UserAsked; + ++nfev; + fnorm1 = wa4.stableNorm(); + + /* compute the scaled actual reduction. */ + actred = -1.; + if (fnorm1 < fnorm) /* Computing 2nd power */ + actred = 1. - numext::abs2(fnorm1 / fnorm); + + /* compute the scaled predicted reduction. */ + wa3 = R.template triangularView() * wa1 + qtf; + temp = wa3.stableNorm(); + prered = 0.; + if (temp < fnorm) /* Computing 2nd power */ + prered = 1. - numext::abs2(temp / fnorm); + + /* compute the ratio of the actual to the predicted reduction. */ + ratio = 0.; + if (prered > 0.) ratio = actred / prered; + + /* update the step bound. */ + if (ratio < Scalar(.1)) { + ncsuc = 0; + ++ncfail; + delta = Scalar(.5) * delta; + } else { + ncfail = 0; + ++ncsuc; + if (ratio >= Scalar(.5) || ncsuc > 1) delta = (std::max)(delta, pnorm / Scalar(.5)); + if (abs(ratio - 1.) <= Scalar(.1)) { + delta = pnorm / Scalar(.5); + } + } + + /* test for successful iteration. */ + if (ratio >= Scalar(1e-4)) { + /* successful iteration. update x, fvec, and their norms. */ + x = wa2; + wa2 = diag.cwiseProduct(x); + fvec = wa4; + xnorm = wa2.stableNorm(); + fnorm = fnorm1; + ++iter; + } + + /* determine the progress of the iteration. */ + ++nslow1; + if (actred >= Scalar(.001)) nslow1 = 0; + if (jeval) ++nslow2; + if (actred >= Scalar(.1)) nslow2 = 0; + + /* test for convergence. */ + if (delta <= parameters.xtol * xnorm || fnorm == 0.) return HybridNonLinearSolverSpace::RelativeErrorTooSmall; + + /* tests for termination and stringent tolerances. */ + if (nfev >= parameters.maxfev) return HybridNonLinearSolverSpace::TooManyFunctionEvaluation; + if (Scalar(.1) * (std::max)(Scalar(.1) * delta, pnorm) <= NumTraits::epsilon() * xnorm) + return HybridNonLinearSolverSpace::TolTooSmall; + if (nslow2 == 5) return HybridNonLinearSolverSpace::NotMakingProgressJacobian; + if (nslow1 == 10) return HybridNonLinearSolverSpace::NotMakingProgressIterations; + + /* criterion for recalculating jacobian. */ + if (ncfail == 2) break; // leave inner loop and go for the next outer loop iteration + + /* calculate the rank one modification to the jacobian */ + /* and update qtf if necessary. */ + wa1 = diag.cwiseProduct(diag.cwiseProduct(wa1) / pnorm); + wa2 = fjac.transpose() * wa4; + if (ratio >= Scalar(1e-4)) qtf = wa2; + wa2 = (wa2 - wa3) / pnorm; + + /* compute the qr factorization of the updated jacobian. */ + internal::r1updt(R, wa1, v_givens, w_givens, wa2, wa3, &sing); + internal::r1mpyq(n, n, fjac.data(), v_givens, w_givens); + internal::r1mpyq(1, n, qtf.data(), v_givens, w_givens); + + jeval = false; + } + return HybridNonLinearSolverSpace::Running; +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::solve(FVectorType &x) { + HybridNonLinearSolverSpace::Status status = solveInit(x); + if (status == HybridNonLinearSolverSpace::ImproperInputParameters) return status; + while (status == HybridNonLinearSolverSpace::Running) status = solveOneStep(x); + return status; +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::hybrd1(FVectorType &x, + const Scalar tol) { + n = x.size(); + + /* check the input parameters for errors. */ + if (n <= 0 || tol < 0.) return HybridNonLinearSolverSpace::ImproperInputParameters; + + resetParameters(); + parameters.maxfev = 200 * (n + 1); + parameters.xtol = tol; + + diag.setConstant(n, 1.); + useExternalScaling = true; + return solveNumericalDiff(x); +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::solveNumericalDiffInit(FVectorType &x) { + n = x.size(); + + if (parameters.nb_of_subdiagonals < 0) parameters.nb_of_subdiagonals = n - 1; + if (parameters.nb_of_superdiagonals < 0) parameters.nb_of_superdiagonals = n - 1; + + wa1.resize(n); + wa2.resize(n); + wa3.resize(n); + wa4.resize(n); + qtf.resize(n); + fjac.resize(n, n); + fvec.resize(n); + if (!useExternalScaling) diag.resize(n); + eigen_assert((!useExternalScaling || diag.size() == n) && + "When useExternalScaling is set, the caller must provide a valid 'diag'"); + + /* Function Body */ + nfev = 0; + njev = 0; + + /* check the input parameters for errors. */ + if (n <= 0 || parameters.xtol < 0. || parameters.maxfev <= 0 || parameters.nb_of_subdiagonals < 0 || + parameters.nb_of_superdiagonals < 0 || parameters.factor <= 0.) + return HybridNonLinearSolverSpace::ImproperInputParameters; + if (useExternalScaling) + for (Index j = 0; j < n; ++j) + if (diag[j] <= 0.) return HybridNonLinearSolverSpace::ImproperInputParameters; + + /* evaluate the function at the starting point */ + /* and calculate its norm. */ + nfev = 1; + if (functor(x, fvec) < 0) return HybridNonLinearSolverSpace::UserAsked; + fnorm = fvec.stableNorm(); + + /* initialize iteration counter and monitors. */ + iter = 1; + ncsuc = 0; + ncfail = 0; + nslow1 = 0; + nslow2 = 0; + + return HybridNonLinearSolverSpace::Running; +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::solveNumericalDiffOneStep( + FVectorType &x) { + using std::abs; + using std::sqrt; + + eigen_assert(x.size() == n); // check the caller is not cheating us + + Index j; + std::vector > v_givens(n), w_givens(n); + + jeval = true; + if (parameters.nb_of_subdiagonals < 0) parameters.nb_of_subdiagonals = n - 1; + if (parameters.nb_of_superdiagonals < 0) parameters.nb_of_superdiagonals = n - 1; + + /* calculate the jacobian matrix. */ + if (internal::fdjac1(functor, x, fvec, fjac, parameters.nb_of_subdiagonals, parameters.nb_of_superdiagonals, + parameters.epsfcn) < 0) + return HybridNonLinearSolverSpace::UserAsked; + nfev += (std::min)(parameters.nb_of_subdiagonals + parameters.nb_of_superdiagonals + 1, n); + + wa2 = fjac.colwise().blueNorm(); + + /* on the first iteration and if external scaling is not used, scale according */ + /* to the norms of the columns of the initial jacobian. */ + if (iter == 1) { + if (!useExternalScaling) + for (j = 0; j < n; ++j) diag[j] = (wa2[j] == 0.) ? 1. : wa2[j]; + + /* on the first iteration, calculate the norm of the scaled x */ + /* and initialize the step bound delta. */ + xnorm = diag.cwiseProduct(x).stableNorm(); + delta = parameters.factor * xnorm; + if (delta == 0.) delta = parameters.factor; + } + + /* compute the qr factorization of the jacobian. */ + HouseholderQR qrfac(fjac); // no pivoting: + + /* copy the triangular factor of the qr factorization into r. */ + R = qrfac.matrixQR(); + + /* accumulate the orthogonal factor in fjac. */ + fjac = qrfac.householderQ(); + + /* form (q transpose)*fvec and store in qtf. */ + qtf = fjac.transpose() * fvec; + + /* rescale if necessary. */ + if (!useExternalScaling) diag = diag.cwiseMax(wa2); + + while (true) { + /* determine the direction p. */ + internal::dogleg(R, diag, qtf, delta, wa1); + + /* store the direction p and x + p. calculate the norm of p. */ + wa1 = -wa1; + wa2 = x + wa1; + pnorm = diag.cwiseProduct(wa1).stableNorm(); + + /* on the first iteration, adjust the initial step bound. */ + if (iter == 1) delta = (std::min)(delta, pnorm); + + /* evaluate the function at x + p and calculate its norm. */ + if (functor(wa2, wa4) < 0) return HybridNonLinearSolverSpace::UserAsked; + ++nfev; + fnorm1 = wa4.stableNorm(); + + /* compute the scaled actual reduction. */ + actred = -1.; + if (fnorm1 < fnorm) /* Computing 2nd power */ + actred = 1. - numext::abs2(fnorm1 / fnorm); + + /* compute the scaled predicted reduction. */ + wa3 = R.template triangularView() * wa1 + qtf; + temp = wa3.stableNorm(); + prered = 0.; + if (temp < fnorm) /* Computing 2nd power */ + prered = 1. - numext::abs2(temp / fnorm); + + /* compute the ratio of the actual to the predicted reduction. */ + ratio = 0.; + if (prered > 0.) ratio = actred / prered; + + /* update the step bound. */ + if (ratio < Scalar(.1)) { + ncsuc = 0; + ++ncfail; + delta = Scalar(.5) * delta; + } else { + ncfail = 0; + ++ncsuc; + if (ratio >= Scalar(.5) || ncsuc > 1) delta = (std::max)(delta, pnorm / Scalar(.5)); + if (abs(ratio - 1.) <= Scalar(.1)) { + delta = pnorm / Scalar(.5); + } + } + + /* test for successful iteration. */ + if (ratio >= Scalar(1e-4)) { + /* successful iteration. update x, fvec, and their norms. */ + x = wa2; + wa2 = diag.cwiseProduct(x); + fvec = wa4; + xnorm = wa2.stableNorm(); + fnorm = fnorm1; + ++iter; + } + + /* determine the progress of the iteration. */ + ++nslow1; + if (actred >= Scalar(.001)) nslow1 = 0; + if (jeval) ++nslow2; + if (actred >= Scalar(.1)) nslow2 = 0; + + /* test for convergence. */ + if (delta <= parameters.xtol * xnorm || fnorm == 0.) return HybridNonLinearSolverSpace::RelativeErrorTooSmall; + + /* tests for termination and stringent tolerances. */ + if (nfev >= parameters.maxfev) return HybridNonLinearSolverSpace::TooManyFunctionEvaluation; + if (Scalar(.1) * (std::max)(Scalar(.1) * delta, pnorm) <= NumTraits::epsilon() * xnorm) + return HybridNonLinearSolverSpace::TolTooSmall; + if (nslow2 == 5) return HybridNonLinearSolverSpace::NotMakingProgressJacobian; + if (nslow1 == 10) return HybridNonLinearSolverSpace::NotMakingProgressIterations; + + /* criterion for recalculating jacobian. */ + if (ncfail == 2) break; // leave inner loop and go for the next outer loop iteration + + /* calculate the rank one modification to the jacobian */ + /* and update qtf if necessary. */ + wa1 = diag.cwiseProduct(diag.cwiseProduct(wa1) / pnorm); + wa2 = fjac.transpose() * wa4; + if (ratio >= Scalar(1e-4)) qtf = wa2; + wa2 = (wa2 - wa3) / pnorm; + + /* compute the qr factorization of the updated jacobian. */ + internal::r1updt(R, wa1, v_givens, w_givens, wa2, wa3, &sing); + internal::r1mpyq(n, n, fjac.data(), v_givens, w_givens); + internal::r1mpyq(1, n, qtf.data(), v_givens, w_givens); + + jeval = false; + } + return HybridNonLinearSolverSpace::Running; +} + +template +HybridNonLinearSolverSpace::Status HybridNonLinearSolver::solveNumericalDiff(FVectorType &x) { + HybridNonLinearSolverSpace::Status status = solveNumericalDiffInit(x); + if (status == HybridNonLinearSolverSpace::ImproperInputParameters) return status; + while (status == HybridNonLinearSolverSpace::Running) status = solveNumericalDiffOneStep(x); + return status; +} + +} // end namespace Eigen + +#endif // EIGEN_HYBRIDNONLINEARSOLVER_H + +// vim: ai ts=4 sts=4 et sw=4 diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/InternalHeaderCheck.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/InternalHeaderCheck.h new file mode 100644 index 00000000000..d06970f51dc --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/InternalHeaderCheck.h @@ -0,0 +1,4 @@ +#ifndef EIGEN_NONLINEAROPTIMIZATION_MODULE_H +#error \ + "Please include unsupported/Eigen/NonLinearOptimization instead of including headers inside the src directory directly." +#endif diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/LevenbergMarquardt.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/LevenbergMarquardt.h new file mode 100644 index 00000000000..19ec8ea333f --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/LevenbergMarquardt.h @@ -0,0 +1,587 @@ +// -*- coding: utf-8 +// vim: set fileencoding=utf-8 + +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_LEVENBERGMARQUARDT__H +#define EIGEN_LEVENBERGMARQUARDT__H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace LevenbergMarquardtSpace { +enum Status { + NotStarted = -2, + Running = -1, + ImproperInputParameters = 0, + RelativeReductionTooSmall = 1, + RelativeErrorTooSmall = 2, + RelativeErrorAndReductionTooSmall = 3, + CosinusTooSmall = 4, + TooManyFunctionEvaluation = 5, + FtolTooSmall = 6, + XtolTooSmall = 7, + GtolTooSmall = 8, + UserAsked = 9 +}; +} + +/** + * \ingroup NonLinearOptimization_Module + * \brief Performs non linear optimization over a non-linear function, + * using a variant of the Levenberg Marquardt algorithm. + * + * Check wikipedia for more information. + * http://en.wikipedia.org/wiki/Levenberg%E2%80%93Marquardt_algorithm + */ +template +class LevenbergMarquardt { + static Scalar sqrt_epsilon() { + using std::sqrt; + return sqrt(NumTraits::epsilon()); + } + + public: + LevenbergMarquardt(FunctorType &_functor) : functor(_functor) { + nfev = njev = iter = 0; + fnorm = gnorm = 0.; + useExternalScaling = false; + } + + typedef DenseIndex Index; + + struct Parameters { + Parameters() + : factor(Scalar(100.)), + maxfev(400), + ftol(sqrt_epsilon()), + xtol(sqrt_epsilon()), + gtol(Scalar(0.)), + epsfcn(Scalar(0.)) {} + Scalar factor; + Index maxfev; // maximum number of function evaluation + Scalar ftol; + Scalar xtol; + Scalar gtol; + Scalar epsfcn; + }; + + typedef Matrix FVectorType; + typedef Matrix JacobianType; + + LevenbergMarquardtSpace::Status lmder1(FVectorType &x, const Scalar tol = sqrt_epsilon()); + + LevenbergMarquardtSpace::Status minimize(FVectorType &x); + LevenbergMarquardtSpace::Status minimizeInit(FVectorType &x); + LevenbergMarquardtSpace::Status minimizeOneStep(FVectorType &x); + + static LevenbergMarquardtSpace::Status lmdif1(FunctorType &functor, FVectorType &x, Index *nfev, + const Scalar tol = sqrt_epsilon()); + + LevenbergMarquardtSpace::Status lmstr1(FVectorType &x, const Scalar tol = sqrt_epsilon()); + + LevenbergMarquardtSpace::Status minimizeOptimumStorage(FVectorType &x); + LevenbergMarquardtSpace::Status minimizeOptimumStorageInit(FVectorType &x); + LevenbergMarquardtSpace::Status minimizeOptimumStorageOneStep(FVectorType &x); + + void resetParameters(void) { parameters = Parameters(); } + + Parameters parameters; + FVectorType fvec, qtf, diag; + JacobianType fjac; + PermutationMatrix permutation; + Index nfev; + Index njev; + Index iter; + Scalar fnorm, gnorm; + bool useExternalScaling; + + Scalar lm_param(void) { return par; } + + private: + FunctorType &functor; + Index n; + Index m; + FVectorType wa1, wa2, wa3, wa4; + + Scalar par, sum; + Scalar temp, temp1, temp2; + Scalar delta; + Scalar ratio; + Scalar pnorm, xnorm, fnorm1, actred, dirder, prered; + + LevenbergMarquardt &operator=(const LevenbergMarquardt &); +}; + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::lmder1(FVectorType &x, const Scalar tol) { + n = x.size(); + m = functor.values(); + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || tol < 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + resetParameters(); + parameters.ftol = tol; + parameters.xtol = tol; + parameters.maxfev = 100 * (n + 1); + + return minimize(x); +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimize(FVectorType &x) { + LevenbergMarquardtSpace::Status status = minimizeInit(x); + if (status == LevenbergMarquardtSpace::ImproperInputParameters) return status; + do { + status = minimizeOneStep(x); + } while (status == LevenbergMarquardtSpace::Running); + return status; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeInit(FVectorType &x) { + n = x.size(); + m = functor.values(); + + wa1.resize(n); + wa2.resize(n); + wa3.resize(n); + wa4.resize(m); + fvec.resize(m); + fjac.resize(m, n); + if (!useExternalScaling) diag.resize(n); + eigen_assert((!useExternalScaling || diag.size() == n) && + "When useExternalScaling is set, the caller must provide a valid 'diag'"); + qtf.resize(n); + + /* Function Body */ + nfev = 0; + njev = 0; + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || parameters.ftol < 0. || parameters.xtol < 0. || parameters.gtol < 0. || + parameters.maxfev <= 0 || parameters.factor <= 0.) + return LevenbergMarquardtSpace::ImproperInputParameters; + + if (useExternalScaling) + for (Index j = 0; j < n; ++j) + if (diag[j] <= 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + /* evaluate the function at the starting point */ + /* and calculate its norm. */ + nfev = 1; + if (functor(x, fvec) < 0) return LevenbergMarquardtSpace::UserAsked; + fnorm = fvec.stableNorm(); + + /* initialize levenberg-marquardt parameter and iteration counter. */ + par = 0.; + iter = 1; + + return LevenbergMarquardtSpace::NotStarted; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeOneStep(FVectorType &x) { + using std::abs; + using std::sqrt; + + eigen_assert(x.size() == n); // check the caller is not cheating us + + /* calculate the jacobian matrix. */ + Index df_ret = functor.df(x, fjac); + if (df_ret < 0) return LevenbergMarquardtSpace::UserAsked; + if (df_ret > 0) + // numerical diff, we evaluated the function df_ret times + nfev += df_ret; + else + njev++; + + /* compute the qr factorization of the jacobian. */ + wa2 = fjac.colwise().blueNorm(); + ColPivHouseholderQR qrfac(fjac); + fjac = qrfac.matrixQR(); + permutation = qrfac.colsPermutation(); + + /* on the first iteration and if external scaling is not used, scale according */ + /* to the norms of the columns of the initial jacobian. */ + if (iter == 1) { + if (!useExternalScaling) + for (Index j = 0; j < n; ++j) diag[j] = (wa2[j] == 0.) ? 1. : wa2[j]; + + /* on the first iteration, calculate the norm of the scaled x */ + /* and initialize the step bound delta. */ + xnorm = diag.cwiseProduct(x).stableNorm(); + delta = parameters.factor * xnorm; + if (delta == 0.) delta = parameters.factor; + } + + /* form (q transpose)*fvec and store the first n components in */ + /* qtf. */ + wa4 = fvec; + wa4.applyOnTheLeft(qrfac.householderQ().adjoint()); + qtf = wa4.head(n); + + /* compute the norm of the scaled gradient. */ + gnorm = 0.; + if (fnorm != 0.) + for (Index j = 0; j < n; ++j) + if (wa2[permutation.indices()[j]] != 0.) + gnorm = (std::max)(gnorm, + abs(fjac.col(j).head(j + 1).dot(qtf.head(j + 1) / fnorm) / wa2[permutation.indices()[j]])); + + /* test for convergence of the gradient norm. */ + if (gnorm <= parameters.gtol) return LevenbergMarquardtSpace::CosinusTooSmall; + + /* rescale if necessary. */ + if (!useExternalScaling) diag = diag.cwiseMax(wa2); + + do { + /* determine the levenberg-marquardt parameter. */ + internal::lmpar2(qrfac, diag, qtf, delta, par, wa1); + + /* store the direction p and x + p. calculate the norm of p. */ + wa1 = -wa1; + wa2 = x + wa1; + pnorm = diag.cwiseProduct(wa1).stableNorm(); + + /* on the first iteration, adjust the initial step bound. */ + if (iter == 1) delta = (std::min)(delta, pnorm); + + /* evaluate the function at x + p and calculate its norm. */ + if (functor(wa2, wa4) < 0) return LevenbergMarquardtSpace::UserAsked; + ++nfev; + fnorm1 = wa4.stableNorm(); + + /* compute the scaled actual reduction. */ + actred = -1.; + if (Scalar(.1) * fnorm1 < fnorm) actred = 1. - numext::abs2(fnorm1 / fnorm); + + /* compute the scaled predicted reduction and */ + /* the scaled directional derivative. */ + wa3.noalias() = fjac.template triangularView() * (qrfac.colsPermutation().inverse() * wa1); + temp1 = numext::abs2(wa3.stableNorm() / fnorm); + temp2 = numext::abs2(sqrt(par) * pnorm / fnorm); + prered = temp1 + temp2 / Scalar(.5); + dirder = -(temp1 + temp2); + + /* compute the ratio of the actual to the predicted */ + /* reduction. */ + ratio = 0.; + if (prered != 0.) ratio = actred / prered; + + /* update the step bound. */ + if (ratio <= Scalar(.25)) { + if (actred >= 0.) temp = Scalar(.5); + if (actred < 0.) temp = Scalar(.5) * dirder / (dirder + Scalar(.5) * actred); + if (Scalar(.1) * fnorm1 >= fnorm || temp < Scalar(.1)) temp = Scalar(.1); + /* Computing MIN */ + delta = temp * (std::min)(delta, pnorm / Scalar(.1)); + par /= temp; + } else if (!(par != 0. && ratio < Scalar(.75))) { + delta = pnorm / Scalar(.5); + par = Scalar(.5) * par; + } + + /* test for successful iteration. */ + if (ratio >= Scalar(1e-4)) { + /* successful iteration. update x, fvec, and their norms. */ + x = wa2; + wa2 = diag.cwiseProduct(x); + fvec = wa4; + xnorm = wa2.stableNorm(); + fnorm = fnorm1; + ++iter; + } + + /* tests for convergence. */ + if (abs(actred) <= parameters.ftol && prered <= parameters.ftol && Scalar(.5) * ratio <= 1. && + delta <= parameters.xtol * xnorm) + return LevenbergMarquardtSpace::RelativeErrorAndReductionTooSmall; + if (abs(actred) <= parameters.ftol && prered <= parameters.ftol && Scalar(.5) * ratio <= 1.) + return LevenbergMarquardtSpace::RelativeReductionTooSmall; + if (delta <= parameters.xtol * xnorm) return LevenbergMarquardtSpace::RelativeErrorTooSmall; + + /* tests for termination and stringent tolerances. */ + if (nfev >= parameters.maxfev) return LevenbergMarquardtSpace::TooManyFunctionEvaluation; + if (abs(actred) <= NumTraits::epsilon() && prered <= NumTraits::epsilon() && + Scalar(.5) * ratio <= 1.) + return LevenbergMarquardtSpace::FtolTooSmall; + if (delta <= NumTraits::epsilon() * xnorm) return LevenbergMarquardtSpace::XtolTooSmall; + if (gnorm <= NumTraits::epsilon()) return LevenbergMarquardtSpace::GtolTooSmall; + + } while (ratio < Scalar(1e-4)); + + return LevenbergMarquardtSpace::Running; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::lmstr1(FVectorType &x, const Scalar tol) { + n = x.size(); + m = functor.values(); + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || tol < 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + resetParameters(); + parameters.ftol = tol; + parameters.xtol = tol; + parameters.maxfev = 100 * (n + 1); + + return minimizeOptimumStorage(x); +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeOptimumStorageInit(FVectorType &x) { + n = x.size(); + m = functor.values(); + + wa1.resize(n); + wa2.resize(n); + wa3.resize(n); + wa4.resize(m); + fvec.resize(m); + // Only R is stored in fjac. Q is only used to compute 'qtf', which is + // Q.transpose()*rhs. qtf will be updated using givens rotation, + // instead of storing them in Q. + // The purpose it to only use a nxn matrix, instead of mxn here, so + // that we can handle cases where m>>n : + fjac.resize(n, n); + if (!useExternalScaling) diag.resize(n); + eigen_assert((!useExternalScaling || diag.size() == n) && + "When useExternalScaling is set, the caller must provide a valid 'diag'"); + qtf.resize(n); + + /* Function Body */ + nfev = 0; + njev = 0; + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || parameters.ftol < 0. || parameters.xtol < 0. || parameters.gtol < 0. || + parameters.maxfev <= 0 || parameters.factor <= 0.) + return LevenbergMarquardtSpace::ImproperInputParameters; + + if (useExternalScaling) + for (Index j = 0; j < n; ++j) + if (diag[j] <= 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + /* evaluate the function at the starting point */ + /* and calculate its norm. */ + nfev = 1; + if (functor(x, fvec) < 0) return LevenbergMarquardtSpace::UserAsked; + fnorm = fvec.stableNorm(); + + /* initialize levenberg-marquardt parameter and iteration counter. */ + par = 0.; + iter = 1; + + return LevenbergMarquardtSpace::NotStarted; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeOptimumStorageOneStep(FVectorType &x) { + using std::abs; + using std::sqrt; + + eigen_assert(x.size() == n); // check the caller is not cheating us + + Index i, j; + bool sing; + + /* compute the qr factorization of the jacobian matrix */ + /* calculated one row at a time, while simultaneously */ + /* forming (q transpose)*fvec and storing the first */ + /* n components in qtf. */ + qtf.fill(0.); + fjac.fill(0.); + Index rownb = 2; + for (i = 0; i < m; ++i) { + if (functor.df(x, wa3, rownb) < 0) return LevenbergMarquardtSpace::UserAsked; + internal::rwupdt(fjac, wa3, qtf, fvec[i]); + ++rownb; + } + ++njev; + + /* if the jacobian is rank deficient, call qrfac to */ + /* reorder its columns and update the components of qtf. */ + sing = false; + for (j = 0; j < n; ++j) { + if (fjac(j, j) == 0.) sing = true; + wa2[j] = fjac.col(j).head(j).stableNorm(); + } + permutation.setIdentity(n); + if (sing) { + wa2 = fjac.colwise().blueNorm(); + // TODO We have no unit test covering this code path, do not modify + // until it is carefully tested + ColPivHouseholderQR qrfac(fjac); + fjac = qrfac.matrixQR(); + wa1 = fjac.diagonal(); + fjac.diagonal() = qrfac.hCoeffs(); + permutation = qrfac.colsPermutation(); + // TODO : avoid this: + for (Index ii = 0; ii < fjac.cols(); ii++) + fjac.col(ii).segment(ii + 1, fjac.rows() - ii - 1) *= fjac(ii, ii); // rescale vectors + + for (j = 0; j < n; ++j) { + if (fjac(j, j) != 0.) { + sum = 0.; + for (i = j; i < n; ++i) sum += fjac(i, j) * qtf[i]; + temp = -sum / fjac(j, j); + for (i = j; i < n; ++i) qtf[i] += fjac(i, j) * temp; + } + fjac(j, j) = wa1[j]; + } + } + + /* on the first iteration and if external scaling is not used, scale according */ + /* to the norms of the columns of the initial jacobian. */ + if (iter == 1) { + if (!useExternalScaling) + for (j = 0; j < n; ++j) diag[j] = (wa2[j] == 0.) ? 1. : wa2[j]; + + /* on the first iteration, calculate the norm of the scaled x */ + /* and initialize the step bound delta. */ + xnorm = diag.cwiseProduct(x).stableNorm(); + delta = parameters.factor * xnorm; + if (delta == 0.) delta = parameters.factor; + } + + /* compute the norm of the scaled gradient. */ + gnorm = 0.; + if (fnorm != 0.) + for (j = 0; j < n; ++j) + if (wa2[permutation.indices()[j]] != 0.) + gnorm = (std::max)(gnorm, + abs(fjac.col(j).head(j + 1).dot(qtf.head(j + 1) / fnorm) / wa2[permutation.indices()[j]])); + + /* test for convergence of the gradient norm. */ + if (gnorm <= parameters.gtol) return LevenbergMarquardtSpace::CosinusTooSmall; + + /* rescale if necessary. */ + if (!useExternalScaling) diag = diag.cwiseMax(wa2); + + do { + /* determine the levenberg-marquardt parameter. */ + internal::lmpar(fjac, permutation.indices(), diag, qtf, delta, par, wa1); + + /* store the direction p and x + p. calculate the norm of p. */ + wa1 = -wa1; + wa2 = x + wa1; + pnorm = diag.cwiseProduct(wa1).stableNorm(); + + /* on the first iteration, adjust the initial step bound. */ + if (iter == 1) delta = (std::min)(delta, pnorm); + + /* evaluate the function at x + p and calculate its norm. */ + if (functor(wa2, wa4) < 0) return LevenbergMarquardtSpace::UserAsked; + ++nfev; + fnorm1 = wa4.stableNorm(); + + /* compute the scaled actual reduction. */ + actred = -1.; + if (Scalar(.1) * fnorm1 < fnorm) actred = 1. - numext::abs2(fnorm1 / fnorm); + + /* compute the scaled predicted reduction and */ + /* the scaled directional derivative. */ + wa3 = fjac.topLeftCorner(n, n).template triangularView() * (permutation.inverse() * wa1); + temp1 = numext::abs2(wa3.stableNorm() / fnorm); + temp2 = numext::abs2(sqrt(par) * pnorm / fnorm); + prered = temp1 + temp2 / Scalar(.5); + dirder = -(temp1 + temp2); + + /* compute the ratio of the actual to the predicted */ + /* reduction. */ + ratio = 0.; + if (prered != 0.) ratio = actred / prered; + + /* update the step bound. */ + if (ratio <= Scalar(.25)) { + if (actred >= 0.) temp = Scalar(.5); + if (actred < 0.) temp = Scalar(.5) * dirder / (dirder + Scalar(.5) * actred); + if (Scalar(.1) * fnorm1 >= fnorm || temp < Scalar(.1)) temp = Scalar(.1); + /* Computing MIN */ + delta = temp * (std::min)(delta, pnorm / Scalar(.1)); + par /= temp; + } else if (!(par != 0. && ratio < Scalar(.75))) { + delta = pnorm / Scalar(.5); + par = Scalar(.5) * par; + } + + /* test for successful iteration. */ + if (ratio >= Scalar(1e-4)) { + /* successful iteration. update x, fvec, and their norms. */ + x = wa2; + wa2 = diag.cwiseProduct(x); + fvec = wa4; + xnorm = wa2.stableNorm(); + fnorm = fnorm1; + ++iter; + } + + /* tests for convergence. */ + if (abs(actred) <= parameters.ftol && prered <= parameters.ftol && Scalar(.5) * ratio <= 1. && + delta <= parameters.xtol * xnorm) + return LevenbergMarquardtSpace::RelativeErrorAndReductionTooSmall; + if (abs(actred) <= parameters.ftol && prered <= parameters.ftol && Scalar(.5) * ratio <= 1.) + return LevenbergMarquardtSpace::RelativeReductionTooSmall; + if (delta <= parameters.xtol * xnorm) return LevenbergMarquardtSpace::RelativeErrorTooSmall; + + /* tests for termination and stringent tolerances. */ + if (nfev >= parameters.maxfev) return LevenbergMarquardtSpace::TooManyFunctionEvaluation; + if (abs(actred) <= NumTraits::epsilon() && prered <= NumTraits::epsilon() && + Scalar(.5) * ratio <= 1.) + return LevenbergMarquardtSpace::FtolTooSmall; + if (delta <= NumTraits::epsilon() * xnorm) return LevenbergMarquardtSpace::XtolTooSmall; + if (gnorm <= NumTraits::epsilon()) return LevenbergMarquardtSpace::GtolTooSmall; + + } while (ratio < Scalar(1e-4)); + + return LevenbergMarquardtSpace::Running; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::minimizeOptimumStorage(FVectorType &x) { + LevenbergMarquardtSpace::Status status = minimizeOptimumStorageInit(x); + if (status == LevenbergMarquardtSpace::ImproperInputParameters) return status; + do { + status = minimizeOptimumStorageOneStep(x); + } while (status == LevenbergMarquardtSpace::Running); + return status; +} + +template +LevenbergMarquardtSpace::Status LevenbergMarquardt::lmdif1(FunctorType &functor, FVectorType &x, + Index *nfev, const Scalar tol) { + Index n = x.size(); + Index m = functor.values(); + + /* check the input parameters for errors. */ + if (n <= 0 || m < n || tol < 0.) return LevenbergMarquardtSpace::ImproperInputParameters; + + NumericalDiff numDiff(functor); + // embedded LevenbergMarquardt + LevenbergMarquardt, Scalar> lm(numDiff); + lm.parameters.ftol = tol; + lm.parameters.xtol = tol; + lm.parameters.maxfev = 200 * (n + 1); + + LevenbergMarquardtSpace::Status info = LevenbergMarquardtSpace::Status(lm.minimize(x)); + if (nfev) *nfev = lm.nfev; + return info; +} + +} // end namespace Eigen + +#endif // EIGEN_LEVENBERGMARQUARDT__H + +// vim: ai ts=4 sts=4 et sw=4 diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/chkder.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/chkder.h new file mode 100644 index 00000000000..a9311ff440f --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/chkder.h @@ -0,0 +1,57 @@ +#define chkder_log10e 0.43429448190325182765 +#define chkder_factor 100. + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void chkder(const Matrix &x, const Matrix &fvec, + const Matrix &fjac, Matrix &xp, + const Matrix &fvecp, int mode, Matrix &err) { + using std::abs; + using std::log; + using std::sqrt; + + typedef DenseIndex Index; + + const Scalar eps = sqrt(NumTraits::epsilon()); + const Scalar epsf = chkder_factor * NumTraits::epsilon(); + const Scalar epslog = chkder_log10e * log(eps); + Scalar temp; + + const Index m = fvec.size(), n = x.size(); + + if (mode != 2) { + /* mode = 1. */ + xp.resize(n); + for (Index j = 0; j < n; ++j) { + temp = eps * abs(x[j]); + if (temp == 0.) temp = eps; + xp[j] = x[j] + temp; + } + } else { + /* mode = 2. */ + err.setZero(m); + for (Index j = 0; j < n; ++j) { + temp = abs(x[j]); + if (temp == 0.) temp = 1.; + err += temp * fjac.col(j); + } + for (Index i = 0; i < m; ++i) { + temp = 1.; + if (fvec[i] != 0. && fvecp[i] != 0. && abs(fvecp[i] - fvec[i]) >= epsf * abs(fvec[i])) + temp = eps * abs((fvecp[i] - fvec[i]) / eps - err[i]) / (abs(fvec[i]) + abs(fvecp[i])); + err[i] = 1.; + if (temp > NumTraits::epsilon() && temp < eps) err[i] = (chkder_log10e * log(temp) - epslog) / epslog; + if (temp >= eps) err[i] = 0.; + } + } +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/covar.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/covar.h new file mode 100644 index 00000000000..311d998258c --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/covar.h @@ -0,0 +1,66 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void covar(Matrix &r, const VectorXi &ipvt, + Scalar tol = std::sqrt(NumTraits::epsilon())) { + using std::abs; + typedef DenseIndex Index; + + /* Local variables */ + Index i, j, k, l, ii, jj; + bool sing; + Scalar temp; + + /* Function Body */ + const Index n = r.cols(); + const Scalar tolr = tol * abs(r(0, 0)); + Matrix wa(n); + eigen_assert(ipvt.size() == n); + + /* form the inverse of r in the full upper triangle of r. */ + l = -1; + for (k = 0; k < n; ++k) + if (abs(r(k, k)) > tolr) { + r(k, k) = 1. / r(k, k); + for (j = 0; j <= k - 1; ++j) { + temp = r(k, k) * r(j, k); + r(j, k) = 0.; + r.col(k).head(j + 1) -= r.col(j).head(j + 1) * temp; + } + l = k; + } + + /* form the full upper triangle of the inverse of (r transpose)*r */ + /* in the full upper triangle of r. */ + for (k = 0; k <= l; ++k) { + for (j = 0; j <= k - 1; ++j) r.col(j).head(j + 1) += r.col(k).head(j + 1) * r(j, k); + r.col(k).head(k + 1) *= r(k, k); + } + + /* form the full lower triangle of the covariance matrix */ + /* in the strict lower triangle of r and in wa. */ + for (j = 0; j < n; ++j) { + jj = ipvt[j]; + sing = j > l; + for (i = 0; i <= j; ++i) { + if (sing) r(i, j) = 0.; + ii = ipvt[i]; + if (ii > jj) r(ii, jj) = r(i, j); + if (ii < jj) r(jj, ii) = r(i, j); + } + wa[jj] = r(j, j); + } + + /* symmetrize the covariance matrix in r. */ + r.topLeftCorner(n, n).template triangularView() = r.topLeftCorner(n, n).transpose(); + r.diagonal() = wa; +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/dogleg.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/dogleg.h new file mode 100644 index 00000000000..d1abb9e37ea --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/dogleg.h @@ -0,0 +1,103 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void dogleg(const Matrix &qrfac, const Matrix &diag, + const Matrix &qtb, Scalar delta, Matrix &x) { + using std::abs; + using std::sqrt; + + typedef DenseIndex Index; + + /* Local variables */ + Index i, j; + Scalar sum, temp, alpha, bnorm; + Scalar gnorm, qnorm; + Scalar sgnorm; + + /* Function Body */ + const Scalar epsmch = NumTraits::epsilon(); + const Index n = qrfac.cols(); + eigen_assert(n == qtb.size()); + eigen_assert(n == x.size()); + eigen_assert(n == diag.size()); + Matrix wa1(n), wa2(n); + + /* first, calculate the gauss-newton direction. */ + for (j = n - 1; j >= 0; --j) { + temp = qrfac(j, j); + if (temp == 0.) { + temp = epsmch * qrfac.col(j).head(j + 1).maxCoeff(); + if (temp == 0.) temp = epsmch; + } + if (j == n - 1) + x[j] = qtb[j] / temp; + else + x[j] = (qtb[j] - qrfac.row(j).tail(n - j - 1).dot(x.tail(n - j - 1))) / temp; + } + + /* test whether the gauss-newton direction is acceptable. */ + qnorm = diag.cwiseProduct(x).stableNorm(); + if (qnorm <= delta) return; + + // TODO : this path is not tested by Eigen unit tests + + /* the gauss-newton direction is not acceptable. */ + /* next, calculate the scaled gradient direction. */ + + wa1.fill(0.); + for (j = 0; j < n; ++j) { + wa1.tail(n - j) += qrfac.row(j).tail(n - j) * qtb[j]; + wa1[j] /= diag[j]; + } + + /* calculate the norm of the scaled gradient and test for */ + /* the special case in which the scaled gradient is zero. */ + gnorm = wa1.stableNorm(); + sgnorm = 0.; + alpha = delta / qnorm; + if (gnorm == 0.) goto algo_end; + + /* calculate the point along the scaled gradient */ + /* at which the quadratic is minimized. */ + wa1.array() /= (diag * gnorm).array(); + // TODO : once unit tests cover this part,: + // wa2 = qrfac.template triangularView() * wa1; + for (j = 0; j < n; ++j) { + sum = 0.; + for (i = j; i < n; ++i) { + sum += qrfac(j, i) * wa1[i]; + } + wa2[j] = sum; + } + temp = wa2.stableNorm(); + sgnorm = gnorm / temp / temp; + + /* test whether the scaled gradient direction is acceptable. */ + alpha = 0.; + if (sgnorm >= delta) goto algo_end; + + /* the scaled gradient direction is not acceptable. */ + /* finally, calculate the point along the dogleg */ + /* at which the quadratic is minimized. */ + bnorm = qtb.stableNorm(); + temp = bnorm / gnorm * (bnorm / qnorm) * (sgnorm / delta); + temp = temp - delta / qnorm * numext::abs2(sgnorm / delta) + + sqrt(numext::abs2(temp - delta / qnorm) + + (1. - numext::abs2(delta / qnorm)) * (1. - numext::abs2(sgnorm / delta))); + alpha = delta / qnorm * (1. - numext::abs2(sgnorm / delta)) / temp; +algo_end: + + /* form appropriate convex combination of the gauss-newton */ + /* direction and the scaled gradient direction. */ + temp = (1. - alpha) * (std::min)(sgnorm, delta); + x = temp * wa1 + alpha * x; +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/fdjac1.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/fdjac1.h new file mode 100644 index 00000000000..70da3f96d78 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/fdjac1.h @@ -0,0 +1,73 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +DenseIndex fdjac1(const FunctorType &Functor, Matrix &x, Matrix &fvec, + Matrix &fjac, DenseIndex ml, DenseIndex mu, Scalar epsfcn) { + using std::abs; + using std::sqrt; + + typedef DenseIndex Index; + + /* Local variables */ + Scalar h; + Index j, k; + Scalar eps, temp; + Index msum; + int iflag; + Index start, length; + + /* Function Body */ + const Scalar epsmch = NumTraits::epsilon(); + const Index n = x.size(); + eigen_assert(fvec.size() == n); + Matrix wa1(n); + Matrix wa2(n); + + eps = sqrt((std::max)(epsfcn, epsmch)); + msum = ml + mu + 1; + if (msum >= n) { + /* computation of dense approximate jacobian. */ + for (j = 0; j < n; ++j) { + temp = x[j]; + h = eps * abs(temp); + if (h == 0.) h = eps; + x[j] = temp + h; + iflag = Functor(x, wa1); + if (iflag < 0) return iflag; + x[j] = temp; + fjac.col(j) = (wa1 - fvec) / h; + } + + } else { + /* computation of banded approximate jacobian. */ + for (k = 0; k < msum; ++k) { + for (j = k; (msum < 0) ? (j > n) : (j < n); j += msum) { + wa2[j] = x[j]; + h = eps * abs(wa2[j]); + if (h == 0.) h = eps; + x[j] = wa2[j] + h; + } + iflag = Functor(x, wa1); + if (iflag < 0) return iflag; + for (j = k; (msum < 0) ? (j > n) : (j < n); j += msum) { + x[j] = wa2[j]; + h = eps * abs(wa2[j]); + if (h == 0.) h = eps; + fjac.col(j).setZero(); + start = std::max(0, j - mu); + length = (std::min)(n - 1, j + ml) - start + 1; + fjac.col(j).segment(start, length) = (wa1.segment(start, length) - fvec.segment(start, length)) / h; + } + } + } + return 0; +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/lmpar.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/lmpar.h new file mode 100644 index 00000000000..14202012abb --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/lmpar.h @@ -0,0 +1,265 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void lmpar(Matrix &r, const VectorXi &ipvt, const Matrix &diag, + const Matrix &qtb, Scalar delta, Scalar &par, Matrix &x) { + using std::abs; + using std::sqrt; + typedef DenseIndex Index; + + /* Local variables */ + Index i, j, l; + Scalar fp; + Scalar parc, parl; + Index iter; + Scalar temp, paru; + Scalar gnorm; + Scalar dxnorm; + + /* Function Body */ + const Scalar dwarf = (std::numeric_limits::min)(); + const Index n = r.cols(); + eigen_assert(n == diag.size()); + eigen_assert(n == qtb.size()); + eigen_assert(n == x.size()); + + Matrix wa1, wa2; + + /* compute and store in x the gauss-newton direction. if the */ + /* jacobian is rank-deficient, obtain a least squares solution. */ + Index nsing = n - 1; + wa1 = qtb; + for (j = 0; j < n; ++j) { + if (r(j, j) == 0. && nsing == n - 1) nsing = j - 1; + if (nsing < n - 1) wa1[j] = 0.; + } + for (j = nsing; j >= 0; --j) { + wa1[j] /= r(j, j); + temp = wa1[j]; + for (i = 0; i < j; ++i) wa1[i] -= r(i, j) * temp; + } + + for (j = 0; j < n; ++j) x[ipvt[j]] = wa1[j]; + + /* initialize the iteration counter. */ + /* evaluate the function at the origin, and test */ + /* for acceptance of the gauss-newton direction. */ + iter = 0; + wa2 = diag.cwiseProduct(x); + dxnorm = wa2.blueNorm(); + fp = dxnorm - delta; + if (fp <= Scalar(0.1) * delta) { + par = 0; + return; + } + + /* if the jacobian is not rank deficient, the newton */ + /* step provides a lower bound, parl, for the zero of */ + /* the function. otherwise set this bound to zero. */ + parl = 0.; + if (nsing >= n - 1) { + for (j = 0; j < n; ++j) { + l = ipvt[j]; + wa1[j] = diag[l] * (wa2[l] / dxnorm); + } + // it's actually a triangularView.solveInplace(), though in a weird + // way: + for (j = 0; j < n; ++j) { + Scalar sum = 0.; + for (i = 0; i < j; ++i) sum += r(i, j) * wa1[i]; + wa1[j] = (wa1[j] - sum) / r(j, j); + } + temp = wa1.blueNorm(); + parl = fp / delta / temp / temp; + } + + /* calculate an upper bound, paru, for the zero of the function. */ + for (j = 0; j < n; ++j) wa1[j] = r.col(j).head(j + 1).dot(qtb.head(j + 1)) / diag[ipvt[j]]; + + gnorm = wa1.stableNorm(); + paru = gnorm / delta; + if (paru == 0.) paru = dwarf / (std::min)(delta, Scalar(0.1)); + + /* if the input par lies outside of the interval (parl,paru), */ + /* set par to the closer endpoint. */ + par = (std::max)(par, parl); + par = (std::min)(par, paru); + if (par == 0.) par = gnorm / dxnorm; + + /* beginning of an iteration. */ + while (true) { + ++iter; + + /* evaluate the function at the current value of par. */ + if (par == 0.) par = (std::max)(dwarf, Scalar(.001) * paru); /* Computing MAX */ + wa1 = sqrt(par) * diag; + + Matrix sdiag(n); + qrsolv(r, ipvt, wa1, qtb, x, sdiag); + + wa2 = diag.cwiseProduct(x); + dxnorm = wa2.blueNorm(); + temp = fp; + fp = dxnorm - delta; + + /* if the function is small enough, accept the current value */ + /* of par. also test for the exceptional cases where parl */ + /* is zero or the number of iterations has reached 10. */ + if (abs(fp) <= Scalar(0.1) * delta || (parl == 0. && fp <= temp && temp < 0.) || iter == 10) break; + + /* compute the newton correction. */ + for (j = 0; j < n; ++j) { + l = ipvt[j]; + wa1[j] = diag[l] * (wa2[l] / dxnorm); + } + for (j = 0; j < n; ++j) { + wa1[j] /= sdiag[j]; + temp = wa1[j]; + for (i = j + 1; i < n; ++i) wa1[i] -= r(i, j) * temp; + } + temp = wa1.blueNorm(); + parc = fp / delta / temp / temp; + + /* depending on the sign of the function, update parl or paru. */ + if (fp > 0.) parl = (std::max)(parl, par); + if (fp < 0.) paru = (std::min)(paru, par); + + /* compute an improved estimate for par. */ + /* Computing MAX */ + par = (std::max)(parl, par + parc); + + /* end of an iteration. */ + } + + /* termination. */ + if (iter == 0) par = 0.; + return; +} + +template +void lmpar2(const ColPivHouseholderQR > &qr, const Matrix &diag, + const Matrix &qtb, Scalar delta, Scalar &par, Matrix &x) + +{ + using std::abs; + using std::sqrt; + typedef DenseIndex Index; + + /* Local variables */ + Index j; + Scalar fp; + Scalar parc, parl; + Index iter; + Scalar temp, paru; + Scalar gnorm; + Scalar dxnorm; + + /* Function Body */ + const Scalar dwarf = (std::numeric_limits::min)(); + const Index n = qr.matrixQR().cols(); + eigen_assert(n == diag.size()); + eigen_assert(n == qtb.size()); + + Matrix wa1, wa2; + + /* compute and store in x the gauss-newton direction. if the */ + /* jacobian is rank-deficient, obtain a least squares solution. */ + + // const Index rank = qr.nonzeroPivots(); // exactly double(0.) + const Index rank = qr.rank(); // use a threshold + wa1 = qtb; + wa1.tail(n - rank).setZero(); + qr.matrixQR().topLeftCorner(rank, rank).template triangularView().solveInPlace(wa1.head(rank)); + + x = qr.colsPermutation() * wa1; + + /* initialize the iteration counter. */ + /* evaluate the function at the origin, and test */ + /* for acceptance of the gauss-newton direction. */ + iter = 0; + wa2 = diag.cwiseProduct(x); + dxnorm = wa2.blueNorm(); + fp = dxnorm - delta; + if (fp <= Scalar(0.1) * delta) { + par = 0; + return; + } + + /* if the jacobian is not rank deficient, the newton */ + /* step provides a lower bound, parl, for the zero of */ + /* the function. otherwise set this bound to zero. */ + parl = 0.; + if (rank == n) { + wa1 = qr.colsPermutation().inverse() * diag.cwiseProduct(wa2) / dxnorm; + qr.matrixQR().topLeftCorner(n, n).transpose().template triangularView().solveInPlace(wa1); + temp = wa1.blueNorm(); + parl = fp / delta / temp / temp; + } + + /* calculate an upper bound, paru, for the zero of the function. */ + for (j = 0; j < n; ++j) + wa1[j] = qr.matrixQR().col(j).head(j + 1).dot(qtb.head(j + 1)) / diag[qr.colsPermutation().indices()(j)]; + + gnorm = wa1.stableNorm(); + paru = gnorm / delta; + if (paru == 0.) paru = dwarf / (std::min)(delta, Scalar(0.1)); + + /* if the input par lies outside of the interval (parl,paru), */ + /* set par to the closer endpoint. */ + par = (std::max)(par, parl); + par = (std::min)(par, paru); + if (par == 0.) par = gnorm / dxnorm; + + /* beginning of an iteration. */ + Matrix s = qr.matrixQR(); + while (true) { + ++iter; + + /* evaluate the function at the current value of par. */ + if (par == 0.) par = (std::max)(dwarf, Scalar(.001) * paru); /* Computing MAX */ + wa1 = sqrt(par) * diag; + + Matrix sdiag(n); + qrsolv(s, qr.colsPermutation().indices(), wa1, qtb, x, sdiag); + + wa2 = diag.cwiseProduct(x); + dxnorm = wa2.blueNorm(); + temp = fp; + fp = dxnorm - delta; + + /* if the function is small enough, accept the current value */ + /* of par. also test for the exceptional cases where parl */ + /* is zero or the number of iterations has reached 10. */ + if (abs(fp) <= Scalar(0.1) * delta || (parl == 0. && fp <= temp && temp < 0.) || iter == 10) break; + + /* compute the newton correction. */ + wa1 = qr.colsPermutation().inverse() * diag.cwiseProduct(wa2 / dxnorm); + // we could almost use this here, but the diagonal is outside qr, in sdiag[] + // qr.matrixQR().topLeftCorner(n, n).transpose().template triangularView().solveInPlace(wa1); + for (j = 0; j < n; ++j) { + wa1[j] /= sdiag[j]; + temp = wa1[j]; + for (Index i = j + 1; i < n; ++i) wa1[i] -= s(i, j) * temp; + } + temp = wa1.blueNorm(); + parc = fp / delta / temp / temp; + + /* depending on the sign of the function, update parl or paru. */ + if (fp > 0.) parl = (std::max)(parl, par); + if (fp < 0.) paru = (std::min)(paru, par); + + /* compute an improved estimate for par. */ + par = (std::max)(parl, par + parc); + } + if (iter == 0) par = 0.; + return; +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/qrsolv.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/qrsolv.h new file mode 100644 index 00000000000..2e4d03633c0 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/qrsolv.h @@ -0,0 +1,89 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +// TODO : once qrsolv2 is removed, use ColPivHouseholderQR or PermutationMatrix instead of ipvt +template +void qrsolv(Matrix &s, + // TODO : use a PermutationMatrix once lmpar is no more: + const VectorXi &ipvt, const Matrix &diag, const Matrix &qtb, + Matrix &x, Matrix &sdiag) + +{ + typedef DenseIndex Index; + + /* Local variables */ + Index i, j, k, l; + Scalar temp; + Index n = s.cols(); + Matrix wa(n); + JacobiRotation givens; + + /* Function Body */ + // the following will only change the lower triangular part of s, including + // the diagonal, though the diagonal is restored afterward + + /* copy r and (q transpose)*b to preserve input and initialize s. */ + /* in particular, save the diagonal elements of r in x. */ + x = s.diagonal(); + wa = qtb; + + s.topLeftCorner(n, n).template triangularView() = s.topLeftCorner(n, n).transpose(); + + /* eliminate the diagonal matrix d using a givens rotation. */ + for (j = 0; j < n; ++j) { + /* prepare the row of d to be eliminated, locating the */ + /* diagonal element using p from the qr factorization. */ + l = ipvt[j]; + if (diag[l] == 0.) break; + sdiag.tail(n - j).setZero(); + sdiag[j] = diag[l]; + + /* the transformations to eliminate the row of d */ + /* modify only a single element of (q transpose)*b */ + /* beyond the first n, which is initially zero. */ + Scalar qtbpj = 0.; + for (k = j; k < n; ++k) { + /* determine a givens rotation which eliminates the */ + /* appropriate element in the current row of d. */ + givens.makeGivens(-s(k, k), sdiag[k]); + + /* compute the modified diagonal element of r and */ + /* the modified element of ((q transpose)*b,0). */ + s(k, k) = givens.c() * s(k, k) + givens.s() * sdiag[k]; + temp = givens.c() * wa[k] + givens.s() * qtbpj; + qtbpj = -givens.s() * wa[k] + givens.c() * qtbpj; + wa[k] = temp; + + /* accumulate the transformation in the row of s. */ + for (i = k + 1; i < n; ++i) { + temp = givens.c() * s(i, k) + givens.s() * sdiag[i]; + sdiag[i] = -givens.s() * s(i, k) + givens.c() * sdiag[i]; + s(i, k) = temp; + } + } + } + + /* solve the triangular system for z. if the system is */ + /* singular, then obtain a least squares solution. */ + Index nsing; + for (nsing = 0; nsing < n && sdiag[nsing] != 0; nsing++) { + } + + wa.tail(n - nsing).setZero(); + s.topLeftCorner(nsing, nsing).transpose().template triangularView().solveInPlace(wa.head(nsing)); + + // restore + sdiag = s.diagonal(); + s.diagonal() = x; + + /* permute the components of z back to components of x. */ + for (j = 0; j < n; ++j) x[ipvt[j]] = wa[j]; +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/r1mpyq.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/r1mpyq.h new file mode 100644 index 00000000000..ea41315990a --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/r1mpyq.h @@ -0,0 +1,33 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +// TODO : move this to GivensQR once there's such a thing in Eigen + +template +void r1mpyq(DenseIndex m, DenseIndex n, Scalar *a, const std::vector > &v_givens, + const std::vector > &w_givens) { + typedef DenseIndex Index; + + /* apply the first set of givens rotations to a. */ + for (Index j = n - 2; j >= 0; --j) + for (Index i = 0; i < m; ++i) { + Scalar temp = v_givens[j].c() * a[i + m * j] - v_givens[j].s() * a[i + m * (n - 1)]; + a[i + m * (n - 1)] = v_givens[j].s() * a[i + m * j] + v_givens[j].c() * a[i + m * (n - 1)]; + a[i + m * j] = temp; + } + /* apply the second set of givens rotations to a. */ + for (Index j = 0; j < n - 1; ++j) + for (Index i = 0; i < m; ++i) { + Scalar temp = w_givens[j].c() * a[i + m * j] + w_givens[j].s() * a[i + m * (n - 1)]; + a[i + m * (n - 1)] = -w_givens[j].s() * a[i + m * j] + w_givens[j].c() * a[i + m * (n - 1)]; + a[i + m * j] = temp; + } +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/r1updt.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/r1updt.h new file mode 100644 index 00000000000..201fba35256 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/r1updt.h @@ -0,0 +1,96 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void r1updt(Matrix &s, const Matrix &u, + std::vector > &v_givens, std::vector > &w_givens, + Matrix &v, Matrix &w, bool *sing) { + typedef DenseIndex Index; + const JacobiRotation IdentityRotation = JacobiRotation(1, 0); + + /* Local variables */ + const Index m = s.rows(); + const Index n = s.cols(); + Index i, j = 1; + Scalar temp; + JacobiRotation givens; + + // r1updt had a broader usecase, but we don't use it here. And, more + // importantly, we can not test it. + eigen_assert(m == n); + eigen_assert(u.size() == m); + eigen_assert(v.size() == n); + eigen_assert(w.size() == n); + + /* move the nontrivial part of the last column of s into w. */ + w[n - 1] = s(n - 1, n - 1); + + /* rotate the vector v into a multiple of the n-th unit vector */ + /* in such a way that a spike is introduced into w. */ + for (j = n - 2; j >= 0; --j) { + w[j] = 0.; + if (v[j] != 0.) { + /* determine a givens rotation which eliminates the */ + /* j-th element of v. */ + givens.makeGivens(-v[n - 1], v[j]); + + /* apply the transformation to v and store the information */ + /* necessary to recover the givens rotation. */ + v[n - 1] = givens.s() * v[j] + givens.c() * v[n - 1]; + v_givens[j] = givens; + + /* apply the transformation to s and extend the spike in w. */ + for (i = j; i < m; ++i) { + temp = givens.c() * s(j, i) - givens.s() * w[i]; + w[i] = givens.s() * s(j, i) + givens.c() * w[i]; + s(j, i) = temp; + } + } else + v_givens[j] = IdentityRotation; + } + + /* add the spike from the rank 1 update to w. */ + w += v[n - 1] * u; + + /* eliminate the spike. */ + *sing = false; + for (j = 0; j < n - 1; ++j) { + if (w[j] != 0.) { + /* determine a givens rotation which eliminates the */ + /* j-th element of the spike. */ + givens.makeGivens(-s(j, j), w[j]); + + /* apply the transformation to s and reduce the spike in w. */ + for (i = j; i < m; ++i) { + temp = givens.c() * s(j, i) + givens.s() * w[i]; + w[i] = -givens.s() * s(j, i) + givens.c() * w[i]; + s(j, i) = temp; + } + + /* store the information necessary to recover the */ + /* givens rotation. */ + w_givens[j] = givens; + } else + w_givens[j] = IdentityRotation; + + /* test for zero diagonal elements in the output s. */ + if (s(j, j) == 0.) { + *sing = true; + } + } + /* move w back into the last column of the output s. */ + s(n - 1, n - 1) = w[n - 1]; + + if (s(j, j) == 0.) { + *sing = true; + } + return; +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/rwupdt.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/rwupdt.h new file mode 100644 index 00000000000..8ae584870ea --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NonLinearOptimization/rwupdt.h @@ -0,0 +1,47 @@ +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +namespace internal { + +template +void rwupdt(Matrix &r, const Matrix &w, Matrix &b, + Scalar alpha) { + typedef DenseIndex Index; + + const Index n = r.cols(); + eigen_assert(r.rows() >= n); + std::vector > givens(n); + + /* Local variables */ + Scalar temp, rowj; + + /* Function Body */ + for (Index j = 0; j < n; ++j) { + rowj = w[j]; + + /* apply the previous transformations to */ + /* r(i,j), i=0,1,...,j-1, and to w(j). */ + for (Index i = 0; i < j; ++i) { + temp = givens[i].c() * r(i, j) + givens[i].s() * rowj; + rowj = -givens[i].s() * r(i, j) + givens[i].c() * rowj; + r(i, j) = temp; + } + + /* determine a givens rotation which eliminates w(j). */ + givens[j].makeGivens(-r(j, j), rowj); + + if (rowj == 0.) continue; // givens[j] is identity + + /* apply the current transformation to r(j,j), b(j), and alpha. */ + r(j, j) = givens[j].c() * r(j, j) + givens[j].s() * rowj; + temp = givens[j].c() * b[j] + givens[j].s() * alpha; + alpha = -givens[j].s() * b[j] + givens[j].c() * alpha; + b[j] = temp; + } +} + +} // end namespace internal + +} // end namespace Eigen diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NumericalDiff/InternalHeaderCheck.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NumericalDiff/InternalHeaderCheck.h new file mode 100644 index 00000000000..8c513d20348 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NumericalDiff/InternalHeaderCheck.h @@ -0,0 +1,3 @@ +#ifndef EIGEN_NUMERICALDIFF_MODULE_H +#error "Please include unsupported/Eigen/NumericalDiff instead of including headers inside the src directory directly." +#endif diff --git a/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NumericalDiff/NumericalDiff.h b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NumericalDiff/NumericalDiff.h new file mode 100644 index 00000000000..1f552636572 --- /dev/null +++ b/Modules/ThirdParty/Eigen3/src/itkeigen/unsupported/Eigen/src/NumericalDiff/NumericalDiff.h @@ -0,0 +1,127 @@ +// -*- coding: utf-8 +// vim: set fileencoding=utf-8 + +// This file is part of Eigen, a lightweight C++ template library +// for linear algebra. +// +// Copyright (C) 2009 Thomas Capricelli +// +// This Source Code Form is subject to the terms of the Mozilla +// Public License v. 2.0. If a copy of the MPL was not distributed +// with this file, You can obtain one at http://mozilla.org/MPL/2.0/. + +#ifndef EIGEN_NUMERICAL_DIFF_H +#define EIGEN_NUMERICAL_DIFF_H + +// IWYU pragma: private +#include "./InternalHeaderCheck.h" + +namespace Eigen { + +enum NumericalDiffMode { Forward, Central }; + +/** + * This class allows you to add a method df() to your functor, which will + * use numerical differentiation to compute an approximate of the + * derivative for the functor. Of course, if you have an analytical form + * for the derivative, you should rather implement df() by yourself. + * + * More information on + * http://en.wikipedia.org/wiki/Numerical_differentiation + * + * Currently only "Forward" and "Central" scheme are implemented. + */ +template +class NumericalDiff : public Functor_ { + public: + typedef Functor_ Functor; + typedef typename Functor::Scalar Scalar; + typedef typename Functor::InputType InputType; + typedef typename Functor::ValueType ValueType; + typedef typename Functor::JacobianType JacobianType; + + NumericalDiff(Scalar _epsfcn = 0.) : Functor(), epsfcn(_epsfcn) {} + NumericalDiff(const Functor& f, Scalar _epsfcn = 0.) : Functor(f), epsfcn(_epsfcn) {} + + // forward constructors + template + NumericalDiff(const T0& a0) : Functor(a0), epsfcn(0) {} + template + NumericalDiff(const T0& a0, const T1& a1) : Functor(a0, a1), epsfcn(0) {} + template + NumericalDiff(const T0& a0, const T1& a1, const T2& a2) : Functor(a0, a1, a2), epsfcn(0) {} + + enum { InputsAtCompileTime = Functor::InputsAtCompileTime, ValuesAtCompileTime = Functor::ValuesAtCompileTime }; + + /** + * return the number of evaluation of functor + */ + int df(const InputType& _x, JacobianType& jac) const { + using std::abs; + using std::sqrt; + /* Local variables */ + Scalar h; + int nfev = 0; + const typename InputType::Index n = _x.size(); + const Scalar eps = sqrt(((std::max)(epsfcn, NumTraits::epsilon()))); + ValueType val1, val2; + InputType x = _x; + // TODO : we should do this only if the size is not already known + val1.resize(Functor::values()); + val2.resize(Functor::values()); + + // initialization + switch (mode) { + case Forward: + // compute f(x) + Functor::operator()(x, val1); + nfev++; + break; + case Central: + // do nothing + break; + default: + eigen_assert(false); + }; + + // Function Body + for (int j = 0; j < n; ++j) { + h = eps * abs(x[j]); + if (h == 0.) { + h = eps; + } + switch (mode) { + case Forward: + x[j] += h; + Functor::operator()(x, val2); + nfev++; + x[j] = _x[j]; + jac.col(j) = (val2 - val1) / h; + break; + case Central: + x[j] += h; + Functor::operator()(x, val2); + nfev++; + x[j] -= 2 * h; + Functor::operator()(x, val1); + nfev++; + x[j] = _x[j]; + jac.col(j) = (val2 - val1) / (2 * h); + break; + default: + eigen_assert(false); + }; + } + return nfev; + } + + private: + Scalar epsfcn; + + NumericalDiff& operator=(const NumericalDiff&); +}; + +} // end namespace Eigen + +// vim: ai ts=4 sts=4 et sw=4 +#endif // EIGEN_NUMERICAL_DIFF_H diff --git a/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/CMakeLists.txt b/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/CMakeLists.txt index 3bc8f967d85..aa2fdbf3174 100644 --- a/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/CMakeLists.txt +++ b/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/CMakeLists.txt @@ -62,6 +62,10 @@ vxl_add_library(LIBRARY_NAME itkvnl_algo LIBRARY_SOURCES ${vnl_algo_sources} HEADER_INSTALL_DIR vnl/algo) target_link_libraries( itkvnl_algo PUBLIC itkv3p_netlib itkvnl ) + +# Eigen-backed vnl_levenberg_marquardt needs the vendored Eigen headers (private, header-only). +target_include_directories( itkvnl_algo + PRIVATE ${CMAKE_CURRENT_SOURCE_DIR}/../../../../../../Eigen3/src ) set(CURR_LIB_NAME vnl_algo) set_vxl_library_properties( TARGET_NAME itk${CURR_LIB_NAME} diff --git a/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/vnl_levenberg_marquardt.cxx b/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/vnl_levenberg_marquardt.cxx index 2397c2488bd..59145759d06 100644 --- a/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/vnl_levenberg_marquardt.cxx +++ b/Modules/ThirdParty/VNL/src/vxl/core/vnl/algo/vnl_levenberg_marquardt.cxx @@ -4,21 +4,100 @@ // \author Andrew W. Fitzgibbon, Oxford RRG // \date 31 Aug 96 // -//----------------------------------------------------------------------------- +// ITK: minimization uses Eigen's NonLinearOptimization Levenberg-Marquardt. #include #include +#include #include "vnl_levenberg_marquardt.h" #include "vnl/vnl_fastops.h" #include "vnl/vnl_matrix_ref.h" +#include "vnl/vnl_vector_ref.h" #include "vnl/vnl_least_squares_function.h" -#include // lmdif_() + +#include "itkeigen/unsupported/Eigen/NonLinearOptimization" +#include "itkeigen/unsupported/Eigen/NumericalDiff" + +namespace +{ +//: Eigen functor adapting a vnl_least_squares_function. +struct vnl_lsf_functor +{ + using Scalar = double; + using InputType = Eigen::VectorXd; + using ValueType = Eigen::VectorXd; + using JacobianType = Eigen::MatrixXd; + enum + { + InputsAtCompileTime = Eigen::Dynamic, + ValuesAtCompileTime = Eigen::Dynamic + }; + + vnl_least_squares_function * f_; + int m_; // residuals + int n_; // unknowns + + int + inputs() const + { + return n_; + } + int + values() const + { + return m_; + } + + int + operator()(const Eigen::VectorXd & x, Eigen::VectorXd & fx) const + { + const vnl_vector_ref rx(n_, const_cast(x.data())); + vnl_vector_ref rfx(m_, fx.data()); + f_->f(rx, rfx); + if (f_->failure) + { + f_->clear_failure(); + return -1; + } + return 0; + } + + // Eigen wants fjac(i,j) = d r_i / d x_j (m-by-n). vnl gradf fills the same + // residual-by-unknown layout. + int + df(const Eigen::VectorXd & x, Eigen::MatrixXd & fjac) const + { + const vnl_vector_ref rx(n_, const_cast(x.data())); + vnl_matrix jac(m_, n_); + f_->gradf(rx, jac); + for (int i = 0; i < m_; ++i) + { + for (int j = 0; j < n_; ++j) + { + fjac(i, j) = jac(i, j); + } + } + if (f_->failure) + { + f_->clear_failure(); + return -1; + } + return 0; + } +}; + +double +rms_of(const vnl_vector & v) +{ + return v.size() ? v.magnitude() / std::sqrt(static_cast(v.size())) : 0.0; +} +} // namespace // see header vnl_vector vnl_levenberg_marquardt_minimize(vnl_least_squares_function & f, const vnl_vector & initial_estimate) { - vnl_vector x = initial_estimate; + vnl_vector x = initial_estimate; vnl_levenberg_marquardt lm(f); lm.minimize(x); return x; @@ -48,81 +127,40 @@ vnl_levenberg_marquardt::init(vnl_least_squares_function * f) ipvt_.fill(0); inv_covar_.set_size(n, n); inv_covar_.fill(0.0); - // fdjac_ = new vnl_matrix(n,m); - // ipvt_ = new vnl_vector(n); - // covariance_ = new vnl_matrix(n,n); } -vnl_levenberg_marquardt::~vnl_levenberg_marquardt() -{ - // delete covariance_; - // delete fdjac_; - // delete ipvt_; -} +vnl_levenberg_marquardt::~vnl_levenberg_marquardt() = default; //-------------------------------------------------------------------------------- +namespace +{ +//: Store the R factor and permutation from an Eigen LM solve into the vnl +// members consumed by get_JtJ(). Eigen's fjac holds R in its top n-by-n; vnl +// get_JtJ() expects fdjac_.extract(n,n).transpose() to be that R, so store the +// transpose. ipvt_ is 1-based. +template void -vnl_levenberg_marquardt::lmdif_lsqfun(long * n, // I Number of residuals - long * p, // I Number of unknowns - double * x, // I Solution vector, size p - double * fx, // O Residual vector f(x) - long * iflag, // IO 0 ==> print, -1 ==> terminate - void * userdata) +store_r_and_permutation(const TEigenMatrix & fjac, + const TPermutation & permutation, + unsigned int n, + vnl_matrix & fdjac, + vnl_vector & ipvt) { - auto * self = static_cast(userdata); - vnl_least_squares_function * f = self->f_; - assert(*p == (int)f->get_number_of_unknowns()); - assert(*n == (int)f->get_number_of_residuals()); - assert(*p > 0); - assert(*n >= *p); - const vnl_vector_ref ref_x(*p, const_cast(x)); - vnl_vector_ref ref_fx(*n, fx); - - if (*iflag == 0) + for (unsigned int a = 0; a < n; ++a) { - if (self->trace) + for (unsigned int b = 0; b < n; ++b) { - std::cerr << "lmdif: iter " << self->num_iterations_ << " err [" << x[0]; - if (*p > 1) - std::cerr << ", " << x[1]; - if (*p > 2) - std::cerr << ", " << x[2]; - if (*p > 3) - std::cerr << ", " << x[3]; - if (*p > 4) - std::cerr << ", " << x[4]; - if (*p > 5) - std::cerr << ", ... "; - std::cerr << "] = " << ref_fx.magnitude() << '\n'; + fdjac(a, b) = fjac(b, a); } - - f->trace(static_cast(self->num_iterations_), ref_x, ref_fx); - ++(self->num_iterations_); } - else - { - f->f(ref_x, ref_fx); - } - - if (self->start_error_ == 0) - self->start_error_ = ref_fx.rms(); - - if (f->failure) + for (unsigned int i = 0; i < n; ++i) { - f->clear_failure(); - *iflag = -1; // fsm + ipvt[i] = permutation.indices()[i] + 1; } } +} // namespace - -// This function shouldn't be inlined, because (1) modification of the -// body will not cause the timestamp on the header to change, and so -// others will not be forced to recompile, and (2) the cost of making -// one more function call is far, far less than the cost of actually -// performing the minimisation, so the inline doesn't gain you -// anything. -// bool vnl_levenberg_marquardt::minimize(vnl_vector & x) { @@ -132,20 +170,16 @@ vnl_levenberg_marquardt::minimize(vnl_vector & x) return minimize_without_gradient(x); } - -// bool vnl_levenberg_marquardt::minimize_without_gradient(vnl_vector & x) { - // fsm if (f_->has_gradient()) { std::cerr << __FILE__ " : WARNING. calling minimize_without_gradient(), but f_ has gradient.\n"; } - // e04fcf - long m = f_->get_number_of_residuals(); // I Number of residuals, must be > #unknowns - long n = f_->get_number_of_unknowns(); // I Number of unknowns + const long m = f_->get_number_of_residuals(); + const long n = f_->get_number_of_unknowns(); if (m < n) { @@ -153,8 +187,7 @@ vnl_levenberg_marquardt::minimize_without_gradient(vnl_vector & x) failure_code_ = ERROR_DODGY_INPUT; return false; } - - if (int(x.size()) != n) + if (long(x.size()) != n) { std::cerr << "vnl_levenberg_marquardt: Input vector length (" << x.size() << ") not equal to num unknowns (" << n << ")\n"; @@ -162,186 +195,69 @@ vnl_levenberg_marquardt::minimize_without_gradient(vnl_vector & x) return false; } - vnl_vector fx(m, 0.0); // W m Storage for target vector - vnl_vector diag(n, 0); // I Multiplicative scale factors for variables - long user_provided_scale_factors = 1; // 1 is no, 2 is yes - double factor = 100; - long nprint = 1; + vnl_lsf_functor functor{ f_, static_cast(m), static_cast(n) }; + Eigen::NumericalDiff numdiff(functor, epsfcn); + Eigen::LevenbergMarquardt> lm(numdiff); + lm.parameters.ftol = ftol; + lm.parameters.xtol = xtol; + lm.parameters.gtol = gtol; + lm.parameters.maxfev = maxfev; + lm.parameters.factor = 100; + lm.parameters.epsfcn = epsfcn; - vnl_vector qtf(n, 0); - vnl_vector wa1(n, 0); - vnl_vector wa2(n, 0); - vnl_vector wa3(n, 0); - vnl_vector wa4(m, 0); - -#ifdef DEBUG - std::cerr << "STATUS: " << failure_code_ << '\n'; -#endif + Eigen::VectorXd ex(n); + for (long i = 0; i < n; ++i) + ex[i] = x[i]; num_iterations_ = 0; set_covariance_ = false; - long info = 0; - start_error_ = 0; // Set to 0 so first call to lmdif_lsqfun will know to set it. - v3p_netlib_lmdif_(lmdif_lsqfun, - &m, - &n, - x.data_block(), - fx.data_block(), - &ftol, - &xtol, - >ol, - &maxfev, - &epsfcn, - &diag[0], - &user_provided_scale_factors, - &factor, - &nprint, - &info, - &num_evaluations_, - fdjac_.data_block(), - &m, - ipvt_.data_block(), - &qtf[0], - &wa1[0], - &wa2[0], - &wa3[0], - &wa4[0], - this); - failure_code_ = (ReturnCodes)info; - - // One more call to compute final error. - lmdif_lsqfun(&m, // I Number of residuals - &n, // I Number of unknowns - x.data_block(), // I Solution vector, size n - fx.data_block(), // O Residual vector f(x) - &info, - this); - end_error_ = fx.rms(); - - // Translate status code - switch ((int)failure_code_) - { - case 1: // ftol - case 2: // xtol - case 3: // both - case 4: // gtol - return true; - default: - return false; - } -} + start_error_ = 0; -//-------------------------------------------------------------------------------- - -void -vnl_levenberg_marquardt::lmder_lsqfun(long * n, // I Number of residuals - long * p, // I Number of unknowns - double * x, // I Solution vector, size p - double * fx, // O Residual vector f(x) - double * fJ, // O m * n Jacobian f(x) - long *, - long * iflag, // I 1 -> calc fx, 2 -> calc fjac - void * userdata) -{ - auto * self = static_cast(userdata); - vnl_least_squares_function * f = self->f_; - assert(*p == (int)f->get_number_of_unknowns()); - assert(*n == (int)f->get_number_of_residuals()); - assert(*p > 0); - assert(*n >= *p); - const vnl_vector_ref ref_x(*p, (double *)x); // const violation! - vnl_vector_ref ref_fx(*n, fx); - vnl_matrix_ref ref_fJ(*n, *p, fJ); - - if (*iflag == 0) + Eigen::LevenbergMarquardtSpace::Status status = lm.minimizeInit(ex); + if (lm.fvec.size() > 0) + start_error_ = lm.fvec.norm() / std::sqrt(static_cast(lm.fvec.size())); + if (status != Eigen::LevenbergMarquardtSpace::ImproperInputParameters) { - if (self->trace) + do { - std::cerr << "lmder: iter " << self->num_iterations_ << " err [" << x[0]; - if (*p > 1) - std::cerr << ", " << x[1]; - if (*p > 2) - std::cerr << ", " << x[2]; - if (*p > 3) - std::cerr << ", " << x[3]; - if (*p > 4) - std::cerr << ", " << x[4]; - if (*p > 5) - std::cerr << ", ... "; - std::cerr << "] = " << ref_fx.magnitude() << '\n'; - } - f->trace(static_cast(self->num_iterations_), ref_x, ref_fx); - } - else if (*iflag == 1) - { - f->f(ref_x, ref_fx); - if (self->start_error_ == 0) - self->start_error_ = ref_fx.rms(); - ++(self->num_iterations_); + status = lm.minimizeOneStep(ex); + ++num_iterations_; + } while (status == Eigen::LevenbergMarquardtSpace::Running); } - else if (*iflag == 2) - { - f->gradf(ref_x, ref_fJ); - ref_fJ.inplace_transpose(); - // check derivative? - if (self->check_derivatives_ > 0) - { - self->check_derivatives_--; - - // use finite difference to compute Jacobian - vnl_vector feval(*n); - vnl_matrix finite_jac(*p, *n, 0.0); - vnl_vector wa1(*n); - long info = 1; - f->f(ref_x, feval); - v3p_netlib_fdjac2_(lmdif_lsqfun, - n, - p, - x, - feval.data_block(), - finite_jac.data_block(), - n, - &info, - &(self->epsfcn), - wa1.data_block(), - self); - // compute difference - for (unsigned i = 0; i < ref_fJ.cols(); ++i) - for (unsigned j = 0; j < ref_fJ.rows(); ++j) - { - double diff = ref_fJ(j, i) - finite_jac(j, i); - diff = diff * diff; - if (diff > self->epsfcn) - { - std::cout << "Jac(" << i << ", " << j << ") diff: " << ref_fJ(j, i) << " " << finite_jac(j, i) << " " - << ref_fJ(j, i) - finite_jac(j, i) << '\n'; - } - } - } - } + for (long i = 0; i < n; ++i) + x[i] = ex[i]; + num_evaluations_ = static_cast(lm.nfev); + failure_code_ = (static_cast(status) < 0) ? ERROR_FAILURE : static_cast(status); + store_r_and_permutation(lm.fjac, lm.permutation, static_cast(n), fdjac_, ipvt_); + + vnl_vector fx(m, 0.0); + f_->f(x, fx); + end_error_ = rms_of(fx); - if (f->failure) + switch (static_cast(failure_code_)) { - f->clear_failure(); - *iflag = -1; // fsm + case 1: + case 2: + case 3: + case 4: + return true; + default: + return false; } } - -// bool vnl_levenberg_marquardt::minimize_using_gradient(vnl_vector & x) { - // fsm if (!f_->has_gradient()) { std::cerr << __FILE__ ": called method minimize_using_gradient(), but f_ has no gradient.\n"; return false; } - long m = f_->get_number_of_residuals(); // I Number of residuals, must be > #unknowns - long n = f_->get_number_of_unknowns(); // I Number of unknowns + const long m = f_->get_number_of_residuals(); + const long n = f_->get_number_of_unknowns(); if (m < n) { @@ -350,68 +266,50 @@ vnl_levenberg_marquardt::minimize_using_gradient(vnl_vector & x) return false; } - vnl_vector fx(m, 0.0); // W m Explicitly set target to 0.0 + vnl_lsf_functor functor{ f_, static_cast(m), static_cast(n) }; + Eigen::LevenbergMarquardt lm(functor); + lm.parameters.ftol = ftol; + lm.parameters.xtol = xtol; + lm.parameters.gtol = gtol; + lm.parameters.maxfev = maxfev; + lm.parameters.factor = 100; + + Eigen::VectorXd ex(n); + for (long i = 0; i < n; ++i) + ex[i] = x[i]; num_iterations_ = 0; set_covariance_ = false; - long info = 0; - start_error_ = 0; // Set to 0 so first call to lmder_lsqfun will know to set it. - - - double factor = 100; - long nprint = 1; - long mode = 1; - long nfev = 0; - long njev = 0; - - vnl_vector diag(n, 0); - vnl_vector qtf(n, 0); - vnl_vector wa1(n, 0); - vnl_vector wa2(n, 0); - vnl_vector wa3(n, 0); - vnl_vector wa4(m, 0); - - - v3p_netlib_lmder_(lmder_lsqfun, - &m, - &n, - x.data_block(), - fx.data_block(), - fdjac_.data_block(), - &m, - &ftol, - &xtol, - >ol, - &maxfev, - diag.data_block(), - &mode, - &factor, - &nprint, - &info, - &nfev, - &njev, - ipvt_.data_block(), - qtf.data_block(), - wa1.data_block(), - wa2.data_block(), - wa3.data_block(), - wa4.data_block(), - this); + start_error_ = 0; + Eigen::LevenbergMarquardtSpace::Status status = lm.minimizeInit(ex); + if (lm.fvec.size() > 0) + start_error_ = lm.fvec.norm() / std::sqrt(static_cast(lm.fvec.size())); + if (status != Eigen::LevenbergMarquardtSpace::ImproperInputParameters) + { + do + { + status = lm.minimizeOneStep(ex); + ++num_iterations_; + } while (status == Eigen::LevenbergMarquardtSpace::Running); + } + for (long i = 0; i < n; ++i) + x[i] = ex[i]; num_evaluations_ = num_iterations_; // for lmder, these are the same. - if (info < 0) - info = ERROR_FAILURE; - failure_code_ = (ReturnCodes)info; - end_error_ = fx.rms(); + failure_code_ = (static_cast(status) < 0) ? ERROR_FAILURE : static_cast(status); + store_r_and_permutation(lm.fjac, lm.permutation, static_cast(n), fdjac_, ipvt_); - // Translate status code - switch (failure_code_) + vnl_vector fx(m, 0.0); + f_->f(x, fx); + end_error_ = rms_of(fx); + + switch (static_cast(failure_code_)) { - case 1: // ftol - case 2: // xtol - case 3: // both - case 4: // gtol + case 1: + case 2: + case 3: + case 4: return true; default: return false; @@ -432,12 +330,8 @@ void vnl_levenberg_marquardt::diagnose_outcome(std::ostream & s) const { #define whoami "vnl_levenberg_marquardt" - // if (!verbose_) return; switch (failure_code_) { - // case -1: - // have already warned. - // return; case ERROR_FAILURE: s << (whoami ": OIOIOI -- failure in leastsquares function\n"); break; diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/CMakeLists.txt b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/CMakeLists.txt index 829290cbea1..f056ef445bc 100644 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/CMakeLists.txt +++ b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/CMakeLists.txt @@ -236,17 +236,10 @@ set(V3P_NETLIB_lapack_SOURCES set(V3P_NETLIB_napack_SOURCES napack/cg.c napack/cg.h ) -set(V3P_NETLIB_minpack_SOURCES - minpack/dpmpar.c minpack/dpmpar.h - minpack/enorm.c minpack/enorm.h - minpack/fdjac2.c minpack/fdjac2.h - minpack/lmder.c minpack/lmder.h - minpack/lmder1.c minpack/lmder1.h - minpack/lmdif.c minpack/lmdif.h - minpack/lmpar.c minpack/lmpar.h - minpack/qrfac.c minpack/qrfac.h - minpack/qrsolv.c minpack/qrsolv.h - ) +# The netlib MINPACK lmdif/lmder port has been removed: ITK's +# vnl_levenberg_marquardt is now backed by Eigen's MINPACK-port +# Levenberg-Marquardt (unsupported/Eigen/NonLinearOptimization), which was its +# only consumer. set(V3P_NETLIB_opt_SOURCES opt/lbfgs.c opt/lbfgs.h opt/lbfgsb.c opt/lbfgsb.h @@ -282,7 +275,6 @@ set(v3p_netlib_sources ${V3P_NETLIB_eispack_SOURCES} ${V3P_NETLIB_lapack_SOURCES} ${V3P_NETLIB_napack_SOURCES} - ${V3P_NETLIB_minpack_SOURCES} ${V3P_NETLIB_opt_SOURCES} ${V3P_NETLIB_linalg_SOURCES} ${V3P_NETLIB_mathews_SOURCES} diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.c deleted file mode 100644 index 8eb50f2b778..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.c +++ /dev/null @@ -1,228 +0,0 @@ -/* minpack/dpmpar.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/*< double precision function dpmpar(i) >*/ -doublereal dpmpar_(integer *i__) -{ - /* Initialized data */ - - static struct { /* constant */ - doublereal e_1[3]; - doublereal fill_2[1]; - } - equiv_2 = - { {2.22044604926e-16, 2.22507385852e-308, 1.79769313485e308}, {0.0} }; - - - /* System generated locals */ - doublereal ret_val; - - /* Local variables */ -#define dmach ((doublereal *)&equiv_2) -#define minmag ((integer *)&equiv_2 + 2) -#define maxmag ((integer *)&equiv_2 + 4) -#define mcheps ((integer *)&equiv_2) - -/*< integer i >*/ -/* ********** */ - -/* Function dpmpar */ - -/* This function provides double precision machine parameters */ -/* when the appropriate set of data statements is activated (by */ -/* removing the c from column 1) and all other data statements are */ -/* rendered inactive. Most of the parameter values were obtained */ -/* from the corresponding Bell Laboratories Port Library function. */ - -/* The function statement is */ - -/* double precision function dpmpar(i) */ - -/* where */ - -/* i is an integer input variable set to 1, 2, or 3 which */ -/* selects the desired machine parameter. If the machine has */ -/* t base b digits and its smallest and largest exponents are */ -/* emin and emax, respectively, then these parameters are */ - -/* dpmpar(1) = b**(1 - t), the machine precision, */ - -/* dpmpar(2) = b**(emin - 1), the smallest magnitude, */ - -/* dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. */ - -/* Argonne National Laboratory. MINPACK Project. November 1996. */ -/* Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' */ - -/* ********** */ -/*< integer mcheps(4) >*/ -/*< integer minmag(4) >*/ -/*< integer maxmag(4) >*/ -/*< double precision dmach(3) >*/ -/*< equivalence (dmach(1),mcheps(1)) >*/ -/*< equivalence (dmach(2),minmag(1)) >*/ -/*< equivalence (dmach(3),maxmag(1)) >*/ - -/* Machine constants for the IBM 360/370 series, */ -/* the Amdahl 470/V6, the ICL 2900, the Itel AS/6, */ -/* the Xerox Sigma 5/7/9 and the Sel systems 85/86. */ - -/* data mcheps(1),mcheps(2) / z34100000, z00000000 / */ -/* data minmag(1),minmag(2) / z00100000, z00000000 / */ -/* data maxmag(1),maxmag(2) / z7fffffff, zffffffff / */ - -/* Machine constants for the Honeywell 600/6000 series. */ - -/* data mcheps(1),mcheps(2) / o606400000000, o000000000000 / */ -/* data minmag(1),minmag(2) / o402400000000, o000000000000 / */ -/* data maxmag(1),maxmag(2) / o376777777777, o777777777777 / */ - -/* Machine constants for the CDC 6000/7000 series. */ - -/* data mcheps(1) / 15614000000000000000b / */ -/* data mcheps(2) / 15010000000000000000b / */ - -/* data minmag(1) / 00604000000000000000b / */ -/* data minmag(2) / 00000000000000000000b / */ - -/* data maxmag(1) / 37767777777777777777b / */ -/* data maxmag(2) / 37167777777777777777b / */ - -/* Machine constants for the PDP-10 (KA processor). */ - -/* data mcheps(1),mcheps(2) / "114400000000, "000000000000 / */ -/* data minmag(1),minmag(2) / "033400000000, "000000000000 / */ -/* data maxmag(1),maxmag(2) / "377777777777, "344777777777 / */ - -/* Machine constants for the PDP-10 (KI processor). */ - -/* data mcheps(1),mcheps(2) / "104400000000, "000000000000 / */ -/* data minmag(1),minmag(2) / "000400000000, "000000000000 / */ -/* data maxmag(1),maxmag(2) / "377777777777, "377777777777 / */ - -/* Machine constants for the PDP-11. */ - -/* data mcheps(1),mcheps(2) / 9472, 0 / */ -/* data mcheps(3),mcheps(4) / 0, 0 / */ - -/* data minmag(1),minmag(2) / 128, 0 / */ -/* data minmag(3),minmag(4) / 0, 0 / */ - -/* data maxmag(1),maxmag(2) / 32767, -1 / */ -/* data maxmag(3),maxmag(4) / -1, -1 / */ - -/* Machine constants for the Burroughs 6700/7700 systems. */ - -/* data mcheps(1) / o1451000000000000 / */ -/* data mcheps(2) / o0000000000000000 / */ - -/* data minmag(1) / o1771000000000000 / */ -/* data minmag(2) / o7770000000000000 / */ - -/* data maxmag(1) / o0777777777777777 / */ -/* data maxmag(2) / o7777777777777777 / */ - -/* Machine constants for the Burroughs 5700 system. */ - -/* data mcheps(1) / o1451000000000000 / */ -/* data mcheps(2) / o0000000000000000 / */ - -/* data minmag(1) / o1771000000000000 / */ -/* data minmag(2) / o0000000000000000 / */ - -/* data maxmag(1) / o0777777777777777 / */ -/* data maxmag(2) / o0007777777777777 / */ - -/* Machine constants for the Burroughs 1700 system. */ - -/* data mcheps(1) / zcc6800000 / */ -/* data mcheps(2) / z000000000 / */ - -/* data minmag(1) / zc00800000 / */ -/* data minmag(2) / z000000000 / */ - -/* data maxmag(1) / zdffffffff / */ -/* data maxmag(2) / zfffffffff / */ - -/* Machine constants for the Univac 1100 series. */ - -/* data mcheps(1),mcheps(2) / o170640000000, o000000000000 / */ -/* data minmag(1),minmag(2) / o000040000000, o000000000000 / */ -/* data maxmag(1),maxmag(2) / o377777777777, o777777777777 / */ - -/* Machine constants for the Data General Eclipse S/200. */ - -/* Note - it may be appropriate to include the following card - */ -/* static dmach(3) */ /* constant */ - -/* data minmag/20k,3*0/,maxmag/77777k,3*177777k/ */ -/* data mcheps/32020k,3*0/ */ - -/* Machine constants for the Harris 220. */ - -/* data mcheps(1),mcheps(2) / '20000000, '00000334 / */ -/* data minmag(1),minmag(2) / '20000000, '00000201 / */ -/* data maxmag(1),maxmag(2) / '37777777, '37777577 / */ - -/* Machine constants for the Cray-1. */ - -/* data mcheps(1) / 0376424000000000000000b / */ -/* data mcheps(2) / 0000000000000000000000b / */ - -/* data minmag(1) / 0200034000000000000000b / */ -/* data minmag(2) / 0000000000000000000000b / */ - -/* data maxmag(1) / 0577777777777777777777b / */ -/* data maxmag(2) / 0000007777777777777776b / */ - -/* Machine constants for the Prime 400. */ - -/* data mcheps(1),mcheps(2) / :10000000000, :00000000123 / */ -/* data minmag(1),minmag(2) / :10000000000, :00000100000 / */ -/* data maxmag(1),maxmag(2) / :17777777777, :37777677776 / */ - -/* Machine constants for the VAX-11. */ - -/* data mcheps(1),mcheps(2) / 9472, 0 / */ -/* data minmag(1),minmag(2) / 128, 0 / */ -/* data maxmag(1),maxmag(2) / -32769, -1 / */ - -/* Machine constants for IEEE machines. */ - -/*< data dmach(1) /2.22044604926d-16/ >*/ -/*< data dmach(2) /2.22507385852d-308/ >*/ -/*< data dmach(3) /1.79769313485d+308/ >*/ - -/*< dpmpar = dmach(i) >*/ - ret_val = dmach[(0 + (0 + ((*i__ - 1) << 3))) / 8]; -/*< return >*/ - return ret_val; - -/* Last card of function dpmpar. */ - -/*< end >*/ -} /* dpmpar_ */ - -#undef mcheps -#undef maxmag -#undef minmag -#undef dmach - - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.f deleted file mode 100644 index ed1409ef4db..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.f +++ /dev/null @@ -1,177 +0,0 @@ - double precision function dpmpar(i) - integer i -c ********** -c -c Function dpmpar -c -c This function provides double precision machine parameters -c when the appropriate set of data statements is activated (by -c removing the c from column 1) and all other data statements are -c rendered inactive. Most of the parameter values were obtained -c from the corresponding Bell Laboratories Port Library function. -c -c The function statement is -c -c double precision function dpmpar(i) -c -c where -c -c i is an integer input variable set to 1, 2, or 3 which -c selects the desired machine parameter. If the machine has -c t base b digits and its smallest and largest exponents are -c emin and emax, respectively, then these parameters are -c -c dpmpar(1) = b**(1 - t), the machine precision, -c -c dpmpar(2) = b**(emin - 1), the smallest magnitude, -c -c dpmpar(3) = b**emax*(1 - b**(-t)), the largest magnitude. -c -c Argonne National Laboratory. MINPACK Project. November 1996. -c Burton S. Garbow, Kenneth E. Hillstrom, Jorge J. More' -c -c ********** - integer mcheps(4) - integer minmag(4) - integer maxmag(4) - double precision dmach(3) - equivalence (dmach(1),mcheps(1)) - equivalence (dmach(2),minmag(1)) - equivalence (dmach(3),maxmag(1)) -c -c Machine constants for the IBM 360/370 series, -c the Amdahl 470/V6, the ICL 2900, the Itel AS/6, -c the Xerox Sigma 5/7/9 and the Sel systems 85/86. -c -c data mcheps(1),mcheps(2) / z34100000, z00000000 / -c data minmag(1),minmag(2) / z00100000, z00000000 / -c data maxmag(1),maxmag(2) / z7fffffff, zffffffff / -c -c Machine constants for the Honeywell 600/6000 series. -c -c data mcheps(1),mcheps(2) / o606400000000, o000000000000 / -c data minmag(1),minmag(2) / o402400000000, o000000000000 / -c data maxmag(1),maxmag(2) / o376777777777, o777777777777 / -c -c Machine constants for the CDC 6000/7000 series. -c -c data mcheps(1) / 15614000000000000000b / -c data mcheps(2) / 15010000000000000000b / -c -c data minmag(1) / 00604000000000000000b / -c data minmag(2) / 00000000000000000000b / -c -c data maxmag(1) / 37767777777777777777b / -c data maxmag(2) / 37167777777777777777b / -c -c Machine constants for the PDP-10 (KA processor). -c -c data mcheps(1),mcheps(2) / "114400000000, "000000000000 / -c data minmag(1),minmag(2) / "033400000000, "000000000000 / -c data maxmag(1),maxmag(2) / "377777777777, "344777777777 / -c -c Machine constants for the PDP-10 (KI processor). -c -c data mcheps(1),mcheps(2) / "104400000000, "000000000000 / -c data minmag(1),minmag(2) / "000400000000, "000000000000 / -c data maxmag(1),maxmag(2) / "377777777777, "377777777777 / -c -c Machine constants for the PDP-11. -c -c data mcheps(1),mcheps(2) / 9472, 0 / -c data mcheps(3),mcheps(4) / 0, 0 / -c -c data minmag(1),minmag(2) / 128, 0 / -c data minmag(3),minmag(4) / 0, 0 / -c -c data maxmag(1),maxmag(2) / 32767, -1 / -c data maxmag(3),maxmag(4) / -1, -1 / -c -c Machine constants for the Burroughs 6700/7700 systems. -c -c data mcheps(1) / o1451000000000000 / -c data mcheps(2) / o0000000000000000 / -c -c data minmag(1) / o1771000000000000 / -c data minmag(2) / o7770000000000000 / -c -c data maxmag(1) / o0777777777777777 / -c data maxmag(2) / o7777777777777777 / -c -c Machine constants for the Burroughs 5700 system. -c -c data mcheps(1) / o1451000000000000 / -c data mcheps(2) / o0000000000000000 / -c -c data minmag(1) / o1771000000000000 / -c data minmag(2) / o0000000000000000 / -c -c data maxmag(1) / o0777777777777777 / -c data maxmag(2) / o0007777777777777 / -c -c Machine constants for the Burroughs 1700 system. -c -c data mcheps(1) / zcc6800000 / -c data mcheps(2) / z000000000 / -c -c data minmag(1) / zc00800000 / -c data minmag(2) / z000000000 / -c -c data maxmag(1) / zdffffffff / -c data maxmag(2) / zfffffffff / -c -c Machine constants for the Univac 1100 series. -c -c data mcheps(1),mcheps(2) / o170640000000, o000000000000 / -c data minmag(1),minmag(2) / o000040000000, o000000000000 / -c data maxmag(1),maxmag(2) / o377777777777, o777777777777 / -c -c Machine constants for the Data General Eclipse S/200. -c -c Note - it may be appropriate to include the following card - -c static dmach(3) -c -c data minmag/20k,3*0/,maxmag/77777k,3*177777k/ -c data mcheps/32020k,3*0/ -c -c Machine constants for the Harris 220. -c -c data mcheps(1),mcheps(2) / '20000000, '00000334 / -c data minmag(1),minmag(2) / '20000000, '00000201 / -c data maxmag(1),maxmag(2) / '37777777, '37777577 / -c -c Machine constants for the Cray-1. -c -c data mcheps(1) / 0376424000000000000000b / -c data mcheps(2) / 0000000000000000000000b / -c -c data minmag(1) / 0200034000000000000000b / -c data minmag(2) / 0000000000000000000000b / -c -c data maxmag(1) / 0577777777777777777777b / -c data maxmag(2) / 0000007777777777777776b / -c -c Machine constants for the Prime 400. -c -c data mcheps(1),mcheps(2) / :10000000000, :00000000123 / -c data minmag(1),minmag(2) / :10000000000, :00000100000 / -c data maxmag(1),maxmag(2) / :17777777777, :37777677776 / -c -c Machine constants for the VAX-11. -c -c data mcheps(1),mcheps(2) / 9472, 0 / -c data minmag(1),minmag(2) / 128, 0 / -c data maxmag(1),maxmag(2) / -32769, -1 / -c -c Machine constants for IEEE machines. -c - data dmach(1) /2.22044604926d-16/ - data dmach(2) /2.22507385852d-308/ - data dmach(3) /1.79769313485d+308/ -c - dpmpar = dmach(i) - return -c -c Last card of function dpmpar. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.h deleted file mode 100644 index ef1373ce2d6..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/dpmpar.h +++ /dev/null @@ -1,3 +0,0 @@ -extern v3p_netlib_doublereal v3p_netlib_dpmpar_( - v3p_netlib_integer *i__ - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.c deleted file mode 100644 index ab49c604484..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.c +++ /dev/null @@ -1,228 +0,0 @@ -/* minpack/enorm.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/*< double precision function enorm(n,x) >*/ -doublereal enorm_(integer *n, doublereal *x) -{ - /* Initialized data */ - - static doublereal one = 1.; /* constant */ - static doublereal zero = 0.; /* constant */ - static doublereal rdwarf = 3.834e-20; /* constant */ - static doublereal rgiant = 1.304e19; /* constant */ - - /* System generated locals */ - integer i__1; - doublereal ret_val=0, d__1; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__; - doublereal s1, s2, s3, xabs, x1max, x3max, agiant, floatn; - -/*< integer n >*/ -/*< double precision x(n) >*/ -/* ********** */ - -/* function enorm */ - -/* given an n-vector x, this function calculates the */ -/* euclidean norm of x. */ - -/* the euclidean norm is computed by accumulating the sum of */ -/* squares in three different sums. the sums of squares for the */ -/* small and large components are scaled so that no overflows */ -/* occur. non-destructive underflows are permitted. underflows */ -/* and overflows do not occur in the computation of the unscaled */ -/* sum of squares for the intermediate components. */ -/* the definitions of small, intermediate and large components */ -/* depend on two constants, rdwarf and rgiant. the main */ -/* restrictions on these constants are that rdwarf**2 not */ -/* underflow and rgiant**2 not overflow. the constants */ -/* given here are suitable for every known computer. */ - -/* the function statement is */ - -/* double precision function enorm(n,x) */ - -/* where */ - -/* n is a positive integer input variable. */ - -/* x is an input array of length n. */ - -/* subprograms called */ - -/* fortran-supplied ... dabs,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i >*/ -/*< >*/ -/*< data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ >*/ - /* Parameter adjustments */ - --x; - - /* Function Body */ -/*< s1 = zero >*/ - s1 = zero; -/*< s2 = zero >*/ - s2 = zero; -/*< s3 = zero >*/ - s3 = zero; -/*< x1max = zero >*/ - x1max = zero; -/*< x3max = zero >*/ - x3max = zero; -/*< floatn = n >*/ - floatn = (doublereal) (*n); -/*< agiant = rgiant/floatn >*/ - agiant = rgiant / floatn; -/*< do 90 i = 1, n >*/ - i__1 = *n; - for (i__ = 1; i__ <= i__1; ++i__) { -/*< xabs = dabs(x(i)) >*/ - xabs = (d__1 = x[i__], abs(d__1)); -/*< if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 >*/ - if (xabs > rdwarf && xabs < agiant) { - goto L70; - } -/*< if (xabs .le. rdwarf) go to 30 >*/ - if (xabs <= rdwarf) { - goto L30; - } - -/* sum for large components. */ - -/*< if (xabs .le. x1max) go to 10 >*/ - if (xabs <= x1max) { - goto L10; - } -/*< s1 = one + s1*(x1max/xabs)**2 >*/ -/* Computing 2nd power */ - d__1 = x1max / xabs; - s1 = one + s1 * (d__1 * d__1); -/*< x1max = xabs >*/ - x1max = xabs; -/*< go to 20 >*/ - goto L20; -/*< 10 continue >*/ -L10: -/*< s1 = s1 + (xabs/x1max)**2 >*/ -/* Computing 2nd power */ - d__1 = xabs / x1max; - s1 += d__1 * d__1; -/*< 20 continue >*/ -L20: -/*< go to 60 >*/ - goto L60; -/*< 30 continue >*/ -L30: - -/* sum for small components. */ - -/*< if (xabs .le. x3max) go to 40 >*/ - if (xabs <= x3max) { - goto L40; - } -/*< s3 = one + s3*(x3max/xabs)**2 >*/ -/* Computing 2nd power */ - d__1 = x3max / xabs; - s3 = one + s3 * (d__1 * d__1); -/*< x3max = xabs >*/ - x3max = xabs; -/*< go to 50 >*/ - goto L50; -/*< 40 continue >*/ -L40: -/*< if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 >*/ - if (xabs != zero) { -/* Computing 2nd power */ - d__1 = xabs / x3max; - s3 += d__1 * d__1; - } -/*< 50 continue >*/ -L50: -/*< 60 continue >*/ -L60: -/*< go to 80 >*/ - goto L80; -/*< 70 continue >*/ -L70: - -/* sum for intermediate components. */ - -/*< s2 = s2 + xabs**2 >*/ -/* Computing 2nd power */ - d__1 = xabs; - s2 += d__1 * d__1; -/*< 80 continue >*/ -L80: -/*< 90 continue >*/ -/* L90: */ - ; - } - -/* calculation of norm. */ - -/*< if (s1 .eq. zero) go to 100 >*/ - if (s1 == zero) { - goto L100; - } -/*< enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) >*/ - ret_val = x1max * sqrt(s1 + s2 / x1max / x1max); -/*< go to 130 >*/ - goto L130; -/*< 100 continue >*/ -L100: -/*< if (s2 .eq. zero) go to 110 >*/ - if (s2 == zero) { - goto L110; - } -/*< >*/ - if (s2 >= x3max) { - ret_val = sqrt(s2 * (one + x3max / s2 * (x3max * s3))); - } -/*< >*/ - if (s2 < x3max) { - ret_val = sqrt(x3max * (s2 / x3max + x3max * s3)); - } -/*< go to 120 >*/ - goto L120; -/*< 110 continue >*/ -L110: -/*< enorm = x3max*dsqrt(s3) >*/ - ret_val = x3max * sqrt(s3); -/*< 120 continue >*/ -L120: -/*< 130 continue >*/ -L130: -/*< return >*/ - return ret_val; - -/* last card of function enorm. */ - -/*< end >*/ -} /* enorm_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.f deleted file mode 100644 index 2cb5b607e17..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.f +++ /dev/null @@ -1,108 +0,0 @@ - double precision function enorm(n,x) - integer n - double precision x(n) -c ********** -c -c function enorm -c -c given an n-vector x, this function calculates the -c euclidean norm of x. -c -c the euclidean norm is computed by accumulating the sum of -c squares in three different sums. the sums of squares for the -c small and large components are scaled so that no overflows -c occur. non-destructive underflows are permitted. underflows -c and overflows do not occur in the computation of the unscaled -c sum of squares for the intermediate components. -c the definitions of small, intermediate and large components -c depend on two constants, rdwarf and rgiant. the main -c restrictions on these constants are that rdwarf**2 not -c underflow and rgiant**2 not overflow. the constants -c given here are suitable for every known computer. -c -c the function statement is -c -c double precision function enorm(n,x) -c -c where -c -c n is a positive integer input variable. -c -c x is an input array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i - double precision agiant,floatn,one,rdwarf,rgiant,s1,s2,s3,xabs, - * x1max,x3max,zero - data one,zero,rdwarf,rgiant /1.0d0,0.0d0,3.834d-20,1.304d19/ - s1 = zero - s2 = zero - s3 = zero - x1max = zero - x3max = zero - floatn = n - agiant = rgiant/floatn - do 90 i = 1, n - xabs = dabs(x(i)) - if (xabs .gt. rdwarf .and. xabs .lt. agiant) go to 70 - if (xabs .le. rdwarf) go to 30 -c -c sum for large components. -c - if (xabs .le. x1max) go to 10 - s1 = one + s1*(x1max/xabs)**2 - x1max = xabs - go to 20 - 10 continue - s1 = s1 + (xabs/x1max)**2 - 20 continue - go to 60 - 30 continue -c -c sum for small components. -c - if (xabs .le. x3max) go to 40 - s3 = one + s3*(x3max/xabs)**2 - x3max = xabs - go to 50 - 40 continue - if (xabs .ne. zero) s3 = s3 + (xabs/x3max)**2 - 50 continue - 60 continue - go to 80 - 70 continue -c -c sum for intermediate components. -c - s2 = s2 + xabs**2 - 80 continue - 90 continue -c -c calculation of norm. -c - if (s1 .eq. zero) go to 100 - enorm = x1max*dsqrt(s1+(s2/x1max)/x1max) - go to 130 - 100 continue - if (s2 .eq. zero) go to 110 - if (s2 .ge. x3max) - * enorm = dsqrt(s2*(one+(x3max/s2)*(x3max*s3))) - if (s2 .lt. x3max) - * enorm = dsqrt(x3max*((s2/x3max)+(x3max*s3))) - go to 120 - 110 continue - enorm = x3max*dsqrt(s3) - 120 continue - 130 continue - return -c -c last card of function enorm. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.h deleted file mode 100644 index 3cc95906504..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/enorm.h +++ /dev/null @@ -1,4 +0,0 @@ -extern v3p_netlib_doublereal v3p_netlib_enorm_( - v3p_netlib_integer *n, - v3p_netlib_doublereal *x - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.c deleted file mode 100644 index edafc301de9..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.c +++ /dev/null @@ -1,188 +0,0 @@ -/* minpack/fdjac2.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/*< subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) >*/ -/* Subroutine */ int fdjac2_( - void (*fcn)(integer*,integer*,doublereal*,doublereal*,integer*,void*), - integer *m, integer *n, doublereal *x, - doublereal *fvec, doublereal *fjac, integer *ldfjac, integer *iflag, - doublereal *epsfcn, doublereal *wa, void* userdata) -{ - /* Initialized data */ - - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer fjac_dim1, fjac_offset, i__1, i__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - doublereal h__; - integer i__, j; - doublereal eps, temp, epsmch; - extern doublereal dpmpar_(integer *); - -/*< integer m,n,ldfjac,iflag >*/ -/*< double precision epsfcn >*/ -/*< double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) >*/ -/* ********** */ - -/* subroutine fdjac2 */ - -/* this subroutine computes a forward-difference approximation */ -/* to the m by n jacobian matrix associated with a specified */ -/* problem of m functions in n variables. */ - -/* the subroutine statement is */ - -/* subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) */ - -/* where */ - -/* fcn is the name of the user-supplied subroutine which */ -/* calculates the functions. fcn must be declared */ -/* in an external statement in the user calling */ -/* program, and should be written as follows. */ - -/* subroutine fcn(m,n,x,fvec,iflag) */ -/* integer m,n,iflag */ -/* double precision x(n),fvec(m) */ -/* ---------- */ -/* calculate the functions at x and */ -/* return this vector in fvec. */ -/* ---------- */ -/* return */ -/* end */ - -/* the value of iflag should not be changed by fcn unless */ -/* the user wants to terminate execution of fdjac2. */ -/* in this case set iflag to a negative integer. */ - -/* m is a positive integer input variable set to the number */ -/* of functions. */ - -/* n is a positive integer input variable set to the number */ -/* of variables. n must not exceed m. */ - -/* x is an input array of length n. */ - -/* fvec is an input array of length m which must contain the */ -/* functions evaluated at x. */ - -/* fjac is an output m by n array which contains the */ -/* approximation to the jacobian matrix evaluated at x. */ - -/* ldfjac is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array fjac. */ - -/* iflag is an integer variable which can be used to terminate */ -/* the execution of fdjac2. see description of fcn. */ - -/* epsfcn is an input variable used in determining a suitable */ -/* step length for the forward-difference approximation. this */ -/* approximation assumes that the relative errors in the */ -/* functions are of the order of epsfcn. if epsfcn is less */ -/* than the machine precision, it is assumed that the relative */ -/* errors in the functions are of the order of the machine */ -/* precision. */ - -/* wa is a work array of length m. */ - -/* subprograms called */ - -/* user-supplied ...... fcn */ - -/* minpack-supplied ... dpmpar */ - -/* fortran-supplied ... dabs,dmax1,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i,j >*/ -/*< double precision eps,epsmch,h,temp,zero >*/ -/*< double precision dpmpar >*/ -/*< data zero /0.0d0/ >*/ - /* Parameter adjustments */ - --wa; - --fvec; - --x; - fjac_dim1 = *ldfjac; - fjac_offset = 1 + fjac_dim1; - fjac -= fjac_offset; - - /* Function Body */ - -/* epsmch is the machine precision. */ - -/*< epsmch = dpmpar(1) >*/ - epsmch = dpmpar_(&c__1); - -/*< eps = dsqrt(dmax1(epsfcn,epsmch)) >*/ - eps = sqrt((max(*epsfcn,epsmch))); -/*< do 20 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< temp = x(j) >*/ - temp = x[j]; -/*< h = eps*dabs(temp) >*/ - h__ = eps * abs(temp); -/*< if (h .eq. zero) h = eps >*/ - if (h__ == zero) { - h__ = eps; - } -/*< x(j) = temp + h >*/ - x[j] = temp + h__; -/*< call fcn(m,n,x,wa,iflag) >*/ - (*fcn)(m, n, &x[1], &wa[1], iflag, userdata); -/*< if (iflag .lt. 0) go to 30 >*/ - if (*iflag < 0) { - goto L30; - } -/*< x(j) = temp >*/ - x[j] = temp; -/*< do 10 i = 1, m >*/ - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< fjac(i,j) = (wa(i) - fvec(i))/h >*/ - fjac[i__ + j * fjac_dim1] = (wa[i__] - fvec[i__]) / h__; -/*< 10 continue >*/ -/* L10: */ - } -/*< 20 continue >*/ -/* L20: */ - } -/*< 30 continue >*/ -L30: -/*< return >*/ - return 0; - -/* last card of subroutine fdjac2. */ - -/*< end >*/ -} /* fdjac2_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.f deleted file mode 100644 index 218ab94c179..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.f +++ /dev/null @@ -1,107 +0,0 @@ - subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) - integer m,n,ldfjac,iflag - double precision epsfcn - double precision x(n),fvec(m),fjac(ldfjac,n),wa(m) -c ********** -c -c subroutine fdjac2 -c -c this subroutine computes a forward-difference approximation -c to the m by n jacobian matrix associated with a specified -c problem of m functions in n variables. -c -c the subroutine statement is -c -c subroutine fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of fdjac2. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an input array of length n. -c -c fvec is an input array of length m which must contain the -c functions evaluated at x. -c -c fjac is an output m by n array which contains the -c approximation to the jacobian matrix evaluated at x. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c iflag is an integer variable which can be used to terminate -c the execution of fdjac2. see description of fcn. -c -c epsfcn is an input variable used in determining a suitable -c step length for the forward-difference approximation. this -c approximation assumes that the relative errors in the -c functions are of the order of epsfcn. if epsfcn is less -c than the machine precision, it is assumed that the relative -c errors in the functions are of the order of the machine -c precision. -c -c wa is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar -c -c fortran-supplied ... dabs,dmax1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j - double precision eps,epsmch,h,temp,zero - double precision dpmpar - data zero /0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - eps = dsqrt(dmax1(epsfcn,epsmch)) - do 20 j = 1, n - temp = x(j) - h = eps*dabs(temp) - if (h .eq. zero) h = eps - x(j) = temp + h - call fcn(m,n,x,wa,iflag) - if (iflag .lt. 0) go to 30 - x(j) = temp - do 10 i = 1, m - fjac(i,j) = (wa(i) - fvec(i))/h - 10 continue - 20 continue - 30 continue - return -c -c last card of subroutine fdjac2. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.h deleted file mode 100644 index db3406d0fa1..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/fdjac2.h +++ /dev/null @@ -1,18 +0,0 @@ -extern int v3p_netlib_fdjac2_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - void*), - v3p_netlib_integer *m, - v3p_netlib_integer *n, - v3p_netlib_doublereal *x, - v3p_netlib_doublereal *fvec, - v3p_netlib_doublereal *fjac, - v3p_netlib_integer *ldfjac, - v3p_netlib_integer *iflag, - v3p_netlib_doublereal *epsfcn, - v3p_netlib_doublereal *wa, - void* userdata - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.c deleted file mode 100644 index b197805164e..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.c +++ /dev/null @@ -1,820 +0,0 @@ -/* minpack/lmder.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static logical c_true = TRUE_; - -/*< >*/ -/* Subroutine */ int lmder_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - v3p_netlib_integer*, - void*), - integer *m, integer *n, doublereal *x, - doublereal *fvec, doublereal *fjac, integer *ldfjac, doublereal *ftol, - doublereal *xtol, doublereal *gtol, integer *maxfev, doublereal * - diag, integer *mode, doublereal *factor, integer *nprint, integer * - info, integer *nfev, integer *njev, integer *ipvt, doublereal *qtf, - doublereal *wa1, doublereal *wa2, doublereal *wa3, doublereal *wa4, - void* userdata) -{ - /* Initialized data */ - - static doublereal one = 1.; /* constant */ - static doublereal p1 = .1; /* constant */ - static doublereal p5 = .5; /* constant */ - static doublereal p25 = .25; /* constant */ - static doublereal p75 = .75; /* constant */ - static doublereal p0001 = 1e-4; /* constant */ - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer fjac_dim1, fjac_offset, i__1, i__2; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, l; - doublereal par, sum; - integer iter; - doublereal temp=0, temp1, temp2; - integer iflag; - doublereal delta; - extern /* Subroutine */ int qrfac_(integer *, integer *, doublereal *, - integer *, logical *, integer *, integer *, doublereal *, - doublereal *, doublereal *), lmpar_(integer *, doublereal *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - doublereal ratio; - extern doublereal enorm_(integer *, doublereal *); - doublereal fnorm, gnorm, pnorm, xnorm=0, fnorm1, actred, dirder, epsmch, - prered; - extern doublereal dpmpar_(integer *); - -/*< integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev >*/ -/*< integer ipvt(n) >*/ -/*< double precision ftol,xtol,gtol,factor >*/ -/*< >*/ -/* ********** */ - -/* subroutine lmder */ - -/* the purpose of lmder is to minimize the sum of the squares of */ -/* m nonlinear functions in n variables by a modification of */ -/* the levenberg-marquardt algorithm. the user must provide a */ -/* subroutine which calculates the functions and the jacobian. */ - -/* the subroutine statement is */ - -/* subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, */ -/* maxfev,diag,mode,factor,nprint,info,nfev, */ -/* njev,ipvt,qtf,wa1,wa2,wa3,wa4) */ - -/* where */ - -/* fcn is the name of the user-supplied subroutine which */ -/* calculates the functions and the jacobian. fcn must */ -/* be declared in an external statement in the user */ -/* calling program, and should be written as follows. */ - -/* subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) */ -/* integer m,n,ldfjac,iflag */ -/* double precision x(n),fvec(m),fjac(ldfjac,n) */ -/* ---------- */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. do not alter fjac. */ -/* if iflag = 2 calculate the jacobian at x and */ -/* return this matrix in fjac. do not alter fvec. */ -/* ---------- */ -/* return */ -/* end */ - -/* the value of iflag should not be changed by fcn unless */ -/* the user wants to terminate execution of lmder. */ -/* in this case set iflag to a negative integer. */ - -/* m is a positive integer input variable set to the number */ -/* of functions. */ - -/* n is a positive integer input variable set to the number */ -/* of variables. n must not exceed m. */ - -/* x is an array of length n. on input x must contain */ -/* an initial estimate of the solution vector. on output x */ -/* contains the final estimate of the solution vector. */ - -/* fvec is an output array of length m which contains */ -/* the functions evaluated at the output x. */ - -/* fjac is an output m by n array. the upper n by n submatrix */ -/* of fjac contains an upper triangular matrix r with */ -/* diagonal elements of nonincreasing magnitude such that */ - -/* t t t */ -/* p *(jac *jac)*p = r *r, */ - -/* where p is a permutation matrix and jac is the final */ -/* calculated jacobian. column j of p is column ipvt(j) */ -/* (see below) of the identity matrix. the lower trapezoidal */ -/* part of fjac contains information generated during */ -/* the computation of r. */ - -/* ldfjac is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array fjac. */ - -/* ftol is a nonnegative input variable. termination */ -/* occurs when both the actual and predicted relative */ -/* reductions in the sum of squares are at most ftol. */ -/* therefore, ftol measures the relative error desired */ -/* in the sum of squares. */ - -/* xtol is a nonnegative input variable. termination */ -/* occurs when the relative error between two consecutive */ -/* iterates is at most xtol. therefore, xtol measures the */ -/* relative error desired in the approximate solution. */ - -/* gtol is a nonnegative input variable. termination */ -/* occurs when the cosine of the angle between fvec and */ -/* any column of the jacobian is at most gtol in absolute */ -/* value. therefore, gtol measures the orthogonality */ -/* desired between the function vector and the columns */ -/* of the jacobian. */ - -/* maxfev is a positive integer input variable. termination */ -/* occurs when the number of calls to fcn with iflag = 1 */ -/* has reached maxfev. */ - -/* diag is an array of length n. if mode = 1 (see */ -/* below), diag is internally set. if mode = 2, diag */ -/* must contain positive entries that serve as */ -/* multiplicative scale factors for the variables. */ - -/* mode is an integer input variable. if mode = 1, the */ -/* variables will be scaled internally. if mode = 2, */ -/* the scaling is specified by the input diag. other */ -/* values of mode are equivalent to mode = 1. */ - -/* factor is a positive input variable used in determining the */ -/* initial step bound. this bound is set to the product of */ -/* factor and the euclidean norm of diag*x if nonzero, or else */ -/* to factor itself. in most cases factor should lie in the */ -/* interval (.1,100.).100. is a generally recommended value. */ - -/* nprint is an integer input variable that enables controlled */ -/* printing of iterates if it is positive. in this case, */ -/* fcn is called with iflag = 0 at the beginning of the first */ -/* iteration and every nprint iterations thereafter and */ -/* immediately prior to return, with x, fvec, and fjac */ -/* available for printing. fvec and fjac should not be */ -/* altered. if nprint is not positive, no special calls */ -/* of fcn with iflag = 0 are made. */ - -/* info is an integer output variable. if the user has */ -/* terminated execution, info is set to the (negative) */ -/* value of iflag. see description of fcn. otherwise, */ -/* info is set as follows. */ - -/* info = 0 improper input parameters. */ - -/* info = 1 both actual and predicted relative reductions */ -/* in the sum of squares are at most ftol. */ - -/* info = 2 relative error between two consecutive iterates */ -/* is at most xtol. */ - -/* info = 3 conditions for info = 1 and info = 2 both hold. */ - -/* info = 4 the cosine of the angle between fvec and any */ -/* column of the jacobian is at most gtol in */ -/* absolute value. */ - -/* info = 5 number of calls to fcn with iflag = 1 has */ -/* reached maxfev. */ - -/* info = 6 ftol is too small. no further reduction in */ -/* the sum of squares is possible. */ - -/* info = 7 xtol is too small. no further improvement in */ -/* the approximate solution x is possible. */ - -/* info = 8 gtol is too small. fvec is orthogonal to the */ -/* columns of the jacobian to machine precision. */ - -/* nfev is an integer output variable set to the number of */ -/* calls to fcn with iflag = 1. */ - -/* njev is an integer output variable set to the number of */ -/* calls to fcn with iflag = 2. */ - -/* ipvt is an integer output array of length n. ipvt */ -/* defines a permutation matrix p such that jac*p = q*r, */ -/* where jac is the final calculated jacobian, q is */ -/* orthogonal (not stored), and r is upper triangular */ -/* with diagonal elements of nonincreasing magnitude. */ -/* column j of p is column ipvt(j) of the identity matrix. */ - -/* qtf is an output array of length n which contains */ -/* the first n elements of the vector (q transpose)*fvec. */ - -/* wa1, wa2, and wa3 are work arrays of length n. */ - -/* wa4 is a work array of length m. */ - -/* subprograms called */ - -/* user-supplied ...... fcn */ - -/* minpack-supplied ... dpmpar,enorm,lmpar,qrfac */ - -/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i,iflag,iter,j,l >*/ -/*< >*/ -/*< double precision dpmpar,enorm >*/ -/*< >*/ - /* Parameter adjustments */ - --wa4; - --fvec; - --wa3; - --wa2; - --wa1; - --qtf; - --ipvt; - --diag; - --x; - fjac_dim1 = *ldfjac; - fjac_offset = 1 + fjac_dim1; - fjac -= fjac_offset; - - /* Function Body */ - -/* epsmch is the machine precision. */ - -/*< epsmch = dpmpar(1) >*/ - epsmch = dpmpar_(&c__1); - -/*< info = 0 >*/ - *info = 0; -/*< iflag = 0 >*/ - iflag = 0; -/*< nfev = 0 >*/ - *nfev = 0; -/*< njev = 0 >*/ - *njev = 0; - -/* check the input parameters for errors. */ - -/*< >*/ - if (*n <= 0 || *m < *n || *ldfjac < *m || *ftol < zero || *xtol < zero || - *gtol < zero || *maxfev <= 0 || *factor <= zero) { - goto L300; - } -/*< if (mode .ne. 2) go to 20 >*/ - if (*mode != 2) { - goto L20; - } -/*< do 10 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< if (diag(j) .le. zero) go to 300 >*/ - if (diag[j] <= zero) { - goto L300; - } -/*< 10 continue >*/ -/* L10: */ - } -/*< 20 continue >*/ -L20: - -/* evaluate the function at the starting point */ -/* and calculate its norm. */ - -/*< iflag = 1 >*/ - iflag = 1; -/*< call fcn(m,n,x,fvec,fjac,ldfjac,iflag) >*/ - (*fcn)(m, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, - userdata); -/*< nfev = 1 >*/ - *nfev = 1; -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } -/*< fnorm = enorm(m,fvec) >*/ - fnorm = enorm_(m, &fvec[1]); - -/* initialize levenberg-marquardt parameter and iteration counter. */ - -/*< par = zero >*/ - par = zero; -/*< iter = 1 >*/ - iter = 1; - -/* beginning of the outer loop. */ - -/*< 30 continue >*/ -L30: - -/* calculate the jacobian matrix. */ - -/*< iflag = 2 >*/ - iflag = 2; -/*< call fcn(m,n,x,fvec,fjac,ldfjac,iflag) >*/ - (*fcn)(m, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, - userdata); -/*< njev = njev + 1 >*/ - ++(*njev); -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } - -/* if requested, call fcn to enable printing of iterates. */ - -/*< if (nprint .le. 0) go to 40 >*/ - if (*nprint <= 0) { - goto L40; - } -/*< iflag = 0 >*/ - iflag = 0; -/*< >*/ - if ((iter - 1) % *nprint == 0) { - (*fcn)(m, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, - userdata); - } -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } -/*< 40 continue >*/ -L40: - -/* compute the qr factorization of the jacobian. */ - -/*< call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) >*/ - qrfac_(m, n, &fjac[fjac_offset], ldfjac, &c_true, &ipvt[1], n, &wa1[1], & - wa2[1], &wa3[1]); - -/* on the first iteration and if mode is 1, scale according */ -/* to the norms of the columns of the initial jacobian. */ - -/*< if (iter .ne. 1) go to 80 >*/ - if (iter != 1) { - goto L80; - } -/*< if (mode .eq. 2) go to 60 >*/ - if (*mode == 2) { - goto L60; - } -/*< do 50 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< diag(j) = wa2(j) >*/ - diag[j] = wa2[j]; -/*< if (wa2(j) .eq. zero) diag(j) = one >*/ - if (wa2[j] == zero) { - diag[j] = one; - } -/*< 50 continue >*/ -/* L50: */ - } -/*< 60 continue >*/ -L60: - -/* on the first iteration, calculate the norm of the scaled x */ -/* and initialize the step bound delta. */ - -/*< do 70 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa3(j) = diag(j)*x(j) >*/ - wa3[j] = diag[j] * x[j]; -/*< 70 continue >*/ -/* L70: */ - } -/*< xnorm = enorm(n,wa3) >*/ - xnorm = enorm_(n, &wa3[1]); -/*< delta = factor*xnorm >*/ - delta = *factor * xnorm; -/*< if (delta .eq. zero) delta = factor >*/ - if (delta == zero) { - delta = *factor; - } -/*< 80 continue >*/ -L80: - -/* form (q transpose)*fvec and store the first n components in */ -/* qtf. */ - -/*< do 90 i = 1, m >*/ - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/*< wa4(i) = fvec(i) >*/ - wa4[i__] = fvec[i__]; -/*< 90 continue >*/ -/* L90: */ - } -/*< do 130 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< if (fjac(j,j) .eq. zero) go to 120 >*/ - if (fjac[j + j * fjac_dim1] == zero) { - goto L120; - } -/*< sum = zero >*/ - sum = zero; -/*< do 100 i = j, m >*/ - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/*< sum = sum + fjac(i,j)*wa4(i) >*/ - sum += fjac[i__ + j * fjac_dim1] * wa4[i__]; -/*< 100 continue >*/ -/* L100: */ - } -/*< temp = -sum/fjac(j,j) >*/ - temp = -sum / fjac[j + j * fjac_dim1]; -/*< do 110 i = j, m >*/ - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/*< wa4(i) = wa4(i) + fjac(i,j)*temp >*/ - wa4[i__] += fjac[i__ + j * fjac_dim1] * temp; -/*< 110 continue >*/ -/* L110: */ - } -/*< 120 continue >*/ -L120: -/*< fjac(j,j) = wa1(j) >*/ - fjac[j + j * fjac_dim1] = wa1[j]; -/*< qtf(j) = wa4(j) >*/ - qtf[j] = wa4[j]; -/*< 130 continue >*/ -/* L130: */ - } - -/* compute the norm of the scaled gradient. */ - -/*< gnorm = zero >*/ - gnorm = zero; -/*< if (fnorm .eq. zero) go to 170 >*/ - if (fnorm == zero) { - goto L170; - } -/*< do 160 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< if (wa2(l) .eq. zero) go to 150 >*/ - if (wa2[l] == zero) { - goto L150; - } -/*< sum = zero >*/ - sum = zero; -/*< do 140 i = 1, j >*/ - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< sum = sum + fjac(i,j)*(qtf(i)/fnorm) >*/ - sum += fjac[i__ + j * fjac_dim1] * (qtf[i__] / fnorm); -/*< 140 continue >*/ -/* L140: */ - } -/*< gnorm = dmax1(gnorm,dabs(sum/wa2(l))) >*/ -/* Computing MAX */ - d__2 = gnorm, d__3 = (d__1 = sum / wa2[l], abs(d__1)); - gnorm = max(d__2,d__3); -/*< 150 continue >*/ -L150: -/*< 160 continue >*/ -/* L160: */ - ; - } -/*< 170 continue >*/ -L170: - -/* test for convergence of the gradient norm. */ - -/*< if (gnorm .le. gtol) info = 4 >*/ - if (gnorm <= *gtol) { - *info = 4; - } -/*< if (info .ne. 0) go to 300 >*/ - if (*info != 0) { - goto L300; - } - -/* rescale if necessary. */ - -/*< if (mode .eq. 2) go to 190 >*/ - if (*mode == 2) { - goto L190; - } -/*< do 180 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< diag(j) = dmax1(diag(j),wa2(j)) >*/ -/* Computing MAX */ - d__1 = diag[j], d__2 = wa2[j]; - diag[j] = max(d__1,d__2); -/*< 180 continue >*/ -/* L180: */ - } -/*< 190 continue >*/ -L190: - -/* beginning of the inner loop. */ - -/*< 200 continue >*/ -L200: - -/* determine the levenberg-marquardt parameter. */ - -/*< >*/ - lmpar_(n, &fjac[fjac_offset], ldfjac, &ipvt[1], &diag[1], &qtf[1], &delta, - &par, &wa1[1], &wa2[1], &wa3[1], &wa4[1]); - -/* store the direction p and x + p. calculate the norm of p. */ - -/*< do 210 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa1(j) = -wa1(j) >*/ - wa1[j] = -wa1[j]; -/*< wa2(j) = x(j) + wa1(j) >*/ - wa2[j] = x[j] + wa1[j]; -/*< wa3(j) = diag(j)*wa1(j) >*/ - wa3[j] = diag[j] * wa1[j]; -/*< 210 continue >*/ -/* L210: */ - } -/*< pnorm = enorm(n,wa3) >*/ - pnorm = enorm_(n, &wa3[1]); - -/* on the first iteration, adjust the initial step bound. */ - -/*< if (iter .eq. 1) delta = dmin1(delta,pnorm) >*/ - if (iter == 1) { - delta = min(delta,pnorm); - } - -/* evaluate the function at x + p and calculate its norm. */ - -/*< iflag = 1 >*/ - iflag = 1; -/*< call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) >*/ - (*fcn)(m, n, &wa2[1], &wa4[1], &fjac[fjac_offset], ldfjac, &iflag, - userdata); -/*< nfev = nfev + 1 >*/ - ++(*nfev); -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } -/*< fnorm1 = enorm(m,wa4) >*/ - fnorm1 = enorm_(m, &wa4[1]); - -/* compute the scaled actual reduction. */ - -/*< actred = -one >*/ - actred = -one; -/*< if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 >*/ - if (p1 * fnorm1 < fnorm) { -/* Computing 2nd power */ - d__1 = fnorm1 / fnorm; - actred = one - d__1 * d__1; - } - -/* compute the scaled predicted reduction and */ -/* the scaled directional derivative. */ - -/*< do 230 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa3(j) = zero >*/ - wa3[j] = zero; -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< temp = wa1(l) >*/ - temp = wa1[l]; -/*< do 220 i = 1, j >*/ - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< wa3(i) = wa3(i) + fjac(i,j)*temp >*/ - wa3[i__] += fjac[i__ + j * fjac_dim1] * temp; -/*< 220 continue >*/ -/* L220: */ - } -/*< 230 continue >*/ -/* L230: */ - } -/*< temp1 = enorm(n,wa3)/fnorm >*/ - temp1 = enorm_(n, &wa3[1]) / fnorm; -/*< temp2 = (dsqrt(par)*pnorm)/fnorm >*/ - temp2 = sqrt(par) * pnorm / fnorm; -/*< prered = temp1**2 + temp2**2/p5 >*/ -/* Computing 2nd power */ - d__1 = temp1; -/* Computing 2nd power */ - d__2 = temp2; - prered = d__1 * d__1 + d__2 * d__2 / p5; -/*< dirder = -(temp1**2 + temp2**2) >*/ -/* Computing 2nd power */ - d__1 = temp1; -/* Computing 2nd power */ - d__2 = temp2; - dirder = -(d__1 * d__1 + d__2 * d__2); - -/* compute the ratio of the actual to the predicted */ -/* reduction. */ - -/*< ratio = zero >*/ - ratio = zero; -/*< if (prered .ne. zero) ratio = actred/prered >*/ - if (prered != zero) { - ratio = actred / prered; - } - -/* update the step bound. */ - -/*< if (ratio .gt. p25) go to 240 >*/ - if (ratio > p25) { - goto L240; - } -/*< if (actred .ge. zero) temp = p5 >*/ - if (actred >= zero) { - temp = p5; - } -/*< >*/ - if (actred < zero) { - temp = p5 * dirder / (dirder + p5 * actred); - } -/*< if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 >*/ - if (p1 * fnorm1 >= fnorm || temp < p1) { - temp = p1; - } -/*< delta = temp*dmin1(delta,pnorm/p1) >*/ -/* Computing MIN */ - d__1 = delta, d__2 = pnorm / p1; - delta = temp * min(d__1,d__2); -/*< par = par/temp >*/ - par /= temp; -/*< go to 260 >*/ - goto L260; -/*< 240 continue >*/ -L240: -/*< if (par .ne. zero .and. ratio .lt. p75) go to 250 >*/ - if (par != zero && ratio < p75) { - goto L250; - } -/*< delta = pnorm/p5 >*/ - delta = pnorm / p5; -/*< par = p5*par >*/ - par = p5 * par; -/*< 250 continue >*/ -L250: -/*< 260 continue >*/ -L260: - -/* test for successful iteration. */ - -/*< if (ratio .lt. p0001) go to 290 >*/ - if (ratio < p0001) { - goto L290; - } - -/* successful iteration. update x, fvec, and their norms. */ - -/*< do 270 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< x(j) = wa2(j) >*/ - x[j] = wa2[j]; -/*< wa2(j) = diag(j)*x(j) >*/ - wa2[j] = diag[j] * x[j]; -/*< 270 continue >*/ -/* L270: */ - } -/*< do 280 i = 1, m >*/ - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/*< fvec(i) = wa4(i) >*/ - fvec[i__] = wa4[i__]; -/*< 280 continue >*/ -/* L280: */ - } -/*< xnorm = enorm(n,wa2) >*/ - xnorm = enorm_(n, &wa2[1]); -/*< fnorm = fnorm1 >*/ - fnorm = fnorm1; -/*< iter = iter + 1 >*/ - ++iter; -/*< 290 continue >*/ -L290: - -/* tests for convergence. */ - -/*< >*/ - if (abs(actred) <= *ftol && prered <= *ftol && p5 * ratio <= one) { - *info = 1; - } -/*< if (delta .le. xtol*xnorm) info = 2 >*/ - if (delta <= *xtol * xnorm) { - *info = 2; - } -/*< >*/ - if (abs(actred) <= *ftol && prered <= *ftol && p5 * ratio <= one && *info - == 2) { - *info = 3; - } -/*< if (info .ne. 0) go to 300 >*/ - if (*info != 0) { - goto L300; - } - -/* tests for termination and stringent tolerances. */ - -/*< if (nfev .ge. maxfev) info = 5 >*/ - if (*nfev >= *maxfev) { - *info = 5; - } -/*< >*/ - if (abs(actred) <= epsmch && prered <= epsmch && p5 * ratio <= one) { - *info = 6; - } -/*< if (delta .le. epsmch*xnorm) info = 7 >*/ - if (delta <= epsmch * xnorm) { - *info = 7; - } -/*< if (gnorm .le. epsmch) info = 8 >*/ - if (gnorm <= epsmch) { - *info = 8; - } -/*< if (info .ne. 0) go to 300 >*/ - if (*info != 0) { - goto L300; - } - -/* end of the inner loop. repeat if iteration unsuccessful. */ - -/*< if (ratio .lt. p0001) go to 200 >*/ - if (ratio < p0001) { - goto L200; - } - -/* end of the outer loop. */ - -/*< go to 30 >*/ - goto L30; -/*< 300 continue >*/ -L300: - -/* termination, either normal or user imposed. */ - -/*< if (iflag .lt. 0) info = iflag >*/ - if (iflag < 0) { - *info = iflag; - } -/*< iflag = 0 >*/ - iflag = 0; -/*< if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) >*/ - if (*nprint > 0) { - (*fcn)(m, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, &iflag, - userdata); - } -/*< return >*/ - return 0; - -/* last card of subroutine lmder. */ - -/*< end >*/ -} /* lmder_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.f deleted file mode 100644 index 8797d8bed89..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.f +++ /dev/null @@ -1,452 +0,0 @@ - subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, - * maxfev,diag,mode,factor,nprint,info,nfev,njev, - * ipvt,qtf,wa1,wa2,wa3,wa4) - integer m,n,ldfjac,maxfev,mode,nprint,info,nfev,njev - integer ipvt(n) - double precision ftol,xtol,gtol,factor - double precision x(n),fvec(m),fjac(ldfjac,n),diag(n),qtf(n), - * wa1(n),wa2(n),wa3(n),wa4(m) -c ********** -c -c subroutine lmder -c -c the purpose of lmder is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of -c the levenberg-marquardt algorithm. the user must provide a -c subroutine which calculates the functions and the jacobian. -c -c the subroutine statement is -c -c subroutine lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol, -c maxfev,diag,mode,factor,nprint,info,nfev, -c njev,ipvt,qtf,wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) -c integer m,n,ldfjac,iflag -c double precision x(n),fvec(m),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmder. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c fjac is an output m by n array. the upper n by n submatrix -c of fjac contains an upper triangular matrix r with -c diagonal elements of nonincreasing magnitude such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower trapezoidal -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c ftol is a nonnegative input variable. termination -c occurs when both the actual and predicted relative -c reductions in the sum of squares are at most ftol. -c therefore, ftol measures the relative error desired -c in the sum of squares. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. therefore, xtol measures the -c relative error desired in the approximate solution. -c -c gtol is a nonnegative input variable. termination -c occurs when the cosine of the angle between fvec and -c any column of the jacobian is at most gtol in absolute -c value. therefore, gtol measures the orthogonality -c desired between the function vector and the columns -c of the jacobian. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn with iflag = 1 -c has reached maxfev. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.).100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x, fvec, and fjac -c available for printing. fvec and fjac should not be -c altered. if nprint is not positive, no special calls -c of fcn with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 both actual and predicted relative reductions -c in the sum of squares are at most ftol. -c -c info = 2 relative error between two consecutive iterates -c is at most xtol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 the cosine of the angle between fvec and any -c column of the jacobian is at most gtol in -c absolute value. -c -c info = 5 number of calls to fcn with iflag = 1 has -c reached maxfev. -c -c info = 6 ftol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 8 gtol is too small. fvec is orthogonal to the -c columns of the jacobian to machine precision. -c -c nfev is an integer output variable set to the number of -c calls to fcn with iflag = 1. -c -c njev is an integer output variable set to the number of -c calls to fcn with iflag = 2. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular -c with diagonal elements of nonincreasing magnitude. -c column j of p is column ipvt(j) of the identity matrix. -c -c qtf is an output array of length n which contains -c the first n elements of the vector (q transpose)*fvec. -c -c wa1, wa2, and wa3 are work arrays of length n. -c -c wa4 is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,lmpar,qrfac -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,l - double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, - * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, - * sum,temp,temp1,temp2,xnorm,zero - double precision dpmpar,enorm - data one,p1,p5,p25,p75,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 - njev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m - * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(m,fvec) -c -c initialize levenberg-marquardt parameter and iteration counter. -c - par = zero - iter = 1 -c -c beginning of the outer loop. -c - 30 continue -c -c calculate the jacobian matrix. -c - iflag = 2 - call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - njev = njev + 1 - if (iflag .lt. 0) go to 300 -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 40 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) - * call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - if (iflag .lt. 0) go to 300 - 40 continue -c -c compute the qr factorization of the jacobian. -c - call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 80 - if (mode .eq. 2) go to 60 - do 50 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 50 continue - 60 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 70 j = 1, n - wa3(j) = diag(j)*x(j) - 70 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 80 continue -c -c form (q transpose)*fvec and store the first n components in -c qtf. -c - do 90 i = 1, m - wa4(i) = fvec(i) - 90 continue - do 130 j = 1, n - if (fjac(j,j) .eq. zero) go to 120 - sum = zero - do 100 i = j, m - sum = sum + fjac(i,j)*wa4(i) - 100 continue - temp = -sum/fjac(j,j) - do 110 i = j, m - wa4(i) = wa4(i) + fjac(i,j)*temp - 110 continue - 120 continue - fjac(j,j) = wa1(j) - qtf(j) = wa4(j) - 130 continue -c -c compute the norm of the scaled gradient. -c - gnorm = zero - if (fnorm .eq. zero) go to 170 - do 160 j = 1, n - l = ipvt(j) - if (wa2(l) .eq. zero) go to 150 - sum = zero - do 140 i = 1, j - sum = sum + fjac(i,j)*(qtf(i)/fnorm) - 140 continue - gnorm = dmax1(gnorm,dabs(sum/wa2(l))) - 150 continue - 160 continue - 170 continue -c -c test for convergence of the gradient norm. -c - if (gnorm .le. gtol) info = 4 - if (info .ne. 0) go to 300 -c -c rescale if necessary. -c - if (mode .eq. 2) go to 190 - do 180 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 180 continue - 190 continue -c -c beginning of the inner loop. -c - 200 continue -c -c determine the levenberg-marquardt parameter. -c - call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, - * wa3,wa4) -c -c store the direction p and x + p. calculate the norm of p. -c - do 210 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 210 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(m,n,wa2,wa4,fjac,ldfjac,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(m,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction and -c the scaled directional derivative. -c - do 230 j = 1, n - wa3(j) = zero - l = ipvt(j) - temp = wa1(l) - do 220 i = 1, j - wa3(i) = wa3(i) + fjac(i,j)*temp - 220 continue - 230 continue - temp1 = enorm(n,wa3)/fnorm - temp2 = (dsqrt(par)*pnorm)/fnorm - prered = temp1**2 + temp2**2/p5 - dirder = -(temp1**2 + temp2**2) -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .ne. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .gt. p25) go to 240 - if (actred .ge. zero) temp = p5 - if (actred .lt. zero) - * temp = p5*dirder/(dirder + p5*actred) - if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 - delta = temp*dmin1(delta,pnorm/p1) - par = par/temp - go to 260 - 240 continue - if (par .ne. zero .and. ratio .lt. p75) go to 250 - delta = pnorm/p5 - par = p5*par - 250 continue - 260 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 290 -c -c successful iteration. update x, fvec, and their norms. -c - do 270 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - 270 continue - do 280 i = 1, m - fvec(i) = wa4(i) - 280 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 290 continue -c -c tests for convergence. -c - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one) info = 1 - if (delta .le. xtol*xnorm) info = 2 - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 5 - if (dabs(actred) .le. epsmch .and. prered .le. epsmch - * .and. p5*ratio .le. one) info = 6 - if (delta .le. epsmch*xnorm) info = 7 - if (gnorm .le. epsmch) info = 8 - if (info .ne. 0) go to 300 -c -c end of the inner loop. repeat if iteration unsuccessful. -c - if (ratio .lt. p0001) go to 200 -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(m,n,x,fvec,fjac,ldfjac,iflag) - return -c -c last card of subroutine lmder. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.h deleted file mode 100644 index 6b5936a301c..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder.h +++ /dev/null @@ -1,35 +0,0 @@ -/*: Minimizes the sum of the squares of m nonlin functions in n variables */ -extern int v3p_netlib_lmder_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - v3p_netlib_integer*, - void*), - v3p_netlib_integer *m, - v3p_netlib_integer *n, - v3p_netlib_doublereal *x, - v3p_netlib_doublereal *fvec, - v3p_netlib_doublereal *fjac, - v3p_netlib_integer *ldfjac, - v3p_netlib_doublereal *ftol, - v3p_netlib_doublereal *xtol, - v3p_netlib_doublereal *gtol, - v3p_netlib_integer *maxfev, - v3p_netlib_doublereal *diag, - v3p_netlib_integer *mode, - v3p_netlib_doublereal *factor, - v3p_netlib_integer *nprint, - v3p_netlib_integer *info, - v3p_netlib_integer *nfev, - v3p_netlib_integer *njev, - v3p_netlib_integer *ipvt, - v3p_netlib_doublereal *qtf, - v3p_netlib_doublereal *wa1, - v3p_netlib_doublereal *wa2, - v3p_netlib_doublereal *wa3, - v3p_netlib_doublereal *wa4, - void* userdata - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.c deleted file mode 100644 index cf29acd06b2..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.c +++ /dev/null @@ -1,247 +0,0 @@ -/* minpack/lmder1.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/*< >*/ -/* Subroutine */ int lmder1_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - v3p_netlib_integer*, - void*), - integer *m, integer *n, doublereal *x, - doublereal *fvec, doublereal *fjac, integer *ldfjac, doublereal *tol, - integer *info, integer *ipvt, doublereal *wa, integer *lwa, - void* userdata) -{ - /* Initialized data */ - - static doublereal factor = 100.; /* constant */ - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer fjac_dim1, fjac_offset; - - /* Local variables */ - integer mode, nfev, njev; - doublereal ftol, gtol, xtol; - extern /* Subroutine */ int lmder_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - v3p_netlib_integer*, - void*), - integer *, integer *, doublereal - *, doublereal *, doublereal *, integer *, doublereal *, - doublereal *, doublereal *, integer *, doublereal *, integer *, - doublereal *, integer *, integer *, integer *, integer *, integer - *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *, void*); - integer maxfev, nprint; - -/*< integer m,n,ldfjac,info,lwa >*/ -/*< integer ipvt(n) >*/ -/*< double precision tol >*/ -/*< double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) >*/ -/*< external fcn >*/ -/* ********** */ - -/* subroutine lmder1 */ - -/* the purpose of lmder1 is to minimize the sum of the squares of */ -/* m nonlinear functions in n variables by a modification of the */ -/* levenberg-marquardt algorithm. this is done by using the more */ -/* general least-squares solver lmder. the user must provide a */ -/* subroutine which calculates the functions and the jacobian. */ - -/* the subroutine statement is */ - -/* subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, */ -/* ipvt,wa,lwa) */ - -/* where */ - -/* fcn is the name of the user-supplied subroutine which */ -/* calculates the functions and the jacobian. fcn must */ -/* be declared in an external statement in the user */ -/* calling program, and should be written as follows. */ - -/* subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) */ -/* integer m,n,ldfjac,iflag */ -/* double precision x(n),fvec(m),fjac(ldfjac,n) */ -/* ---------- */ -/* if iflag = 1 calculate the functions at x and */ -/* return this vector in fvec. do not alter fjac. */ -/* if iflag = 2 calculate the jacobian at x and */ -/* return this matrix in fjac. do not alter fvec. */ -/* ---------- */ -/* return */ -/* end */ - -/* the value of iflag should not be changed by fcn unless */ -/* the user wants to terminate execution of lmder1. */ -/* in this case set iflag to a negative integer. */ - -/* m is a positive integer input variable set to the number */ -/* of functions. */ - -/* n is a positive integer input variable set to the number */ -/* of variables. n must not exceed m. */ - -/* x is an array of length n. on input x must contain */ -/* an initial estimate of the solution vector. on output x */ -/* contains the final estimate of the solution vector. */ - -/* fvec is an output array of length m which contains */ -/* the functions evaluated at the output x. */ - -/* fjac is an output m by n array. the upper n by n submatrix */ -/* of fjac contains an upper triangular matrix r with */ -/* diagonal elements of nonincreasing magnitude such that */ - -/* t t t */ -/* p *(jac *jac)*p = r *r, */ - -/* where p is a permutation matrix and jac is the final */ -/* calculated jacobian. column j of p is column ipvt(j) */ -/* (see below) of the identity matrix. the lower trapezoidal */ -/* part of fjac contains information generated during */ -/* the computation of r. */ - -/* ldfjac is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array fjac. */ - -/* tol is a nonnegative input variable. termination occurs */ -/* when the algorithm estimates either that the relative */ -/* error in the sum of squares is at most tol or that */ -/* the relative error between x and the solution is at */ -/* most tol. */ - -/* info is an integer output variable. if the user has */ -/* terminated execution, info is set to the (negative) */ -/* value of iflag. see description of fcn. otherwise, */ -/* info is set as follows. */ - -/* info = 0 improper input parameters. */ - -/* info = 1 algorithm estimates that the relative error */ -/* in the sum of squares is at most tol. */ - -/* info = 2 algorithm estimates that the relative error */ -/* between x and the solution is at most tol. */ - -/* info = 3 conditions for info = 1 and info = 2 both hold. */ - -/* info = 4 fvec is orthogonal to the columns of the */ -/* jacobian to machine precision. */ - -/* info = 5 number of calls to fcn with iflag = 1 has */ -/* reached 100*(n+1). */ - -/* info = 6 tol is too small. no further reduction in */ -/* the sum of squares is possible. */ - -/* info = 7 tol is too small. no further improvement in */ -/* the approximate solution x is possible. */ - -/* ipvt is an integer output array of length n. ipvt */ -/* defines a permutation matrix p such that jac*p = q*r, */ -/* where jac is the final calculated jacobian, q is */ -/* orthogonal (not stored), and r is upper triangular */ -/* with diagonal elements of nonincreasing magnitude. */ -/* column j of p is column ipvt(j) of the identity matrix. */ - -/* wa is a work array of length lwa. */ - -/* lwa is a positive integer input variable not less than 5*n+m. */ - -/* subprograms called */ - -/* user-supplied ...... fcn */ - -/* minpack-supplied ... lmder */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer maxfev,mode,nfev,njev,nprint >*/ -/*< double precision factor,ftol,gtol,xtol,zero >*/ -/*< data factor,zero /1.0d2,0.0d0/ >*/ - /* Parameter adjustments */ - --fvec; - --ipvt; - --x; - fjac_dim1 = *ldfjac; - fjac_offset = 1 + fjac_dim1; - fjac -= fjac_offset; - --wa; - - /* Function Body */ -/*< info = 0 >*/ - *info = 0; - -/* check the input parameters for errors. */ - -/*< >*/ - if (*n <= 0 || *m < *n || *ldfjac < *m || *tol < zero || *lwa < *n * 5 + * - m) { - goto L10; - } - -/* call lmder. */ - -/*< maxfev = 100*(n + 1) >*/ - maxfev = (*n + 1) * 100; -/*< ftol = tol >*/ - ftol = *tol; -/*< xtol = tol >*/ - xtol = *tol; -/*< gtol = zero >*/ - gtol = zero; -/*< mode = 1 >*/ - mode = 1; -/*< nprint = 0 >*/ - nprint = 0; -/*< >*/ - lmder_(fcn, m, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, & - ftol, &xtol, >ol, &maxfev, &wa[1], &mode, &factor, &nprint, - info, &nfev, &njev, &ipvt[1], &wa[*n + 1], &wa[(*n << 1) + 1], & - wa[*n * 3 + 1], &wa[(*n << 2) + 1], &wa[*n * 5 + 1], - userdata); -/*< if (info .eq. 8) info = 4 >*/ - if (*info == 8) { - *info = 4; - } -/*< 10 continue >*/ -L10: -/*< return >*/ - return 0; - -/* last card of subroutine lmder1. */ - -/*< end >*/ -} /* lmder1_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.f deleted file mode 100644 index d691940fd7b..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.f +++ /dev/null @@ -1,156 +0,0 @@ - subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info,ipvt,wa, - * lwa) - integer m,n,ldfjac,info,lwa - integer ipvt(n) - double precision tol - double precision x(n),fvec(m),fjac(ldfjac,n),wa(lwa) - external fcn -c ********** -c -c subroutine lmder1 -c -c the purpose of lmder1 is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of the -c levenberg-marquardt algorithm. this is done by using the more -c general least-squares solver lmder. the user must provide a -c subroutine which calculates the functions and the jacobian. -c -c the subroutine statement is -c -c subroutine lmder1(fcn,m,n,x,fvec,fjac,ldfjac,tol,info, -c ipvt,wa,lwa) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions and the jacobian. fcn must -c be declared in an external statement in the user -c calling program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,fjac,ldfjac,iflag) -c integer m,n,ldfjac,iflag -c double precision x(n),fvec(m),fjac(ldfjac,n) -c ---------- -c if iflag = 1 calculate the functions at x and -c return this vector in fvec. do not alter fjac. -c if iflag = 2 calculate the jacobian at x and -c return this matrix in fjac. do not alter fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmder1. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c fjac is an output m by n array. the upper n by n submatrix -c of fjac contains an upper triangular matrix r with -c diagonal elements of nonincreasing magnitude such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower trapezoidal -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c tol is a nonnegative input variable. termination occurs -c when the algorithm estimates either that the relative -c error in the sum of squares is at most tol or that -c the relative error between x and the solution is at -c most tol. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 algorithm estimates that the relative error -c in the sum of squares is at most tol. -c -c info = 2 algorithm estimates that the relative error -c between x and the solution is at most tol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 fvec is orthogonal to the columns of the -c jacobian to machine precision. -c -c info = 5 number of calls to fcn with iflag = 1 has -c reached 100*(n+1). -c -c info = 6 tol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 tol is too small. no further improvement in -c the approximate solution x is possible. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular -c with diagonal elements of nonincreasing magnitude. -c column j of p is column ipvt(j) of the identity matrix. -c -c wa is a work array of length lwa. -c -c lwa is a positive integer input variable not less than 5*n+m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... lmder -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer maxfev,mode,nfev,njev,nprint - double precision factor,ftol,gtol,xtol,zero - data factor,zero /1.0d2,0.0d0/ - info = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m .or. tol .lt. zero - * .or. lwa .lt. 5*n + m) go to 10 -c -c call lmder. -c - maxfev = 100*(n + 1) - ftol = tol - xtol = tol - gtol = zero - mode = 1 - nprint = 0 - call lmder(fcn,m,n,x,fvec,fjac,ldfjac,ftol,xtol,gtol,maxfev, - * wa(1),mode,factor,nprint,info,nfev,njev,ipvt,wa(n+1), - * wa(2*n+1),wa(3*n+1),wa(4*n+1),wa(5*n+1)) - if (info .eq. 8) info = 4 - 10 continue - return -c -c last card of subroutine lmder1. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.h deleted file mode 100644 index aebfb9b98c4..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmder1.h +++ /dev/null @@ -1,23 +0,0 @@ -/*: Minimizes the sum of the squares of m nonlin functions in n variables */ -extern int v3p_netlib_lmder1_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - v3p_netlib_integer*, - void*), - v3p_netlib_integer *m, - v3p_netlib_integer *n, - v3p_netlib_doublereal *x, - v3p_netlib_doublereal *fvec, - v3p_netlib_doublereal *fjac, - v3p_netlib_integer *ldfjac, - v3p_netlib_doublereal *tol, - v3p_netlib_integer *info, - v3p_netlib_integer *ipvt, - v3p_netlib_doublereal *wa, - v3p_netlib_integer *lwa, - void* userdata - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.c deleted file mode 100644 index 55fc9bf51ff..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.c +++ /dev/null @@ -1,826 +0,0 @@ -/* minpack/lmdif.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/* Table of constant values */ - -static integer c__1 = 1; -static logical c_true = TRUE_; - -/*< >*/ -/* Subroutine */ int lmdif_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - void*), - integer *m, integer *n, doublereal *x, - doublereal *fvec, doublereal *ftol, doublereal *xtol, doublereal * - gtol, integer *maxfev, doublereal *epsfcn, doublereal *diag, integer * - mode, doublereal *factor, integer *nprint, integer *info, integer * - nfev, doublereal *fjac, integer *ldfjac, integer *ipvt, doublereal * - qtf, doublereal *wa1, doublereal *wa2, doublereal *wa3, doublereal * - wa4, void* userdata) -{ - /* Initialized data */ - - static doublereal one = 1.; /* constant */ - static doublereal p1 = .1; /* constant */ - static doublereal p5 = .5; /* constant */ - static doublereal p25 = .25; /* constant */ - static doublereal p75 = .75; /* constant */ - static doublereal p0001 = 1e-4; /* constant */ - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer fjac_dim1, fjac_offset, i__1, i__2; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, l; - doublereal par, sum; - integer iter; - doublereal temp=0, temp1, temp2; - integer iflag; - doublereal delta; - extern /* Subroutine */ int qrfac_(integer *, integer *, doublereal *, - integer *, logical *, integer *, integer *, doublereal *, - doublereal *, doublereal *), lmpar_(integer *, doublereal *, - integer *, integer *, doublereal *, doublereal *, doublereal *, - doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - doublereal ratio; - extern doublereal enorm_(integer *, doublereal *); - doublereal fnorm, gnorm; - extern /* Subroutine */ int fdjac2_( - void (*)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - void*), - integer *, integer *, - doublereal *, doublereal *, doublereal *, integer *, integer *, - doublereal *, doublereal *, void*); - doublereal pnorm, xnorm=0, fnorm1, actred, dirder, epsmch, prered; - extern doublereal dpmpar_(integer *); - -/*< integer m,n,maxfev,mode,nprint,info,nfev,ldfjac >*/ -/*< integer ipvt(n) >*/ -/*< double precision ftol,xtol,gtol,epsfcn,factor >*/ -/*< >*/ -/*< external fcn >*/ -/* ********** */ - -/* subroutine lmdif */ - -/* the purpose of lmdif is to minimize the sum of the squares of */ -/* m nonlinear functions in n variables by a modification of */ -/* the levenberg-marquardt algorithm. the user must provide a */ -/* subroutine which calculates the functions. the jacobian is */ -/* then calculated by a forward-difference approximation. */ - -/* the subroutine statement is */ - -/* subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, */ -/* diag,mode,factor,nprint,info,nfev,fjac, */ -/* ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) */ - -/* where */ - -/* fcn is the name of the user-supplied subroutine which */ -/* calculates the functions. fcn must be declared */ -/* in an external statement in the user calling */ -/* program, and should be written as follows. */ - -/* subroutine fcn(m,n,x,fvec,iflag) */ -/* integer m,n,iflag */ -/* double precision x(n),fvec(m) */ -/* ---------- */ -/* calculate the functions at x and */ -/* return this vector in fvec. */ -/* ---------- */ -/* return */ -/* end */ - -/* the value of iflag should not be changed by fcn unless */ -/* the user wants to terminate execution of lmdif. */ -/* in this case set iflag to a negative integer. */ - -/* m is a positive integer input variable set to the number */ -/* of functions. */ - -/* n is a positive integer input variable set to the number */ -/* of variables. n must not exceed m. */ - -/* x is an array of length n. on input x must contain */ -/* an initial estimate of the solution vector. on output x */ -/* contains the final estimate of the solution vector. */ - -/* fvec is an output array of length m which contains */ -/* the functions evaluated at the output x. */ - -/* ftol is a nonnegative input variable. termination */ -/* occurs when both the actual and predicted relative */ -/* reductions in the sum of squares are at most ftol. */ -/* therefore, ftol measures the relative error desired */ -/* in the sum of squares. */ - -/* xtol is a nonnegative input variable. termination */ -/* occurs when the relative error between two consecutive */ -/* iterates is at most xtol. therefore, xtol measures the */ -/* relative error desired in the approximate solution. */ - -/* gtol is a nonnegative input variable. termination */ -/* occurs when the cosine of the angle between fvec and */ -/* any column of the jacobian is at most gtol in absolute */ -/* value. therefore, gtol measures the orthogonality */ -/* desired between the function vector and the columns */ -/* of the jacobian. */ - -/* maxfev is a positive integer input variable. termination */ -/* occurs when the number of calls to fcn is at least */ -/* maxfev by the end of an iteration. */ - -/* epsfcn is an input variable used in determining a suitable */ -/* step length for the forward-difference approximation. this */ -/* approximation assumes that the relative errors in the */ -/* functions are of the order of epsfcn. if epsfcn is less */ -/* than the machine precision, it is assumed that the relative */ -/* errors in the functions are of the order of the machine */ -/* precision. */ - -/* diag is an array of length n. if mode = 1 (see */ -/* below), diag is internally set. if mode = 2, diag */ -/* must contain positive entries that serve as */ -/* multiplicative scale factors for the variables. */ - -/* mode is an integer input variable. if mode = 1, the */ -/* variables will be scaled internally. if mode = 2, */ -/* the scaling is specified by the input diag. other */ -/* values of mode are equivalent to mode = 1. */ - -/* factor is a positive input variable used in determining the */ -/* initial step bound. this bound is set to the product of */ -/* factor and the euclidean norm of diag*x if nonzero, or else */ -/* to factor itself. in most cases factor should lie in the */ -/* interval (.1,100.). 100. is a generally recommended value. */ - -/* nprint is an integer input variable that enables controlled */ -/* printing of iterates if it is positive. in this case, */ -/* fcn is called with iflag = 0 at the beginning of the first */ -/* iteration and every nprint iterations thereafter and */ -/* immediately prior to return, with x and fvec available */ -/* for printing. if nprint is not positive, no special calls */ -/* of fcn with iflag = 0 are made. */ - -/* info is an integer output variable. if the user has */ -/* terminated execution, info is set to the (negative) */ -/* value of iflag. see description of fcn. otherwise, */ -/* info is set as follows. */ - -/* info = 0 improper input parameters. */ - -/* info = 1 both actual and predicted relative reductions */ -/* in the sum of squares are at most ftol. */ - -/* info = 2 relative error between two consecutive iterates */ -/* is at most xtol. */ - -/* info = 3 conditions for info = 1 and info = 2 both hold. */ - -/* info = 4 the cosine of the angle between fvec and any */ -/* column of the jacobian is at most gtol in */ -/* absolute value. */ - -/* info = 5 number of calls to fcn has reached or */ -/* exceeded maxfev. */ - -/* info = 6 ftol is too small. no further reduction in */ -/* the sum of squares is possible. */ - -/* info = 7 xtol is too small. no further improvement in */ -/* the approximate solution x is possible. */ - -/* info = 8 gtol is too small. fvec is orthogonal to the */ -/* columns of the jacobian to machine precision. */ - -/* nfev is an integer output variable set to the number of */ -/* calls to fcn. */ - -/* fjac is an output m by n array. the upper n by n submatrix */ -/* of fjac contains an upper triangular matrix r with */ -/* diagonal elements of nonincreasing magnitude such that */ - -/* t t t */ -/* p *(jac *jac)*p = r *r, */ - -/* where p is a permutation matrix and jac is the final */ -/* calculated jacobian. column j of p is column ipvt(j) */ -/* (see below) of the identity matrix. the lower trapezoidal */ -/* part of fjac contains information generated during */ -/* the computation of r. */ - -/* ldfjac is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array fjac. */ - -/* ipvt is an integer output array of length n. ipvt */ -/* defines a permutation matrix p such that jac*p = q*r, */ -/* where jac is the final calculated jacobian, q is */ -/* orthogonal (not stored), and r is upper triangular */ -/* with diagonal elements of nonincreasing magnitude. */ -/* column j of p is column ipvt(j) of the identity matrix. */ - -/* qtf is an output array of length n which contains */ -/* the first n elements of the vector (q transpose)*fvec. */ - -/* wa1, wa2, and wa3 are work arrays of length n. */ - -/* wa4 is a work array of length m. */ - -/* subprograms called */ - -/* user-supplied ...... fcn */ - -/* minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac */ - -/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i,iflag,iter,j,l >*/ -/*< >*/ -/*< double precision dpmpar,enorm >*/ -/*< >*/ - /* Parameter adjustments */ - --wa4; - --fvec; - --wa3; - --wa2; - --wa1; - --qtf; - --ipvt; - --diag; - --x; - fjac_dim1 = *ldfjac; - fjac_offset = 1 + fjac_dim1; - fjac -= fjac_offset; - - /* Function Body */ - -/* epsmch is the machine precision. */ - -/*< epsmch = dpmpar(1) >*/ - epsmch = dpmpar_(&c__1); - -/*< info = 0 >*/ - *info = 0; -/*< iflag = 0 >*/ - iflag = 0; -/*< nfev = 0 >*/ - *nfev = 0; - -/* check the input parameters for errors. */ - -/*< >*/ - if (*n <= 0 || *m < *n || *ldfjac < *m || *ftol < zero || *xtol < zero || - *gtol < zero || *maxfev <= 0 || *factor <= zero) { - goto L300; - } -/*< if (mode .ne. 2) go to 20 >*/ - if (*mode != 2) { - goto L20; - } -/*< do 10 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< if (diag(j) .le. zero) go to 300 >*/ - if (diag[j] <= zero) { - goto L300; - } -/*< 10 continue >*/ -/* L10: */ - } -/*< 20 continue >*/ -L20: - -/* evaluate the function at the starting point */ -/* and calculate its norm. */ - -/*< iflag = 1 >*/ - iflag = 1; -/*< call fcn(m,n,x,fvec,iflag) >*/ - (*fcn)(m, n, &x[1], &fvec[1], &iflag, userdata); -/*< nfev = 1 >*/ - *nfev = 1; -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } -/*< fnorm = enorm(m,fvec) >*/ - fnorm = enorm_(m, &fvec[1]); - -/* initialize levenberg-marquardt parameter and iteration counter. */ - -/*< par = zero >*/ - par = zero; -/*< iter = 1 >*/ - iter = 1; - -/* beginning of the outer loop. */ - -/*< 30 continue >*/ -L30: - -/* calculate the jacobian matrix. */ - -/*< iflag = 2 >*/ - iflag = 2; -/*< call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) >*/ - fdjac2_(fcn, m, n, &x[1], &fvec[1], &fjac[fjac_offset], ldfjac, & - iflag, epsfcn, &wa4[1], userdata); -/*< nfev = nfev + n >*/ - *nfev += *n; -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } - -/* if requested, call fcn to enable printing of iterates. */ - -/*< if (nprint .le. 0) go to 40 >*/ - if (*nprint <= 0) { - goto L40; - } -/*< iflag = 0 >*/ - iflag = 0; -/*< if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) >*/ - if ((iter - 1) % *nprint == 0) { - (*fcn)(m, n, &x[1], &fvec[1], &iflag, userdata); - } -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } -/*< 40 continue >*/ -L40: - -/* compute the qr factorization of the jacobian. */ - -/*< call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) >*/ - qrfac_(m, n, &fjac[fjac_offset], ldfjac, &c_true, &ipvt[1], n, &wa1[1], & - wa2[1], &wa3[1]); - -/* on the first iteration and if mode is 1, scale according */ -/* to the norms of the columns of the initial jacobian. */ - -/*< if (iter .ne. 1) go to 80 >*/ - if (iter != 1) { - goto L80; - } -/*< if (mode .eq. 2) go to 60 >*/ - if (*mode == 2) { - goto L60; - } -/*< do 50 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< diag(j) = wa2(j) >*/ - diag[j] = wa2[j]; -/*< if (wa2(j) .eq. zero) diag(j) = one >*/ - if (wa2[j] == zero) { - diag[j] = one; - } -/*< 50 continue >*/ -/* L50: */ - } -/*< 60 continue >*/ -L60: - -/* on the first iteration, calculate the norm of the scaled x */ -/* and initialize the step bound delta. */ - -/*< do 70 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa3(j) = diag(j)*x(j) >*/ - wa3[j] = diag[j] * x[j]; -/*< 70 continue >*/ -/* L70: */ - } -/*< xnorm = enorm(n,wa3) >*/ - xnorm = enorm_(n, &wa3[1]); -/*< delta = factor*xnorm >*/ - delta = *factor * xnorm; -/*< if (delta .eq. zero) delta = factor >*/ - if (delta == zero) { - delta = *factor; - } -/*< 80 continue >*/ -L80: - -/* form (q transpose)*fvec and store the first n components in */ -/* qtf. */ - -/*< do 90 i = 1, m >*/ - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/*< wa4(i) = fvec(i) >*/ - wa4[i__] = fvec[i__]; -/*< 90 continue >*/ -/* L90: */ - } -/*< do 130 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< if (fjac(j,j) .eq. zero) go to 120 >*/ - if (fjac[j + j * fjac_dim1] == zero) { - goto L120; - } -/*< sum = zero >*/ - sum = zero; -/*< do 100 i = j, m >*/ - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/*< sum = sum + fjac(i,j)*wa4(i) >*/ - sum += fjac[i__ + j * fjac_dim1] * wa4[i__]; -/*< 100 continue >*/ -/* L100: */ - } -/*< temp = -sum/fjac(j,j) >*/ - temp = -sum / fjac[j + j * fjac_dim1]; -/*< do 110 i = j, m >*/ - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/*< wa4(i) = wa4(i) + fjac(i,j)*temp >*/ - wa4[i__] += fjac[i__ + j * fjac_dim1] * temp; -/*< 110 continue >*/ -/* L110: */ - } -/*< 120 continue >*/ -L120: -/*< fjac(j,j) = wa1(j) >*/ - fjac[j + j * fjac_dim1] = wa1[j]; -/*< qtf(j) = wa4(j) >*/ - qtf[j] = wa4[j]; -/*< 130 continue >*/ -/* L130: */ - } - -/* compute the norm of the scaled gradient. */ - -/*< gnorm = zero >*/ - gnorm = zero; -/*< if (fnorm .eq. zero) go to 170 >*/ - if (fnorm == zero) { - goto L170; - } -/*< do 160 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< if (wa2(l) .eq. zero) go to 150 >*/ - if (wa2[l] == zero) { - goto L150; - } -/*< sum = zero >*/ - sum = zero; -/*< do 140 i = 1, j >*/ - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< sum = sum + fjac(i,j)*(qtf(i)/fnorm) >*/ - sum += fjac[i__ + j * fjac_dim1] * (qtf[i__] / fnorm); -/*< 140 continue >*/ -/* L140: */ - } -/*< gnorm = dmax1(gnorm,dabs(sum/wa2(l))) >*/ -/* Computing MAX */ - d__2 = gnorm, d__3 = (d__1 = sum / wa2[l], abs(d__1)); - gnorm = max(d__2,d__3); -/*< 150 continue >*/ -L150: -/*< 160 continue >*/ -/* L160: */ - ; - } -/*< 170 continue >*/ -L170: - -/* test for convergence of the gradient norm. */ - -/*< if (gnorm .le. gtol) info = 4 >*/ - if (gnorm <= *gtol) { - *info = 4; - } -/*< if (info .ne. 0) go to 300 >*/ - if (*info != 0) { - goto L300; - } - -/* rescale if necessary. */ - -/*< if (mode .eq. 2) go to 190 >*/ - if (*mode == 2) { - goto L190; - } -/*< do 180 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< diag(j) = dmax1(diag(j),wa2(j)) >*/ -/* Computing MAX */ - d__1 = diag[j], d__2 = wa2[j]; - diag[j] = max(d__1,d__2); -/*< 180 continue >*/ -/* L180: */ - } -/*< 190 continue >*/ -L190: - -/* beginning of the inner loop. */ - -/*< 200 continue >*/ -L200: - -/* determine the levenberg-marquardt parameter. */ - -/*< >*/ - lmpar_(n, &fjac[fjac_offset], ldfjac, &ipvt[1], &diag[1], &qtf[1], &delta, - &par, &wa1[1], &wa2[1], &wa3[1], &wa4[1]); - -/* store the direction p and x + p. calculate the norm of p. */ - -/*< do 210 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa1(j) = -wa1(j) >*/ - wa1[j] = -wa1[j]; -/*< wa2(j) = x(j) + wa1(j) >*/ - wa2[j] = x[j] + wa1[j]; -/*< wa3(j) = diag(j)*wa1(j) >*/ - wa3[j] = diag[j] * wa1[j]; -/*< 210 continue >*/ -/* L210: */ - } -/*< pnorm = enorm(n,wa3) >*/ - pnorm = enorm_(n, &wa3[1]); - -/* on the first iteration, adjust the initial step bound. */ - -/*< if (iter .eq. 1) delta = dmin1(delta,pnorm) >*/ - if (iter == 1) { - delta = min(delta,pnorm); - } - -/* evaluate the function at x + p and calculate its norm. */ - -/*< iflag = 1 >*/ - iflag = 1; -/*< call fcn(m,n,wa2,wa4,iflag) >*/ - (*fcn)(m, n, &wa2[1], &wa4[1], &iflag, userdata); -/*< nfev = nfev + 1 >*/ - ++(*nfev); -/*< if (iflag .lt. 0) go to 300 >*/ - if (iflag < 0) { - goto L300; - } -/*< fnorm1 = enorm(m,wa4) >*/ - fnorm1 = enorm_(m, &wa4[1]); - -/* compute the scaled actual reduction. */ - -/*< actred = -one >*/ - actred = -one; -/*< if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 >*/ - if (p1 * fnorm1 < fnorm) { -/* Computing 2nd power */ - d__1 = fnorm1 / fnorm; - actred = one - d__1 * d__1; - } - -/* compute the scaled predicted reduction and */ -/* the scaled directional derivative. */ - -/*< do 230 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa3(j) = zero >*/ - wa3[j] = zero; -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< temp = wa1(l) >*/ - temp = wa1[l]; -/*< do 220 i = 1, j >*/ - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< wa3(i) = wa3(i) + fjac(i,j)*temp >*/ - wa3[i__] += fjac[i__ + j * fjac_dim1] * temp; -/*< 220 continue >*/ -/* L220: */ - } -/*< 230 continue >*/ -/* L230: */ - } -/*< temp1 = enorm(n,wa3)/fnorm >*/ - temp1 = enorm_(n, &wa3[1]) / fnorm; -/*< temp2 = (dsqrt(par)*pnorm)/fnorm >*/ - temp2 = sqrt(par) * pnorm / fnorm; -/*< prered = temp1**2 + temp2**2/p5 >*/ -/* Computing 2nd power */ - d__1 = temp1; -/* Computing 2nd power */ - d__2 = temp2; - prered = d__1 * d__1 + d__2 * d__2 / p5; -/*< dirder = -(temp1**2 + temp2**2) >*/ -/* Computing 2nd power */ - d__1 = temp1; -/* Computing 2nd power */ - d__2 = temp2; - dirder = -(d__1 * d__1 + d__2 * d__2); - -/* compute the ratio of the actual to the predicted */ -/* reduction. */ - -/*< ratio = zero >*/ - ratio = zero; -/*< if (prered .ne. zero) ratio = actred/prered >*/ - if (prered != zero) { - ratio = actred / prered; - } - -/* update the step bound. */ - -/*< if (ratio .gt. p25) go to 240 >*/ - if (ratio > p25) { - goto L240; - } -/*< if (actred .ge. zero) temp = p5 >*/ - if (actred >= zero) { - temp = p5; - } -/*< >*/ - if (actred < zero) { - temp = p5 * dirder / (dirder + p5 * actred); - } -/*< if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 >*/ - if (p1 * fnorm1 >= fnorm || temp < p1) { - temp = p1; - } -/*< delta = temp*dmin1(delta,pnorm/p1) >*/ -/* Computing MIN */ - d__1 = delta, d__2 = pnorm / p1; - delta = temp * min(d__1,d__2); -/*< par = par/temp >*/ - par /= temp; -/*< go to 260 >*/ - goto L260; -/*< 240 continue >*/ -L240: -/*< if (par .ne. zero .and. ratio .lt. p75) go to 250 >*/ - if (par != zero && ratio < p75) { - goto L250; - } -/*< delta = pnorm/p5 >*/ - delta = pnorm / p5; -/*< par = p5*par >*/ - par = p5 * par; -/*< 250 continue >*/ -L250: -/*< 260 continue >*/ -L260: - -/* test for successful iteration. */ - -/*< if (ratio .lt. p0001) go to 290 >*/ - if (ratio < p0001) { - goto L290; - } - -/* successful iteration. update x, fvec, and their norms. */ - -/*< do 270 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< x(j) = wa2(j) >*/ - x[j] = wa2[j]; -/*< wa2(j) = diag(j)*x(j) >*/ - wa2[j] = diag[j] * x[j]; -/*< 270 continue >*/ -/* L270: */ - } -/*< do 280 i = 1, m >*/ - i__1 = *m; - for (i__ = 1; i__ <= i__1; ++i__) { -/*< fvec(i) = wa4(i) >*/ - fvec[i__] = wa4[i__]; -/*< 280 continue >*/ -/* L280: */ - } -/*< xnorm = enorm(n,wa2) >*/ - xnorm = enorm_(n, &wa2[1]); -/*< fnorm = fnorm1 >*/ - fnorm = fnorm1; -/*< iter = iter + 1 >*/ - ++iter; -/*< 290 continue >*/ -L290: - -/* tests for convergence. */ - -/*< >*/ - if (abs(actred) <= *ftol && prered <= *ftol && p5 * ratio <= one) { - *info = 1; - } -/*< if (delta .le. xtol*xnorm) info = 2 >*/ - if (delta <= *xtol * xnorm) { - *info = 2; - } -/*< >*/ - if (abs(actred) <= *ftol && prered <= *ftol && p5 * ratio <= one && *info - == 2) { - *info = 3; - } -/*< if (info .ne. 0) go to 300 >*/ - if (*info != 0) { - goto L300; - } - -/* tests for termination and stringent tolerances. */ - -/*< if (nfev .ge. maxfev) info = 5 >*/ - if (*nfev >= *maxfev) { - *info = 5; - } -/*< >*/ - if (abs(actred) <= epsmch && prered <= epsmch && p5 * ratio <= one) { - *info = 6; - } -/*< if (delta .le. epsmch*xnorm) info = 7 >*/ - if (delta <= epsmch * xnorm) { - *info = 7; - } -/*< if (gnorm .le. epsmch) info = 8 >*/ - if (gnorm <= epsmch) { - *info = 8; - } -/*< if (info .ne. 0) go to 300 >*/ - if (*info != 0) { - goto L300; - } - -/* end of the inner loop. repeat if iteration unsuccessful. */ - -/*< if (ratio .lt. p0001) go to 200 >*/ - if (ratio < p0001) { - goto L200; - } - -/* end of the outer loop. */ - -/*< go to 30 >*/ - goto L30; -/*< 300 continue >*/ -L300: - -/* termination, either normal or user imposed. */ - -/*< if (iflag .lt. 0) info = iflag >*/ - if (iflag < 0) { - *info = iflag; - } -/*< iflag = 0 >*/ - iflag = 0; -/*< if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) >*/ - if (*nprint > 0) { - (*fcn)(m, n, &x[1], &fvec[1], &iflag, userdata); - } -/*< return >*/ - return 0; - -/* last card of subroutine lmdif. */ - -/*< end >*/ -} /* lmdif_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.f deleted file mode 100644 index dd3d4ee2565..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.f +++ /dev/null @@ -1,454 +0,0 @@ - subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, - * diag,mode,factor,nprint,info,nfev,fjac,ldfjac, - * ipvt,qtf,wa1,wa2,wa3,wa4) - integer m,n,maxfev,mode,nprint,info,nfev,ldfjac - integer ipvt(n) - double precision ftol,xtol,gtol,epsfcn,factor - double precision x(n),fvec(m),diag(n),fjac(ldfjac,n),qtf(n), - * wa1(n),wa2(n),wa3(n),wa4(m) - external fcn -c ********** -c -c subroutine lmdif -c -c the purpose of lmdif is to minimize the sum of the squares of -c m nonlinear functions in n variables by a modification of -c the levenberg-marquardt algorithm. the user must provide a -c subroutine which calculates the functions. the jacobian is -c then calculated by a forward-difference approximation. -c -c the subroutine statement is -c -c subroutine lmdif(fcn,m,n,x,fvec,ftol,xtol,gtol,maxfev,epsfcn, -c diag,mode,factor,nprint,info,nfev,fjac, -c ldfjac,ipvt,qtf,wa1,wa2,wa3,wa4) -c -c where -c -c fcn is the name of the user-supplied subroutine which -c calculates the functions. fcn must be declared -c in an external statement in the user calling -c program, and should be written as follows. -c -c subroutine fcn(m,n,x,fvec,iflag) -c integer m,n,iflag -c double precision x(n),fvec(m) -c ---------- -c calculate the functions at x and -c return this vector in fvec. -c ---------- -c return -c end -c -c the value of iflag should not be changed by fcn unless -c the user wants to terminate execution of lmdif. -c in this case set iflag to a negative integer. -c -c m is a positive integer input variable set to the number -c of functions. -c -c n is a positive integer input variable set to the number -c of variables. n must not exceed m. -c -c x is an array of length n. on input x must contain -c an initial estimate of the solution vector. on output x -c contains the final estimate of the solution vector. -c -c fvec is an output array of length m which contains -c the functions evaluated at the output x. -c -c ftol is a nonnegative input variable. termination -c occurs when both the actual and predicted relative -c reductions in the sum of squares are at most ftol. -c therefore, ftol measures the relative error desired -c in the sum of squares. -c -c xtol is a nonnegative input variable. termination -c occurs when the relative error between two consecutive -c iterates is at most xtol. therefore, xtol measures the -c relative error desired in the approximate solution. -c -c gtol is a nonnegative input variable. termination -c occurs when the cosine of the angle between fvec and -c any column of the jacobian is at most gtol in absolute -c value. therefore, gtol measures the orthogonality -c desired between the function vector and the columns -c of the jacobian. -c -c maxfev is a positive integer input variable. termination -c occurs when the number of calls to fcn is at least -c maxfev by the end of an iteration. -c -c epsfcn is an input variable used in determining a suitable -c step length for the forward-difference approximation. this -c approximation assumes that the relative errors in the -c functions are of the order of epsfcn. if epsfcn is less -c than the machine precision, it is assumed that the relative -c errors in the functions are of the order of the machine -c precision. -c -c diag is an array of length n. if mode = 1 (see -c below), diag is internally set. if mode = 2, diag -c must contain positive entries that serve as -c multiplicative scale factors for the variables. -c -c mode is an integer input variable. if mode = 1, the -c variables will be scaled internally. if mode = 2, -c the scaling is specified by the input diag. other -c values of mode are equivalent to mode = 1. -c -c factor is a positive input variable used in determining the -c initial step bound. this bound is set to the product of -c factor and the euclidean norm of diag*x if nonzero, or else -c to factor itself. in most cases factor should lie in the -c interval (.1,100.). 100. is a generally recommended value. -c -c nprint is an integer input variable that enables controlled -c printing of iterates if it is positive. in this case, -c fcn is called with iflag = 0 at the beginning of the first -c iteration and every nprint iterations thereafter and -c immediately prior to return, with x and fvec available -c for printing. if nprint is not positive, no special calls -c of fcn with iflag = 0 are made. -c -c info is an integer output variable. if the user has -c terminated execution, info is set to the (negative) -c value of iflag. see description of fcn. otherwise, -c info is set as follows. -c -c info = 0 improper input parameters. -c -c info = 1 both actual and predicted relative reductions -c in the sum of squares are at most ftol. -c -c info = 2 relative error between two consecutive iterates -c is at most xtol. -c -c info = 3 conditions for info = 1 and info = 2 both hold. -c -c info = 4 the cosine of the angle between fvec and any -c column of the jacobian is at most gtol in -c absolute value. -c -c info = 5 number of calls to fcn has reached or -c exceeded maxfev. -c -c info = 6 ftol is too small. no further reduction in -c the sum of squares is possible. -c -c info = 7 xtol is too small. no further improvement in -c the approximate solution x is possible. -c -c info = 8 gtol is too small. fvec is orthogonal to the -c columns of the jacobian to machine precision. -c -c nfev is an integer output variable set to the number of -c calls to fcn. -c -c fjac is an output m by n array. the upper n by n submatrix -c of fjac contains an upper triangular matrix r with -c diagonal elements of nonincreasing magnitude such that -c -c t t t -c p *(jac *jac)*p = r *r, -c -c where p is a permutation matrix and jac is the final -c calculated jacobian. column j of p is column ipvt(j) -c (see below) of the identity matrix. the lower trapezoidal -c part of fjac contains information generated during -c the computation of r. -c -c ldfjac is a positive integer input variable not less than m -c which specifies the leading dimension of the array fjac. -c -c ipvt is an integer output array of length n. ipvt -c defines a permutation matrix p such that jac*p = q*r, -c where jac is the final calculated jacobian, q is -c orthogonal (not stored), and r is upper triangular -c with diagonal elements of nonincreasing magnitude. -c column j of p is column ipvt(j) of the identity matrix. -c -c qtf is an output array of length n which contains -c the first n elements of the vector (q transpose)*fvec. -c -c wa1, wa2, and wa3 are work arrays of length n. -c -c wa4 is a work array of length m. -c -c subprograms called -c -c user-supplied ...... fcn -c -c minpack-supplied ... dpmpar,enorm,fdjac2,lmpar,qrfac -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt,mod -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iflag,iter,j,l - double precision actred,delta,dirder,epsmch,fnorm,fnorm1,gnorm, - * one,par,pnorm,prered,p1,p5,p25,p75,p0001,ratio, - * sum,temp,temp1,temp2,xnorm,zero - double precision dpmpar,enorm - data one,p1,p5,p25,p75,p0001,zero - * /1.0d0,1.0d-1,5.0d-1,2.5d-1,7.5d-1,1.0d-4,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c - info = 0 - iflag = 0 - nfev = 0 -c -c check the input parameters for errors. -c - if (n .le. 0 .or. m .lt. n .or. ldfjac .lt. m - * .or. ftol .lt. zero .or. xtol .lt. zero .or. gtol .lt. zero - * .or. maxfev .le. 0 .or. factor .le. zero) go to 300 - if (mode .ne. 2) go to 20 - do 10 j = 1, n - if (diag(j) .le. zero) go to 300 - 10 continue - 20 continue -c -c evaluate the function at the starting point -c and calculate its norm. -c - iflag = 1 - call fcn(m,n,x,fvec,iflag) - nfev = 1 - if (iflag .lt. 0) go to 300 - fnorm = enorm(m,fvec) -c -c initialize levenberg-marquardt parameter and iteration counter. -c - par = zero - iter = 1 -c -c beginning of the outer loop. -c - 30 continue -c -c calculate the jacobian matrix. -c - iflag = 2 - call fdjac2(fcn,m,n,x,fvec,fjac,ldfjac,iflag,epsfcn,wa4) - nfev = nfev + n - if (iflag .lt. 0) go to 300 -c -c if requested, call fcn to enable printing of iterates. -c - if (nprint .le. 0) go to 40 - iflag = 0 - if (mod(iter-1,nprint) .eq. 0) call fcn(m,n,x,fvec,iflag) - if (iflag .lt. 0) go to 300 - 40 continue -c -c compute the qr factorization of the jacobian. -c - call qrfac(m,n,fjac,ldfjac,.true.,ipvt,n,wa1,wa2,wa3) -c -c on the first iteration and if mode is 1, scale according -c to the norms of the columns of the initial jacobian. -c - if (iter .ne. 1) go to 80 - if (mode .eq. 2) go to 60 - do 50 j = 1, n - diag(j) = wa2(j) - if (wa2(j) .eq. zero) diag(j) = one - 50 continue - 60 continue -c -c on the first iteration, calculate the norm of the scaled x -c and initialize the step bound delta. -c - do 70 j = 1, n - wa3(j) = diag(j)*x(j) - 70 continue - xnorm = enorm(n,wa3) - delta = factor*xnorm - if (delta .eq. zero) delta = factor - 80 continue -c -c form (q transpose)*fvec and store the first n components in -c qtf. -c - do 90 i = 1, m - wa4(i) = fvec(i) - 90 continue - do 130 j = 1, n - if (fjac(j,j) .eq. zero) go to 120 - sum = zero - do 100 i = j, m - sum = sum + fjac(i,j)*wa4(i) - 100 continue - temp = -sum/fjac(j,j) - do 110 i = j, m - wa4(i) = wa4(i) + fjac(i,j)*temp - 110 continue - 120 continue - fjac(j,j) = wa1(j) - qtf(j) = wa4(j) - 130 continue -c -c compute the norm of the scaled gradient. -c - gnorm = zero - if (fnorm .eq. zero) go to 170 - do 160 j = 1, n - l = ipvt(j) - if (wa2(l) .eq. zero) go to 150 - sum = zero - do 140 i = 1, j - sum = sum + fjac(i,j)*(qtf(i)/fnorm) - 140 continue - gnorm = dmax1(gnorm,dabs(sum/wa2(l))) - 150 continue - 160 continue - 170 continue -c -c test for convergence of the gradient norm. -c - if (gnorm .le. gtol) info = 4 - if (info .ne. 0) go to 300 -c -c rescale if necessary. -c - if (mode .eq. 2) go to 190 - do 180 j = 1, n - diag(j) = dmax1(diag(j),wa2(j)) - 180 continue - 190 continue -c -c beginning of the inner loop. -c - 200 continue -c -c determine the levenberg-marquardt parameter. -c - call lmpar(n,fjac,ldfjac,ipvt,diag,qtf,delta,par,wa1,wa2, - * wa3,wa4) -c -c store the direction p and x + p. calculate the norm of p. -c - do 210 j = 1, n - wa1(j) = -wa1(j) - wa2(j) = x(j) + wa1(j) - wa3(j) = diag(j)*wa1(j) - 210 continue - pnorm = enorm(n,wa3) -c -c on the first iteration, adjust the initial step bound. -c - if (iter .eq. 1) delta = dmin1(delta,pnorm) -c -c evaluate the function at x + p and calculate its norm. -c - iflag = 1 - call fcn(m,n,wa2,wa4,iflag) - nfev = nfev + 1 - if (iflag .lt. 0) go to 300 - fnorm1 = enorm(m,wa4) -c -c compute the scaled actual reduction. -c - actred = -one - if (p1*fnorm1 .lt. fnorm) actred = one - (fnorm1/fnorm)**2 -c -c compute the scaled predicted reduction and -c the scaled directional derivative. -c - do 230 j = 1, n - wa3(j) = zero - l = ipvt(j) - temp = wa1(l) - do 220 i = 1, j - wa3(i) = wa3(i) + fjac(i,j)*temp - 220 continue - 230 continue - temp1 = enorm(n,wa3)/fnorm - temp2 = (dsqrt(par)*pnorm)/fnorm - prered = temp1**2 + temp2**2/p5 - dirder = -(temp1**2 + temp2**2) -c -c compute the ratio of the actual to the predicted -c reduction. -c - ratio = zero - if (prered .ne. zero) ratio = actred/prered -c -c update the step bound. -c - if (ratio .gt. p25) go to 240 - if (actred .ge. zero) temp = p5 - if (actred .lt. zero) - * temp = p5*dirder/(dirder + p5*actred) - if (p1*fnorm1 .ge. fnorm .or. temp .lt. p1) temp = p1 - delta = temp*dmin1(delta,pnorm/p1) - par = par/temp - go to 260 - 240 continue - if (par .ne. zero .and. ratio .lt. p75) go to 250 - delta = pnorm/p5 - par = p5*par - 250 continue - 260 continue -c -c test for successful iteration. -c - if (ratio .lt. p0001) go to 290 -c -c successful iteration. update x, fvec, and their norms. -c - do 270 j = 1, n - x(j) = wa2(j) - wa2(j) = diag(j)*x(j) - 270 continue - do 280 i = 1, m - fvec(i) = wa4(i) - 280 continue - xnorm = enorm(n,wa2) - fnorm = fnorm1 - iter = iter + 1 - 290 continue -c -c tests for convergence. -c - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one) info = 1 - if (delta .le. xtol*xnorm) info = 2 - if (dabs(actred) .le. ftol .and. prered .le. ftol - * .and. p5*ratio .le. one .and. info .eq. 2) info = 3 - if (info .ne. 0) go to 300 -c -c tests for termination and stringent tolerances. -c - if (nfev .ge. maxfev) info = 5 - if (dabs(actred) .le. epsmch .and. prered .le. epsmch - * .and. p5*ratio .le. one) info = 6 - if (delta .le. epsmch*xnorm) info = 7 - if (gnorm .le. epsmch) info = 8 - if (info .ne. 0) go to 300 -c -c end of the inner loop. repeat if iteration unsuccessful. -c - if (ratio .lt. p0001) go to 200 -c -c end of the outer loop. -c - go to 30 - 300 continue -c -c termination, either normal or user imposed. -c - if (iflag .lt. 0) info = iflag - iflag = 0 - if (nprint .gt. 0) call fcn(m,n,x,fvec,iflag) - return -c -c last card of subroutine lmdif. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.h deleted file mode 100644 index 51f44b6efa4..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmdif.h +++ /dev/null @@ -1,33 +0,0 @@ -/*: Minimizes the sum of the squares of m nonlin functions in n variables */ -extern int v3p_netlib_lmdif_( - void (*fcn)(v3p_netlib_integer*, - v3p_netlib_integer*, - v3p_netlib_doublereal*, - v3p_netlib_doublereal*, - v3p_netlib_integer*, - void*), - v3p_netlib_integer *m, - v3p_netlib_integer *n, - v3p_netlib_doublereal *x, - v3p_netlib_doublereal *fvec, - v3p_netlib_doublereal *ftol, - v3p_netlib_doublereal *xtol, - v3p_netlib_doublereal *gtol, - v3p_netlib_integer *maxfev, - v3p_netlib_doublereal *epsfcn, - v3p_netlib_doublereal *diag, - v3p_netlib_integer *mode, - v3p_netlib_doublereal *factor, - v3p_netlib_integer *nprint, - v3p_netlib_integer *info, - v3p_netlib_integer *nfev, - v3p_netlib_doublereal *fjac, - v3p_netlib_integer *ldfjac, - v3p_netlib_integer *ipvt, - v3p_netlib_doublereal *qtf, - v3p_netlib_doublereal *wa1, - v3p_netlib_doublereal *wa2, - v3p_netlib_doublereal *wa3, - v3p_netlib_doublereal *wa4, - void* userdata - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.c deleted file mode 100644 index 849c325cce0..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.c +++ /dev/null @@ -1,502 +0,0 @@ -/* minpack/lmpar.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/* Table of constant values */ - -static integer c__2 = 2; - -/*< >*/ -/* Subroutine */ int lmpar_(integer *n, doublereal *r__, integer *ldr, - integer *ipvt, doublereal *diag, doublereal *qtb, doublereal *delta, - doublereal *par, doublereal *x, doublereal *sdiag, doublereal *wa1, - doublereal *wa2) -{ - /* Initialized data */ - - static doublereal p1 = .1; /* constant */ - static doublereal p001 = .001; /* constant */ - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer r_dim1, r_offset, i__1, i__2; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, k, l; - doublereal fp; - integer jm1, jp1; - doublereal sum, parc, parl; - integer iter; - doublereal temp, paru, dwarf; - integer nsing; - extern doublereal enorm_(integer *, doublereal *); - doublereal gnorm; - extern doublereal dpmpar_(integer *); - doublereal dxnorm; - extern /* Subroutine */ int qrsolv_(integer *, doublereal *, integer *, - integer *, doublereal *, doublereal *, doublereal *, doublereal *, - doublereal *); - -/*< integer n,ldr >*/ -/*< integer ipvt(n) >*/ -/*< double precision delta,par >*/ -/*< >*/ -/* ********** */ - -/* subroutine lmpar */ - -/* given an m by n matrix a, an n by n nonsingular diagonal */ -/* matrix d, an m-vector b, and a positive number delta, */ -/* the problem is to determine a value for the parameter */ -/* par such that if x solves the system */ - -/* a*x = b , sqrt(par)*d*x = 0 , */ - -/* in the least squares sense, and dxnorm is the euclidean */ -/* norm of d*x, then either par is zero and */ - -/* (dxnorm-delta) .le. 0.1*delta , */ - -/* or par is positive and */ - -/* abs(dxnorm-delta) .le. 0.1*delta . */ - -/* this subroutine completes the solution of the problem */ -/* if it is provided with the necessary information from the */ -/* qr factorization, with column pivoting, of a. that is, if */ -/* a*p = q*r, where p is a permutation matrix, q has orthogonal */ -/* columns, and r is an upper triangular matrix with diagonal */ -/* elements of nonincreasing magnitude, then lmpar expects */ -/* the full upper triangle of r, the permutation matrix p, */ -/* and the first n components of (q transpose)*b. on output */ -/* lmpar also provides an upper triangular matrix s such that */ - -/* t t t */ -/* p *(a *a + par*d*d)*p = s *s . */ - -/* s is employed within lmpar and may be of separate interest. */ - -/* only a few iterations are generally needed for convergence */ -/* of the algorithm. if, however, the limit of 10 iterations */ -/* is reached, then the output par will contain the best */ -/* value obtained so far. */ - -/* the subroutine statement is */ - -/* subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, */ -/* wa1,wa2) */ - -/* where */ - -/* n is a positive integer input variable set to the order of r. */ - -/* r is an n by n array. on input the full upper triangle */ -/* must contain the full upper triangle of the matrix r. */ -/* on output the full upper triangle is unaltered, and the */ -/* strict lower triangle contains the strict upper triangle */ -/* (transposed) of the upper triangular matrix s. */ - -/* ldr is a positive integer input variable not less than n */ -/* which specifies the leading dimension of the array r. */ - -/* ipvt is an integer input array of length n which defines the */ -/* permutation matrix p such that a*p = q*r. column j of p */ -/* is column ipvt(j) of the identity matrix. */ - -/* diag is an input array of length n which must contain the */ -/* diagonal elements of the matrix d. */ - -/* qtb is an input array of length n which must contain the first */ -/* n elements of the vector (q transpose)*b. */ - -/* delta is a positive input variable which specifies an upper */ -/* bound on the euclidean norm of d*x. */ - -/* par is a nonnegative variable. on input par contains an */ -/* initial estimate of the levenberg-marquardt parameter. */ -/* on output par contains the final estimate. */ - -/* x is an output array of length n which contains the least */ -/* squares solution of the system a*x = b, sqrt(par)*d*x = 0, */ -/* for the output par. */ - -/* sdiag is an output array of length n which contains the */ -/* diagonal elements of the upper triangular matrix s. */ - -/* wa1 and wa2 are work arrays of length n. */ - -/* subprograms called */ - -/* minpack-supplied ... dpmpar,enorm,qrsolv */ - -/* fortran-supplied ... dabs,dmax1,dmin1,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i,iter,j,jm1,jp1,k,l,nsing >*/ -/*< >*/ -/*< double precision dpmpar,enorm >*/ -/*< data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ >*/ - /* Parameter adjustments */ - --wa2; - --wa1; - --sdiag; - --x; - --qtb; - --diag; - --ipvt; - r_dim1 = *ldr; - r_offset = 1 + r_dim1; - r__ -= r_offset; - - /* Function Body */ - -/* dwarf is the smallest positive magnitude. */ - -/*< dwarf = dpmpar(2) >*/ - dwarf = dpmpar_(&c__2); - -/* compute and store in x the gauss-newton direction. if the */ -/* jacobian is rank-deficient, obtain a least squares solution. */ - -/*< nsing = n >*/ - nsing = *n; -/*< do 10 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa1(j) = qtb(j) >*/ - wa1[j] = qtb[j]; -/*< if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 >*/ - if (r__[j + j * r_dim1] == zero && nsing == *n) { - nsing = j - 1; - } -/*< if (nsing .lt. n) wa1(j) = zero >*/ - if (nsing < *n) { - wa1[j] = zero; - } -/*< 10 continue >*/ -/* L10: */ - } -/*< if (nsing .lt. 1) go to 50 >*/ - if (nsing < 1) { - goto L50; - } -/*< do 40 k = 1, nsing >*/ - i__1 = nsing; - for (k = 1; k <= i__1; ++k) { -/*< j = nsing - k + 1 >*/ - j = nsing - k + 1; -/*< wa1(j) = wa1(j)/r(j,j) >*/ - wa1[j] /= r__[j + j * r_dim1]; -/*< temp = wa1(j) >*/ - temp = wa1[j]; -/*< jm1 = j - 1 >*/ - jm1 = j - 1; -/*< if (jm1 .lt. 1) go to 30 >*/ - if (jm1 < 1) { - goto L30; - } -/*< do 20 i = 1, jm1 >*/ - i__2 = jm1; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< wa1(i) = wa1(i) - r(i,j)*temp >*/ - wa1[i__] -= r__[i__ + j * r_dim1] * temp; -/*< 20 continue >*/ -/* L20: */ - } -/*< 30 continue >*/ -L30: -/*< 40 continue >*/ -/* L40: */ - ; - } -/*< 50 continue >*/ -L50: -/*< do 60 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< x(l) = wa1(j) >*/ - x[l] = wa1[j]; -/*< 60 continue >*/ -/* L60: */ - } - -/* initialize the iteration counter. */ -/* evaluate the function at the origin, and test */ -/* for acceptance of the gauss-newton direction. */ - -/*< iter = 0 >*/ - iter = 0; -/*< do 70 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa2(j) = diag(j)*x(j) >*/ - wa2[j] = diag[j] * x[j]; -/*< 70 continue >*/ -/* L70: */ - } -/*< dxnorm = enorm(n,wa2) >*/ - dxnorm = enorm_(n, &wa2[1]); -/*< fp = dxnorm - delta >*/ - fp = dxnorm - *delta; -/*< if (fp .le. p1*delta) go to 220 >*/ - if (fp <= p1 * *delta) { - goto L220; - } - -/* if the jacobian is not rank deficient, the newton */ -/* step provides a lower bound, parl, for the zero of */ -/* the function. otherwise set this bound to zero. */ - -/*< parl = zero >*/ - parl = zero; -/*< if (nsing .lt. n) go to 120 >*/ - if (nsing < *n) { - goto L120; - } -/*< do 80 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< wa1(j) = diag(l)*(wa2(l)/dxnorm) >*/ - wa1[j] = diag[l] * (wa2[l] / dxnorm); -/*< 80 continue >*/ -/* L80: */ - } -/*< do 110 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< sum = zero >*/ - sum = zero; -/*< jm1 = j - 1 >*/ - jm1 = j - 1; -/*< if (jm1 .lt. 1) go to 100 >*/ - if (jm1 < 1) { - goto L100; - } -/*< do 90 i = 1, jm1 >*/ - i__2 = jm1; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< sum = sum + r(i,j)*wa1(i) >*/ - sum += r__[i__ + j * r_dim1] * wa1[i__]; -/*< 90 continue >*/ -/* L90: */ - } -/*< 100 continue >*/ -L100: -/*< wa1(j) = (wa1(j) - sum)/r(j,j) >*/ - wa1[j] = (wa1[j] - sum) / r__[j + j * r_dim1]; -/*< 110 continue >*/ -/* L110: */ - } -/*< temp = enorm(n,wa1) >*/ - temp = enorm_(n, &wa1[1]); -/*< parl = ((fp/delta)/temp)/temp >*/ - parl = fp / *delta / temp / temp; -/*< 120 continue >*/ -L120: - -/* calculate an upper bound, paru, for the zero of the function. */ - -/*< do 140 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< sum = zero >*/ - sum = zero; -/*< do 130 i = 1, j >*/ - i__2 = j; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< sum = sum + r(i,j)*qtb(i) >*/ - sum += r__[i__ + j * r_dim1] * qtb[i__]; -/*< 130 continue >*/ -/* L130: */ - } -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< wa1(j) = sum/diag(l) >*/ - wa1[j] = sum / diag[l]; -/*< 140 continue >*/ -/* L140: */ - } -/*< gnorm = enorm(n,wa1) >*/ - gnorm = enorm_(n, &wa1[1]); -/*< paru = gnorm/delta >*/ - paru = gnorm / *delta; -/*< if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) >*/ - if (paru == zero) { - paru = dwarf / min(*delta,p1); - } - -/* if the input par lies outside of the interval (parl,paru), */ -/* set par to the closer endpoint. */ - -/*< par = dmax1(par,parl) >*/ - *par = max(*par,parl); -/*< par = dmin1(par,paru) >*/ - *par = min(*par,paru); -/*< if (par .eq. zero) par = gnorm/dxnorm >*/ - if (*par == zero) { - *par = gnorm / dxnorm; - } - -/* beginning of an iteration. */ - -/*< 150 continue >*/ -L150: -/*< iter = iter + 1 >*/ - ++iter; - -/* evaluate the function at the current value of par. */ - -/*< if (par .eq. zero) par = dmax1(dwarf,p001*paru) >*/ - if (*par == zero) { -/* Computing MAX */ - d__1 = dwarf, d__2 = p001 * paru; - *par = max(d__1,d__2); - } -/*< temp = dsqrt(par) >*/ - temp = sqrt(*par); -/*< do 160 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa1(j) = temp*diag(j) >*/ - wa1[j] = temp * diag[j]; -/*< 160 continue >*/ -/* L160: */ - } -/*< call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) >*/ - qrsolv_(n, &r__[r_offset], ldr, &ipvt[1], &wa1[1], &qtb[1], &x[1], &sdiag[ - 1], &wa2[1]); -/*< do 170 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa2(j) = diag(j)*x(j) >*/ - wa2[j] = diag[j] * x[j]; -/*< 170 continue >*/ -/* L170: */ - } -/*< dxnorm = enorm(n,wa2) >*/ - dxnorm = enorm_(n, &wa2[1]); -/*< temp = fp >*/ - temp = fp; -/*< fp = dxnorm - delta >*/ - fp = dxnorm - *delta; - -/* if the function is small enough, accept the current value */ -/* of par. also test for the exceptional cases where parl */ -/* is zero or the number of iterations has reached 10. */ - -/*< >*/ - if (abs(fp) <= p1 * *delta || (parl == zero && fp <= temp && temp < zero) || - iter == 10) { - goto L220; - } - -/* compute the newton correction. */ - -/*< do 180 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< wa1(j) = diag(l)*(wa2(l)/dxnorm) >*/ - wa1[j] = diag[l] * (wa2[l] / dxnorm); -/*< 180 continue >*/ -/* L180: */ - } -/*< do 210 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< wa1(j) = wa1(j)/sdiag(j) >*/ - wa1[j] /= sdiag[j]; -/*< temp = wa1(j) >*/ - temp = wa1[j]; -/*< jp1 = j + 1 >*/ - jp1 = j + 1; -/*< if (n .lt. jp1) go to 200 >*/ - if (*n < jp1) { - goto L200; - } -/*< do 190 i = jp1, n >*/ - i__2 = *n; - for (i__ = jp1; i__ <= i__2; ++i__) { -/*< wa1(i) = wa1(i) - r(i,j)*temp >*/ - wa1[i__] -= r__[i__ + j * r_dim1] * temp; -/*< 190 continue >*/ -/* L190: */ - } -/*< 200 continue >*/ -L200: -/*< 210 continue >*/ -/* L210: */ - ; - } -/*< temp = enorm(n,wa1) >*/ - temp = enorm_(n, &wa1[1]); -/*< parc = ((fp/delta)/temp)/temp >*/ - parc = fp / *delta / temp / temp; - -/* depending on the sign of the function, update parl or paru. */ - -/*< if (fp .gt. zero) parl = dmax1(parl,par) >*/ - if (fp > zero) { - parl = max(parl,*par); - } -/*< if (fp .lt. zero) paru = dmin1(paru,par) >*/ - if (fp < zero) { - paru = min(paru,*par); - } - -/* compute an improved estimate for par. */ - -/*< par = dmax1(parl,par+parc) >*/ -/* Computing MAX */ - d__1 = parl, d__2 = *par + parc; - *par = max(d__1,d__2); - -/* end of an iteration. */ - -/*< go to 150 >*/ - goto L150; -/*< 220 continue >*/ -L220: - -/* termination. */ - -/*< if (iter .eq. 0) par = zero >*/ - if (iter == 0) { - *par = zero; - } -/*< return >*/ - return 0; - -/* last card of subroutine lmpar. */ - -/*< end >*/ -} /* lmpar_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.f deleted file mode 100644 index 26c422a79e9..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.f +++ /dev/null @@ -1,264 +0,0 @@ - subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag,wa1, - * wa2) - integer n,ldr - integer ipvt(n) - double precision delta,par - double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa1(n), - * wa2(n) -c ********** -c -c subroutine lmpar -c -c given an m by n matrix a, an n by n nonsingular diagonal -c matrix d, an m-vector b, and a positive number delta, -c the problem is to determine a value for the parameter -c par such that if x solves the system -c -c a*x = b , sqrt(par)*d*x = 0 , -c -c in the least squares sense, and dxnorm is the euclidean -c norm of d*x, then either par is zero and -c -c (dxnorm-delta) .le. 0.1*delta , -c -c or par is positive and -c -c abs(dxnorm-delta) .le. 0.1*delta . -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization, with column pivoting, of a. that is, if -c a*p = q*r, where p is a permutation matrix, q has orthogonal -c columns, and r is an upper triangular matrix with diagonal -c elements of nonincreasing magnitude, then lmpar expects -c the full upper triangle of r, the permutation matrix p, -c and the first n components of (q transpose)*b. on output -c lmpar also provides an upper triangular matrix s such that -c -c t t t -c p *(a *a + par*d*d)*p = s *s . -c -c s is employed within lmpar and may be of separate interest. -c -c only a few iterations are generally needed for convergence -c of the algorithm. if, however, the limit of 10 iterations -c is reached, then the output par will contain the best -c value obtained so far. -c -c the subroutine statement is -c -c subroutine lmpar(n,r,ldr,ipvt,diag,qtb,delta,par,x,sdiag, -c wa1,wa2) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an n by n array. on input the full upper triangle -c must contain the full upper triangle of the matrix r. -c on output the full upper triangle is unaltered, and the -c strict lower triangle contains the strict upper triangle -c (transposed) of the upper triangular matrix s. -c -c ldr is a positive integer input variable not less than n -c which specifies the leading dimension of the array r. -c -c ipvt is an integer input array of length n which defines the -c permutation matrix p such that a*p = q*r. column j of p -c is column ipvt(j) of the identity matrix. -c -c diag is an input array of length n which must contain the -c diagonal elements of the matrix d. -c -c qtb is an input array of length n which must contain the first -c n elements of the vector (q transpose)*b. -c -c delta is a positive input variable which specifies an upper -c bound on the euclidean norm of d*x. -c -c par is a nonnegative variable. on input par contains an -c initial estimate of the levenberg-marquardt parameter. -c on output par contains the final estimate. -c -c x is an output array of length n which contains the least -c squares solution of the system a*x = b, sqrt(par)*d*x = 0, -c for the output par. -c -c sdiag is an output array of length n which contains the -c diagonal elements of the upper triangular matrix s. -c -c wa1 and wa2 are work arrays of length n. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm,qrsolv -c -c fortran-supplied ... dabs,dmax1,dmin1,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,iter,j,jm1,jp1,k,l,nsing - double precision dxnorm,dwarf,fp,gnorm,parc,parl,paru,p1,p001, - * sum,temp,zero - double precision dpmpar,enorm - data p1,p001,zero /1.0d-1,1.0d-3,0.0d0/ -c -c dwarf is the smallest positive magnitude. -c - dwarf = dpmpar(2) -c -c compute and store in x the gauss-newton direction. if the -c jacobian is rank-deficient, obtain a least squares solution. -c - nsing = n - do 10 j = 1, n - wa1(j) = qtb(j) - if (r(j,j) .eq. zero .and. nsing .eq. n) nsing = j - 1 - if (nsing .lt. n) wa1(j) = zero - 10 continue - if (nsing .lt. 1) go to 50 - do 40 k = 1, nsing - j = nsing - k + 1 - wa1(j) = wa1(j)/r(j,j) - temp = wa1(j) - jm1 = j - 1 - if (jm1 .lt. 1) go to 30 - do 20 i = 1, jm1 - wa1(i) = wa1(i) - r(i,j)*temp - 20 continue - 30 continue - 40 continue - 50 continue - do 60 j = 1, n - l = ipvt(j) - x(l) = wa1(j) - 60 continue -c -c initialize the iteration counter. -c evaluate the function at the origin, and test -c for acceptance of the gauss-newton direction. -c - iter = 0 - do 70 j = 1, n - wa2(j) = diag(j)*x(j) - 70 continue - dxnorm = enorm(n,wa2) - fp = dxnorm - delta - if (fp .le. p1*delta) go to 220 -c -c if the jacobian is not rank deficient, the newton -c step provides a lower bound, parl, for the zero of -c the function. otherwise set this bound to zero. -c - parl = zero - if (nsing .lt. n) go to 120 - do 80 j = 1, n - l = ipvt(j) - wa1(j) = diag(l)*(wa2(l)/dxnorm) - 80 continue - do 110 j = 1, n - sum = zero - jm1 = j - 1 - if (jm1 .lt. 1) go to 100 - do 90 i = 1, jm1 - sum = sum + r(i,j)*wa1(i) - 90 continue - 100 continue - wa1(j) = (wa1(j) - sum)/r(j,j) - 110 continue - temp = enorm(n,wa1) - parl = ((fp/delta)/temp)/temp - 120 continue -c -c calculate an upper bound, paru, for the zero of the function. -c - do 140 j = 1, n - sum = zero - do 130 i = 1, j - sum = sum + r(i,j)*qtb(i) - 130 continue - l = ipvt(j) - wa1(j) = sum/diag(l) - 140 continue - gnorm = enorm(n,wa1) - paru = gnorm/delta - if (paru .eq. zero) paru = dwarf/dmin1(delta,p1) -c -c if the input par lies outside of the interval (parl,paru), -c set par to the closer endpoint. -c - par = dmax1(par,parl) - par = dmin1(par,paru) - if (par .eq. zero) par = gnorm/dxnorm -c -c beginning of an iteration. -c - 150 continue - iter = iter + 1 -c -c evaluate the function at the current value of par. -c - if (par .eq. zero) par = dmax1(dwarf,p001*paru) - temp = dsqrt(par) - do 160 j = 1, n - wa1(j) = temp*diag(j) - 160 continue - call qrsolv(n,r,ldr,ipvt,wa1,qtb,x,sdiag,wa2) - do 170 j = 1, n - wa2(j) = diag(j)*x(j) - 170 continue - dxnorm = enorm(n,wa2) - temp = fp - fp = dxnorm - delta -c -c if the function is small enough, accept the current value -c of par. also test for the exceptional cases where parl -c is zero or the number of iterations has reached 10. -c - if (dabs(fp) .le. p1*delta - * .or. parl .eq. zero .and. fp .le. temp - * .and. temp .lt. zero .or. iter .eq. 10) go to 220 -c -c compute the newton correction. -c - do 180 j = 1, n - l = ipvt(j) - wa1(j) = diag(l)*(wa2(l)/dxnorm) - 180 continue - do 210 j = 1, n - wa1(j) = wa1(j)/sdiag(j) - temp = wa1(j) - jp1 = j + 1 - if (n .lt. jp1) go to 200 - do 190 i = jp1, n - wa1(i) = wa1(i) - r(i,j)*temp - 190 continue - 200 continue - 210 continue - temp = enorm(n,wa1) - parc = ((fp/delta)/temp)/temp -c -c depending on the sign of the function, update parl or paru. -c - if (fp .gt. zero) parl = dmax1(parl,par) - if (fp .lt. zero) paru = dmin1(paru,par) -c -c compute an improved estimate for par. -c - par = dmax1(parl,par+parc) -c -c end of an iteration. -c - go to 150 - 220 continue -c -c termination. -c - if (iter .eq. 0) par = zero - return -c -c last card of subroutine lmpar. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.h deleted file mode 100644 index bd8a1ad7221..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/lmpar.h +++ /dev/null @@ -1,14 +0,0 @@ -extern int v3p_netlib_lmpar_( - v3p_netlib_integer *n, - v3p_netlib_doublereal *r__, - v3p_netlib_integer *ldr, - v3p_netlib_integer *ipvt, - v3p_netlib_doublereal *diag, - v3p_netlib_doublereal *qtb, - v3p_netlib_doublereal *delta, - v3p_netlib_doublereal *par, - v3p_netlib_doublereal *x, - v3p_netlib_doublereal *sdiag, - v3p_netlib_doublereal *wa1, - v3p_netlib_doublereal *wa2 - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.c deleted file mode 100644 index 665c37fce2b..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.c +++ /dev/null @@ -1,329 +0,0 @@ -/* minpack/qrfac.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/* Table of constant values */ - -static integer c__1 = 1; - -/*< subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) >*/ -/* Subroutine */ int qrfac_(integer *m, integer *n, doublereal *a, integer * - lda, logical *pivot, integer *ipvt, integer *lipvt, doublereal *rdiag, - doublereal *acnorm, doublereal *wa) -{ - /* Initialized data */ - - static doublereal one = 1.; /* constant */ - static doublereal p05 = .05; /* constant */ - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer a_dim1, a_offset, i__1, i__2, i__3; - doublereal d__1, d__2, d__3; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, k, jp1; - doublereal sum; - integer kmax; - doublereal temp; - integer minmn; - extern doublereal enorm_(integer *, doublereal *); - doublereal epsmch; - extern doublereal dpmpar_(integer *); - doublereal ajnorm; - - (void)lipvt; - -/*< integer m,n,lda,lipvt >*/ -/*< integer ipvt(lipvt) >*/ -/*< logical pivot >*/ -/*< double precision a(lda,n),rdiag(n),acnorm(n),wa(n) >*/ -/* ********** */ - -/* subroutine qrfac */ - -/* this subroutine uses householder transformations with column */ -/* pivoting (optional) to compute a qr factorization of the */ -/* m by n matrix a. that is, qrfac determines an orthogonal */ -/* matrix q, a permutation matrix p, and an upper trapezoidal */ -/* matrix r with diagonal elements of nonincreasing magnitude, */ -/* such that a*p = q*r. the householder transformation for */ -/* column k, k = 1,2,...,min(m,n), is of the form */ - -/* t */ -/* i - (1/u(k))*u*u */ - -/* where u has zeros in the first k-1 positions. the form of */ -/* this transformation and the method of pivoting first */ -/* appeared in the corresponding linpack subroutine. */ - -/* the subroutine statement is */ - -/* subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) */ - -/* where */ - -/* m is a positive integer input variable set to the number */ -/* of rows of a. */ - -/* n is a positive integer input variable set to the number */ -/* of columns of a. */ - -/* a is an m by n array. on input a contains the matrix for */ -/* which the qr factorization is to be computed. on output */ -/* the strict upper trapezoidal part of a contains the strict */ -/* upper trapezoidal part of r, and the lower trapezoidal */ -/* part of a contains a factored form of q (the non-trivial */ -/* elements of the u vectors described above). */ - -/* lda is a positive integer input variable not less than m */ -/* which specifies the leading dimension of the array a. */ - -/* pivot is a logical input variable. if pivot is set true, */ -/* then column pivoting is enforced. if pivot is set false, */ -/* then no column pivoting is done. */ - -/* ipvt is an integer output array of length lipvt. ipvt */ -/* defines the permutation matrix p such that a*p = q*r. */ -/* column j of p is column ipvt(j) of the identity matrix. */ -/* if pivot is false, ipvt is not referenced. */ - -/* lipvt is a positive integer input variable. if pivot is false, */ -/* then lipvt may be as small as 1. if pivot is true, then */ -/* lipvt must be at least n. */ - -/* rdiag is an output array of length n which contains the */ -/* diagonal elements of r. */ - -/* acnorm is an output array of length n which contains the */ -/* norms of the corresponding columns of the input matrix a. */ -/* if this information is not needed, then acnorm can coincide */ -/* with rdiag. */ - -/* wa is a work array of length n. if pivot is false, then wa */ -/* can coincide with rdiag. */ - -/* subprograms called */ - -/* minpack-supplied ... dpmpar,enorm */ - -/* fortran-supplied ... dmax1,dsqrt,min0 */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i,j,jp1,k,kmax,minmn >*/ -/*< double precision ajnorm,epsmch,one,p05,sum,temp,zero >*/ -/*< double precision dpmpar,enorm >*/ -/*< data one,p05,zero /1.0d0,5.0d-2,0.0d0/ >*/ - /* Parameter adjustments */ - --wa; - --acnorm; - --rdiag; - a_dim1 = *lda; - a_offset = 1 + a_dim1; - a -= a_offset; - --ipvt; - - /* Function Body */ - -/* epsmch is the machine precision. */ - -/*< epsmch = dpmpar(1) >*/ - epsmch = dpmpar_(&c__1); - -/* compute the initial column norms and initialize several arrays. */ - -/*< do 10 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< acnorm(j) = enorm(m,a(1,j)) >*/ - acnorm[j] = enorm_(m, &a[j * a_dim1 + 1]); -/*< rdiag(j) = acnorm(j) >*/ - rdiag[j] = acnorm[j]; -/*< wa(j) = rdiag(j) >*/ - wa[j] = rdiag[j]; -/*< if (pivot) ipvt(j) = j >*/ - if (*pivot) { - ipvt[j] = j; - } -/*< 10 continue >*/ -/* L10: */ - } - -/* reduce a to r with householder transformations. */ - -/*< minmn = min0(m,n) >*/ - minmn = min(*m,*n); -/*< do 110 j = 1, minmn >*/ - i__1 = minmn; - for (j = 1; j <= i__1; ++j) { -/*< if (.not.pivot) go to 40 >*/ - if (! (*pivot)) { - goto L40; - } - -/* bring the column of largest norm into the pivot position. */ - -/*< kmax = j >*/ - kmax = j; -/*< do 20 k = j, n >*/ - i__2 = *n; - for (k = j; k <= i__2; ++k) { -/*< if (rdiag(k) .gt. rdiag(kmax)) kmax = k >*/ - if (rdiag[k] > rdiag[kmax]) { - kmax = k; - } -/*< 20 continue >*/ -/* L20: */ - } -/*< if (kmax .eq. j) go to 40 >*/ - if (kmax == j) { - goto L40; - } -/*< do 30 i = 1, m >*/ - i__2 = *m; - for (i__ = 1; i__ <= i__2; ++i__) { -/*< temp = a(i,j) >*/ - temp = a[i__ + j * a_dim1]; -/*< a(i,j) = a(i,kmax) >*/ - a[i__ + j * a_dim1] = a[i__ + kmax * a_dim1]; -/*< a(i,kmax) = temp >*/ - a[i__ + kmax * a_dim1] = temp; -/*< 30 continue >*/ -/* L30: */ - } -/*< rdiag(kmax) = rdiag(j) >*/ - rdiag[kmax] = rdiag[j]; -/*< wa(kmax) = wa(j) >*/ - wa[kmax] = wa[j]; -/*< k = ipvt(j) >*/ - k = ipvt[j]; -/*< ipvt(j) = ipvt(kmax) >*/ - ipvt[j] = ipvt[kmax]; -/*< ipvt(kmax) = k >*/ - ipvt[kmax] = k; -/*< 40 continue >*/ -L40: - -/* compute the householder transformation to reduce the */ -/* j-th column of a to a multiple of the j-th unit vector. */ - -/*< ajnorm = enorm(m-j+1,a(j,j)) >*/ - i__2 = *m - j + 1; - ajnorm = enorm_(&i__2, &a[j + j * a_dim1]); -/*< if (ajnorm .eq. zero) go to 100 >*/ - if (ajnorm == zero) { - goto L100; - } -/*< if (a(j,j) .lt. zero) ajnorm = -ajnorm >*/ - if (a[j + j * a_dim1] < zero) { - ajnorm = -ajnorm; - } -/*< do 50 i = j, m >*/ - i__2 = *m; - for (i__ = j; i__ <= i__2; ++i__) { -/*< a(i,j) = a(i,j)/ajnorm >*/ - a[i__ + j * a_dim1] /= ajnorm; -/*< 50 continue >*/ -/* L50: */ - } -/*< a(j,j) = a(j,j) + one >*/ - a[j + j * a_dim1] += one; - -/* apply the transformation to the remaining columns */ -/* and update the norms. */ - -/*< jp1 = j + 1 >*/ - jp1 = j + 1; -/*< if (n .lt. jp1) go to 100 >*/ - if (*n < jp1) { - goto L100; - } -/*< do 90 k = jp1, n >*/ - i__2 = *n; - for (k = jp1; k <= i__2; ++k) { -/*< sum = zero >*/ - sum = zero; -/*< do 60 i = j, m >*/ - i__3 = *m; - for (i__ = j; i__ <= i__3; ++i__) { -/*< sum = sum + a(i,j)*a(i,k) >*/ - sum += a[i__ + j * a_dim1] * a[i__ + k * a_dim1]; -/*< 60 continue >*/ -/* L60: */ - } -/*< temp = sum/a(j,j) >*/ - temp = sum / a[j + j * a_dim1]; -/*< do 70 i = j, m >*/ - i__3 = *m; - for (i__ = j; i__ <= i__3; ++i__) { -/*< a(i,k) = a(i,k) - temp*a(i,j) >*/ - a[i__ + k * a_dim1] -= temp * a[i__ + j * a_dim1]; -/*< 70 continue >*/ -/* L70: */ - } -/*< if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 >*/ - if (! (*pivot) || rdiag[k] == zero) { - goto L80; - } -/*< temp = a(j,k)/rdiag(k) >*/ - temp = a[j + k * a_dim1] / rdiag[k]; -/*< rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) >*/ -/* Computing MAX */ -/* Computing 2nd power */ - d__3 = temp; - d__1 = zero, d__2 = one - d__3 * d__3; - rdiag[k] *= sqrt((max(d__1,d__2))); -/*< if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 >*/ -/* Computing 2nd power */ - d__1 = rdiag[k] / wa[k]; - if (p05 * (d__1 * d__1) > epsmch) { - goto L80; - } -/*< rdiag(k) = enorm(m-j,a(jp1,k)) >*/ - i__3 = *m - j; - rdiag[k] = enorm_(&i__3, &a[jp1 + k * a_dim1]); -/*< wa(k) = rdiag(k) >*/ - wa[k] = rdiag[k]; -/*< 80 continue >*/ -L80: -/*< 90 continue >*/ -/* L90: */ - ; - } -/*< 100 continue >*/ -L100: -/*< rdiag(j) = -ajnorm >*/ - rdiag[j] = -ajnorm; -/*< 110 continue >*/ -/* L110: */ - } -/*< return >*/ - return 0; - -/* last card of subroutine qrfac. */ - -/*< end >*/ -} /* qrfac_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.f deleted file mode 100644 index cb686086c51..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.f +++ /dev/null @@ -1,164 +0,0 @@ - subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) - integer m,n,lda,lipvt - integer ipvt(lipvt) - logical pivot - double precision a(lda,n),rdiag(n),acnorm(n),wa(n) -c ********** -c -c subroutine qrfac -c -c this subroutine uses householder transformations with column -c pivoting (optional) to compute a qr factorization of the -c m by n matrix a. that is, qrfac determines an orthogonal -c matrix q, a permutation matrix p, and an upper trapezoidal -c matrix r with diagonal elements of nonincreasing magnitude, -c such that a*p = q*r. the householder transformation for -c column k, k = 1,2,...,min(m,n), is of the form -c -c t -c i - (1/u(k))*u*u -c -c where u has zeros in the first k-1 positions. the form of -c this transformation and the method of pivoting first -c appeared in the corresponding linpack subroutine. -c -c the subroutine statement is -c -c subroutine qrfac(m,n,a,lda,pivot,ipvt,lipvt,rdiag,acnorm,wa) -c -c where -c -c m is a positive integer input variable set to the number -c of rows of a. -c -c n is a positive integer input variable set to the number -c of columns of a. -c -c a is an m by n array. on input a contains the matrix for -c which the qr factorization is to be computed. on output -c the strict upper trapezoidal part of a contains the strict -c upper trapezoidal part of r, and the lower trapezoidal -c part of a contains a factored form of q (the non-trivial -c elements of the u vectors described above). -c -c lda is a positive integer input variable not less than m -c which specifies the leading dimension of the array a. -c -c pivot is a logical input variable. if pivot is set true, -c then column pivoting is enforced. if pivot is set false, -c then no column pivoting is done. -c -c ipvt is an integer output array of length lipvt. ipvt -c defines the permutation matrix p such that a*p = q*r. -c column j of p is column ipvt(j) of the identity matrix. -c if pivot is false, ipvt is not referenced. -c -c lipvt is a positive integer input variable. if pivot is false, -c then lipvt may be as small as 1. if pivot is true, then -c lipvt must be at least n. -c -c rdiag is an output array of length n which contains the -c diagonal elements of r. -c -c acnorm is an output array of length n which contains the -c norms of the corresponding columns of the input matrix a. -c if this information is not needed, then acnorm can coincide -c with rdiag. -c -c wa is a work array of length n. if pivot is false, then wa -c can coincide with rdiag. -c -c subprograms called -c -c minpack-supplied ... dpmpar,enorm -c -c fortran-supplied ... dmax1,dsqrt,min0 -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jp1,k,kmax,minmn - double precision ajnorm,epsmch,one,p05,sum,temp,zero - double precision dpmpar,enorm - data one,p05,zero /1.0d0,5.0d-2,0.0d0/ -c -c epsmch is the machine precision. -c - epsmch = dpmpar(1) -c -c compute the initial column norms and initialize several arrays. -c - do 10 j = 1, n - acnorm(j) = enorm(m,a(1,j)) - rdiag(j) = acnorm(j) - wa(j) = rdiag(j) - if (pivot) ipvt(j) = j - 10 continue -c -c reduce a to r with householder transformations. -c - minmn = min0(m,n) - do 110 j = 1, minmn - if (.not.pivot) go to 40 -c -c bring the column of largest norm into the pivot position. -c - kmax = j - do 20 k = j, n - if (rdiag(k) .gt. rdiag(kmax)) kmax = k - 20 continue - if (kmax .eq. j) go to 40 - do 30 i = 1, m - temp = a(i,j) - a(i,j) = a(i,kmax) - a(i,kmax) = temp - 30 continue - rdiag(kmax) = rdiag(j) - wa(kmax) = wa(j) - k = ipvt(j) - ipvt(j) = ipvt(kmax) - ipvt(kmax) = k - 40 continue -c -c compute the householder transformation to reduce the -c j-th column of a to a multiple of the j-th unit vector. -c - ajnorm = enorm(m-j+1,a(j,j)) - if (ajnorm .eq. zero) go to 100 - if (a(j,j) .lt. zero) ajnorm = -ajnorm - do 50 i = j, m - a(i,j) = a(i,j)/ajnorm - 50 continue - a(j,j) = a(j,j) + one -c -c apply the transformation to the remaining columns -c and update the norms. -c - jp1 = j + 1 - if (n .lt. jp1) go to 100 - do 90 k = jp1, n - sum = zero - do 60 i = j, m - sum = sum + a(i,j)*a(i,k) - 60 continue - temp = sum/a(j,j) - do 70 i = j, m - a(i,k) = a(i,k) - temp*a(i,j) - 70 continue - if (.not.pivot .or. rdiag(k) .eq. zero) go to 80 - temp = a(j,k)/rdiag(k) - rdiag(k) = rdiag(k)*dsqrt(dmax1(zero,one-temp**2)) - if (p05*(rdiag(k)/wa(k))**2 .gt. epsmch) go to 80 - rdiag(k) = enorm(m-j,a(jp1,k)) - wa(k) = rdiag(k) - 80 continue - 90 continue - 100 continue - rdiag(j) = -ajnorm - 110 continue - return -c -c last card of subroutine qrfac. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.h deleted file mode 100644 index 1f5a00e0bd7..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrfac.h +++ /dev/null @@ -1,12 +0,0 @@ -extern int v3p_netlib_qrfac_( - v3p_netlib_integer *m, - v3p_netlib_integer *n, - v3p_netlib_doublereal *a, - v3p_netlib_integer *lda, - v3p_netlib_logical *pivot, - v3p_netlib_integer *ipvt, - v3p_netlib_integer *lipvt, - v3p_netlib_doublereal *rdiag, - v3p_netlib_doublereal *acnorm, - v3p_netlib_doublereal *wa - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.c b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.c deleted file mode 100644 index 6144cc79e70..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.c +++ /dev/null @@ -1,361 +0,0 @@ -/* minpack/qrsolv.f -- translated by f2c (version 20050501). - You must link the resulting object file with libf2c: - on Microsoft Windows system, link with libf2c.lib; - on Linux or Unix systems, link with .../path/to/libf2c.a -lm - or, if you install libf2c.a in a standard place, with -lf2c -lm - -- in that order, at the end of the command line, as in - cc *.o -lf2c -lm - Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., - - http://www.netlib.org/f2c/libf2c.zip -*/ - -#ifdef __cplusplus -extern "C" { -#endif -#include "v3p_netlib.h" - -/*< subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) >*/ -/* Subroutine */ int qrsolv_(integer *n, doublereal *r__, integer *ldr, - integer *ipvt, doublereal *diag, doublereal *qtb, doublereal *x, - doublereal *sdiag, doublereal *wa) -{ - /* Initialized data */ - - static doublereal p5 = .5; /* constant */ - static doublereal p25 = .25; /* constant */ - static doublereal zero = 0.; /* constant */ - - /* System generated locals */ - integer r_dim1, r_offset, i__1, i__2, i__3; - doublereal d__1, d__2; - - /* Builtin functions */ - double sqrt(doublereal); - - /* Local variables */ - integer i__, j, k, l, jp1, kp1; - doublereal tan__, cos__, sin__, sum, temp, cotan; - integer nsing; - doublereal qtbpj; - -/*< integer n,ldr >*/ -/*< integer ipvt(n) >*/ -/*< double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) >*/ -/* ********** */ - -/* subroutine qrsolv */ - -/* given an m by n matrix a, an n by n diagonal matrix d, */ -/* and an m-vector b, the problem is to determine an x which */ -/* solves the system */ - -/* a*x = b , d*x = 0 , */ - -/* in the least squares sense. */ - -/* this subroutine completes the solution of the problem */ -/* if it is provided with the necessary information from the */ -/* qr factorization, with column pivoting, of a. that is, if */ -/* a*p = q*r, where p is a permutation matrix, q has orthogonal */ -/* columns, and r is an upper triangular matrix with diagonal */ -/* elements of nonincreasing magnitude, then qrsolv expects */ -/* the full upper triangle of r, the permutation matrix p, */ -/* and the first n components of (q transpose)*b. the system */ -/* a*x = b, d*x = 0, is then equivalent to */ - -/* t t */ -/* r*z = q *b , p *d*p*z = 0 , */ - -/* where x = p*z. if this system does not have full rank, */ -/* then a least squares solution is obtained. on output qrsolv */ -/* also provides an upper triangular matrix s such that */ - -/* t t t */ -/* p *(a *a + d*d)*p = s *s . */ - -/* s is computed within qrsolv and may be of separate interest. */ - -/* the subroutine statement is */ - -/* subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) */ - -/* where */ - -/* n is a positive integer input variable set to the order of r. */ - -/* r is an n by n array. on input the full upper triangle */ -/* must contain the full upper triangle of the matrix r. */ -/* on output the full upper triangle is unaltered, and the */ -/* strict lower triangle contains the strict upper triangle */ -/* (transposed) of the upper triangular matrix s. */ - -/* ldr is a positive integer input variable not less than n */ -/* which specifies the leading dimension of the array r. */ - -/* ipvt is an integer input array of length n which defines the */ -/* permutation matrix p such that a*p = q*r. column j of p */ -/* is column ipvt(j) of the identity matrix. */ - -/* diag is an input array of length n which must contain the */ -/* diagonal elements of the matrix d. */ - -/* qtb is an input array of length n which must contain the first */ -/* n elements of the vector (q transpose)*b. */ - -/* x is an output array of length n which contains the least */ -/* squares solution of the system a*x = b, d*x = 0. */ - -/* sdiag is an output array of length n which contains the */ -/* diagonal elements of the upper triangular matrix s. */ - -/* wa is a work array of length n. */ - -/* subprograms called */ - -/* fortran-supplied ... dabs,dsqrt */ - -/* argonne national laboratory. minpack project. march 1980. */ -/* burton s. garbow, kenneth e. hillstrom, jorge j. more */ - -/* ********** */ -/*< integer i,j,jp1,k,kp1,l,nsing >*/ -/*< double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero >*/ -/*< data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ >*/ - /* Parameter adjustments */ - --wa; - --sdiag; - --x; - --qtb; - --diag; - --ipvt; - r_dim1 = *ldr; - r_offset = 1 + r_dim1; - r__ -= r_offset; - - /* Function Body */ - -/* copy r and (q transpose)*b to preserve input and initialize s. */ -/* in particular, save the diagonal elements of r in x. */ - -/*< do 20 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< do 10 i = j, n >*/ - i__2 = *n; - for (i__ = j; i__ <= i__2; ++i__) { -/*< r(i,j) = r(j,i) >*/ - r__[i__ + j * r_dim1] = r__[j + i__ * r_dim1]; -/*< 10 continue >*/ -/* L10: */ - } -/*< x(j) = r(j,j) >*/ - x[j] = r__[j + j * r_dim1]; -/*< wa(j) = qtb(j) >*/ - wa[j] = qtb[j]; -/*< 20 continue >*/ -/* L20: */ - } - -/* eliminate the diagonal matrix d using a givens rotation. */ - -/*< do 100 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { - -/* prepare the row of d to be eliminated, locating the */ -/* diagonal element using p from the qr factorization. */ - -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< if (diag(l) .eq. zero) go to 90 >*/ - if (diag[l] == zero) { - goto L90; - } -/*< do 30 k = j, n >*/ - i__2 = *n; - for (k = j; k <= i__2; ++k) { -/*< sdiag(k) = zero >*/ - sdiag[k] = zero; -/*< 30 continue >*/ -/* L30: */ - } -/*< sdiag(j) = diag(l) >*/ - sdiag[j] = diag[l]; - -/* the transformations to eliminate the row of d */ -/* modify only a single element of (q transpose)*b */ -/* beyond the first n, which is initially zero. */ - -/*< qtbpj = zero >*/ - qtbpj = zero; -/*< do 80 k = j, n >*/ - i__2 = *n; - for (k = j; k <= i__2; ++k) { - -/* determine a givens rotation which eliminates the */ -/* appropriate element in the current row of d. */ - -/*< if (sdiag(k) .eq. zero) go to 70 >*/ - if (sdiag[k] == zero) { - goto L70; - } -/*< if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 >*/ - if ((d__1 = r__[k + k * r_dim1], abs(d__1)) >= (d__2 = sdiag[k], - abs(d__2))) { - goto L40; - } -/*< cotan = r(k,k)/sdiag(k) >*/ - cotan = r__[k + k * r_dim1] / sdiag[k]; -/*< sin = p5/dsqrt(p25+p25*cotan**2) >*/ -/* Computing 2nd power */ - d__1 = cotan; - sin__ = p5 / sqrt(p25 + p25 * (d__1 * d__1)); -/*< cos = sin*cotan >*/ - cos__ = sin__ * cotan; -/*< go to 50 >*/ - goto L50; -/*< 40 continue >*/ -L40: -/*< tan = sdiag(k)/r(k,k) >*/ - tan__ = sdiag[k] / r__[k + k * r_dim1]; -/*< cos = p5/dsqrt(p25+p25*tan**2) >*/ -/* Computing 2nd power */ - d__1 = tan__; - cos__ = p5 / sqrt(p25 + p25 * (d__1 * d__1)); -/*< sin = cos*tan >*/ - sin__ = cos__ * tan__; -/*< 50 continue >*/ -L50: - -/* compute the modified diagonal element of r and */ -/* the modified element of ((q transpose)*b,0). */ - -/*< r(k,k) = cos*r(k,k) + sin*sdiag(k) >*/ - r__[k + k * r_dim1] = cos__ * r__[k + k * r_dim1] + sin__ * sdiag[ - k]; -/*< temp = cos*wa(k) + sin*qtbpj >*/ - temp = cos__ * wa[k] + sin__ * qtbpj; -/*< qtbpj = -sin*wa(k) + cos*qtbpj >*/ - qtbpj = -sin__ * wa[k] + cos__ * qtbpj; -/*< wa(k) = temp >*/ - wa[k] = temp; - -/* accumulate the transformation in the row of s. */ - -/*< kp1 = k + 1 >*/ - kp1 = k + 1; -/*< if (n .lt. kp1) go to 70 >*/ - if (*n < kp1) { - goto L70; - } -/*< do 60 i = kp1, n >*/ - i__3 = *n; - for (i__ = kp1; i__ <= i__3; ++i__) { -/*< temp = cos*r(i,k) + sin*sdiag(i) >*/ - temp = cos__ * r__[i__ + k * r_dim1] + sin__ * sdiag[i__]; -/*< sdiag(i) = -sin*r(i,k) + cos*sdiag(i) >*/ - sdiag[i__] = -sin__ * r__[i__ + k * r_dim1] + cos__ * sdiag[ - i__]; -/*< r(i,k) = temp >*/ - r__[i__ + k * r_dim1] = temp; -/*< 60 continue >*/ -/* L60: */ - } -/*< 70 continue >*/ -L70: -/*< 80 continue >*/ -/* L80: */ - ; - } -/*< 90 continue >*/ -L90: - -/* store the diagonal element of s and restore */ -/* the corresponding diagonal element of r. */ - -/*< sdiag(j) = r(j,j) >*/ - sdiag[j] = r__[j + j * r_dim1]; -/*< r(j,j) = x(j) >*/ - r__[j + j * r_dim1] = x[j]; -/*< 100 continue >*/ -/* L100: */ - } - -/* solve the triangular system for z. if the system is */ -/* singular, then obtain a least squares solution. */ - -/*< nsing = n >*/ - nsing = *n; -/*< do 110 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 >*/ - if (sdiag[j] == zero && nsing == *n) { - nsing = j - 1; - } -/*< if (nsing .lt. n) wa(j) = zero >*/ - if (nsing < *n) { - wa[j] = zero; - } -/*< 110 continue >*/ -/* L110: */ - } -/*< if (nsing .lt. 1) go to 150 >*/ - if (nsing < 1) { - goto L150; - } -/*< do 140 k = 1, nsing >*/ - i__1 = nsing; - for (k = 1; k <= i__1; ++k) { -/*< j = nsing - k + 1 >*/ - j = nsing - k + 1; -/*< sum = zero >*/ - sum = zero; -/*< jp1 = j + 1 >*/ - jp1 = j + 1; -/*< if (nsing .lt. jp1) go to 130 >*/ - if (nsing < jp1) { - goto L130; - } -/*< do 120 i = jp1, nsing >*/ - i__2 = nsing; - for (i__ = jp1; i__ <= i__2; ++i__) { -/*< sum = sum + r(i,j)*wa(i) >*/ - sum += r__[i__ + j * r_dim1] * wa[i__]; -/*< 120 continue >*/ -/* L120: */ - } -/*< 130 continue >*/ -L130: -/*< wa(j) = (wa(j) - sum)/sdiag(j) >*/ - wa[j] = (wa[j] - sum) / sdiag[j]; -/*< 140 continue >*/ -/* L140: */ - } -/*< 150 continue >*/ -L150: - -/* permute the components of z back to components of x. */ - -/*< do 160 j = 1, n >*/ - i__1 = *n; - for (j = 1; j <= i__1; ++j) { -/*< l = ipvt(j) >*/ - l = ipvt[j]; -/*< x(l) = wa(j) >*/ - x[l] = wa[j]; -/*< 160 continue >*/ -/* L160: */ - } -/*< return >*/ - return 0; - -/* last card of subroutine qrsolv. */ - -/*< end >*/ -} /* qrsolv_ */ - -#ifdef __cplusplus - } -#endif diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.f b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.f deleted file mode 100644 index 5580087ca28..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.f +++ /dev/null @@ -1,193 +0,0 @@ - subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) - integer n,ldr - integer ipvt(n) - double precision r(ldr,n),diag(n),qtb(n),x(n),sdiag(n),wa(n) -c ********** -c -c subroutine qrsolv -c -c given an m by n matrix a, an n by n diagonal matrix d, -c and an m-vector b, the problem is to determine an x which -c solves the system -c -c a*x = b , d*x = 0 , -c -c in the least squares sense. -c -c this subroutine completes the solution of the problem -c if it is provided with the necessary information from the -c qr factorization, with column pivoting, of a. that is, if -c a*p = q*r, where p is a permutation matrix, q has orthogonal -c columns, and r is an upper triangular matrix with diagonal -c elements of nonincreasing magnitude, then qrsolv expects -c the full upper triangle of r, the permutation matrix p, -c and the first n components of (q transpose)*b. the system -c a*x = b, d*x = 0, is then equivalent to -c -c t t -c r*z = q *b , p *d*p*z = 0 , -c -c where x = p*z. if this system does not have full rank, -c then a least squares solution is obtained. on output qrsolv -c also provides an upper triangular matrix s such that -c -c t t t -c p *(a *a + d*d)*p = s *s . -c -c s is computed within qrsolv and may be of separate interest. -c -c the subroutine statement is -c -c subroutine qrsolv(n,r,ldr,ipvt,diag,qtb,x,sdiag,wa) -c -c where -c -c n is a positive integer input variable set to the order of r. -c -c r is an n by n array. on input the full upper triangle -c must contain the full upper triangle of the matrix r. -c on output the full upper triangle is unaltered, and the -c strict lower triangle contains the strict upper triangle -c (transposed) of the upper triangular matrix s. -c -c ldr is a positive integer input variable not less than n -c which specifies the leading dimension of the array r. -c -c ipvt is an integer input array of length n which defines the -c permutation matrix p such that a*p = q*r. column j of p -c is column ipvt(j) of the identity matrix. -c -c diag is an input array of length n which must contain the -c diagonal elements of the matrix d. -c -c qtb is an input array of length n which must contain the first -c n elements of the vector (q transpose)*b. -c -c x is an output array of length n which contains the least -c squares solution of the system a*x = b, d*x = 0. -c -c sdiag is an output array of length n which contains the -c diagonal elements of the upper triangular matrix s. -c -c wa is a work array of length n. -c -c subprograms called -c -c fortran-supplied ... dabs,dsqrt -c -c argonne national laboratory. minpack project. march 1980. -c burton s. garbow, kenneth e. hillstrom, jorge j. more -c -c ********** - integer i,j,jp1,k,kp1,l,nsing - double precision cos,cotan,p5,p25,qtbpj,sin,sum,tan,temp,zero - data p5,p25,zero /5.0d-1,2.5d-1,0.0d0/ -c -c copy r and (q transpose)*b to preserve input and initialize s. -c in particular, save the diagonal elements of r in x. -c - do 20 j = 1, n - do 10 i = j, n - r(i,j) = r(j,i) - 10 continue - x(j) = r(j,j) - wa(j) = qtb(j) - 20 continue -c -c eliminate the diagonal matrix d using a givens rotation. -c - do 100 j = 1, n -c -c prepare the row of d to be eliminated, locating the -c diagonal element using p from the qr factorization. -c - l = ipvt(j) - if (diag(l) .eq. zero) go to 90 - do 30 k = j, n - sdiag(k) = zero - 30 continue - sdiag(j) = diag(l) -c -c the transformations to eliminate the row of d -c modify only a single element of (q transpose)*b -c beyond the first n, which is initially zero. -c - qtbpj = zero - do 80 k = j, n -c -c determine a givens rotation which eliminates the -c appropriate element in the current row of d. -c - if (sdiag(k) .eq. zero) go to 70 - if (dabs(r(k,k)) .ge. dabs(sdiag(k))) go to 40 - cotan = r(k,k)/sdiag(k) - sin = p5/dsqrt(p25+p25*cotan**2) - cos = sin*cotan - go to 50 - 40 continue - tan = sdiag(k)/r(k,k) - cos = p5/dsqrt(p25+p25*tan**2) - sin = cos*tan - 50 continue -c -c compute the modified diagonal element of r and -c the modified element of ((q transpose)*b,0). -c - r(k,k) = cos*r(k,k) + sin*sdiag(k) - temp = cos*wa(k) + sin*qtbpj - qtbpj = -sin*wa(k) + cos*qtbpj - wa(k) = temp -c -c accumulate the transformation in the row of s. -c - kp1 = k + 1 - if (n .lt. kp1) go to 70 - do 60 i = kp1, n - temp = cos*r(i,k) + sin*sdiag(i) - sdiag(i) = -sin*r(i,k) + cos*sdiag(i) - r(i,k) = temp - 60 continue - 70 continue - 80 continue - 90 continue -c -c store the diagonal element of s and restore -c the corresponding diagonal element of r. -c - sdiag(j) = r(j,j) - r(j,j) = x(j) - 100 continue -c -c solve the triangular system for z. if the system is -c singular, then obtain a least squares solution. -c - nsing = n - do 110 j = 1, n - if (sdiag(j) .eq. zero .and. nsing .eq. n) nsing = j - 1 - if (nsing .lt. n) wa(j) = zero - 110 continue - if (nsing .lt. 1) go to 150 - do 140 k = 1, nsing - j = nsing - k + 1 - sum = zero - jp1 = j + 1 - if (nsing .lt. jp1) go to 130 - do 120 i = jp1, nsing - sum = sum + r(i,j)*wa(i) - 120 continue - 130 continue - wa(j) = (wa(j) - sum)/sdiag(j) - 140 continue - 150 continue -c -c permute the components of z back to components of x. -c - do 160 j = 1, n - l = ipvt(j) - x(l) = wa(j) - 160 continue - return -c -c last card of subroutine qrsolv. -c - end diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.h deleted file mode 100644 index b63563e9388..00000000000 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/minpack/qrsolv.h +++ /dev/null @@ -1,11 +0,0 @@ -extern int v3p_netlib_qrsolv_( - v3p_netlib_integer *n, - v3p_netlib_doublereal *r__, - v3p_netlib_integer *ldr, - v3p_netlib_integer *ipvt, - v3p_netlib_doublereal *diag, - v3p_netlib_doublereal *qtb, - v3p_netlib_doublereal *x, - v3p_netlib_doublereal *sdiag, - v3p_netlib_doublereal *wa - ); diff --git a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/v3p_netlib_prototypes.h b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/v3p_netlib_prototypes.h index 08a21ef227c..b403c949957 100644 --- a/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/v3p_netlib_prototypes.h +++ b/Modules/ThirdParty/VNL/src/vxl/v3p/netlib/v3p_netlib_prototypes.h @@ -174,15 +174,6 @@ #include "lapack/util/lsame.h" #include "lapack/util/izmax1.h" #include "napack/cg.h" -#include "minpack/dpmpar.h" -#include "minpack/enorm.h" -#include "minpack/fdjac2.h" -#include "minpack/lmder.h" -#include "minpack/lmder1.h" -#include "minpack/lmdif.h" -#include "minpack/lmpar.h" -#include "minpack/qrfac.h" -#include "minpack/qrsolv.h" #include "opt/lbfgs.h" #include "opt/lbfgsb.h" #include "mathews/simpson.h"